Artifact dc844ca31d9aef97b43aca201f8ee41d1f11cc22:
- File sxml/utils.ss — part of check-in [cd7a31d87b] at 2017-05-03 18:01:41 on branch trunk — many fixes to usb.sls (user: aldo size: 20538)
0000: 0a 0a 0a 28 64 65 66 69 6e 65 20 63 68 65 7a 2d ...(define chez- 0010: 65 72 72 6f 72 20 73 63 68 65 6d 65 3a 65 72 72 error scheme:err 0020: 6f 72 29 0a 28 64 65 66 69 6e 65 20 65 72 72 6f or).(define erro 0030: 72 0a 20 20 28 6c 61 6d 62 64 61 20 28 6d 73 67 r. (lambda (msg 0040: 20 2e 20 61 72 67 73 29 0a 20 20 20 20 28 63 68 . args). (ch 0050: 65 7a 2d 65 72 72 6f 72 20 27 72 75 6e 74 69 6d ez-error 'runtim 0060: 65 2d 65 72 72 6f 72 20 22 7e 61 7e 25 22 20 28 e-error "~a~%" ( 0070: 63 6f 6e 73 20 6d 73 67 20 61 72 67 73 29 29 29 cons msg args))) 0080: 29 0a 0a 0a 28 64 65 66 69 6e 65 20 70 70 20 70 )...(define pp p 0090: 72 65 74 74 79 2d 70 72 69 6e 74 29 0a 0a 0a 28 retty-print)...( 00a0: 64 65 66 69 6e 65 2d 73 79 6e 74 61 78 20 64 65 define-syntax de 00b0: 63 6c 61 72 65 09 3b 20 47 61 6d 62 69 74 2d 73 clare.; Gambit-s 00c0: 70 65 63 69 66 69 63 20 63 6f 6d 70 69 6c 65 72 pecific compiler 00d0: 2d 64 65 63 6c 0a 20 20 28 73 79 6e 74 61 78 2d -decl. (syntax- 00e0: 72 75 6c 65 73 20 28 29 20 28 28 64 65 63 6c 61 rules () ((decla 00f0: 72 65 20 2e 20 78 29 20 28 62 65 67 69 6e 20 23 re . x) (begin # 0100: 66 29 29 29 29 0a 0a 3b 20 41 20 66 65 77 20 63 f))))..; A few c 0110: 6f 6e 76 65 6e 69 65 6e 74 20 66 75 6e 63 74 69 onvenient functi 0120: 6f 6e 73 20 74 68 61 74 20 61 72 65 20 6e 6f 74 ons that are not 0130: 20 43 68 65 7a 0a 28 64 65 66 69 6e 65 20 28 63 Chez.(define (c 0140: 61 6c 6c 2d 77 69 74 68 2d 69 6e 70 75 74 2d 73 all-with-input-s 0150: 74 72 69 6e 67 20 73 74 72 20 70 72 6f 63 29 0a tring str proc). 0160: 20 20 20 20 28 70 72 6f 63 20 28 6f 70 65 6e 2d (proc (open- 0170: 69 6e 70 75 74 2d 73 74 72 69 6e 67 20 73 74 72 input-string str 0180: 29 29 29 0a 28 64 65 66 69 6e 65 20 28 63 61 6c ))).(define (cal 0190: 6c 2d 77 69 74 68 2d 6f 75 74 70 75 74 2d 73 74 l-with-output-st 01a0: 72 69 6e 67 20 70 72 6f 63 29 0a 20 20 28 6c 65 ring proc). (le 01b0: 74 20 28 28 70 6f 72 74 20 28 6f 70 65 6e 2d 6f t ((port (open-o 01c0: 75 74 70 75 74 2d 73 74 72 69 6e 67 29 29 29 0a utput-string))). 01d0: 20 20 20 20 28 70 72 6f 63 20 70 6f 72 74 29 0a (proc port). 01e0: 20 20 20 20 28 67 65 74 2d 6f 75 74 70 75 74 2d (get-output- 01f0: 73 74 72 69 6e 67 20 70 6f 72 74 29 29 29 0a 0a string port))).. 0200: 0a 3b 20 46 72 65 71 75 65 6e 74 6c 79 2d 6f 63 .; Frequently-oc 0210: 63 75 72 72 69 6e 67 20 73 79 6e 74 61 78 2d 72 curring syntax-r 0220: 75 6c 65 20 6d 61 63 72 6f 73 0a 0a 3b 20 41 20 ule macros..; A 0230: 73 79 6d 62 6f 6c 3f 20 70 72 65 64 69 63 61 74 symbol? predicat 0240: 65 20 61 74 20 74 68 65 20 6d 61 63 72 6f 2d 65 e at the macro-e 0250: 78 70 61 6e 64 20 74 69 6d 65 0a 3b 09 73 79 6d xpand time.;.sym 0260: 62 6f 6c 3f 3f 20 46 4f 52 4d 20 4b 54 20 4b 46 bol?? FORM KT KF 0270: 0a 3b 20 46 4f 52 4d 20 69 73 20 61 6e 20 61 72 .; FORM is an ar 0280: 62 69 74 72 61 72 79 20 66 6f 72 6d 20 6f 72 20 bitrary form or 0290: 64 61 74 75 6d 0a 3b 20 65 78 70 61 6e 64 73 20 datum.; expands 02a0: 69 6e 20 4b 54 20 69 66 20 46 4f 52 4d 20 69 73 in KT if FORM is 02b0: 20 61 20 73 79 6d 62 6f 6c 20 28 69 64 65 6e 74 a symbol (ident 02c0: 69 66 69 65 72 29 2c 20 4f 74 68 65 72 77 69 73 ifier), Otherwis 02d0: 65 2c 20 65 78 70 61 6e 64 73 20 69 6e 20 4b 46 e, expands in KF 02e0: 0a 0a 28 64 65 66 69 6e 65 2d 73 79 6e 74 61 78 ..(define-syntax 02f0: 20 73 79 6d 62 6f 6c 3f 3f 0a 20 20 28 73 79 6e symbol??. (syn 0300: 74 61 78 2d 72 75 6c 65 73 20 28 29 0a 20 20 20 tax-rules (). 0310: 20 28 28 73 79 6d 62 6f 6c 3f 3f 20 28 78 20 2e ((symbol?? (x . 0320: 20 79 29 20 6b 74 20 6b 66 29 20 6b 66 29 09 3b y) kt kf) kf).; 0330: 20 49 74 27 73 20 61 20 70 61 69 72 2c 20 6e 6f It's a pair, no 0340: 74 20 61 20 73 79 6d 62 6f 6c 0a 20 20 20 20 28 t a symbol. ( 0350: 28 73 79 6d 62 6f 6c 3f 3f 20 23 28 78 20 2e 2e (symbol?? #(x .. 0360: 2e 29 20 6b 74 20 6b 66 29 20 6b 66 29 09 3b 20 .) kt kf) kf).; 0370: 49 74 27 73 20 61 20 76 65 63 74 6f 72 2c 20 6e It's a vector, n 0380: 6f 74 20 61 20 73 79 6d 62 6f 6c 0a 20 20 20 20 ot a symbol. 0390: 28 28 73 79 6d 62 6f 6c 3f 3f 20 6d 61 79 62 65 ((symbol?? maybe 03a0: 2d 73 79 6d 62 6f 6c 20 6b 74 20 6b 66 29 0a 20 -symbol kt kf). 03b0: 20 20 20 20 20 28 6c 65 74 2d 73 79 6e 74 61 78 (let-syntax 03c0: 0a 09 28 28 74 65 73 74 0a 09 20 20 20 28 73 79 ..((test.. (sy 03d0: 6e 74 61 78 2d 72 75 6c 65 73 20 28 29 0a 09 20 ntax-rules ().. 03e0: 20 20 20 20 28 28 74 65 73 74 20 6d 61 79 62 65 ((test maybe 03f0: 2d 73 79 6d 62 6f 6c 20 74 20 66 29 20 74 29 0a -symbol t f) t). 0400: 09 20 20 20 20 20 28 28 74 65 73 74 20 78 20 74 . ((test x t 0410: 20 66 29 20 66 29 29 29 29 0a 09 28 74 65 73 74 f) f))))..(test 0420: 20 61 62 72 61 63 61 64 61 62 72 61 20 6b 74 20 abracadabra kt 0430: 6b 66 29 29 29 29 29 0a 0a 3b 20 41 20 6d 61 63 kf)))))..; A mac 0440: 72 6f 2d 65 78 70 61 6e 64 2d 74 69 6d 65 20 6d ro-expand-time m 0450: 65 6d 76 20 66 75 6e 63 74 69 6f 6e 20 66 6f 72 emv function for 0460: 20 69 64 65 6e 74 69 66 69 65 72 73 0a 3b 09 69 identifiers.;.i 0470: 64 2d 6d 65 6d 76 3f 3f 20 46 4f 52 4d 20 28 49 d-memv?? FORM (I 0480: 44 20 2e 2e 2e 29 20 4b 54 20 4b 46 0a 3b 20 46 D ...) KT KF.; F 0490: 4f 52 4d 20 69 73 20 61 6e 20 61 72 62 69 74 72 ORM is an arbitr 04a0: 61 72 79 20 66 6f 72 6d 20 6f 72 20 64 61 74 75 ary form or datu 04b0: 6d 2c 20 49 44 20 69 73 20 61 6e 20 69 64 65 6e m, ID is an iden 04c0: 74 69 66 69 65 72 2e 0a 3b 20 54 68 65 20 6d 61 tifier..; The ma 04d0: 63 72 6f 20 65 78 70 61 6e 64 73 20 69 6e 74 6f cro expands into 04e0: 20 4b 54 20 69 66 20 46 4f 52 4d 20 69 73 20 61 KT if FORM is a 04f0: 6e 20 69 64 65 6e 74 69 66 69 65 72 2c 20 77 68 n identifier, wh 0500: 69 63 68 20 6f 63 63 75 72 73 0a 3b 20 69 6e 20 ich occurs.; in 0510: 74 68 65 20 6c 69 73 74 20 6f 66 20 69 64 65 6e the list of iden 0520: 74 69 66 69 65 72 73 20 73 75 70 70 6c 69 65 64 tifiers supplied 0530: 20 62 79 20 74 68 65 20 73 65 63 6f 6e 64 20 61 by the second a 0540: 72 67 75 6d 65 6e 74 2e 0a 3b 20 41 6c 6c 20 74 rgument..; All t 0550: 68 65 20 69 64 65 6e 74 69 66 69 65 72 73 20 69 he identifiers i 0560: 6e 20 74 68 61 74 20 6c 69 73 74 20 6d 75 73 74 n that list must 0570: 20 62 65 20 75 6e 69 71 75 65 2e 0a 3b 20 4f 74 be unique..; Ot 0580: 68 65 72 77 69 73 65 2c 20 69 64 2d 6d 65 6d 76 herwise, id-memv 0590: 3f 3f 20 65 78 70 61 6e 64 73 20 74 6f 20 4b 46 ?? expands to KF 05a0: 2e 0a 3b 20 54 77 6f 20 69 64 65 6e 74 69 66 69 ..; Two identifi 05b0: 65 72 73 20 6d 61 74 63 68 20 69 66 20 62 6f 74 ers match if bot 05c0: 68 20 72 65 66 65 72 20 74 6f 20 74 68 65 20 73 h refer to the s 05d0: 61 6d 65 20 62 69 6e 64 69 6e 67 20 6f 63 63 75 ame binding occu 05e0: 72 72 65 6e 63 65 2c 20 6f 72 0a 3b 20 28 62 6f rrence, or.; (bo 05f0: 74 68 20 61 72 65 20 75 6e 64 65 66 69 6e 65 64 th are undefined 0600: 20 61 6e 64 20 68 61 76 65 20 74 68 65 20 73 61 and have the sa 0610: 6d 65 20 73 70 65 6c 6c 69 6e 67 29 2e 0a 0a 28 me spelling)...( 0620: 64 65 66 69 6e 65 2d 73 79 6e 74 61 78 20 69 64 define-syntax id 0630: 2d 6d 65 6d 76 3f 3f 0a 20 20 28 73 79 6e 74 61 -memv??. (synta 0640: 78 2d 72 75 6c 65 73 20 28 29 0a 20 20 20 20 28 x-rules (). ( 0650: 28 69 64 2d 6d 65 6d 76 3f 3f 20 66 6f 72 6d 20 (id-memv?? form 0660: 28 69 64 20 2e 2e 2e 29 20 6b 74 20 6b 66 29 0a (id ...) kt kf). 0670: 20 20 20 20 20 20 28 6c 65 74 2d 73 79 6e 74 61 (let-synta 0680: 78 0a 09 28 28 74 65 73 74 0a 09 20 20 20 28 73 x..((test.. (s 0690: 79 6e 74 61 78 2d 72 75 6c 65 73 20 28 69 64 20 yntax-rules (id 06a0: 2e 2e 2e 29 0a 09 20 20 20 20 20 28 28 74 65 73 ...).. ((tes 06b0: 74 20 69 64 20 5f 6b 74 20 5f 6b 66 29 20 5f 6b t id _kt _kf) _k 06c0: 74 29 20 2e 2e 2e 0a 09 20 20 20 20 20 28 28 74 t) ..... ((t 06d0: 65 73 74 20 6f 74 68 65 72 77 69 73 65 20 5f 6b est otherwise _k 06e0: 74 20 5f 6b 66 29 20 5f 6b 66 29 29 29 29 0a 09 t _kf) _kf)))).. 06f0: 28 74 65 73 74 20 66 6f 72 6d 20 6b 74 20 6b 66 (test form kt kf 0700: 29 29 29 29 29 0a 0a 3b 20 43 6f 6d 6d 6f 6e 6c )))))..; Commonl 0710: 79 2d 75 73 65 64 20 43 50 53 20 6d 61 63 72 6f y-used CPS macro 0720: 73 0a 3b 20 54 68 65 20 66 6f 6c 6c 6f 77 69 6e s.; The followin 0730: 67 20 6d 61 63 72 6f 73 20 66 6f 6c 6c 6f 77 20 g macros follow 0740: 74 68 65 20 63 6f 6e 76 65 6e 74 69 6f 6e 20 74 the convention t 0750: 68 61 74 20 61 20 63 6f 6e 74 69 6e 75 61 74 69 hat a continuati 0760: 6f 6e 20 61 72 67 75 6d 65 6e 74 0a 3b 20 68 61 on argument.; ha 0770: 73 20 74 68 65 20 66 6f 72 6d 20 28 6b 2d 68 65 s the form (k-he 0780: 61 64 20 21 20 61 72 67 73 20 2e 2e 2e 29 0a 3b ad ! args ...).; 0790: 20 77 68 65 72 65 20 21 20 69 73 20 61 20 64 65 where ! is a de 07a0: 64 69 63 61 74 65 64 20 73 79 6d 62 6f 6c 20 28 dicated symbol ( 07b0: 70 6c 61 63 65 68 6f 6c 64 65 72 29 2e 0a 3b 20 placeholder)..; 07c0: 57 68 65 6e 20 61 20 43 50 53 20 6d 61 63 72 6f When a CPS macro 07d0: 20 69 6e 76 6f 6b 65 73 20 69 74 73 20 63 6f 6e invokes its con 07e0: 74 69 6e 75 61 74 69 6f 6e 2c 20 69 74 20 65 78 tinuation, it ex 07f0: 70 61 6e 64 73 20 69 6e 74 6f 0a 3b 20 28 6b 2d pands into.; (k- 0800: 68 65 61 64 20 76 61 6c 75 65 20 61 72 67 73 20 head value args 0810: 2e 2e 2e 29 0a 3b 20 54 6f 20 64 69 73 74 69 6e ...).; To distin 0820: 67 75 69 73 68 20 73 75 63 68 20 63 61 6c 6c 69 guish such calli 0830: 6e 67 20 63 6f 6e 76 65 6e 74 69 6f 6e 73 2c 20 ng conventions, 0840: 77 65 20 70 72 65 66 69 78 20 74 68 65 20 6e 61 we prefix the na 0850: 6d 65 73 20 6f 66 0a 3b 20 73 75 63 68 20 6d 61 mes of.; such ma 0860: 63 72 6f 73 20 77 69 74 68 20 6b 21 0a 0a 28 64 cros with k!..(d 0870: 65 66 69 6e 65 2d 73 79 6e 74 61 78 20 6b 21 69 efine-syntax k!i 0880: 64 09 09 09 3b 20 4a 75 73 74 20 74 68 65 20 69 d...; Just the i 0890: 64 65 6e 74 69 74 79 2e 20 55 73 65 66 75 6c 20 dentity. Useful 08a0: 69 6e 20 43 50 53 0a 20 20 28 73 79 6e 74 61 78 in CPS. (syntax 08b0: 2d 72 75 6c 65 73 20 28 29 0a 20 20 20 20 28 28 -rules (). (( 08c0: 6b 21 69 64 20 78 29 20 78 29 29 29 0a 0a 3b 20 k!id x) x)))..; 08d0: 6b 21 72 65 76 65 72 73 65 20 41 43 43 20 28 46 k!reverse ACC (F 08e0: 4f 52 4d 20 2e 2e 2e 29 20 4b 0a 3b 20 72 65 76 ORM ...) K.; rev 08f0: 65 72 73 65 73 20 74 68 65 20 73 65 63 6f 6e 64 erses the second 0900: 20 61 72 67 75 6d 65 6e 74 2c 20 61 70 70 65 6e argument, appen 0910: 64 73 20 69 74 20 74 6f 20 74 68 65 20 66 69 72 ds it to the fir 0920: 73 74 20 61 6e 64 20 70 61 73 73 65 73 0a 3b 20 st and passes.; 0930: 74 68 65 20 72 65 73 75 6c 74 20 74 6f 20 4b 0a the result to K. 0940: 0a 28 64 65 66 69 6e 65 2d 73 79 6e 74 61 78 20 .(define-syntax 0950: 6b 21 72 65 76 65 72 73 65 0a 20 20 28 73 79 6e k!reverse. (syn 0960: 74 61 78 2d 72 75 6c 65 73 20 28 21 29 0a 20 20 tax-rules (!). 0970: 20 20 28 28 6b 21 72 65 76 65 72 73 65 20 61 63 ((k!reverse ac 0980: 63 20 28 29 20 28 6b 2d 68 65 61 64 20 21 20 2e c () (k-head ! . 0990: 20 6b 2d 61 72 67 73 29 29 0a 20 20 20 20 20 20 k-args)). 09a0: 28 6b 2d 68 65 61 64 20 61 63 63 20 2e 20 6b 2d (k-head acc . k- 09b0: 61 72 67 73 29 29 0a 20 20 20 20 28 28 6b 21 72 args)). ((k!r 09c0: 65 76 65 72 73 65 20 61 63 63 20 28 78 20 2e 20 everse acc (x . 09d0: 72 65 73 74 29 20 6b 29 0a 20 20 20 20 20 20 28 rest) k). ( 09e0: 6b 21 72 65 76 65 72 73 65 20 28 78 20 2e 20 61 k!reverse (x . a 09f0: 63 63 29 20 72 65 73 74 20 6b 29 29 29 29 0a 0a cc) rest k)))).. 0a00: 28 64 65 66 69 6e 65 2d 73 79 6e 74 61 78 20 61 (define-syntax a 0a10: 73 73 75 72 65 0a 20 20 28 73 79 6e 74 61 78 2d ssure. (syntax- 0a20: 72 75 6c 65 73 20 28 29 0a 20 20 20 20 28 28 61 rules (). ((a 0a30: 73 73 75 72 65 20 65 78 70 20 65 72 72 6f 72 2d ssure exp error- 0a40: 6d 73 67 29 20 28 61 73 73 65 72 74 20 65 78 70 msg) (assert exp 0a50: 20 72 65 70 6f 72 74 3a 20 65 72 72 6f 72 2d 6d report: error-m 0a60: 73 67 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 sg))))..(define 0a70: 28 69 64 65 6e 74 69 66 79 2d 65 72 72 6f 72 20 (identify-error 0a80: 6d 73 67 20 61 72 67 73 20 2e 20 64 69 73 70 6f msg args . dispo 0a90: 73 69 74 69 6f 6e 2d 6d 73 67 73 29 0a 20 20 28 sition-msgs). ( 0aa0: 6c 65 74 20 28 28 70 6f 72 74 20 28 63 6f 6e 73 let ((port (cons 0ab0: 6f 6c 65 2d 6f 75 74 70 75 74 2d 70 6f 72 74 29 ole-output-port) 0ac0: 29 29 0a 20 20 20 20 28 6e 65 77 6c 69 6e 65 20 )). (newline 0ad0: 70 6f 72 74 29 0a 20 20 20 20 28 64 69 73 70 6c port). (displ 0ae0: 61 79 20 22 45 52 52 4f 52 22 20 70 6f 72 74 29 ay "ERROR" port) 0af0: 0a 20 20 20 20 28 64 69 73 70 6c 61 79 20 6d 73 . (display ms 0b00: 67 20 70 6f 72 74 29 0a 20 20 20 20 28 66 6f 72 g port). (for 0b10: 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 20 28 6d -each (lambda (m 0b20: 73 67 29 20 28 64 69 73 70 6c 61 79 20 6d 73 67 sg) (display msg 0b30: 20 70 6f 72 74 29 29 0a 09 20 20 20 20 20 20 28 port)).. ( 0b40: 61 70 70 65 6e 64 20 61 72 67 73 20 64 69 73 70 append args disp 0b50: 6f 73 69 74 69 6f 6e 2d 6d 73 67 73 29 29 0a 20 osition-msgs)). 0b60: 20 20 20 28 6e 65 77 6c 69 6e 65 20 70 6f 72 74 (newline port 0b70: 29 29 29 0a 0a 3b 20 6c 69 6b 65 20 63 6f 75 74 )))..; like cout 0b80: 20 3c 3c 20 61 72 67 75 6d 65 6e 74 73 20 3c 3c << arguments << 0b90: 20 61 72 67 73 0a 3b 20 77 68 65 72 65 20 61 72 args.; where ar 0ba0: 67 75 6d 65 6e 74 20 63 61 6e 20 62 65 20 61 6e gument can be an 0bb0: 79 20 53 63 68 65 6d 65 20 6f 62 6a 65 63 74 2e y Scheme object. 0bc0: 20 49 66 20 69 74 27 73 20 61 20 70 72 6f 63 65 If it's a proce 0bd0: 64 75 72 65 0a 3b 20 28 77 69 74 68 6f 75 74 20 dure.; (without 0be0: 61 72 67 73 29 20 69 74 27 73 20 65 78 65 63 75 args) it's execu 0bf0: 74 65 64 20 72 61 74 68 65 72 20 74 68 61 6e 20 ted rather than 0c00: 70 72 69 6e 74 65 64 20 28 6c 69 6b 65 20 6e 65 printed (like ne 0c10: 77 6c 69 6e 65 29 0a 0a 28 64 65 66 69 6e 65 20 wline)..(define 0c20: 28 63 6f 75 74 20 2e 20 61 72 67 73 29 0a 20 20 (cout . args). 0c30: 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 (for-each (lambd 0c40: 61 20 28 78 29 0a 20 20 20 20 20 20 20 20 20 20 a (x). 0c50: 20 20 20 20 28 69 66 20 28 70 72 6f 63 65 64 75 (if (procedu 0c60: 72 65 3f 20 78 29 20 28 78 29 20 28 64 69 73 70 re? x) (x) (disp 0c70: 6c 61 79 20 78 29 29 29 0a 20 20 20 20 20 20 20 lay x))). 0c80: 20 20 20 20 20 61 72 67 73 29 29 0a 0a 28 64 65 args))..(de 0c90: 66 69 6e 65 20 28 63 65 72 72 20 2e 20 61 72 67 fine (cerr . arg 0ca0: 73 29 0a 20 20 28 66 6f 72 2d 65 61 63 68 20 28 s). (for-each ( 0cb0: 6c 61 6d 62 64 61 20 28 78 29 0a 20 20 20 20 20 lambda (x). 0cc0: 20 20 20 20 20 20 20 20 20 28 69 66 20 28 70 72 (if (pr 0cd0: 6f 63 65 64 75 72 65 3f 20 78 29 20 28 78 20 28 ocedure? x) (x ( 0ce0: 63 6f 6e 73 6f 6c 65 2d 6f 75 74 70 75 74 2d 70 console-output-p 0cf0: 6f 72 74 29 29 0a 09 09 28 64 69 73 70 6c 61 79 ort))...(display 0d00: 20 78 20 28 63 6f 6e 73 6f 6c 65 2d 6f 75 74 70 x (console-outp 0d10: 75 74 2d 70 6f 72 74 29 29 29 29 0a 20 20 20 20 ut-port)))). 0d20: 20 20 20 20 20 20 20 20 61 72 67 73 29 29 0a 0a args)).. 0d30: 28 64 65 66 69 6e 65 20 6e 6c 20 28 73 74 72 69 (define nl (stri 0d40: 6e 67 20 23 5c 6e 65 77 6c 69 6e 65 29 29 0a 0a ng #\newline)).. 0d50: 3b 20 53 6f 6d 65 20 75 73 65 66 75 6c 20 69 6e ; Some useful in 0d60: 63 72 65 6d 65 6e 74 2f 64 65 63 72 65 6d 65 6e crement/decremen 0d70: 74 20 6f 70 65 72 61 74 6f 72 73 0a 0a 28 64 65 t operators..(de 0d80: 66 69 6e 65 2d 73 79 6e 74 61 78 20 69 6e 63 21 fine-syntax inc! 0d90: 09 09 3b 20 4d 75 74 61 62 6c 65 20 69 6e 63 72 ..; Mutable incr 0da0: 65 6d 65 6e 74 0a 20 20 28 73 79 6e 74 61 78 2d ement. (syntax- 0db0: 72 75 6c 65 73 20 28 29 0a 20 20 20 20 28 28 69 rules (). ((i 0dc0: 6e 63 21 20 78 29 20 28 73 65 74 21 20 78 20 28 nc! x) (set! x ( 0dd0: 2b 20 31 20 78 29 29 29 29 29 0a 28 64 65 66 69 + 1 x))))).(defi 0de0: 6e 65 2d 73 79 6e 74 61 78 20 69 6e 63 20 20 20 ne-syntax inc 0df0: 20 20 20 20 20 20 20 20 20 20 20 20 3b 20 52 65 ; Re 0e00: 61 64 2d 6f 6e 6c 79 20 69 6e 63 72 65 6d 65 6e ad-only incremen 0e10: 74 0a 20 20 28 73 79 6e 74 61 78 2d 72 75 6c 65 t. (syntax-rule 0e20: 73 20 28 29 0a 20 20 20 20 28 28 69 6e 63 20 78 s (). ((inc x 0e30: 29 20 28 2b 20 31 20 78 29 29 29 29 0a 0a 28 64 ) (+ 1 x))))..(d 0e40: 65 66 69 6e 65 2d 73 79 6e 74 61 78 20 64 65 63 efine-syntax dec 0e50: 21 09 09 3b 20 4d 75 74 61 62 6c 65 20 64 65 63 !..; Mutable dec 0e60: 72 65 6d 65 6e 74 0a 20 20 28 73 79 6e 74 61 78 rement. (syntax 0e70: 2d 72 75 6c 65 73 20 28 29 0a 20 20 20 20 28 28 -rules (). (( 0e80: 64 65 63 21 20 78 29 20 28 73 65 74 21 20 78 20 dec! x) (set! x 0e90: 28 2d 20 78 20 31 29 29 29 29 29 0a 28 64 65 66 (- x 1))))).(def 0ea0: 69 6e 65 2d 73 79 6e 74 61 78 20 64 65 63 09 09 ine-syntax dec.. 0eb0: 3b 20 52 65 61 64 2d 6f 6e 6c 79 20 64 65 63 72 ; Read-only decr 0ec0: 65 6d 65 6e 74 0a 20 20 28 73 79 6e 74 61 78 2d ement. (syntax- 0ed0: 72 75 6c 65 73 20 28 29 0a 20 20 20 20 28 28 64 rules (). ((d 0ee0: 65 63 20 78 29 20 28 2d 20 78 20 31 29 29 29 29 ec x) (- x 1)))) 0ef0: 0a 0a 3b 20 53 6f 6d 65 20 75 73 65 66 75 6c 20 ..; Some useful 0f00: 63 6f 6e 74 72 6f 6c 20 6f 70 65 72 61 74 6f 72 control operator 0f10: 73 0a 0a 09 09 09 3b 20 69 66 20 63 6f 6e 64 69 s.....; if condi 0f20: 74 69 6f 6e 20 69 73 20 66 61 6c 73 65 20 65 78 tion is false ex 0f30: 65 63 75 74 65 20 73 74 6d 74 73 20 69 6e 20 74 ecute stmts in t 0f40: 75 72 6e 0a 09 09 09 3b 20 61 6e 64 20 72 65 74 urn....; and ret 0f50: 75 72 6e 20 74 68 65 20 72 65 73 75 6c 74 20 6f urn the result o 0f60: 66 20 74 68 65 20 6c 61 73 74 20 73 74 61 74 65 f the last state 0f70: 6d 65 6e 74 0a 09 09 09 3b 20 6f 74 68 65 72 77 ment....; otherw 0f80: 69 73 65 2c 20 72 65 74 75 72 6e 20 75 6e 73 70 ise, return unsp 0f90: 65 63 69 66 69 65 64 2e 0a 09 09 09 3b 20 54 68 ecified.....; Th 0fa0: 69 73 20 70 72 69 6d 69 74 69 76 65 20 69 73 20 is primitive is 0fb0: 6f 66 74 65 6e 20 63 61 6c 6c 65 64 20 27 75 6e often called 'un 0fc0: 6c 65 73 73 27 0a 28 64 65 66 69 6e 65 2d 73 79 less'.(define-sy 0fd0: 6e 74 61 78 20 77 68 65 6e 6e 6f 74 0a 20 20 28 ntax whennot. ( 0fe0: 73 79 6e 74 61 78 2d 72 75 6c 65 73 20 28 29 0a syntax-rules (). 0ff0: 20 20 20 20 28 28 77 68 65 6e 6e 6f 74 20 63 6f ((whennot co 1000: 6e 64 69 74 69 6f 6e 20 2e 20 73 74 6d 74 73 29 ndition . stmts) 1010: 0a 20 20 20 20 20 20 28 6f 72 20 63 6f 6e 64 69 . (or condi 1020: 74 69 6f 6e 20 28 62 65 67 69 6e 20 2e 20 73 74 tion (begin . st 1030: 6d 74 73 29 29 29 29 29 0a 0a 0a 09 09 09 3b 20 mts)))))......; 1040: 45 78 65 63 75 74 65 20 61 20 73 65 71 75 65 6e Execute a sequen 1050: 63 65 20 6f 66 20 66 6f 72 6d 73 20 61 6e 64 20 ce of forms and 1060: 72 65 74 75 72 6e 20 74 68 65 0a 09 09 09 3b 20 return the....; 1070: 72 65 73 75 6c 74 20 6f 66 20 74 68 65 20 5f 66 result of the _f 1080: 69 72 73 74 5f 20 6f 6e 65 2e 20 4c 69 6b 65 20 irst_ one. Like 1090: 50 52 4f 47 31 20 69 6e 20 4c 69 73 70 2e 0a 09 PROG1 in Lisp... 10a0: 09 09 3b 20 54 79 70 69 63 61 6c 6c 79 20 75 73 ..; Typically us 10b0: 65 64 20 74 6f 20 65 76 61 6c 75 61 74 65 20 6f ed to evaluate o 10c0: 6e 65 20 6f 72 20 6d 6f 72 65 20 66 6f 72 6d 73 ne or more forms 10d0: 20 77 69 74 68 0a 09 09 09 3b 20 73 69 64 65 20 with....; side 10e0: 65 66 66 65 63 74 73 20 61 6e 64 20 72 65 74 75 effects and retu 10f0: 72 6e 20 61 20 76 61 6c 75 65 20 74 68 61 74 20 rn a value that 1100: 6d 75 73 74 20 62 65 0a 09 09 09 3b 20 63 6f 6d must be....; com 1110: 70 75 74 65 64 20 62 65 66 6f 72 65 20 73 6f 6d puted before som 1120: 65 20 6f 72 20 61 6c 6c 20 6f 66 20 74 68 65 20 e or all of the 1130: 73 69 64 65 20 65 66 66 65 63 74 73 20 68 61 70 side effects hap 1140: 70 65 6e 2e 0a 28 64 65 66 69 6e 65 2d 73 79 6e pen..(define-syn 1150: 74 61 78 20 62 65 67 69 6e 30 0a 20 20 28 73 79 tax begin0. (sy 1160: 6e 74 61 78 2d 72 75 6c 65 73 20 28 29 0a 20 20 ntax-rules (). 1170: 20 20 28 28 62 65 67 69 6e 30 20 66 6f 72 6d 20 ((begin0 form 1180: 66 6f 72 6d 31 20 2e 2e 2e 20 29 20 0a 20 20 20 form1 ... ) . 1190: 20 20 20 28 6c 65 74 20 28 28 76 61 6c 20 66 6f (let ((val fo 11a0: 72 6d 29 29 20 66 6f 72 6d 31 20 2e 2e 2e 20 76 rm)) form1 ... v 11b0: 61 6c 29 29 29 29 0a 0a 09 09 09 3b 20 50 72 65 al)))).....; Pre 11c0: 70 65 6e 64 20 61 6e 20 49 54 45 4d 20 74 6f 20 pend an ITEM to 11d0: 61 20 4c 49 53 54 2c 20 6c 69 6b 65 20 61 20 4c a LIST, like a L 11e0: 69 73 70 20 6d 61 63 72 6f 20 50 55 53 48 0a 09 isp macro PUSH.. 11f0: 09 09 3b 20 61 6e 20 49 54 45 4d 20 63 61 6e 20 ..; an ITEM can 1200: 62 65 20 61 6e 20 65 78 70 72 65 73 73 69 6f 6e be an expression 1210: 2c 20 62 75 74 20 6c 73 20 6d 75 73 74 20 62 65 , but ls must be 1220: 20 61 20 56 41 52 0a 28 64 65 66 69 6e 65 2d 73 a VAR.(define-s 1230: 79 6e 74 61 78 20 70 75 73 68 21 0a 20 20 28 73 yntax push!. (s 1240: 79 6e 74 61 78 2d 72 75 6c 65 73 20 28 29 0a 20 yntax-rules (). 1250: 20 20 20 28 28 70 75 73 68 21 20 69 74 65 6d 20 ((push! item 1260: 6c 73 29 0a 20 20 20 20 20 20 28 73 65 74 21 20 ls). (set! 1270: 6c 73 20 28 63 6f 6e 73 20 69 74 65 6d 20 6c 73 ls (cons item ls 1280: 29 29 29 29 29 0a 0a 09 09 09 3b 20 61 73 73 6f ))))).....; asso 1290: 63 2d 70 72 69 6d 69 74 69 76 65 73 20 77 69 74 c-primitives wit 12a0: 68 20 61 20 64 65 66 61 75 6c 74 20 63 6c 61 75 h a default clau 12b0: 73 65 0a 09 09 09 3b 20 49 66 20 74 68 65 20 73 se....; If the s 12c0: 65 61 72 63 68 20 69 6e 20 74 68 65 20 61 73 73 earch in the ass 12d0: 6f 63 20 6c 69 73 74 20 66 61 69 6c 73 2c 20 74 oc list fails, t 12e0: 68 65 0a 09 09 09 3b 20 64 65 66 61 75 6c 74 20 he....; default 12f0: 61 63 74 69 6f 6e 20 61 72 67 75 6d 65 6e 74 20 action argument 1300: 69 73 20 72 65 74 75 72 6e 65 64 2e 20 49 66 20 is returned. If 1310: 74 68 69 73 0a 09 09 09 3b 20 64 65 66 61 75 6c this....; defaul 1320: 74 20 61 63 74 69 6f 6e 20 74 75 72 6e 73 20 6f t action turns o 1330: 75 74 20 74 6f 20 62 65 20 61 20 74 68 75 6e 6b ut to be a thunk 1340: 2c 0a 09 09 09 3b 20 74 68 65 20 72 65 73 75 6c ,....; the resul 1350: 74 20 6f 66 20 69 74 73 20 65 76 61 6c 75 61 74 t of its evaluat 1360: 69 6f 6e 20 69 73 20 72 65 74 75 72 6e 65 64 2e ion is returned. 1370: 0a 09 09 09 3b 20 49 66 20 74 68 65 20 64 65 66 ....; If the def 1380: 61 75 6c 74 20 61 63 74 69 6f 6e 20 69 73 20 6e ault action is n 1390: 6f 74 20 67 69 76 65 6e 2c 20 61 6e 20 65 72 72 ot given, an err 13a0: 6f 72 0a 09 09 09 3b 20 69 73 20 73 69 67 6e 61 or....; is signa 13b0: 6c 65 64 0a 0a 28 64 65 66 69 6e 65 2d 73 79 6e led..(define-syn 13c0: 74 61 78 20 61 73 73 71 2d 64 65 66 0a 20 20 28 tax assq-def. ( 13d0: 73 79 6e 74 61 78 2d 72 75 6c 65 73 20 28 29 0a syntax-rules (). 13e0: 20 20 20 20 28 28 61 73 73 71 2d 64 65 66 20 6b ((assq-def k 13f0: 65 79 20 61 6c 69 73 74 29 0a 20 20 20 20 20 20 ey alist). 1400: 28 6f 72 20 28 61 73 73 71 20 6b 65 79 20 61 6c (or (assq key al 1410: 69 73 74 29 0a 09 28 65 72 72 6f 72 20 22 66 61 ist)..(error "fa 1420: 69 6c 65 64 20 74 6f 20 61 73 73 71 20 6b 65 79 iled to assq key 1430: 20 27 22 20 6b 65 79 20 22 27 20 69 6e 20 61 20 '" key "' in a 1440: 6c 69 73 74 20 22 20 61 6c 69 73 74 29 29 29 0a list " alist))). 1450: 20 20 20 20 28 28 61 73 73 71 2d 64 65 66 20 6b ((assq-def k 1460: 65 79 20 61 6c 69 73 74 20 23 66 29 0a 20 20 20 ey alist #f). 1470: 20 20 20 28 61 73 73 71 20 6b 65 79 20 61 6c 69 (assq key ali 1480: 73 74 29 29 0a 20 20 20 20 28 28 61 73 73 71 2d st)). ((assq- 1490: 64 65 66 20 6b 65 79 20 61 6c 69 73 74 20 64 65 def key alist de 14a0: 66 61 75 6c 74 29 0a 20 20 20 20 20 20 28 6f 72 fault). (or 14b0: 20 28 61 73 73 71 20 6b 65 79 20 61 6c 69 73 74 (assq key alist 14c0: 29 20 28 69 66 20 28 70 72 6f 63 65 64 75 72 65 ) (if (procedure 14d0: 3f 20 64 65 66 61 75 6c 74 29 20 28 64 65 66 61 ? default) (defa 14e0: 75 6c 74 29 20 64 65 66 61 75 6c 74 29 29 29 29 ult) default)))) 14f0: 29 0a 0a 28 64 65 66 69 6e 65 2d 73 79 6e 74 61 )..(define-synta 1500: 78 20 61 73 73 76 2d 64 65 66 0a 20 20 28 73 79 x assv-def. (sy 1510: 6e 74 61 78 2d 72 75 6c 65 73 20 28 29 0a 20 20 ntax-rules (). 1520: 20 20 28 28 61 73 73 76 2d 64 65 66 20 6b 65 79 ((assv-def key 1530: 20 61 6c 69 73 74 29 0a 20 20 20 20 20 20 28 6f alist). (o 1540: 72 20 28 61 73 73 76 20 6b 65 79 20 61 6c 69 73 r (assv key alis 1550: 74 29 0a 09 28 65 72 72 6f 72 20 22 66 61 69 6c t)..(error "fail 1560: 65 64 20 74 6f 20 61 73 73 76 20 6b 65 79 20 27 ed to assv key ' 1570: 22 20 6b 65 79 20 22 27 20 69 6e 20 61 20 6c 69 " key "' in a li 1580: 73 74 20 22 20 61 6c 69 73 74 29 29 29 0a 20 20 st " alist))). 1590: 20 20 28 28 61 73 73 76 2d 64 65 66 20 6b 65 79 ((assv-def key 15a0: 20 61 6c 69 73 74 20 23 66 29 0a 20 20 20 20 20 alist #f). 15b0: 20 28 61 73 73 76 20 6b 65 79 20 61 6c 69 73 74 (assv key alist 15c0: 29 29 0a 20 20 20 20 28 28 61 73 73 76 2d 64 65 )). ((assv-de 15d0: 66 20 6b 65 79 20 61 6c 69 73 74 20 64 65 66 61 f key alist defa 15e0: 75 6c 74 29 0a 20 20 20 20 20 20 28 6f 72 20 28 ult). (or ( 15f0: 61 73 73 76 20 6b 65 79 20 61 6c 69 73 74 29 20 assv key alist) 1600: 28 69 66 20 28 70 72 6f 63 65 64 75 72 65 3f 20 (if (procedure? 1610: 64 65 66 61 75 6c 74 29 20 28 64 65 66 61 75 6c default) (defaul 1620: 74 29 20 64 65 66 61 75 6c 74 29 29 29 29 29 0a t) default))))). 1630: 0a 28 64 65 66 69 6e 65 2d 73 79 6e 74 61 78 20 .(define-syntax 1640: 61 73 73 6f 63 2d 64 65 66 0a 20 20 28 73 79 6e assoc-def. (syn 1650: 74 61 78 2d 72 75 6c 65 73 20 28 29 0a 20 20 20 tax-rules (). 1660: 20 28 28 61 73 73 6f 63 2d 64 65 66 20 6b 65 79 ((assoc-def key 1670: 20 61 6c 69 73 74 29 0a 20 20 20 20 20 20 28 6f alist). (o 1680: 72 20 28 61 73 73 6f 63 20 6b 65 79 20 61 6c 69 r (assoc key ali 1690: 73 74 29 0a 09 28 65 72 72 6f 72 20 22 66 61 69 st)..(error "fai 16a0: 6c 65 64 20 74 6f 20 61 73 73 6f 63 20 6b 65 79 led to assoc key 16b0: 20 27 22 20 6b 65 79 20 22 27 20 69 6e 20 61 20 '" key "' in a 16c0: 6c 69 73 74 20 22 20 61 6c 69 73 74 29 29 29 0a list " alist))). 16d0: 20 20 20 20 28 28 61 73 73 6f 63 2d 64 65 66 20 ((assoc-def 16e0: 6b 65 79 20 61 6c 69 73 74 20 23 66 29 0a 20 20 key alist #f). 16f0: 20 20 20 20 28 61 73 73 6f 63 20 6b 65 79 20 61 (assoc key a 1700: 6c 69 73 74 29 29 0a 20 20 20 20 28 28 61 73 73 list)). ((ass 1710: 6f 63 2d 64 65 66 20 6b 65 79 20 61 6c 69 73 74 oc-def key alist 1720: 20 64 65 66 61 75 6c 74 29 0a 20 20 20 20 20 20 default). 1730: 28 6f 72 20 28 61 73 73 6f 63 20 6b 65 79 20 61 (or (assoc key a 1740: 6c 69 73 74 29 20 28 69 66 20 28 70 72 6f 63 65 list) (if (proce 1750: 64 75 72 65 3f 20 64 65 66 61 75 6c 74 29 20 28 dure? default) ( 1760: 64 65 66 61 75 6c 74 29 20 64 65 66 61 75 6c 74 default) default 1770: 29 29 29 29 29 0a 0a 09 09 09 3b 20 43 6f 6e 76 ))))).....; Conv 1780: 65 6e 69 65 6e 63 65 20 6d 61 63 72 6f 73 20 74 enience macros t 1790: 6f 20 61 76 6f 69 64 20 71 75 6f 74 69 6e 67 20 o avoid quoting 17a0: 6f 66 20 73 79 6d 62 6f 6c 73 0a 09 09 09 3b 20 of symbols....; 17b0: 62 65 69 6e 67 20 64 65 70 6f 73 69 74 65 64 2f being deposited/ 17c0: 6c 6f 6f 6b 65 64 20 75 70 20 69 6e 20 74 68 65 looked up in the 17d0: 20 65 6e 76 69 72 6f 6e 6d 65 6e 74 0a 28 64 65 environment.(de 17e0: 66 69 6e 65 2d 73 79 6e 74 61 78 20 65 6e 76 2e fine-syntax env. 17f0: 66 69 6e 64 0a 20 20 28 73 79 6e 74 61 78 2d 72 find. (syntax-r 1800: 75 6c 65 73 20 28 29 20 28 28 65 6e 76 2e 66 69 ules () ((env.fi 1810: 6e 64 20 6b 65 79 29 20 28 25 25 65 6e 76 2e 66 nd key) (%%env.f 1820: 69 6e 64 20 27 6b 65 79 29 29 29 29 0a 28 64 65 ind 'key)))).(de 1830: 66 69 6e 65 2d 73 79 6e 74 61 78 20 65 6e 76 2e fine-syntax env. 1840: 64 65 6d 61 6e 64 0a 20 20 28 73 79 6e 74 61 78 demand. (syntax 1850: 2d 72 75 6c 65 73 20 28 29 20 28 28 65 6e 76 2e -rules () ((env. 1860: 64 65 6d 61 6e 64 20 6b 65 79 29 20 28 25 25 65 demand key) (%%e 1870: 6e 76 2e 64 65 6d 61 6e 64 20 27 6b 65 79 29 29 nv.demand 'key)) 1880: 29 29 0a 28 64 65 66 69 6e 65 2d 73 79 6e 74 61 )).(define-synta 1890: 78 20 65 6e 76 2e 62 69 6e 64 0a 20 20 28 73 79 x env.bind. (sy 18a0: 6e 74 61 78 2d 72 75 6c 65 73 20 28 29 20 28 28 ntax-rules () (( 18b0: 65 6e 76 2e 62 69 6e 64 20 6b 65 79 20 76 61 6c env.bind key val 18c0: 75 65 29 20 28 25 25 65 6e 76 2e 62 69 6e 64 20 ue) (%%env.bind 18d0: 27 6b 65 79 20 76 61 6c 75 65 29 29 29 29 0a 0a 'key value)))).. 18e0: 0a 3b 20 20 20 73 73 61 78 3a 77 61 72 6e 20 50 .; ssax:warn P 18f0: 4f 52 54 20 4d 45 53 53 41 47 45 20 53 50 45 43 ORT MESSAGE SPEC 1900: 49 41 4c 49 53 49 4e 47 2d 4d 53 47 2a 0a 3b 20 IALISING-MSG*.; 1910: 74 6f 20 6e 6f 74 69 66 79 20 74 68 65 20 75 73 to notify the us 1920: 65 72 20 61 62 6f 75 74 20 77 61 72 6e 69 6e 67 er about warning 1930: 73 20 74 68 61 74 20 61 72 65 20 4e 4f 54 20 65 s that are NOT e 1940: 72 72 6f 72 73 20 62 75 74 20 73 74 69 6c 6c 0a rrors but still. 1950: 3b 20 6d 61 79 20 61 6c 65 72 74 20 74 68 65 20 ; may alert the 1960: 75 73 65 72 2e 0a 3b 20 52 65 73 75 6c 74 20 69 user..; Result i 1970: 73 20 75 6e 73 70 65 63 69 66 69 65 64 2e 0a 3b s unspecified..; 1980: 20 57 65 20 6e 65 65 64 20 74 6f 20 64 65 66 69 We need to defi 1990: 6e 65 20 74 68 65 20 66 75 6e 63 74 69 6f 6e 20 ne the function 19a0: 74 6f 20 61 6c 6c 6f 77 20 74 68 65 20 73 65 6c to allow the sel 19b0: 66 2d 74 65 73 74 73 20 74 6f 20 72 75 6e 2e 0a f-tests to run.. 19c0: 3b 20 4e 6f 72 6d 61 6c 6c 79 20 74 68 65 20 64 ; Normally the d 19d0: 65 66 69 6e 69 74 69 6f 6e 20 6f 66 20 73 73 61 efinition of ssa 19e0: 78 3a 77 61 72 6e 20 69 73 20 74 6f 20 62 65 20 x:warn is to be 19f0: 70 72 6f 76 69 64 65 64 20 62 79 20 74 68 65 20 provided by the 1a00: 75 73 65 72 2e 0a 0a 20 28 64 65 66 69 6e 65 20 user... (define 1a10: 28 73 73 61 78 3a 77 61 72 6e 20 70 6f 72 74 20 (ssax:warn port 1a20: 6d 73 67 20 2e 20 6f 74 68 65 72 2d 6d 73 67 29 msg . other-msg) 1a30: 0a 20 20 20 28 61 70 70 6c 79 20 63 65 72 72 20 . (apply cerr 1a40: 28 63 6f 6e 73 2a 20 6e 6c 20 22 57 61 72 6e 69 (cons* nl "Warni 1a50: 6e 67 3a 20 22 20 6d 73 67 20 6f 74 68 65 72 2d ng: " msg other- 1a60: 6d 73 67 29 29 29 0a 0a 0a 0a 3b 20 20 20 70 61 msg)))....; pa 1a70: 72 73 65 72 2d 65 72 72 6f 72 20 50 4f 52 54 20 rser-error PORT 1a80: 4d 45 53 53 41 47 45 20 53 50 45 43 49 41 4c 49 MESSAGE SPECIALI 1a90: 53 49 4e 47 2d 4d 53 47 2a 0a 3b 20 74 6f 20 6c SING-MSG*.; to l 1aa0: 65 74 20 74 68 65 20 75 73 65 72 20 6b 6e 6f 77 et the user know 1ab0: 20 6f 66 20 61 20 73 79 6e 74 61 78 20 65 72 72 of a syntax err 1ac0: 6f 72 20 6f 72 20 61 20 76 69 6f 6c 61 74 69 6f or or a violatio 1ad0: 6e 20 6f 66 20 61 0a 3b 20 77 65 6c 6c 2d 66 6f n of a.; well-fo 1ae0: 72 6d 65 64 6e 65 73 73 20 6f 72 20 76 61 6c 69 rmedness or vali 1af0: 64 61 74 69 6f 6e 20 63 6f 6e 73 74 72 61 69 6e dation constrain 1b00: 74 2e 0a 3b 20 52 65 73 75 6c 74 20 69 73 20 75 t..; Result is u 1b10: 6e 73 70 65 63 69 66 69 65 64 2e 0a 3b 20 57 65 nspecified..; We 1b20: 20 6e 65 65 64 20 74 6f 20 64 65 66 69 6e 65 20 need to define 1b30: 74 68 65 20 66 75 6e 63 74 69 6f 6e 20 74 6f 20 the function to 1b40: 61 6c 6c 6f 77 20 74 68 65 20 73 65 6c 66 2d 74 allow the self-t 1b50: 65 73 74 73 20 74 6f 20 72 75 6e 2e 0a 3b 20 4e ests to run..; N 1b60: 6f 72 6d 61 6c 6c 79 20 74 68 65 20 64 65 66 69 ormally the defi 1b70: 6e 69 74 69 6f 6e 20 6f 66 20 70 61 72 73 65 72 nition of parser 1b80: 2d 65 72 72 6f 72 20 69 73 20 74 6f 20 62 65 20 -error is to be 1b90: 70 72 6f 76 69 64 65 64 20 62 79 20 74 68 65 20 provided by the 1ba0: 75 73 65 72 2e 0a 0a 20 28 64 65 66 69 6e 65 20 user... (define 1bb0: 28 70 61 72 73 65 72 2d 65 72 72 6f 72 20 70 6f (parser-error po 1bc0: 72 74 20 6d 73 67 20 2e 20 73 70 65 63 69 61 6c rt msg . special 1bd0: 69 7a 69 6e 67 2d 6d 73 67 73 29 0a 20 20 20 28 izing-msgs). ( 1be0: 61 70 70 6c 79 20 65 72 72 6f 72 20 28 63 6f 6e apply error (con 1bf0: 73 20 6d 73 67 20 73 70 65 63 69 61 6c 69 7a 69 s msg specializi 1c00: 6e 67 2d 6d 73 67 73 29 29 29 0a 0a 28 64 65 66 ng-msgs)))..(def 1c10: 69 6e 65 2d 73 79 6e 74 61 78 20 64 65 66 69 6e ine-syntax defin 1c20: 65 2d 6f 70 74 0a 20 20 20 20 28 73 79 6e 74 61 e-opt. (synta 1c30: 78 2d 72 75 6c 65 73 20 28 6f 70 74 69 6f 6e 61 x-rules (optiona 1c40: 6c 29 0a 20 20 20 20 20 20 28 28 64 65 66 69 6e l). ((defin 1c50: 65 2d 6f 70 74 20 28 6e 61 6d 65 20 2e 20 62 69 e-opt (name . bi 1c60: 6e 64 69 6e 67 73 29 20 2e 20 62 6f 64 69 65 73 ndings) . bodies 1c70: 29 0a 20 20 20 20 20 20 20 28 64 65 66 69 6e 65 ). (define 1c80: 2d 6f 70 74 20 22 73 65 65 6b 2d 6f 70 74 69 6f -opt "seek-optio 1c90: 6e 61 6c 22 20 62 69 6e 64 69 6e 67 73 20 28 29 nal" bindings () 1ca0: 20 28 28 6e 61 6d 65 20 2e 20 62 69 6e 64 69 6e ((name . bindin 1cb0: 67 73 29 20 2e 20 62 6f 64 69 65 73 29 29 29 0a gs) . bodies))). 1cc0: 0a 20 20 20 20 20 20 28 28 64 65 66 69 6e 65 2d . ((define- 1cd0: 6f 70 74 20 22 73 65 65 6b 2d 6f 70 74 69 6f 6e opt "seek-option 1ce0: 61 6c 22 20 28 28 6f 70 74 69 6f 6e 61 6c 20 2e al" ((optional . 1cf0: 20 5f 6f 70 74 2d 62 69 6e 64 69 6e 67 73 29 29 _opt-bindings)) 1d00: 0a 20 20 20 20 20 20 20 20 20 28 72 65 71 64 20 . (reqd 1d10: 2e 2e 2e 29 20 28 28 6e 61 6d 65 20 2e 20 5f 62 ...) ((name . _b 1d20: 69 6e 64 69 6e 67 73 29 20 2e 20 5f 62 6f 64 69 indings) . _bodi 1d30: 65 73 29 29 0a 20 20 20 20 20 20 20 28 64 65 66 es)). (def 1d40: 69 6e 65 20 28 6e 61 6d 65 20 72 65 71 64 20 2e ine (name reqd . 1d50: 2e 2e 20 2e 20 5f 72 65 73 74 29 0a 20 20 20 20 .. . _rest). 1d60: 20 20 20 20 20 28 6c 65 74 72 65 63 2d 73 79 6e (letrec-syn 1d70: 74 61 78 0a 20 20 20 20 20 20 20 20 20 20 20 20 tax. 1d80: 20 28 28 68 61 6e 64 6c 65 2d 6f 70 74 73 0a 20 ((handle-opts. 1d90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 (s 1da0: 79 6e 74 61 78 2d 72 75 6c 65 73 20 28 29 0a 20 yntax-rules (). 1db0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 1dc0: 28 28 5f 20 72 65 73 74 20 62 6f 64 69 65 73 20 ((_ rest bodies 1dd0: 28 76 61 72 20 69 6e 69 74 29 29 0a 20 20 20 20 (var init)). 1de0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c (l 1df0: 65 74 20 28 28 76 61 72 20 28 69 66 20 28 6e 75 et ((var (if (nu 1e00: 6c 6c 3f 20 72 65 73 74 29 20 69 6e 69 74 0a 20 ll? rest) init. 1e10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 1e20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 1e30: 28 69 66 20 28 6e 75 6c 6c 3f 20 28 63 64 72 20 (if (null? (cdr 1e40: 72 65 73 74 29 29 20 28 63 61 72 20 72 65 73 74 rest)) (car rest 1e50: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ). 1e60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 1e70: 20 20 20 20 20 20 20 28 65 72 72 6f 72 20 22 65 (error "e 1e80: 78 74 72 61 20 72 65 73 74 22 20 72 65 73 74 29 xtra rest" rest) 1e90: 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 )))). 1ea0: 20 20 20 20 20 20 20 20 20 2e 20 62 6f 64 69 65 . bodie 1eb0: 73 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 s)). 1ec0: 20 20 20 20 20 28 28 5f 20 72 65 73 74 20 62 6f ((_ rest bo 1ed0: 64 69 65 73 20 76 61 72 29 20 28 68 61 6e 64 6c dies var) (handl 1ee0: 65 2d 6f 70 74 73 20 72 65 73 74 20 62 6f 64 69 e-opts rest bodi 1ef0: 65 73 20 28 76 61 72 20 23 66 29 29 29 0a 20 20 es (var #f))). 1f00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 ( 1f10: 28 5f 20 72 65 73 74 20 62 6f 64 69 65 73 20 28 (_ rest bodies ( 1f20: 76 61 72 20 69 6e 69 74 29 20 2e 20 6f 74 68 65 var init) . othe 1f30: 72 2d 76 61 72 73 29 0a 20 20 20 20 20 20 20 20 r-vars). 1f40: 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 20 28 (let ( 1f50: 28 76 61 72 20 28 69 66 20 28 6e 75 6c 6c 3f 20 (var (if (null? 1f60: 72 65 73 74 29 20 69 6e 69 74 20 28 63 61 72 20 rest) init (car 1f70: 72 65 73 74 29 29 29 0a 20 20 20 20 20 20 20 20 rest))). 1f80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 1f90: 28 6e 65 77 2d 72 65 73 74 20 28 69 66 20 28 6e (new-rest (if (n 1fa0: 75 6c 6c 3f 20 72 65 73 74 29 20 27 28 29 20 28 ull? rest) '() ( 1fb0: 63 64 72 20 72 65 73 74 29 29 29 29 0a 20 20 20 cdr rest)))). 1fc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 1fd0: 20 28 68 61 6e 64 6c 65 2d 6f 70 74 73 20 6e 65 (handle-opts ne 1fe0: 77 2d 72 65 73 74 20 62 6f 64 69 65 73 20 2e 20 w-rest bodies . 1ff0: 6f 74 68 65 72 2d 76 61 72 73 29 29 29 0a 20 20 other-vars))). 2000: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 ( 2010: 28 5f 20 72 65 73 74 20 62 6f 64 69 65 73 20 76 (_ rest bodies v 2020: 61 72 20 2e 20 6f 74 68 65 72 2d 76 61 72 73 29 ar . other-vars) 2030: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 . 2040: 20 20 20 28 68 61 6e 64 6c 65 2d 6f 70 74 73 20 (handle-opts 2050: 72 65 73 74 20 62 6f 64 69 65 73 20 28 76 61 72 rest bodies (var 2060: 20 23 66 29 20 2e 20 6f 74 68 65 72 2d 76 61 72 #f) . other-var 2070: 73 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 s)). 2080: 20 20 20 20 20 28 28 5f 20 72 65 73 74 20 62 6f ((_ rest bo 2090: 64 69 65 73 29 09 09 3b 20 6e 6f 20 6f 70 74 69 dies)..; no opti 20a0: 6f 6e 61 6c 20 61 72 67 73 2c 20 75 6e 6c 69 6b onal args, unlik 20b0: 65 6c 79 0a 20 20 20 20 20 20 20 20 20 20 20 20 ely. 20c0: 20 20 20 20 20 20 28 6c 65 74 20 28 28 5f 20 28 (let ((_ ( 20d0: 6f 72 20 28 6e 75 6c 6c 3f 20 72 65 73 74 29 20 or (null? rest) 20e0: 28 65 72 72 6f 72 20 22 65 78 74 72 61 20 72 65 (error "extra re 20f0: 73 74 22 20 72 65 73 74 29 29 29 29 0a 20 20 20 st" rest)))). 2100: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 2110: 20 2e 20 62 6f 64 69 65 73 29 29 29 29 29 0a 20 . bodies))))). 2120: 20 20 20 20 20 20 20 20 20 20 28 68 61 6e 64 6c (handl 2130: 65 2d 6f 70 74 73 20 5f 72 65 73 74 20 5f 62 6f e-opts _rest _bo 2140: 64 69 65 73 20 2e 20 5f 6f 70 74 2d 62 69 6e 64 dies . _opt-bind 2150: 69 6e 67 73 29 29 29 29 0a 0a 20 20 20 20 20 20 ings)))).. 2160: 28 28 64 65 66 69 6e 65 2d 6f 70 74 20 22 73 65 ((define-opt "se 2170: 65 6b 2d 6f 70 74 69 6f 6e 61 6c 22 20 28 78 20 ek-optional" (x 2180: 2e 20 72 65 73 74 29 20 28 72 65 71 64 20 2e 2e . rest) (reqd .. 2190: 2e 29 20 66 6f 72 6d 29 0a 20 20 20 20 20 20 20 .) form). 21a0: 28 64 65 66 69 6e 65 2d 6f 70 74 20 22 73 65 65 (define-opt "see 21b0: 6b 2d 6f 70 74 69 6f 6e 61 6c 22 20 72 65 73 74 k-optional" rest 21c0: 20 28 72 65 71 64 20 2e 2e 2e 20 78 29 20 66 6f (reqd ... x) fo 21d0: 72 6d 29 29 0a 0a 20 20 20 20 20 20 28 28 64 65 rm)).. ((de 21e0: 66 69 6e 65 2d 6f 70 74 20 22 73 65 65 6b 2d 6f fine-opt "seek-o 21f0: 70 74 69 6f 6e 61 6c 22 20 6e 6f 74 2d 61 2d 70 ptional" not-a-p 2200: 61 69 72 20 72 65 71 64 20 66 6f 72 6d 29 0a 20 air reqd form). 2210: 20 20 20 20 20 20 28 64 65 66 69 6e 65 20 2e 20 (define . 2220: 66 6f 72 6d 29 29 09 09 09 3b 20 4e 6f 20 6f 70 form))...; No op 2230: 74 69 6f 6e 61 6c 20 66 6f 75 6e 64 2c 20 72 65 tional found, re 2240: 67 75 6c 61 72 20 64 65 66 69 6e 65 0a 0a 20 20 gular define.. 2250: 20 20 20 20 28 28 64 65 66 69 6e 65 2d 6f 70 74 ((define-opt 2260: 20 6e 61 6d 65 20 62 6f 64 79 29 09 09 3b 20 4a name body)..; J 2270: 75 73 74 20 74 68 65 20 64 65 66 69 6e 69 74 69 ust the definiti 2280: 6f 6e 20 66 6f 72 20 27 6e 61 6d 65 27 2c 0a 20 on for 'name',. 2290: 20 20 20 20 20 20 28 64 65 66 69 6e 65 20 6e 61 (define na 22a0: 6d 65 20 62 6f 64 79 29 29 09 09 3b 20 66 6f 72 me body))..; for 22b0: 20 63 6f 6d 70 61 74 69 62 69 6c 69 62 69 6c 69 compatibilibili 22c0: 74 79 20 77 69 74 68 20 64 65 66 69 6e 65 0a 20 ty with define. 22d0: 20 20 20 20 20 29 29 0a 0a 20 20 28 64 65 66 69 )).. (defi 22e0: 6e 65 20 61 73 63 69 69 2d 3e 63 68 61 72 20 69 ne ascii->char i 22f0: 6e 74 65 67 65 72 2d 3e 63 68 61 72 29 0a 20 20 nteger->char). 2300: 28 64 65 66 69 6e 65 20 75 63 73 63 6f 64 65 2d (define ucscode- 2310: 3e 63 68 61 72 20 69 6e 74 65 67 65 72 2d 3e 63 >char integer->c 2320: 68 61 72 29 0a 20 20 0a 20 20 28 64 65 66 69 6e har). . (defin 2330: 65 20 63 68 61 72 2d 72 65 74 75 72 6e 20 28 61 e char-return (a 2340: 73 63 69 69 2d 3e 63 68 61 72 20 31 33 29 29 0a scii->char 13)). 2350: 20 20 28 64 65 66 69 6e 65 20 63 68 61 72 2d 74 (define char-t 2360: 61 62 20 20 20 20 28 61 73 63 69 69 2d 3e 63 68 ab (ascii->ch 2370: 61 72 20 39 29 29 0a 20 20 28 64 65 66 69 6e 65 ar 9)). (define 2380: 20 63 68 61 72 2d 6e 65 77 6c 69 6e 65 20 28 61 char-newline (a 2390: 73 63 69 69 2d 3e 63 68 61 72 20 31 30 29 29 0a scii->char 10)). 23a0: 20 20 20 20 0a 20 20 28 64 65 66 69 6e 65 2d 6f . (define-o 23b0: 70 74 20 28 70 65 65 6b 2d 6e 65 78 74 2d 63 68 pt (peek-next-ch 23c0: 61 72 20 28 6f 70 74 69 6f 6e 61 6c 20 28 70 6f ar (optional (po 23d0: 72 74 20 28 63 75 72 72 65 6e 74 2d 69 6e 70 75 rt (current-inpu 23e0: 74 2d 70 6f 72 74 29 29 29 29 0a 20 20 20 20 28 t-port)))). ( 23f0: 72 65 61 64 2d 63 68 61 72 20 70 6f 72 74 29 20 read-char port) 2400: 0a 20 20 20 20 28 70 65 65 6b 2d 63 68 61 72 20 . (peek-char 2410: 70 6f 72 74 29 29 20 0a 20 20 0a 20 20 28 64 65 port)) . . (de 2420: 66 69 6e 65 2d 6f 70 74 20 28 61 73 73 65 72 74 fine-opt (assert 2430: 2d 63 75 72 72 2d 63 68 61 72 20 65 78 70 65 63 -curr-char expec 2440: 74 65 64 2d 63 68 61 72 73 20 63 6f 6d 6d 65 6e ted-chars commen 2450: 74 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 t. 2460: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 2470: 20 20 28 6f 70 74 69 6f 6e 61 6c 20 28 70 6f 72 (optional (por 2480: 74 20 28 63 75 72 72 65 6e 74 2d 69 6e 70 75 74 t (current-input 2490: 2d 70 6f 72 74 29 29 29 29 0a 20 20 20 20 28 6c -port)))). (l 24a0: 65 74 20 28 28 63 20 28 72 65 61 64 2d 63 68 61 et ((c (read-cha 24b0: 72 20 70 6f 72 74 29 29 29 0a 20 20 20 20 20 20 r port))). 24c0: 28 69 66 20 28 6d 65 6d 76 20 63 20 65 78 70 65 (if (memv c expe 24d0: 63 74 65 64 2d 63 68 61 72 73 29 20 63 0a 20 20 cted-chars) c. 24e0: 20 20 20 20 20 20 20 20 28 70 61 72 73 65 72 2d (parser- 24f0: 65 72 72 6f 72 20 70 6f 72 74 20 22 57 72 6f 6e error port "Wron 2500: 67 20 63 68 61 72 61 63 74 65 72 20 22 20 63 0a g character " c. 2510: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 2520: 20 20 20 20 20 20 20 20 22 20 28 30 78 22 20 28 " (0x" ( 2530: 69 66 20 28 65 6f 66 2d 6f 62 6a 65 63 74 3f 20 if (eof-object? 2540: 63 29 20 22 2a 65 6f 66 2a 22 0a 20 20 20 20 20 c) "*eof*". 2550: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 2560: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6e (n 2570: 75 6d 62 65 72 2d 3e 73 74 72 69 6e 67 20 28 63 umber->string (c 2580: 68 61 72 2d 3e 69 6e 74 65 67 65 72 20 63 29 20 har->integer c) 2590: 31 36 29 29 20 22 29 20 22 0a 20 20 20 20 20 20 16)) ") ". 25a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 25b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 63 6f 6d com 25c0: 6d 65 6e 74 20 22 2e 20 22 20 65 78 70 65 63 74 ment ". " expect 25d0: 65 64 2d 63 68 61 72 73 20 22 20 65 78 70 65 63 ed-chars " expec 25e0: 74 65 64 22 29 29 29 29 0a 0a 20 20 28 64 65 66 ted")))).. (def 25f0: 69 6e 65 2d 6f 70 74 20 28 73 6b 69 70 2d 75 6e ine-opt (skip-un 2600: 74 69 6c 20 61 72 67 20 28 6f 70 74 69 6f 6e 61 til arg (optiona 2610: 6c 20 28 70 6f 72 74 20 28 63 75 72 72 65 6e 74 l (port (current 2620: 2d 69 6e 70 75 74 2d 70 6f 72 74 29 29 29 20 29 -input-port))) ) 2630: 0a 20 20 20 20 28 63 6f 6e 64 0a 20 20 20 20 20 . (cond. 2640: 28 28 6e 75 6d 62 65 72 3f 20 61 72 67 29 09 09 ((number? arg).. 2650: 3b 20 73 6b 69 70 20 27 61 72 67 27 20 63 68 61 ; skip 'arg' cha 2660: 72 61 63 74 65 72 73 0a 20 20 20 20 20 20 28 64 racters. (d 2670: 6f 20 28 28 69 20 61 72 67 20 28 64 65 63 20 69 o ((i arg (dec i 2680: 29 29 29 0a 20 20 20 20 20 20 09 20 20 28 28 6e ))). . ((n 2690: 6f 74 20 28 70 6f 73 69 74 69 76 65 3f 20 69 29 ot (positive? i) 26a0: 29 20 23 66 29 0a 20 20 20 20 20 20 20 20 28 69 ) #f). (i 26b0: 66 20 28 65 6f 66 2d 6f 62 6a 65 63 74 3f 20 28 f (eof-object? ( 26c0: 72 65 61 64 2d 63 68 61 72 20 70 6f 72 74 29 29 read-char port)) 26d0: 0a 20 20 20 20 20 20 09 20 20 20 20 28 70 61 72 . . (par 26e0: 73 65 72 2d 65 72 72 6f 72 20 70 6f 72 74 20 22 ser-error port " 26f0: 55 6e 65 78 70 65 63 74 65 64 20 45 4f 46 20 77 Unexpected EOF w 2700: 68 69 6c 65 20 73 6b 69 70 70 69 6e 67 20 22 0a hile skipping ". 2710: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 2720: 20 20 20 20 20 20 20 20 20 20 61 72 67 20 22 20 arg " 2730: 63 68 61 72 61 63 74 65 72 73 22 29 29 29 29 0a characters")))). 2740: 20 20 20 20 20 28 65 6c 73 65 09 09 09 3b 20 73 (else...; s 2750: 6b 69 70 20 75 6e 74 69 6c 20 62 72 65 61 6b 2d kip until break- 2760: 63 68 61 72 73 20 28 3d 61 72 67 29 0a 20 20 20 chars (=arg). 2770: 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 63 (let loop ((c 2780: 20 28 72 65 61 64 2d 63 68 61 72 20 70 6f 72 74 (read-char port 2790: 29 29 29 0a 20 20 20 20 20 20 20 20 28 63 6f 6e ))). (con 27a0: 64 0a 20 20 20 20 20 20 20 20 20 28 28 6d 65 6d d. ((mem 27b0: 76 20 63 20 61 72 67 29 20 63 29 0a 20 20 20 20 v c arg) c). 27c0: 20 20 20 20 20 28 28 65 6f 66 2d 6f 62 6a 65 63 ((eof-objec 27d0: 74 3f 20 63 29 0a 20 20 20 20 20 20 20 20 20 20 t? c). 27e0: 28 69 66 20 28 6d 65 6d 71 20 27 2a 65 6f 66 2a (if (memq '*eof* 27f0: 20 61 72 67 29 20 63 0a 20 20 20 20 20 20 20 20 arg) c. 2800: 20 20 20 20 20 20 28 70 61 72 73 65 72 2d 65 72 (parser-er 2810: 72 6f 72 20 70 6f 72 74 20 22 55 6e 65 78 70 65 ror port "Unexpe 2820: 63 74 65 64 20 45 4f 46 20 77 68 69 6c 65 20 73 cted EOF while s 2830: 6b 69 70 70 69 6e 67 20 75 6e 74 69 6c 20 22 20 kipping until " 2840: 61 72 67 29 29 29 0a 20 20 20 20 20 20 20 20 20 arg))). 2850: 28 65 6c 73 65 20 28 6c 6f 6f 70 20 28 72 65 61 (else (loop (rea 2860: 64 2d 63 68 61 72 20 70 6f 72 74 29 29 29 29 29 d-char port))))) 2870: 29 29 29 0a 0a 20 20 28 64 65 66 69 6e 65 2d 6f ))).. (define-o 2880: 70 74 20 28 73 6b 69 70 2d 77 68 69 6c 65 20 73 pt (skip-while s 2890: 6b 69 70 2d 63 68 61 72 73 20 28 6f 70 74 69 6f kip-chars (optio 28a0: 6e 61 6c 20 28 70 6f 72 74 20 28 63 75 72 72 65 nal (port (curre 28b0: 6e 74 2d 69 6e 70 75 74 2d 70 6f 72 74 29 29 29 nt-input-port))) 28c0: 20 29 0a 20 20 20 20 28 64 6f 20 28 28 63 20 28 ). (do ((c ( 28d0: 70 65 65 6b 2d 63 68 61 72 20 70 6f 72 74 29 20 peek-char port) 28e0: 28 70 65 65 6b 2d 63 68 61 72 20 70 6f 72 74 29 (peek-char port) 28f0: 29 29 0a 20 20 20 20 20 20 20 20 28 28 6e 6f 74 )). ((not 2900: 20 28 6d 65 6d 76 20 63 20 73 6b 69 70 2d 63 68 (memv c skip-ch 2910: 61 72 73 29 29 20 63 29 0a 20 20 20 20 20 20 28 ars)) c). ( 2920: 72 65 61 64 2d 63 68 61 72 20 70 6f 72 74 29 29 read-char port)) 2930: 29 0a 20 20 0a 20 20 28 64 65 66 69 6e 65 20 69 ). . (define i 2940: 6e 70 75 74 2d 70 61 72 73 65 3a 69 6e 69 74 2d nput-parse:init- 2950: 62 75 66 66 65 72 0a 20 20 20 20 28 6c 65 74 20 buffer. (let 2960: 28 28 62 75 66 66 65 72 20 28 6d 61 6b 65 2d 73 ((buffer (make-s 2970: 74 72 69 6e 67 20 35 31 32 29 29 29 0a 20 20 20 tring 512))). 2980: 20 20 20 28 6c 61 6d 62 64 61 20 28 29 20 62 75 (lambda () bu 2990: 66 66 65 72 29 29 29 0a 20 20 0a 20 20 28 64 65 ffer))). . (de 29a0: 66 69 6e 65 2d 6f 70 74 20 28 6e 65 78 74 2d 74 fine-opt (next-t 29b0: 6f 6b 65 6e 2d 6f 6c 64 20 70 72 65 66 69 78 2d oken-old prefix- 29c0: 73 6b 69 70 70 65 64 2d 63 68 61 72 73 20 62 72 skipped-chars br 29d0: 65 61 6b 2d 63 68 61 72 73 0a 20 20 20 20 20 20 eak-chars. 29e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 29f0: 20 20 20 20 20 20 20 20 28 6f 70 74 69 6f 6e 61 (optiona 2a00: 6c 20 28 63 6f 6d 6d 65 6e 74 20 22 22 29 20 28 l (comment "") ( 2a10: 70 6f 72 74 20 28 63 75 72 72 65 6e 74 2d 69 6e port (current-in 2a20: 70 75 74 2d 70 6f 72 74 29 29 29 20 29 0a 20 20 put-port))) ). 2a30: 20 20 28 6c 65 74 2a 20 28 28 62 75 66 66 65 72 (let* ((buffer 2a40: 20 28 69 6e 70 75 74 2d 70 61 72 73 65 3a 69 6e (input-parse:in 2a50: 69 74 2d 62 75 66 66 65 72 29 29 0a 20 20 20 20 it-buffer)). 2a60: 20 20 20 20 20 20 20 28 63 75 72 72 2d 62 75 66 (curr-buf 2a70: 2d 6c 65 6e 20 28 73 74 72 69 6e 67 2d 6c 65 6e -len (string-len 2a80: 67 74 68 20 62 75 66 66 65 72 29 29 0a 20 20 20 gth buffer)). 2a90: 20 20 20 20 20 20 20 20 28 71 75 61 6e 74 75 6d (quantum 2aa0: 20 63 75 72 72 2d 62 75 66 2d 6c 65 6e 29 29 0a curr-buf-len)). 2ab0: 20 20 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 (let loop 2ac0: 28 28 69 20 30 29 20 28 63 20 28 73 6b 69 70 2d ((i 0) (c (skip- 2ad0: 77 68 69 6c 65 20 70 72 65 66 69 78 2d 73 6b 69 while prefix-ski 2ae0: 70 70 65 64 2d 63 68 61 72 73 20 70 6f 72 74 29 pped-chars port) 2af0: 29 29 0a 20 20 20 20 20 20 20 20 28 63 6f 6e 64 )). (cond 2b00: 0a 20 20 20 20 20 20 20 20 20 28 28 6d 65 6d 76 . ((memv 2b10: 20 63 20 62 72 65 61 6b 2d 63 68 61 72 73 29 20 c break-chars) 2b20: 28 73 75 62 73 74 72 69 6e 67 20 62 75 66 66 65 (substring buffe 2b30: 72 20 30 20 69 29 29 0a 20 20 20 20 20 20 20 20 r 0 i)). 2b40: 20 28 28 65 6f 66 2d 6f 62 6a 65 63 74 3f 20 63 ((eof-object? c 2b50: 29 0a 20 20 20 20 20 20 20 20 20 20 28 69 66 20 ). (if 2b60: 28 6d 65 6d 71 20 27 2a 65 6f 66 2a 20 62 72 65 (memq '*eof* bre 2b70: 61 6b 2d 63 68 61 72 73 29 0a 20 20 20 20 20 20 ak-chars). 2b80: 20 20 20 20 20 20 20 20 28 73 75 62 73 74 72 69 (substri 2b90: 6e 67 20 62 75 66 66 65 72 20 30 20 69 29 0a 20 ng buffer 0 i). 2ba0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 70 61 (pa 2bb0: 72 73 65 72 2d 65 72 72 6f 72 20 70 6f 72 74 20 rser-error port 2bc0: 22 45 4f 46 20 77 68 69 6c 65 20 72 65 61 64 69 "EOF while readi 2bd0: 6e 67 20 61 20 74 6f 6b 65 6e 20 22 20 63 6f 6d ng a token " com 2be0: 6d 65 6e 74 29 29 29 0a 20 20 20 20 20 20 20 20 ment))). 2bf0: 20 28 65 6c 73 65 0a 20 20 20 20 20 20 20 20 20 (else. 2c00: 20 28 69 66 20 28 3e 3d 20 69 20 63 75 72 72 2d (if (>= i curr- 2c10: 62 75 66 2d 6c 65 6e 29 0a 20 20 20 20 20 20 20 buf-len). 2c20: 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a 20 20 (begin. 2c30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 (s 2c40: 65 74 21 20 62 75 66 66 65 72 20 28 73 74 72 69 et! buffer (stri 2c50: 6e 67 2d 61 70 70 65 6e 64 20 62 75 66 66 65 72 ng-append buffer 2c60: 20 28 6d 61 6b 65 2d 73 74 72 69 6e 67 20 71 75 (make-string qu 2c70: 61 6e 74 75 6d 29 29 29 0a 20 20 20 20 20 20 20 antum))). 2c80: 20 20 20 20 20 20 20 20 20 28 73 65 74 21 20 71 (set! q 2c90: 75 61 6e 74 75 6d 20 63 75 72 72 2d 62 75 66 2d uantum curr-buf- 2ca0: 6c 65 6e 29 0a 20 20 20 20 20 20 20 20 20 20 20 len). 2cb0: 20 20 20 20 20 28 73 65 74 21 20 63 75 72 72 2d (set! curr- 2cc0: 62 75 66 2d 6c 65 6e 20 28 73 74 72 69 6e 67 2d buf-len (string- 2cd0: 6c 65 6e 67 74 68 20 62 75 66 66 65 72 29 29 29 length buffer))) 2ce0: 29 0a 20 20 20 20 20 20 20 20 20 20 28 73 74 72 ). (str 2cf0: 69 6e 67 2d 73 65 74 21 20 62 75 66 66 65 72 20 ing-set! buffer 2d00: 69 20 63 29 0a 20 20 20 20 20 20 20 20 20 20 28 i c). ( 2d10: 72 65 61 64 2d 63 68 61 72 20 70 6f 72 74 29 0a read-char port). 2d20: 20 20 20 20 20 20 20 20 20 20 28 6c 6f 6f 70 20 (loop 2d30: 28 69 6e 63 20 69 29 20 28 70 65 65 6b 2d 63 68 (inc i) (peek-ch 2d40: 61 72 20 70 6f 72 74 29 29 0a 20 20 20 20 20 20 ar port)). 2d50: 20 20 20 20 29 29 29 29 29 0a 0a 20 20 28 64 65 ))))).. (de 2d60: 66 69 6e 65 2d 6f 70 74 20 28 6e 65 78 74 2d 74 fine-opt (next-t 2d70: 6f 6b 65 6e 20 70 72 65 66 69 78 2d 73 6b 69 70 oken prefix-skip 2d80: 70 65 64 2d 63 68 61 72 73 20 62 72 65 61 6b 2d ped-chars break- 2d90: 63 68 61 72 73 0a 20 20 20 20 20 20 20 20 20 20 chars. 2da0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 2db0: 28 6f 70 74 69 6f 6e 61 6c 20 28 63 6f 6d 6d 65 (optional (comme 2dc0: 6e 74 20 22 22 29 20 28 70 6f 72 74 20 28 63 75 nt "") (port (cu 2dd0: 72 72 65 6e 74 2d 69 6e 70 75 74 2d 70 6f 72 74 rrent-input-port 2de0: 29 29 29 20 29 0a 20 20 20 20 28 6c 65 74 20 6f ))) ). (let o 2df0: 75 74 65 72 20 28 28 62 75 66 66 65 72 20 28 69 uter ((buffer (i 2e00: 6e 70 75 74 2d 70 61 72 73 65 3a 69 6e 69 74 2d nput-parse:init- 2e10: 62 75 66 66 65 72 29 29 20 28 66 69 6c 6c 65 64 buffer)) (filled 2e20: 2d 62 75 66 66 65 72 2d 6c 20 27 28 29 29 0a 20 -buffer-l '()). 2e30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 ( 2e40: 63 20 28 73 6b 69 70 2d 77 68 69 6c 65 20 70 72 c (skip-while pr 2e50: 65 66 69 78 2d 73 6b 69 70 70 65 64 2d 63 68 61 efix-skipped-cha 2e60: 72 73 20 70 6f 72 74 29 29 29 0a 20 20 20 20 20 rs port))). 2e70: 20 28 6c 65 74 20 28 28 63 75 72 72 2d 62 75 66 (let ((curr-buf 2e80: 2d 6c 65 6e 20 28 73 74 72 69 6e 67 2d 6c 65 6e -len (string-len 2e90: 67 74 68 20 62 75 66 66 65 72 29 29 29 0a 20 20 gth buffer))). 2ea0: 20 20 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 (let loop 2eb0: 28 28 69 20 30 29 20 28 63 20 63 29 29 0a 20 20 ((i 0) (c c)). 2ec0: 20 20 20 20 20 20 20 20 28 63 6f 6e 64 0a 20 20 (cond. 2ed0: 20 20 20 20 20 20 20 20 20 28 28 6d 65 6d 76 20 ((memv 2ee0: 63 20 62 72 65 61 6b 2d 63 68 61 72 73 29 0a 20 c break-chars). 2ef0: 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 (if ( 2f00: 6e 75 6c 6c 3f 20 66 69 6c 6c 65 64 2d 62 75 66 null? filled-buf 2f10: 66 65 72 2d 6c 29 20 28 73 75 62 73 74 72 69 6e fer-l) (substrin 2f20: 67 20 62 75 66 66 65 72 20 30 20 69 29 0a 20 20 g buffer 0 i). 2f30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 (s 2f40: 74 72 69 6e 67 2d 63 6f 6e 63 61 74 65 6e 61 74 tring-concatenat 2f50: 65 2d 72 65 76 65 72 73 65 20 66 69 6c 6c 65 64 e-reverse filled 2f60: 2d 62 75 66 66 65 72 2d 6c 20 62 75 66 66 65 72 -buffer-l buffer 2f70: 20 69 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 i))). 2f80: 20 28 28 65 6f 66 2d 6f 62 6a 65 63 74 3f 20 63 ((eof-object? c 2f90: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 69 ). (i 2fa0: 66 20 28 6d 65 6d 71 20 27 2a 65 6f 66 2a 20 62 f (memq '*eof* b 2fb0: 72 65 61 6b 2d 63 68 61 72 73 29 09 3b 20 77 61 reak-chars).; wa 2fc0: 73 20 45 4f 46 20 65 78 70 65 63 74 65 64 3f 0a s EOF expected?. 2fd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 2fe0: 28 69 66 20 28 6e 75 6c 6c 3f 20 66 69 6c 6c 65 (if (null? fille 2ff0: 64 2d 62 75 66 66 65 72 2d 6c 29 20 28 73 75 62 d-buffer-l) (sub 3000: 73 74 72 69 6e 67 20 62 75 66 66 65 72 20 30 20 string buffer 0 3010: 69 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 i). 3020: 20 20 20 20 20 20 20 28 73 74 72 69 6e 67 2d 63 (string-c 3030: 6f 6e 63 61 74 65 6e 61 74 65 2d 72 65 76 65 72 oncatenate-rever 3040: 73 65 20 66 69 6c 6c 65 64 2d 62 75 66 66 65 72 se filled-buffer 3050: 2d 6c 20 62 75 66 66 65 72 20 69 29 29 0a 20 20 -l buffer i)). 3060: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 70 (p 3070: 61 72 73 65 72 2d 65 72 72 6f 72 20 70 6f 72 74 arser-error port 3080: 20 22 45 4f 46 20 77 68 69 6c 65 20 72 65 61 64 "EOF while read 3090: 69 6e 67 20 61 20 74 6f 6b 65 6e 20 22 20 63 6f ing a token " co 30a0: 6d 6d 65 6e 74 29 29 29 0a 20 20 20 20 20 20 20 mment))). 30b0: 20 20 20 20 28 28 3e 3d 20 69 20 63 75 72 72 2d ((>= i curr- 30c0: 62 75 66 2d 6c 65 6e 29 0a 20 20 20 20 20 20 20 buf-len). 30d0: 20 20 20 20 20 28 6f 75 74 65 72 20 28 6d 61 6b (outer (mak 30e0: 65 2d 73 74 72 69 6e 67 20 63 75 72 72 2d 62 75 e-string curr-bu 30f0: 66 2d 6c 65 6e 29 0a 20 20 20 20 20 20 20 20 20 f-len). 3100: 20 20 20 20 20 20 20 20 20 20 28 63 6f 6e 73 20 (cons 3110: 62 75 66 66 65 72 20 66 69 6c 6c 65 64 2d 62 75 buffer filled-bu 3120: 66 66 65 72 2d 6c 29 20 63 29 29 0a 20 20 20 20 ffer-l) c)). 3130: 20 20 20 20 20 20 20 28 65 6c 73 65 0a 20 20 20 (else. 3140: 20 20 20 20 20 20 20 20 20 28 73 74 72 69 6e 67 (string 3150: 2d 73 65 74 21 20 62 75 66 66 65 72 20 69 20 63 -set! buffer i c 3160: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 72 ). (r 3170: 65 61 64 2d 63 68 61 72 20 70 6f 72 74 29 0a 20 ead-char port). 3180: 20 20 20 20 20 20 20 20 20 20 20 28 6c 6f 6f 70 (loop 3190: 20 28 69 6e 63 20 69 29 20 28 70 65 65 6b 2d 63 (inc i) (peek-c 31a0: 68 61 72 20 70 6f 72 74 29 29 29 29 29 29 29 29 har port)))))))) 31b0: 0a 0a 20 20 28 64 65 66 69 6e 65 2d 6f 70 74 20 .. (define-opt 31c0: 28 6e 65 78 74 2d 74 6f 6b 65 6e 2d 6f 66 20 69 (next-token-of i 31d0: 6e 63 6c 2d 6c 69 73 74 2f 70 72 65 64 0a 20 20 ncl-list/pred. 31e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 31f0: 20 20 20 20 20 20 20 20 20 20 20 28 6f 70 74 69 (opti 3200: 6f 6e 61 6c 20 28 70 6f 72 74 20 28 63 75 72 72 onal (port (curr 3210: 65 6e 74 2d 69 6e 70 75 74 2d 70 6f 72 74 29 29 ent-input-port)) 3220: 29 20 29 0a 20 20 20 20 28 6c 65 74 2a 20 28 28 ) ). (let* (( 3230: 62 75 66 66 65 72 20 28 69 6e 70 75 74 2d 70 61 buffer (input-pa 3240: 72 73 65 3a 69 6e 69 74 2d 62 75 66 66 65 72 29 rse:init-buffer) 3250: 29 0a 20 20 20 20 20 20 20 20 20 20 20 28 63 75 ). (cu 3260: 72 72 2d 62 75 66 2d 6c 65 6e 20 28 73 74 72 69 rr-buf-len (stri 3270: 6e 67 2d 6c 65 6e 67 74 68 20 62 75 66 66 65 72 ng-length buffer 3280: 29 29 29 0a 20 20 20 20 20 20 28 69 66 20 28 70 ))). (if (p 3290: 72 6f 63 65 64 75 72 65 3f 20 69 6e 63 6c 2d 6c rocedure? incl-l 32a0: 69 73 74 2f 70 72 65 64 29 0a 20 20 20 20 20 20 ist/pred). 32b0: 20 20 20 20 28 6c 65 74 20 6f 75 74 65 72 20 28 (let outer ( 32c0: 28 62 75 66 66 65 72 20 62 75 66 66 65 72 29 20 (buffer buffer) 32d0: 28 66 69 6c 6c 65 64 2d 62 75 66 66 65 72 2d 6c (filled-buffer-l 32e0: 20 27 28 29 29 29 0a 20 20 20 20 20 20 20 20 20 '())). 32f0: 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 69 (let loop ((i 3300: 20 30 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 0)). 3310: 20 20 20 28 69 66 20 28 3e 3d 20 69 20 63 75 72 (if (>= i cur 3320: 72 2d 62 75 66 2d 6c 65 6e 29 09 09 3b 20 6d 61 r-buf-len)..; ma 3330: 6b 65 20 73 75 72 65 20 77 65 20 68 61 76 65 20 ke sure we have 3340: 73 70 61 63 65 0a 20 20 20 20 20 20 20 20 20 20 space. 3350: 20 20 20 20 20 20 20 20 28 6f 75 74 65 72 20 28 (outer ( 3360: 6d 61 6b 65 2d 73 74 72 69 6e 67 20 63 75 72 72 make-string curr 3370: 2d 62 75 66 2d 6c 65 6e 29 20 28 63 6f 6e 73 20 -buf-len) (cons 3380: 62 75 66 66 65 72 20 66 69 6c 6c 65 64 2d 62 75 buffer filled-bu 3390: 66 66 65 72 2d 6c 29 29 0a 20 20 20 20 20 20 20 ffer-l)). 33a0: 20 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 20 (let 33b0: 28 28 63 20 28 69 6e 63 6c 2d 6c 69 73 74 2f 70 ((c (incl-list/p 33c0: 72 65 64 20 28 70 65 65 6b 2d 63 68 61 72 20 70 red (peek-char p 33d0: 6f 72 74 29 29 29 29 0a 20 20 20 20 20 20 20 20 ort)))). 33e0: 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 (if 33f0: 63 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 c. 3400: 20 20 20 20 20 20 20 20 20 20 28 62 65 67 69 6e (begin 3410: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 . 3420: 20 20 20 20 20 20 20 20 20 20 20 28 73 74 72 69 (stri 3430: 6e 67 2d 73 65 74 21 20 62 75 66 66 65 72 20 69 ng-set! buffer i 3440: 20 63 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 c). 3450: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 72 (r 3460: 65 61 64 2d 63 68 61 72 20 70 6f 72 74 29 09 09 ead-char port).. 3470: 09 3b 20 6d 6f 76 65 20 74 6f 20 74 68 65 20 6e .; move to the n 3480: 65 78 74 20 63 68 61 72 0a 20 20 20 20 20 20 20 ext char. 3490: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 34a0: 20 20 20 28 6c 6f 6f 70 20 28 69 6e 63 20 69 29 (loop (inc i) 34b0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )). 34c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 34d0: 20 20 20 20 20 20 20 20 20 20 20 3b 20 69 6e 63 ; inc 34e0: 6c 2d 6c 69 73 74 2f 70 72 65 64 20 64 65 63 69 l-list/pred deci 34f0: 64 65 64 20 69 74 20 68 61 64 20 68 61 64 20 65 ded it had had e 3500: 6e 6f 75 67 68 0a 20 20 20 20 20 20 20 20 20 20 nough. 3510: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 (i 3520: 66 20 28 6e 75 6c 6c 3f 20 66 69 6c 6c 65 64 2d f (null? filled- 3530: 62 75 66 66 65 72 2d 6c 29 20 28 73 75 62 73 74 buffer-l) (subst 3540: 72 69 6e 67 20 62 75 66 66 65 72 20 30 20 69 29 ring buffer 0 i) 3550: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 . 3560: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 74 (st 3570: 72 69 6e 67 2d 63 6f 6e 63 61 74 65 6e 61 74 65 ring-concatenate 3580: 2d 72 65 76 65 72 73 65 20 66 69 6c 6c 65 64 2d -reverse filled- 3590: 62 75 66 66 65 72 2d 6c 20 62 75 66 66 65 72 20 buffer-l buffer 35a0: 69 29 29 29 29 29 29 29 0a 0a 20 20 20 20 20 20 i))))))).. 35b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 35c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 35d0: 20 20 3b 20 69 6e 63 6c 2d 6c 69 73 74 2f 70 72 ; incl-list/pr 35e0: 65 64 20 69 73 20 61 20 6c 69 73 74 20 6f 66 20 ed is a list of 35f0: 61 6c 6c 6f 77 65 64 20 63 68 61 72 61 63 74 65 allowed characte 3600: 72 73 0a 20 20 20 20 20 20 20 20 20 20 28 6c 65 rs. (le 3610: 74 20 6f 75 74 65 72 20 28 28 62 75 66 66 65 72 t outer ((buffer 3620: 20 62 75 66 66 65 72 29 20 28 66 69 6c 6c 65 64 buffer) (filled 3630: 2d 62 75 66 66 65 72 2d 6c 20 27 28 29 29 29 0a -buffer-l '())). 3640: 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 (let 3650: 20 6c 6f 6f 70 20 28 28 69 20 30 29 29 0a 20 20 loop ((i 0)). 3660: 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 (if 3670: 28 3e 3d 20 69 20 63 75 72 72 2d 62 75 66 2d 6c (>= i curr-buf-l 3680: 65 6e 29 09 09 3b 20 6d 61 6b 65 20 73 75 72 65 en)..; make sure 3690: 20 77 65 20 68 61 76 65 20 73 70 61 63 65 0a 20 we have space. 36a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 36b0: 20 28 6f 75 74 65 72 20 28 6d 61 6b 65 2d 73 74 (outer (make-st 36c0: 72 69 6e 67 20 63 75 72 72 2d 62 75 66 2d 6c 65 ring curr-buf-le 36d0: 6e 29 20 28 63 6f 6e 73 20 62 75 66 66 65 72 20 n) (cons buffer 36e0: 66 69 6c 6c 65 64 2d 62 75 66 66 65 72 2d 6c 29 filled-buffer-l) 36f0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ). 3700: 20 20 20 20 28 6c 65 74 20 28 28 63 20 28 70 65 (let ((c (pe 3710: 65 6b 2d 63 68 61 72 20 70 6f 72 74 29 29 29 0a ek-char port))). 3720: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3730: 20 20 20 20 28 63 6f 6e 64 0a 20 20 20 20 20 20 (cond. 3740: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 ( 3750: 28 6e 6f 74 20 28 6d 65 6d 76 20 63 20 69 6e 63 (not (memv c inc 3760: 6c 2d 6c 69 73 74 2f 70 72 65 64 29 29 0a 20 20 l-list/pred)). 3770: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3780: 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 66 (if (null? f 3790: 69 6c 6c 65 64 2d 62 75 66 66 65 72 2d 6c 29 20 illed-buffer-l) 37a0: 28 73 75 62 73 74 72 69 6e 67 20 62 75 66 66 65 (substring buffe 37b0: 72 20 30 20 69 29 0a 20 20 20 20 20 20 20 20 20 r 0 i). 37c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 37d0: 20 28 73 74 72 69 6e 67 2d 63 6f 6e 63 61 74 65 (string-concate 37e0: 6e 61 74 65 2d 72 65 76 65 72 73 65 20 66 69 6c nate-reverse fil 37f0: 6c 65 64 2d 62 75 66 66 65 72 2d 6c 20 62 75 66 led-buffer-l buf 3800: 66 65 72 20 69 29 29 29 0a 20 20 20 20 20 20 20 fer i))). 3810: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 65 (e 3820: 6c 73 65 0a 20 20 20 20 20 20 20 20 20 20 20 20 lse. 3830: 20 20 20 20 20 20 20 20 20 20 28 73 74 72 69 6e (strin 3840: 67 2d 73 65 74 21 20 62 75 66 66 65 72 20 69 20 g-set! buffer i 3850: 63 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 c). 3860: 20 20 20 20 20 20 20 20 20 28 72 65 61 64 2d 63 (read-c 3870: 68 61 72 20 70 6f 72 74 29 0a 20 20 20 20 20 20 har port). 3880: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3890: 28 6c 6f 6f 70 20 28 69 6e 63 20 69 29 29 29 29 (loop (inc i)))) 38a0: 29 29 29 29 29 29 29 0a 0a 20 20 28 64 65 66 69 ))))))).. (defi 38b0: 6e 65 20 2a 72 65 61 64 2d 6c 69 6e 65 2d 62 72 ne *read-line-br 38c0: 65 61 6b 73 2a 20 28 6c 69 73 74 20 63 68 61 72 eaks* (list char 38d0: 2d 6e 65 77 6c 69 6e 65 20 63 68 61 72 2d 72 65 -newline char-re 38e0: 74 75 72 6e 20 27 2a 65 6f 66 2a 29 29 0a 0a 20 turn '*eof*)).. 38f0: 20 28 64 65 66 69 6e 65 2d 6f 70 74 20 28 72 65 (define-opt (re 3900: 61 64 2d 74 65 78 74 2d 6c 69 6e 65 20 28 6f 70 ad-text-line (op 3910: 74 69 6f 6e 61 6c 20 28 70 6f 72 74 20 28 63 75 tional (port (cu 3920: 72 72 65 6e 74 2d 69 6e 70 75 74 2d 70 6f 72 74 rrent-input-port 3930: 29 29 29 20 29 0a 20 20 20 20 28 69 66 20 28 65 ))) ). (if (e 3940: 6f 66 2d 6f 62 6a 65 63 74 3f 20 28 70 65 65 6b of-object? (peek 3950: 2d 63 68 61 72 20 70 6f 72 74 29 29 20 28 70 65 -char port)) (pe 3960: 65 6b 2d 63 68 61 72 20 70 6f 72 74 29 0a 20 20 ek-char port). 3970: 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 6c 69 (let* ((li 3980: 6e 65 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 ne. 3990: 20 20 20 28 6e 65 78 74 2d 74 6f 6b 65 6e 20 27 (next-token ' 39a0: 28 29 20 2a 72 65 61 64 2d 6c 69 6e 65 2d 62 72 () *read-line-br 39b0: 65 61 6b 73 2a 0a 20 20 20 20 20 20 20 20 20 20 eaks*. 39c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 39d0: 20 20 22 72 65 61 64 69 6e 67 20 61 20 6c 69 6e "reading a lin 39e0: 65 22 20 70 6f 72 74 29 29 0a 20 20 20 20 20 20 e" port)). 39f0: 20 20 20 20 20 20 20 20 20 28 63 20 28 72 65 61 (c (rea 3a00: 64 2d 63 68 61 72 20 70 6f 72 74 29 29 29 0a 20 d-char port))). 3a10: 20 20 20 20 20 20 20 20 20 28 61 6e 64 20 28 65 (and (e 3a20: 71 76 3f 20 63 20 63 68 61 72 2d 72 65 74 75 72 qv? c char-retur 3a30: 6e 29 20 28 65 71 76 3f 20 28 70 65 65 6b 2d 63 n) (eqv? (peek-c 3a40: 68 61 72 20 70 6f 72 74 29 20 23 5c 6e 65 77 6c har port) #\newl 3a50: 69 6e 65 29 0a 20 20 20 20 20 20 20 20 20 20 20 ine). 3a60: 20 20 20 20 28 72 65 61 64 2d 63 68 61 72 20 70 (read-char p 3a70: 6f 72 74 29 29 0a 20 20 20 20 20 20 20 20 20 20 ort)). 3a80: 6c 69 6e 65 29 29 29 0a 0a 20 20 28 64 65 66 69 line))).. (defi 3a90: 6e 65 2d 6f 70 74 20 28 72 65 61 64 2d 73 74 72 ne-opt (read-str 3aa0: 69 6e 67 20 6e 20 28 6f 70 74 69 6f 6e 61 6c 20 ing n (optional 3ab0: 28 70 6f 72 74 20 28 63 75 72 72 65 6e 74 2d 69 (port (current-i 3ac0: 6e 70 75 74 2d 70 6f 72 74 29 29 29 20 29 0a 20 nput-port))) ). 3ad0: 20 20 20 28 69 66 20 28 6e 6f 74 20 28 70 6f 73 (if (not (pos 3ae0: 69 74 69 76 65 3f 20 6e 29 29 20 22 22 0a 20 20 itive? n)) "". 3af0: 20 20 20 20 20 20 28 6c 65 74 20 28 28 62 75 66 (let ((buf 3b00: 66 65 72 20 28 6d 61 6b 65 2d 73 74 72 69 6e 67 fer (make-string 3b10: 20 6e 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 n))). 3b20: 28 6c 65 74 20 6c 6f 6f 70 20 28 28 69 20 30 29 (let loop ((i 0) 3b30: 20 28 63 20 28 72 65 61 64 2d 63 68 61 72 20 70 (c (read-char p 3b40: 6f 72 74 29 29 29 0a 20 20 20 20 20 20 20 20 20 ort))). 3b50: 20 20 20 28 69 66 20 28 65 6f 66 2d 6f 62 6a 65 (if (eof-obje 3b60: 63 74 3f 20 63 29 20 28 73 75 62 73 74 72 69 6e ct? c) (substrin 3b70: 67 20 62 75 66 66 65 72 20 30 20 69 29 0a 20 20 g buffer 0 i). 3b80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c (l 3b90: 65 74 20 28 28 69 31 20 28 69 6e 63 20 69 29 29 et ((i1 (inc i)) 3ba0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ). 3bb0: 20 20 20 20 28 73 74 72 69 6e 67 2d 73 65 74 21 (string-set! 3bc0: 20 62 75 66 66 65 72 20 69 20 63 29 0a 20 20 20 buffer i c). 3bd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 ( 3be0: 69 66 20 28 3d 20 69 31 20 6e 29 20 62 75 66 66 if (= i1 n) buff 3bf0: 65 72 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 er. 3c00: 20 20 20 20 20 20 20 20 20 28 6c 6f 6f 70 20 69 (loop i 3c10: 31 20 28 72 65 61 64 2d 63 68 61 72 20 70 6f 72 1 (read-char por 3c20: 74 29 29 29 29 29 29 29 29 29 0a 0a 20 20 28 64 t))))))))).. (d 3c30: 65 66 69 6e 65 20 28 6d 69 73 63 69 6f 3a 66 69 efine (miscio:fi 3c40: 6e 64 2d 73 74 72 69 6e 67 2d 66 72 6f 6d 2d 70 nd-string-from-p 3c50: 6f 72 74 3f 20 73 74 72 20 3c 69 6e 70 75 74 2d ort? str <input- 3c60: 70 6f 72 74 3e 20 2e 20 6d 61 78 2d 6e 6f 2d 63 port> . max-no-c 3c70: 68 61 72 29 0a 20 20 20 20 28 73 65 74 21 20 6d har). (set! m 3c80: 61 78 2d 6e 6f 2d 63 68 61 72 20 28 69 66 20 28 ax-no-char (if ( 3c90: 6e 75 6c 6c 3f 20 6d 61 78 2d 6e 6f 2d 63 68 61 null? max-no-cha 3ca0: 72 29 20 23 66 20 28 63 61 72 20 6d 61 78 2d 6e r) #f (car max-n 3cb0: 6f 2d 63 68 61 72 29 29 29 0a 20 20 20 20 28 6c o-char))). (l 3cc0: 65 74 72 65 63 0a 20 20 20 20 20 20 20 20 28 28 etrec. (( 3cd0: 6e 6f 2d 63 68 61 72 73 2d 72 65 61 64 20 30 29 no-chars-read 0) 3ce0: 0a 20 20 20 20 20 20 20 20 20 28 6d 79 2d 70 65 . (my-pe 3cf0: 65 6b 2d 63 68 61 72 0a 20 20 20 20 20 20 20 20 ek-char. 3d00: 20 20 28 6c 61 6d 62 64 61 20 28 29 20 28 61 6e (lambda () (an 3d10: 64 20 28 6f 72 20 28 6e 6f 74 20 6d 61 78 2d 6e d (or (not max-n 3d20: 6f 2d 63 68 61 72 29 20 28 3c 20 6e 6f 2d 63 68 o-char) (< no-ch 3d30: 61 72 73 2d 72 65 61 64 20 6d 61 78 2d 6e 6f 2d ars-read max-no- 3d40: 63 68 61 72 29 29 0a 20 20 20 20 20 20 20 20 20 char)). 3d50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3d60: 20 28 6c 65 74 20 28 28 63 20 28 70 65 65 6b 2d (let ((c (peek- 3d70: 63 68 61 72 20 3c 69 6e 70 75 74 2d 70 6f 72 74 char <input-port 3d80: 3e 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 >))). 3d90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3da0: 20 28 69 66 20 28 65 6f 66 2d 6f 62 6a 65 63 74 (if (eof-object 3db0: 3f 20 63 29 20 23 66 20 63 29 29 29 29 29 0a 20 ? c) #f c))))). 3dc0: 20 20 20 20 20 20 20 20 28 6e 65 78 74 2d 63 68 (next-ch 3dd0: 61 72 20 28 6c 61 6d 62 64 61 20 28 29 20 28 72 ar (lambda () (r 3de0: 65 61 64 2d 63 68 61 72 20 3c 69 6e 70 75 74 2d ead-char <input- 3df0: 70 6f 72 74 3e 29 0a 20 20 20 20 20 20 20 20 20 port>). 3e00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3e10: 20 20 20 28 73 65 74 21 20 6e 6f 2d 63 68 61 72 (set! no-char 3e20: 73 2d 72 65 61 64 20 20 28 69 6e 63 20 6e 6f 2d s-read (inc no- 3e30: 63 68 61 72 73 2d 72 65 61 64 29 29 29 29 0a 20 chars-read)))). 3e40: 20 20 20 20 20 20 20 20 28 6d 61 74 63 68 2d 31 (match-1 3e50: 73 74 2d 63 68 61 72 0a 20 20 20 20 20 20 20 20 st-char. 3e60: 20 20 28 6c 61 6d 62 64 61 20 28 29 0a 20 20 20 (lambda (). 3e70: 20 20 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 (let (( 3e80: 63 20 28 6d 79 2d 70 65 65 6b 2d 63 68 61 72 29 c (my-peek-char) 3e90: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )). 3ea0: 20 28 69 66 20 28 6e 6f 74 20 63 29 20 23 66 0a (if (not c) #f. 3eb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3ec0: 20 20 28 62 65 67 69 6e 20 28 6e 65 78 74 2d 63 (begin (next-c 3ed0: 68 61 72 29 0a 20 20 20 20 20 20 20 20 20 20 20 har). 3ee0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 (i 3ef0: 66 20 28 63 68 61 72 3d 3f 20 63 20 28 73 74 72 f (char=? c (str 3f00: 69 6e 67 2d 72 65 66 20 73 74 72 20 30 29 29 0a ing-ref str 0)). 3f10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3f20: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6d 61 (ma 3f30: 74 63 68 2d 6f 74 68 65 72 2d 63 68 61 72 73 20 tch-other-chars 3f40: 31 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 1). 3f50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3f60: 28 6d 61 74 63 68 2d 31 73 74 2d 63 68 61 72 29 (match-1st-char) 3f70: 29 29 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 )))))). 3f80: 28 6d 61 74 63 68 2d 6f 74 68 65 72 2d 63 68 61 (match-other-cha 3f90: 72 73 0a 20 20 20 20 20 20 20 20 20 20 28 6c 61 rs. (la 3fa0: 6d 62 64 61 20 28 70 6f 73 2d 74 6f 2d 6d 61 74 mbda (pos-to-mat 3fb0: 63 68 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ch). 3fc0: 28 69 66 20 28 3e 3d 20 70 6f 73 2d 74 6f 2d 6d (if (>= pos-to-m 3fd0: 61 74 63 68 20 28 73 74 72 69 6e 67 2d 6c 65 6e atch (string-len 3fe0: 67 74 68 20 73 74 72 29 29 0a 20 20 20 20 20 20 gth str)). 3ff0: 20 20 20 20 20 20 20 20 20 20 6e 6f 2d 63 68 61 no-cha 4000: 72 73 2d 72 65 61 64 0a 20 20 20 20 20 20 20 20 rs-read. 4010: 20 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 63 (let ((c 4020: 20 28 6d 79 2d 70 65 65 6b 2d 63 68 61 72 29 29 (my-peek-char)) 4030: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ). 4040: 20 20 20 20 28 61 6e 64 20 63 0a 20 20 20 20 20 (and c. 4050: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 4060: 20 20 28 69 66 20 28 6e 6f 74 20 28 63 68 61 72 (if (not (char 4070: 3d 3f 20 63 20 28 73 74 72 69 6e 67 2d 72 65 66 =? c (string-ref 4080: 20 73 74 72 20 70 6f 73 2d 74 6f 2d 6d 61 74 63 str pos-to-matc 4090: 68 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 h))). 40a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 40b0: 28 62 61 63 6b 74 72 61 63 6b 20 31 20 70 6f 73 (backtrack 1 pos 40c0: 2d 74 6f 2d 6d 61 74 63 68 29 0a 20 20 20 20 20 -to-match). 40d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 40e0: 20 20 20 20 20 20 28 62 65 67 69 6e 20 28 6e 65 (begin (ne 40f0: 78 74 2d 63 68 61 72 29 0a 20 20 20 20 20 20 20 xt-char). 4100: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 4110: 20 20 20 20 20 20 20 20 20 20 20 28 6d 61 74 63 (matc 4120: 68 2d 6f 74 68 65 72 2d 63 68 61 72 73 20 28 69 h-other-chars (i 4130: 6e 63 20 70 6f 73 2d 74 6f 2d 6d 61 74 63 68 29 nc pos-to-match) 4140: 29 29 29 29 29 29 29 29 0a 20 20 20 20 20 20 20 )))))))). 4150: 20 20 28 62 61 63 6b 74 72 61 63 6b 0a 20 20 20 (backtrack. 4160: 20 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 (lambda ( 4170: 69 20 6d 61 74 63 68 65 64 2d 73 75 62 73 74 72 i matched-substr 4180: 2d 6c 65 6e 29 0a 20 20 20 20 20 20 20 20 20 20 -len). 4190: 20 20 28 6c 65 74 20 28 28 6a 20 28 2d 20 6d 61 (let ((j (- ma 41a0: 74 63 68 65 64 2d 73 75 62 73 74 72 2d 6c 65 6e tched-substr-len 41b0: 20 69 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 i))). 41c0: 20 20 20 20 28 69 66 20 28 3c 3d 20 6a 20 30 29 (if (<= j 0) 41d0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 . 41e0: 20 20 20 28 6d 61 74 63 68 2d 31 73 74 2d 63 68 (match-1st-ch 41f0: 61 72 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ar). 4200: 20 20 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 (let loop 4210: 28 28 6b 20 30 29 29 0a 20 20 20 20 20 20 20 20 ((k 0)). 4220: 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 (if 4230: 28 3e 3d 20 6b 20 6a 29 0a 20 20 20 20 20 20 20 (>= k j). 4240: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 4250: 20 28 6d 61 74 63 68 2d 6f 74 68 65 72 2d 63 68 (match-other-ch 4260: 61 72 73 20 6a 29 0a 20 20 20 20 20 20 20 20 20 ars j). 4270: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 ( 4280: 69 66 20 28 63 68 61 72 3d 3f 20 28 73 74 72 69 if (char=? (stri 4290: 6e 67 2d 72 65 66 20 73 74 72 20 6b 29 0a 20 20 ng-ref str k). 42a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 42b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 42c0: 20 20 28 73 74 72 69 6e 67 2d 72 65 66 20 73 74 (string-ref st 42d0: 72 20 28 2b 20 69 20 6b 29 29 29 0a 20 20 20 20 r (+ i k))). 42e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 42f0: 20 20 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 69 (loop (i 4300: 6e 63 20 6b 29 29 0a 20 20 20 20 20 20 20 20 20 nc k)). 4310: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 4320: 20 20 20 28 62 61 63 6b 74 72 61 63 6b 20 28 69 (backtrack (i 4330: 6e 63 20 69 29 20 6d 61 74 63 68 65 64 2d 73 75 nc i) matched-su 4340: 62 73 74 72 2d 6c 65 6e 29 29 29 29 29 29 29 29 bstr-len)))))))) 4350: 29 0a 20 20 20 20 20 20 28 6d 61 74 63 68 2d 31 ). (match-1 4360: 73 74 2d 63 68 61 72 29 29 29 0a 0a 20 20 28 64 st-char))).. (d 4370: 65 66 69 6e 65 20 66 69 6e 64 2d 73 74 72 69 6e efine find-strin 4380: 67 2d 66 72 6f 6d 2d 70 6f 72 74 3f 20 6d 69 73 g-from-port? mis 4390: 63 69 6f 3a 66 69 6e 64 2d 73 74 72 69 6e 67 2d cio:find-string- 43a0: 66 72 6f 6d 2d 70 6f 72 74 3f 29 0a 0a 0a 3b 20 from-port?)...; 43b0: 6d 61 6b 65 2d 63 68 61 72 2d 71 75 6f 74 61 74 make-char-quotat 43c0: 6f 72 20 51 55 4f 54 2d 52 55 4c 45 53 0a 3b 0a or QUOT-RULES.;. 43d0: 3b 20 47 69 76 65 6e 20 51 55 4f 54 2d 52 55 4c ; Given QUOT-RUL 43e0: 45 53 2c 20 61 6e 20 61 73 73 6f 63 20 6c 69 73 ES, an assoc lis 43f0: 74 20 6f 66 20 28 63 68 61 72 20 2e 20 73 74 72 t of (char . str 4400: 69 6e 67 29 20 70 61 69 72 73 2c 20 72 65 74 75 ing) pairs, retu 4410: 72 6e 0a 3b 20 61 20 71 75 6f 74 61 74 69 6f 6e rn.; a quotation 4420: 20 70 72 6f 63 65 64 75 72 65 2e 20 54 68 65 20 procedure. The 4430: 72 65 74 75 72 6e 65 64 20 71 75 6f 74 61 74 69 returned quotati 4440: 6f 6e 20 70 72 6f 63 65 64 75 72 65 20 74 61 6b on procedure tak 4450: 65 73 20 61 20 73 74 72 69 6e 67 0a 3b 20 61 6e es a string.; an 4460: 64 20 72 65 74 75 72 6e 73 20 65 69 74 68 65 72 d returns either 4470: 20 61 20 73 74 72 69 6e 67 20 6f 72 20 61 20 6c a string or a l 4480: 69 73 74 20 6f 66 20 73 74 72 69 6e 67 73 2e 20 ist of strings. 4490: 54 68 65 20 71 75 6f 74 61 74 69 6f 6e 20 70 72 The quotation pr 44a0: 6f 63 65 64 75 72 65 0a 3b 20 63 68 65 63 6b 20 ocedure.; check 44b0: 74 6f 20 73 65 65 20 69 66 20 69 74 73 20 61 72 to see if its ar 44c0: 67 75 6d 65 6e 74 20 73 74 72 69 6e 67 20 63 6f gument string co 44d0: 6e 74 61 69 6e 73 20 61 6e 79 20 69 6e 73 74 61 ntains any insta 44e0: 6e 63 65 20 6f 66 20 61 20 63 68 61 72 61 63 74 nce of a charact 44f0: 65 72 0a 3b 20 74 68 61 74 20 6e 65 65 64 73 20 er.; that needs 4500: 74 6f 20 62 65 20 65 6e 63 6f 64 65 64 20 28 71 to be encoded (q 4510: 75 6f 74 65 64 29 2e 20 49 66 20 74 68 65 20 61 uoted). If the a 4520: 72 67 75 6d 65 6e 74 20 73 74 72 69 6e 67 20 69 rgument string i 4530: 73 20 22 63 6c 65 61 6e 22 2c 0a 3b 20 69 74 20 s "clean",.; it 4540: 69 73 20 72 65 74 75 72 6e 65 64 20 75 6e 63 68 is returned unch 4550: 61 6e 67 65 64 2e 20 4f 74 68 65 72 77 69 73 65 anged. Otherwise 4560: 2c 20 74 68 65 20 71 75 6f 74 61 74 69 6f 6e 20 , the quotation 4570: 70 72 6f 63 65 64 75 72 65 20 77 69 6c 6c 0a 3b procedure will.; 4580: 20 72 65 74 75 72 6e 20 61 20 6c 69 73 74 20 6f return a list o 4590: 66 20 73 74 72 69 6e 67 20 66 72 61 67 6d 65 6e f string fragmen 45a0: 74 73 2e 20 54 68 65 20 69 6e 70 75 74 20 73 74 ts. The input st 45b0: 72 61 69 6e 67 20 77 69 6c 6c 20 62 65 20 62 72 raing will be br 45c0: 6f 6b 65 6e 0a 3b 20 61 74 20 74 68 65 20 70 6c oken.; at the pl 45d0: 61 63 65 73 20 77 68 65 72 65 20 74 68 65 20 73 aces where the s 45e0: 70 65 63 69 61 6c 20 63 68 61 72 61 63 74 65 72 pecial character 45f0: 73 20 6f 63 63 75 72 2e 20 54 68 65 20 73 70 65 s occur. The spe 4600: 63 69 61 6c 20 63 68 61 72 61 63 74 65 72 0a 3b cial character.; 4610: 20 77 69 6c 6c 20 62 65 20 72 65 70 6c 61 63 65 will be replace 4620: 64 20 62 79 20 74 68 65 20 63 6f 72 72 65 73 70 d by the corresp 4630: 6f 6e 64 69 6e 67 20 65 6e 63 6f 64 69 6e 67 20 onding encoding 4640: 73 74 72 69 6e 67 73 2e 0a 3b 0a 3b 20 46 6f 72 strings..;.; For 4650: 20 65 78 61 6d 70 6c 65 2c 20 74 6f 20 6d 61 6b example, to mak 4660: 65 20 61 20 70 72 6f 63 65 64 75 72 65 20 74 68 e a procedure th 4670: 61 74 20 71 75 6f 74 65 73 20 73 70 65 63 69 61 at quotes specia 4680: 6c 20 48 54 4d 4c 20 63 68 61 72 61 63 74 65 72 l HTML character 4690: 73 2c 0a 3b 20 64 6f 0a 3b 09 28 6d 61 6b 65 2d s,.; do.;.(make- 46a0: 63 68 61 72 2d 71 75 6f 74 61 74 6f 72 0a 3b 09 char-quotator.;. 46b0: 20 20 20 20 27 28 28 23 5c 3c 20 2e 20 22 26 6c '((#\< . "&l 46c0: 74 3b 22 29 20 28 23 5c 3e 20 2e 20 22 26 67 74 t;") (#\> . "> 46d0: 3b 22 29 20 28 23 5c 26 20 2e 20 22 26 61 6d 70 ;") (#\& . "& 46e0: 3b 22 29 20 28 23 5c 22 20 2e 20 22 26 71 75 6f ;") (#\" . "&quo 46f0: 74 3b 22 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 t;")))..(define 4700: 28 6d 61 6b 65 2d 63 68 61 72 2d 71 75 6f 74 61 (make-char-quota 4710: 74 6f 72 20 63 68 61 72 2d 65 6e 63 6f 64 69 6e tor char-encodin 4720: 67 29 0a 20 20 28 6c 65 74 20 28 28 62 61 64 2d g). (let ((bad- 4730: 63 68 61 72 73 20 28 6d 61 70 20 63 61 72 20 63 chars (map car c 4740: 68 61 72 2d 65 6e 63 6f 64 69 6e 67 29 29 29 0a har-encoding))). 4750: 0a 20 20 20 20 3b 20 43 68 65 63 6b 20 74 6f 20 . ; Check to 4760: 73 65 65 20 69 66 20 73 74 72 20 63 6f 6e 74 61 see if str conta 4770: 69 6e 73 20 6f 6e 65 20 6f 66 20 74 68 65 20 63 ins one of the c 4780: 68 61 72 61 63 74 65 72 73 20 69 6e 20 63 68 61 haracters in cha 4790: 72 73 65 74 2c 0a 20 20 20 20 3b 20 66 72 6f 6d rset,. ; from 47a0: 20 74 68 65 20 70 6f 73 69 74 69 6f 6e 20 69 20 the position i 47b0: 6f 6e 77 61 72 64 2e 20 49 66 20 73 6f 2c 20 72 onward. If so, r 47c0: 65 74 75 72 6e 20 74 68 61 74 20 63 68 61 72 61 eturn that chara 47d0: 63 74 65 72 27 73 20 69 6e 64 65 78 2e 0a 20 20 cter's index.. 47e0: 20 20 3b 20 6f 74 68 65 72 77 69 73 65 2c 20 72 ; otherwise, r 47f0: 65 74 75 72 6e 20 23 66 0a 20 20 20 20 28 64 65 eturn #f. (de 4800: 66 69 6e 65 20 28 69 6e 64 65 78 2d 63 73 65 74 fine (index-cset 4810: 20 73 74 72 20 69 20 63 68 61 72 73 65 74 29 0a str i charset). 4820: 20 20 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 (let loop 4830: 28 28 69 20 69 29 29 0a 09 28 61 6e 64 20 28 3c ((i i))..(and (< 4840: 20 69 20 28 73 74 72 69 6e 67 2d 6c 65 6e 67 74 i (string-lengt 4850: 68 20 73 74 72 29 29 0a 09 20 20 20 20 20 28 69 h str)).. (i 4860: 66 20 28 6d 65 6d 76 20 28 73 74 72 69 6e 67 2d f (memv (string- 4870: 72 65 66 20 73 74 72 20 69 29 20 63 68 61 72 73 ref str i) chars 4880: 65 74 29 20 69 0a 09 09 20 28 6c 6f 6f 70 20 28 et) i... (loop ( 4890: 69 6e 63 20 69 29 29 29 29 29 29 0a 0a 20 20 20 inc i)))))).. 48a0: 20 3b 20 54 68 65 20 62 6f 64 79 20 6f 66 20 74 ; The body of t 48b0: 68 65 20 66 75 6e 63 74 69 6f 6e 0a 20 20 20 20 he function. 48c0: 28 6c 61 6d 62 64 61 20 28 73 74 72 29 0a 20 20 (lambda (str). 48d0: 20 20 20 20 28 6c 65 74 20 28 28 62 61 64 2d 70 (let ((bad-p 48e0: 6f 73 20 28 69 6e 64 65 78 2d 63 73 65 74 20 73 os (index-cset s 48f0: 74 72 20 30 20 62 61 64 2d 63 68 61 72 73 29 29 tr 0 bad-chars)) 4900: 29 0a 09 28 69 66 20 28 6e 6f 74 20 62 61 64 2d )..(if (not bad- 4910: 70 6f 73 29 20 73 74 72 09 3b 20 73 74 72 20 68 pos) str.; str h 4920: 61 64 20 61 6c 6c 20 67 6f 6f 64 20 63 68 61 72 ad all good char 4930: 73 0a 09 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 s.. (let loop 4940: 20 28 28 66 72 6f 6d 20 30 29 20 28 74 6f 20 62 ((from 0) (to b 4950: 61 64 2d 70 6f 73 29 29 0a 09 20 20 20 20 20 20 ad-pos)).. 4960: 28 63 6f 6e 64 0a 09 20 20 20 20 20 20 20 28 28 (cond.. (( 4970: 3e 3d 20 66 72 6f 6d 20 28 73 74 72 69 6e 67 2d >= from (string- 4980: 6c 65 6e 67 74 68 20 73 74 72 29 29 20 27 28 29 length str)) '() 4990: 29 0a 09 20 20 20 20 20 20 20 28 28 6e 6f 74 20 ).. ((not 49a0: 74 6f 29 0a 09 09 28 63 6f 6e 73 20 28 73 75 62 to)...(cons (sub 49b0: 73 74 72 69 6e 67 20 73 74 72 20 66 72 6f 6d 20 string str from 49c0: 28 73 74 72 69 6e 67 2d 6c 65 6e 67 74 68 20 73 (string-length s 49d0: 74 72 29 29 20 27 28 29 29 29 0a 09 20 20 20 20 tr)) '())).. 49e0: 20 20 20 28 65 6c 73 65 0a 09 09 28 6c 65 74 20 (else...(let 49f0: 28 28 71 75 6f 74 65 64 2d 63 68 61 72 0a 09 09 ((quoted-char... 4a00: 20 20 20 20 20 20 20 28 63 64 72 20 28 61 73 73 (cdr (ass 4a10: 76 20 28 73 74 72 69 6e 67 2d 72 65 66 20 73 74 v (string-ref st 4a20: 72 20 74 6f 29 20 63 68 61 72 2d 65 6e 63 6f 64 r to) char-encod 4a30: 69 6e 67 29 29 29 0a 09 09 20 20 20 20 20 20 28 ing)))... ( 4a40: 6e 65 77 2d 74 6f 20 0a 09 09 20 20 20 20 20 20 new-to ... 4a50: 20 28 69 6e 64 65 78 2d 63 73 65 74 20 73 74 72 (index-cset str 4a60: 20 28 69 6e 63 20 74 6f 29 20 62 61 64 2d 63 68 (inc to) bad-ch 4a70: 61 72 73 29 29 29 0a 09 09 20 20 28 69 66 20 28 ars)))... (if ( 4a80: 3c 20 66 72 6f 6d 20 74 6f 29 0a 09 09 20 20 20 < from to)... 4a90: 20 20 20 28 63 6f 6e 73 0a 09 09 20 20 20 20 20 (cons... 4aa0: 20 20 28 73 75 62 73 74 72 69 6e 67 20 73 74 72 (substring str 4ab0: 20 66 72 6f 6d 20 74 6f 29 0a 09 09 20 20 20 20 from to)... 4ac0: 20 20 20 28 63 6f 6e 73 20 71 75 6f 74 65 64 2d (cons quoted- 4ad0: 63 68 61 72 20 28 6c 6f 6f 70 20 28 69 6e 63 20 char (loop (inc 4ae0: 74 6f 29 20 6e 65 77 2d 74 6f 29 29 29 0a 09 09 to) new-to)))... 4af0: 20 20 20 20 20 20 28 63 6f 6e 73 20 71 75 6f 74 (cons quot 4b00: 65 64 2d 63 68 61 72 20 28 6c 6f 6f 70 20 28 69 ed-char (loop (i 4b10: 6e 63 20 74 6f 29 20 6e 65 77 2d 74 6f 29 29 29 nc to) new-to))) 4b20: 29 29 29 29 29 29 29 0a 29 29 0a 0a 3b 3b 20 66 ))))))).))..;; f 4b30: 72 6f 6d 20 68 74 74 70 73 3a 2f 2f 73 6f 75 72 rom https://sour 4b40: 63 65 66 6f 72 67 65 2e 6e 65 74 2f 70 2f 73 69 ceforge.net/p/si 4b50: 73 63 2f 6d 61 69 6c 6d 61 6e 2f 6d 65 73 73 61 sc/mailman/messa 4b60: 67 65 2f 32 39 30 39 32 39 34 2f 0a 0a 28 64 65 ge/2909294/..(de 4b70: 66 69 6e 65 2d 73 79 6e 74 61 78 20 6c 6f 6f 6b fine-syntax look 4b80: 75 70 2d 64 65 66 20 0a 20 20 28 73 79 6e 74 61 up-def . (synta 4b90: 78 2d 72 75 6c 65 73 20 28 77 61 72 6e 3a 29 0a x-rules (warn:). 4ba0: 20 20 20 20 28 28 6c 6f 6f 6b 75 70 2d 64 65 66 ((lookup-def 4bb0: 20 6b 65 79 20 61 6c 69 73 74 29 0a 20 20 20 20 key alist). 4bc0: 20 28 6c 65 74 20 28 28 6e 6b 65 79 20 6b 65 79 (let ((nkey key 4bd0: 29 20 28 6e 61 6c 69 73 74 20 61 6c 69 73 74 29 ) (nalist alist) 4be0: 29 20 3b 20 65 76 61 6c 75 61 74 65 20 74 68 65 ) ; evaluate the 4bf0: 6d 20 6f 6e 6c 79 20 6f 6e 63 65 0a 20 20 20 20 m only once. 4c00: 20 20 20 28 6c 65 74 20 28 28 72 65 73 20 28 61 (let ((res (a 4c10: 73 73 71 20 6e 6b 65 79 20 6e 61 6c 69 73 74 29 ssq nkey nalist) 4c20: 29 29 0a 09 20 28 69 66 20 72 65 73 0a 09 20 20 )).. (if res.. 4c30: 20 20 20 28 6c 65 74 20 28 28 72 65 73 20 28 63 (let ((res (c 4c40: 64 72 20 72 65 73 29 29 29 0a 09 20 20 20 20 20 dr res))).. 4c50: 20 20 28 63 6f 6e 64 0a 09 09 28 28 6e 6f 74 20 (cond...((not 4c60: 28 70 61 69 72 3f 20 72 65 73 29 29 20 72 65 73 (pair? res)) res 4c70: 29 0a 09 09 28 28 6e 75 6c 6c 3f 20 28 63 64 72 )...((null? (cdr 4c80: 20 72 65 73 29 29 20 28 63 61 72 20 72 65 73 29 res)) (car res) 4c90: 29 0a 09 09 28 65 6c 73 65 20 72 65 73 29 29 29 )...(else res))) 4ca0: 0a 09 20 20 20 20 20 28 65 72 72 6f 72 20 22 46 .. (error "F 4cb0: 61 69 6c 65 64 20 74 6f 20 66 69 6e 64 20 22 20 ailed to find " 4cc0: 6e 6b 65 79 20 22 20 69 6e 20 22 20 6e 61 6c 69 nkey " in " nali 4cd0: 73 74 29 29 29 29 29 0a 20 20 20 20 28 28 6c 6f st))))). ((lo 4ce0: 6f 6b 75 70 2d 64 65 66 20 6b 65 79 20 61 6c 69 okup-def key ali 4cf0: 73 74 20 64 65 66 61 75 6c 74 2d 65 78 70 29 0a st default-exp). 4d00: 20 20 20 20 20 28 6c 65 74 20 28 28 72 65 73 20 (let ((res 4d10: 28 61 73 73 71 20 6b 65 79 20 61 6c 69 73 74 29 (assq key alist) 4d20: 29 29 0a 20 20 20 20 20 20 20 28 69 66 20 72 65 )). (if re 4d30: 73 0a 09 20 20 20 28 6c 65 74 20 28 28 72 65 73 s.. (let ((res 4d40: 20 28 63 64 72 20 72 65 73 29 29 29 0a 09 20 20 (cdr res))).. 4d50: 20 20 20 28 63 6f 6e 64 0a 09 20 20 20 20 20 20 (cond.. 4d60: 28 28 6e 6f 74 20 28 70 61 69 72 3f 20 72 65 73 ((not (pair? res 4d70: 29 29 20 72 65 73 29 0a 09 20 20 20 20 20 20 28 )) res).. ( 4d80: 28 6e 75 6c 6c 3f 20 28 63 64 72 20 72 65 73 29 (null? (cdr res) 4d90: 29 20 28 63 61 72 20 72 65 73 29 29 0a 09 20 20 ) (car res)).. 4da0: 20 20 20 20 28 65 6c 73 65 20 72 65 73 29 29 29 (else res))) 4db0: 0a 09 20 20 20 64 65 66 61 75 6c 74 2d 65 78 70 .. default-exp 4dc0: 29 29 29 0a 20 20 20 20 28 28 6c 6f 6f 6b 75 70 ))). ((lookup 4dd0: 2d 64 65 66 20 6b 65 79 20 61 6c 69 73 74 20 77 -def key alist w 4de0: 61 72 6e 3a 20 64 65 66 61 75 6c 74 2d 65 78 70 arn: default-exp 4df0: 29 0a 20 20 20 20 20 28 6c 65 74 20 28 28 6e 6b ). (let ((nk 4e00: 65 79 20 6b 65 79 29 20 28 6e 61 6c 69 73 74 20 ey key) (nalist 4e10: 61 6c 69 73 74 29 29 20 3b 20 65 76 61 6c 75 61 alist)) ; evalua 4e20: 74 65 20 74 68 65 6d 20 6f 6e 6c 79 20 6f 6e 63 te them only onc 4e30: 65 0a 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 e. (let (( 4e40: 72 65 73 20 28 61 73 73 71 20 6e 6b 65 79 20 6e res (assq nkey n 4e50: 61 6c 69 73 74 29 29 29 0a 09 20 28 69 66 20 72 alist))).. (if r 4e60: 65 73 0a 09 20 20 20 20 20 28 6c 65 74 20 28 28 es.. (let (( 4e70: 72 65 73 20 28 63 64 72 20 72 65 73 29 29 29 0a res (cdr res))). 4e80: 09 20 20 20 20 20 20 20 28 63 6f 6e 64 0a 09 09 . (cond... 4e90: 28 28 6e 6f 74 20 28 70 61 69 72 3f 20 72 65 73 ((not (pair? res 4ea0: 29 29 20 72 65 73 29 0a 09 09 28 28 6e 75 6c 6c )) res)...((null 4eb0: 3f 20 28 63 64 72 20 72 65 73 29 29 20 28 63 61 ? (cdr res)) (ca 4ec0: 72 20 72 65 73 29 29 0a 09 09 28 65 6c 73 65 20 r res))...(else 4ed0: 72 65 73 29 29 29 0a 09 20 20 20 20 20 28 62 65 res))).. (be 4ee0: 67 69 6e 0a 09 20 20 20 20 20 20 20 28 63 65 72 gin.. (cer 4ef0: 72 20 22 46 61 69 6c 65 64 20 74 6f 20 66 69 6e r "Failed to fin 4f00: 64 20 22 20 6e 6b 65 79 20 22 20 69 6e 20 22 20 d " nkey " in " 4f10: 6e 61 6c 69 73 74 20 23 5c 6e 65 77 6c 69 6e 65 nalist #\newline 4f20: 29 0a 09 20 20 20 20 20 20 20 64 65 66 61 75 6c ).. defaul 4f30: 74 2d 65 78 70 29 29 29 29 29 0a 20 20 20 20 29 t-exp))))). ) 4f40: 29 0a 0a 28 64 65 66 69 6e 65 20 4f 53 3a 66 69 )..(define OS:fi 4f50: 6c 65 2d 6c 65 6e 67 74 68 20 28 6c 61 6d 62 64 le-length (lambd 4f60: 61 20 28 70 61 74 68 29 20 28 63 61 6c 6c 2d 77 a (path) (call-w 4f70: 69 74 68 2d 69 6e 70 75 74 2d 66 69 6c 65 20 70 ith-input-file p 4f80: 61 74 68 20 28 6c 61 6d 62 64 61 20 28 70 29 20 ath (lambda (p) 4f90: 28 66 69 6c 65 2d 6c 65 6e 67 74 68 20 70 29 29 (file-length p)) 4fa0: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 73 74 72 )))..(define str 4fb0: 69 6e 67 2d 3e 69 6e 74 65 67 65 72 0a 20 20 28 ing->integer. ( 4fc0: 63 61 73 65 2d 6c 61 6d 62 64 61 0a 20 20 20 20 case-lambda. 4fd0: 5b 28 73 74 72 29 0a 20 20 20 20 20 28 73 74 72 [(str). (str 4fe0: 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 73 74 72 29 ing->number str) 4ff0: 5d 0a 20 20 20 20 5b 28 73 74 72 20 73 74 61 72 ]. [(str star 5000: 74 20 65 6e 64 29 0a 20 20 20 20 20 28 73 74 72 t end). (str 5010: 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 28 73 75 62 ing->number (sub 5020: 73 74 72 69 6e 67 20 73 74 72 20 73 74 61 72 74 string str start 5030: 20 65 6e 64 29 29 5d 29 29 0a end))])).