Artifact
6f01e31703faf5ad7a21dd7e82f5099f687b4a2f
File
webgate-utils.scm
— part of check-in
[01fdd8217d]
at
2015-05-04 08:03:04
on branch trunk
— Use letrec* in make-at-reader+table to ensure correct sequencing of operations
(user:
murphy
size: 12065)
0000: 3b 3b 20 2d 2a 2d 20 6d 6f 64 65 3a 20 53 63 68 ;; -*- mode: Sch
0010: 65 6d 65 3b 20 2d 2a 2d 0a 3b 3b 0a 3b 3b 20 54 eme; -*-.;;.;; T
0020: 68 69 73 20 66 69 6c 65 20 69 73 20 70 61 72 74 his file is part
0030: 20 6f 66 20 57 65 62 47 61 74 65 20 66 6f 72 20 of WebGate for
0040: 43 48 49 43 4b 45 4e 2e 0a 3b 3b 20 43 6f 70 79 CHICKEN..;; Copy
0050: 72 69 67 68 74 20 28 63 29 20 32 30 31 31 2d 32 right (c) 2011-2
0060: 30 31 33 20 62 79 20 54 68 6f 6d 61 73 20 43 68 013 by Thomas Ch
0070: 75 73 74 2e 20 20 41 6c 6c 20 72 69 67 68 74 73 ust. All rights
0080: 20 72 65 73 65 72 76 65 64 2e 0a 3b 3b 0a 3b 3b reserved..;;.;;
0090: 20 50 65 72 6d 69 73 73 69 6f 6e 20 69 73 20 68 Permission is h
00a0: 65 72 65 62 79 20 67 72 61 6e 74 65 64 2c 20 66 ereby granted, f
00b0: 72 65 65 20 6f 66 20 63 68 61 72 67 65 2c 20 74 ree of charge, t
00c0: 6f 20 61 6e 79 20 70 65 72 73 6f 6e 0a 3b 3b 20 o any person.;;
00d0: 6f 62 74 61 69 6e 69 6e 67 20 61 20 63 6f 70 79 obtaining a copy
00e0: 20 6f 66 20 74 68 69 73 20 73 6f 66 74 77 61 72 of this softwar
00f0: 65 20 61 6e 64 20 61 73 73 6f 63 69 61 74 65 64 e and associated
0100: 20 64 6f 63 75 6d 65 6e 74 61 74 69 6f 6e 0a 3b documentation.;
0110: 3b 20 66 69 6c 65 73 20 28 74 68 65 20 53 6f 66 ; files (the Sof
0120: 74 77 61 72 65 29 2c 20 74 6f 20 64 65 61 6c 20 tware), to deal
0130: 69 6e 20 74 68 65 20 53 6f 66 74 77 61 72 65 20 in the Software
0140: 77 69 74 68 6f 75 74 20 72 65 73 74 72 69 63 74 without restrict
0150: 69 6f 6e 2c 0a 3b 3b 20 69 6e 63 6c 75 64 69 6e ion,.;; includin
0160: 67 20 77 69 74 68 6f 75 74 20 6c 69 6d 69 74 61 g without limita
0170: 74 69 6f 6e 20 74 68 65 20 72 69 67 68 74 73 20 tion the rights
0180: 74 6f 20 75 73 65 2c 20 63 6f 70 79 2c 20 6d 6f to use, copy, mo
0190: 64 69 66 79 2c 0a 3b 3b 20 6d 65 72 67 65 2c 20 dify,.;; merge,
01a0: 70 75 62 6c 69 73 68 2c 20 64 69 73 74 72 69 62 publish, distrib
01b0: 75 74 65 2c 20 73 75 62 6c 69 63 65 6e 73 65 2c ute, sublicense,
01c0: 20 61 6e 64 2f 6f 72 20 73 65 6c 6c 20 63 6f 70 and/or sell cop
01d0: 69 65 73 20 6f 66 20 74 68 65 0a 3b 3b 20 53 6f ies of the.;; So
01e0: 66 74 77 61 72 65 2c 20 61 6e 64 20 74 6f 20 70 ftware, and to p
01f0: 65 72 6d 69 74 20 70 65 72 73 6f 6e 73 20 74 6f ermit persons to
0200: 20 77 68 6f 6d 20 74 68 65 20 53 6f 66 74 77 61 whom the Softwa
0210: 72 65 20 69 73 20 66 75 72 6e 69 73 68 65 64 0a re is furnished.
0220: 3b 3b 20 74 6f 20 64 6f 20 73 6f 2c 20 73 75 62 ;; to do so, sub
0230: 6a 65 63 74 20 74 6f 20 74 68 65 20 66 6f 6c 6c ject to the foll
0240: 6f 77 69 6e 67 20 63 6f 6e 64 69 74 69 6f 6e 73 owing conditions
0250: 3a 0a 3b 3b 20 0a 3b 3b 20 54 68 65 20 61 62 6f :.;; .;; The abo
0260: 76 65 20 63 6f 70 79 72 69 67 68 74 20 6e 6f 74 ve copyright not
0270: 69 63 65 20 61 6e 64 20 74 68 69 73 20 70 65 72 ice and this per
0280: 6d 69 73 73 69 6f 6e 20 6e 6f 74 69 63 65 20 73 mission notice s
0290: 68 61 6c 6c 20 62 65 0a 3b 3b 20 69 6e 63 6c 75 hall be.;; inclu
02a0: 64 65 64 20 69 6e 20 61 6c 6c 20 63 6f 70 69 65 ded in all copie
02b0: 73 20 6f 72 20 73 75 62 73 74 61 6e 74 69 61 6c s or substantial
02c0: 20 70 6f 72 74 69 6f 6e 73 20 6f 66 20 74 68 65 portions of the
02d0: 20 53 6f 66 74 77 61 72 65 2e 0a 3b 3b 20 0a 3b Software..;; .;
02e0: 3b 20 54 48 45 20 53 4f 46 54 57 41 52 45 20 49 ; THE SOFTWARE I
02f0: 53 20 50 52 4f 56 49 44 45 44 20 41 53 49 53 2c S PROVIDED ASIS,
0300: 20 57 49 54 48 4f 55 54 20 57 41 52 52 41 4e 54 WITHOUT WARRANT
0310: 59 20 4f 46 20 41 4e 59 20 4b 49 4e 44 2c 0a 3b Y OF ANY KIND,.;
0320: 3b 20 45 58 50 52 45 53 53 20 4f 52 20 49 4d 50 ; EXPRESS OR IMP
0330: 4c 49 45 44 2c 20 49 4e 43 4c 55 44 49 4e 47 20 LIED, INCLUDING
0340: 42 55 54 20 4e 4f 54 20 4c 49 4d 49 54 45 44 20 BUT NOT LIMITED
0350: 54 4f 20 54 48 45 20 57 41 52 52 41 4e 54 49 45 TO THE WARRANTIE
0360: 53 20 4f 46 0a 3b 3b 20 4d 45 52 43 48 41 4e 54 S OF.;; MERCHANT
0370: 41 42 49 4c 49 54 59 2c 20 46 49 54 4e 45 53 53 ABILITY, FITNESS
0380: 20 46 4f 52 20 41 20 50 41 52 54 49 43 55 4c 41 FOR A PARTICULA
0390: 52 20 50 55 52 50 4f 53 45 20 41 4e 44 0a 3b 3b R PURPOSE AND.;;
03a0: 20 4e 4f 4e 49 4e 46 52 49 4e 47 45 4d 45 4e 54 NONINFRINGEMENT
03b0: 2e 20 49 4e 20 4e 4f 20 45 56 45 4e 54 20 53 48 . IN NO EVENT SH
03c0: 41 4c 4c 20 54 48 45 20 41 55 54 48 4f 52 53 20 ALL THE AUTHORS
03d0: 4f 52 20 43 4f 50 59 52 49 47 48 54 20 48 4f 4c OR COPYRIGHT HOL
03e0: 44 45 52 53 0a 3b 3b 20 42 45 20 4c 49 41 42 4c DERS.;; BE LIABL
03f0: 45 20 46 4f 52 20 41 4e 59 20 43 4c 41 49 4d 2c E FOR ANY CLAIM,
0400: 20 44 41 4d 41 47 45 53 20 4f 52 20 4f 54 48 45 DAMAGES OR OTHE
0410: 52 20 4c 49 41 42 49 4c 49 54 59 2c 20 57 48 45 R LIABILITY, WHE
0420: 54 48 45 52 20 49 4e 20 41 4e 0a 3b 3b 20 41 43 THER IN AN.;; AC
0430: 54 49 4f 4e 20 4f 46 20 43 4f 4e 54 52 41 43 54 TION OF CONTRACT
0440: 2c 20 54 4f 52 54 20 4f 52 20 4f 54 48 45 52 57 , TORT OR OTHERW
0450: 49 53 45 2c 20 41 52 49 53 49 4e 47 20 46 52 4f ISE, ARISING FRO
0460: 4d 2c 20 4f 55 54 20 4f 46 20 4f 52 20 49 4e 0a M, OUT OF OR IN.
0470: 3b 3b 20 43 4f 4e 4e 45 43 54 49 4f 4e 20 57 49 ;; CONNECTION WI
0480: 54 48 20 54 48 45 20 53 4f 46 54 57 41 52 45 20 TH THE SOFTWARE
0490: 4f 52 20 54 48 45 20 55 53 45 20 4f 52 20 4f 54 OR THE USE OR OT
04a0: 48 45 52 20 44 45 41 4c 49 4e 47 53 20 49 4e 20 HER DEALINGS IN
04b0: 54 48 45 0a 3b 3b 20 53 4f 46 54 57 41 52 45 2e THE.;; SOFTWARE.
04c0: 0a 0a 3b 3b 3b 20 4e 65 74 73 74 72 69 6e 67 73 ..;;; Netstrings
04d0: 0a 0a 28 64 65 66 69 6e 65 20 28 77 72 69 74 65 ..(define (write
04e0: 2d 6e 65 74 73 74 72 69 6e 67 20 73 20 23 21 6f -netstring s #!o
04f0: 70 74 69 6f 6e 61 6c 20 28 70 6f 72 74 20 28 63 ptional (port (c
0500: 75 72 72 65 6e 74 2d 6f 75 74 70 75 74 2d 70 6f urrent-output-po
0510: 72 74 29 29 29 0a 20 20 28 66 70 72 69 6e 74 66 rt))). (fprintf
0520: 20 70 6f 72 74 20 22 7e 61 3a 7e 61 2c 22 20 28 port "~a:~a," (
0530: 73 74 72 69 6e 67 2d 6c 65 6e 67 74 68 20 73 29 string-length s)
0540: 20 73 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 s))..(define (r
0550: 65 61 64 2d 6e 65 74 73 74 72 69 6e 67 20 23 21 ead-netstring #!
0560: 6f 70 74 69 6f 6e 61 6c 20 28 70 6f 72 74 20 28 optional (port (
0570: 63 75 72 72 65 6e 74 2d 69 6e 70 75 74 2d 70 6f current-input-po
0580: 72 74 29 29 29 0a 20 20 28 6c 65 74 20 28 28 6c rt))). (let ((l
0590: 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 (string->number
05a0: 20 28 72 65 61 64 2d 74 6f 6b 65 6e 20 63 68 61 (read-token cha
05b0: 72 2d 6e 75 6d 65 72 69 63 3f 20 70 6f 72 74 29 r-numeric? port)
05c0: 29 29 29 0a 20 20 20 20 28 75 6e 6c 65 73 73 20 ))). (unless
05d0: 6c 0a 20 20 20 20 20 20 28 65 72 72 6f 72 0a 20 l. (error.
05e0: 20 20 20 20 20 20 27 72 65 61 64 2d 6e 65 74 73 'read-nets
05f0: 74 72 69 6e 67 0a 20 20 20 20 20 20 20 22 63 6c tring. "cl
0600: 69 65 6e 74 20 73 69 64 65 20 70 72 6f 74 6f 63 ient side protoc
0610: 6f 6c 20 65 72 72 6f 72 3a 20 6d 61 6c 66 6f 72 ol error: malfor
0620: 6d 65 64 20 6e 65 74 73 74 72 69 6e 67 20 28 62 med netstring (b
0630: 61 64 20 6c 65 6e 67 74 68 29 22 29 29 0a 20 20 ad length)")).
0640: 20 20 28 75 6e 6c 65 73 73 20 28 65 71 3f 20 28 (unless (eq? (
0650: 72 65 61 64 2d 63 68 61 72 20 70 6f 72 74 29 20 read-char port)
0660: 23 5c 3a 29 0a 20 20 20 20 20 20 28 65 72 72 6f #\:). (erro
0670: 72 0a 20 20 20 20 20 20 20 27 72 65 61 64 2d 6e r. 'read-n
0680: 65 74 73 74 72 69 6e 67 0a 20 20 20 20 20 20 20 etstring.
0690: 22 63 6c 69 65 6e 74 20 73 69 64 65 20 70 72 6f "client side pro
06a0: 74 6f 63 6f 6c 20 65 72 72 6f 72 3a 20 6d 61 6c tocol error: mal
06b0: 66 6f 72 6d 65 64 20 6e 65 74 73 74 72 69 6e 67 formed netstring
06c0: 20 28 62 61 64 20 64 65 6c 69 6d 69 74 65 72 29 (bad delimiter)
06d0: 22 29 29 0a 20 20 20 20 28 6c 65 74 20 28 28 73 ")). (let ((s
06e0: 20 28 72 65 61 64 2d 73 74 72 69 6e 67 20 6c 20 (read-string l
06f0: 70 6f 72 74 29 29 29 0a 20 20 20 20 20 20 28 75 port))). (u
0700: 6e 6c 65 73 73 20 28 65 71 3f 20 28 72 65 61 64 nless (eq? (read
0710: 2d 63 68 61 72 20 70 6f 72 74 29 20 23 5c 2c 29 -char port) #\,)
0720: 0a 09 28 65 72 72 6f 72 0a 09 20 27 72 65 61 64 ..(error.. 'read
0730: 2d 6e 65 74 73 74 72 69 6e 67 0a 09 20 22 63 6c -netstring.. "cl
0740: 69 65 6e 74 20 73 69 64 65 20 70 72 6f 74 6f 63 ient side protoc
0750: 6f 6c 20 65 72 72 6f 72 3a 20 6d 61 6c 66 6f 72 ol error: malfor
0760: 6d 65 64 20 6e 65 74 73 74 72 69 6e 67 20 28 62 med netstring (b
0770: 61 64 20 74 65 72 6d 69 6e 61 6c 29 22 29 29 0a ad terminal)")).
0780: 20 20 20 20 20 20 73 29 29 29 0a 0a 3b 3b 3b 20 s)))..;;;
0790: 40 2d 65 78 70 72 65 73 73 69 6f 6e 73 0a 0a 28 @-expressions..(
07a0: 64 65 66 69 6e 65 20 28 6d 61 6b 65 2d 61 74 2d define (make-at-
07b0: 72 65 61 64 65 72 2b 74 61 62 6c 65 20 61 72 67 reader+table arg
07c0: 73 29 0a 20 20 28 6c 65 74 72 65 63 2a 20 28 28 s). (letrec* ((
07d0: 63 6f 6d 6d 61 6e 64 2d 63 68 61 72 0a 09 20 20 command-char..
07e0: 20 20 20 28 67 65 74 2d 6b 65 79 77 6f 72 64 20 (get-keyword
07f0: 23 3a 63 6f 6d 6d 61 6e 64 2d 63 68 61 72 20 61 #:command-char a
0800: 72 67 73 20 28 63 6f 6e 73 74 61 6e 74 6c 79 20 rgs (constantly
0810: 23 5c 40 29 29 29 0a 09 20 20 20 20 28 74 72 69 #\@))).. (tri
0820: 6d 2d 77 68 69 74 65 73 70 61 63 65 3f 0a 09 20 m-whitespace?..
0830: 20 20 20 20 28 67 65 74 2d 6b 65 79 77 6f 72 64 (get-keyword
0840: 20 23 3a 74 72 69 6d 2d 77 68 69 74 65 73 70 61 #:trim-whitespa
0850: 63 65 3f 20 61 72 67 73 20 28 63 6f 6e 73 74 61 ce? args (consta
0860: 6e 74 6c 79 20 23 74 29 29 29 0a 09 20 20 20 20 ntly #t)))..
0870: 28 63 6f 6e 64 65 6e 73 65 2d 77 68 69 74 65 73 (condense-whites
0880: 70 61 63 65 3f 0a 09 20 20 20 20 20 28 67 65 74 pace?.. (get
0890: 2d 6b 65 79 77 6f 72 64 20 23 3a 63 6f 6e 64 65 -keyword #:conde
08a0: 6e 73 65 2d 77 68 69 74 65 73 70 61 63 65 3f 20 nse-whitespace?
08b0: 61 72 67 73 20 28 63 6f 6e 73 74 61 6e 74 6c 79 args (constantly
08c0: 20 23 74 29 29 29 0a 09 20 20 20 20 28 6c 69 73 #t))).. (lis
08d0: 74 2d 61 72 67 75 6d 65 6e 74 73 3f 0a 09 20 20 t-arguments?..
08e0: 20 20 20 28 67 65 74 2d 6b 65 79 77 6f 72 64 20 (get-keyword
08f0: 23 3a 6c 69 73 74 2d 61 72 67 75 6d 65 6e 74 73 #:list-arguments
0900: 3f 20 61 72 67 73 20 28 63 6f 6e 73 74 61 6e 74 ? args (constant
0910: 6c 79 20 23 66 29 29 29 0a 09 20 20 20 20 28 63 ly #f))).. (c
0920: 68 61 72 2d 6e 6f 72 6d 61 6c 3f 0a 09 20 20 20 har-normal?..
0930: 20 20 28 63 75 74 65 20 63 68 61 72 2d 73 65 74 (cute char-set
0940: 2d 63 6f 6e 74 61 69 6e 73 3f 0a 09 09 20 20 20 -contains?...
0950: 28 63 68 61 72 2d 73 65 74 2d 63 6f 6d 70 6c 65 (char-set-comple
0960: 6d 65 6e 74 0a 09 09 20 20 20 20 28 63 68 61 72 ment... (char
0970: 2d 73 65 74 20 63 6f 6d 6d 61 6e 64 2d 63 68 61 -set command-cha
0980: 72 20 23 5c 7b 20 23 5c 7d 20 23 5c 72 65 74 75 r #\{ #\} #\retu
0990: 72 6e 20 23 5c 6e 65 77 6c 69 6e 65 29 29 0a 09 rn #\newline))..
09a0: 09 20 20 20 3c 3e 29 29 0a 09 20 20 20 20 28 63 . <>)).. (c
09b0: 68 61 72 2d 67 72 6f 75 70 3f 0a 09 20 20 20 20 har-group?..
09c0: 20 28 63 75 74 65 20 63 68 61 72 2d 73 65 74 2d (cute char-set-
09d0: 63 6f 6e 74 61 69 6e 73 3f 0a 09 09 20 20 20 28 contains?... (
09e0: 63 68 61 72 2d 73 65 74 20 23 5c 5b 20 23 5c 7b char-set #\[ #\{
09f0: 29 0a 09 09 20 20 20 3c 3e 29 29 0a 09 20 20 20 )... <>))..
0a00: 20 28 73 6b 69 70 2d 77 68 69 74 65 73 70 61 63 (skip-whitespac
0a10: 65 0a 09 20 20 20 20 20 28 6c 61 6d 62 64 61 20 e.. (lambda
0a20: 28 70 6f 72 74 29 0a 09 20 20 20 20 20 20 20 28 (port).. (
0a30: 77 68 65 6e 20 28 63 68 61 72 2d 77 68 69 74 65 when (char-white
0a40: 73 70 61 63 65 3f 20 28 70 65 65 6b 2d 63 68 61 space? (peek-cha
0a50: 72 20 70 6f 72 74 29 29 0a 09 09 20 28 72 65 61 r port))... (rea
0a60: 64 2d 63 68 61 72 20 70 6f 72 74 29 0a 09 09 20 d-char port)...
0a70: 28 73 6b 69 70 2d 77 68 69 74 65 73 70 61 63 65 (skip-whitespace
0a80: 20 70 6f 72 74 29 29 29 29 0a 09 20 20 20 20 28 port)))).. (
0a90: 72 65 61 64 2d 77 68 69 74 65 73 70 61 63 65 0a read-whitespace.
0aa0: 09 20 20 20 20 20 28 69 66 20 63 6f 6e 64 65 6e . (if conden
0ab0: 73 65 2d 77 68 69 74 65 73 70 61 63 65 3f 0a 09 se-whitespace?..
0ac0: 09 20 28 6c 61 6d 62 64 61 20 28 70 6f 72 74 29 . (lambda (port)
0ad0: 0a 09 09 20 20 20 28 73 6b 69 70 2d 77 68 69 74 ... (skip-whit
0ae0: 65 73 70 61 63 65 20 70 6f 72 74 29 0a 09 09 20 espace port)...
0af0: 20 20 22 20 22 29 0a 09 09 20 28 63 75 74 20 72 " ")... (cut r
0b00: 65 61 64 2d 74 6f 6b 65 6e 20 63 68 61 72 2d 77 ead-token char-w
0b10: 68 69 74 65 73 70 61 63 65 3f 20 3c 3e 29 29 29 hitespace? <>)))
0b20: 0a 09 20 20 20 20 28 72 65 61 64 2d 64 61 74 75 .. (read-datu
0b30: 6d 0a 09 20 20 20 20 20 28 6c 61 6d 62 64 61 20 m.. (lambda
0b40: 28 70 6f 72 74 29 0a 09 20 20 20 20 20 20 20 28 (port).. (
0b50: 70 61 72 61 6d 65 74 65 72 69 7a 65 20 28 28 63 parameterize ((c
0b60: 75 72 72 65 6e 74 2d 72 65 61 64 2d 74 61 62 6c urrent-read-tabl
0b70: 65 20 64 61 74 75 6d 2d 72 65 61 64 2d 74 61 62 e datum-read-tab
0b80: 6c 65 29 29 0a 09 09 20 28 72 65 61 64 20 70 6f le))... (read po
0b90: 72 74 29 29 29 29 0a 09 20 20 20 20 28 72 65 61 rt)))).. (rea
0ba0: 64 2d 61 74 2d 65 78 70 0a 09 20 20 20 20 20 28 d-at-exp.. (
0bb0: 6c 61 6d 62 64 61 20 28 70 6f 72 74 29 0a 09 20 lambda (port)..
0bc0: 20 20 20 20 20 20 28 73 6b 69 70 2d 77 68 69 74 (skip-whit
0bd0: 65 73 70 61 63 65 20 70 6f 72 74 29 0a 09 20 20 espace port)..
0be0: 20 20 20 20 20 28 6c 65 74 20 28 28 63 68 61 72 (let ((char
0bf0: 20 28 70 65 65 6b 2d 63 68 61 72 20 70 6f 72 74 (peek-char port
0c00: 29 29 29 0a 09 09 20 28 63 6f 6e 64 0a 09 09 20 )))... (cond...
0c10: 20 28 28 65 6f 66 2d 6f 62 6a 65 63 74 3f 20 63 ((eof-object? c
0c20: 68 61 72 29 0a 09 09 20 20 20 28 72 65 61 64 2d har)... (read-
0c30: 63 68 61 72 20 70 6f 72 74 29 29 0a 09 09 20 20 char port))...
0c40: 28 65 6c 73 65 0a 09 09 20 20 20 28 77 68 65 6e (else... (when
0c50: 20 28 65 71 76 3f 20 63 68 61 72 20 63 6f 6d 6d (eqv? char comm
0c60: 61 6e 64 2d 63 68 61 72 29 0a 09 09 20 20 20 20 and-char)...
0c70: 20 28 72 65 61 64 2d 63 68 61 72 20 70 6f 72 74 (read-char port
0c80: 29 29 0a 09 09 20 20 20 28 6c 65 74 2a 20 28 28 ))... (let* ((
0c90: 68 65 61 64 20 28 61 6e 64 20 28 6e 6f 74 20 28 head (and (not (
0ca0: 63 68 61 72 2d 67 72 6f 75 70 3f 20 28 70 65 65 char-group? (pee
0cb0: 6b 2d 63 68 61 72 20 70 6f 72 74 29 29 29 0a 09 k-char port)))..
0cc0: 09 09 09 20 20 20 20 20 28 72 65 61 64 2d 64 61 ... (read-da
0cd0: 74 75 6d 20 70 6f 72 74 29 29 29 0a 09 09 09 20 tum port)))....
0ce0: 20 28 61 72 67 73 20 28 61 6e 64 20 28 65 71 76 (args (and (eqv
0cf0: 3f 20 28 70 65 65 6b 2d 63 68 61 72 20 70 6f 72 ? (peek-char por
0d00: 74 29 20 23 5c 5b 29 0a 09 09 09 09 20 20 20 20 t) #\[).....
0d10: 20 28 72 65 61 64 2d 64 61 74 75 6d 20 70 6f 72 (read-datum por
0d20: 74 29 29 29 0a 09 09 09 20 20 28 62 6f 64 79 20 t))).... (body
0d30: 28 61 6e 64 20 28 65 71 76 3f 20 28 70 65 65 6b (and (eqv? (peek
0d40: 2d 63 68 61 72 20 70 6f 72 74 29 20 23 5c 7b 29 -char port) #\{)
0d50: 0a 09 09 09 09 20 20 20 20 20 28 72 65 61 64 2d ..... (read-
0d60: 69 6e 73 69 64 65 2d 61 74 2d 65 78 70 20 27 73 inside-at-exp 's
0d70: 6b 69 70 20 70 6f 72 74 29 29 29 29 0a 09 09 20 kip port))))...
0d80: 20 20 20 20 28 69 66 20 28 6f 72 20 61 72 67 73 (if (or args
0d90: 20 62 6f 64 79 29 0a 09 09 09 20 28 61 70 70 65 body).... (appe
0da0: 6e 64 21 0a 09 09 09 20 20 28 63 6f 6e 64 0a 09 nd!.... (cond..
0db0: 09 09 20 20 20 28 68 65 61 64 20 3d 3e 20 6c 69 .. (head => li
0dc0: 73 74 29 0a 09 09 09 20 20 20 28 65 6c 73 65 20 st).... (else
0dd0: 27 28 29 29 29 0a 09 09 09 20 20 28 63 6f 6e 64 '())).... (cond
0de0: 0a 09 09 09 20 20 20 28 28 61 6e 64 20 6c 69 73 .... ((and lis
0df0: 74 2d 61 72 67 75 6d 65 6e 74 73 3f 20 61 72 67 t-arguments? arg
0e00: 73 29 20 3d 3e 20 6c 69 73 74 29 0a 09 09 09 20 s) => list)....
0e10: 20 20 28 65 6c 73 65 20 28 6f 72 20 61 72 67 73 (else (or args
0e20: 20 27 28 29 29 29 29 0a 09 09 09 20 20 28 6f 72 '()))).... (or
0e30: 20 62 6f 64 79 20 27 28 29 29 29 0a 09 09 09 20 body '()))....
0e40: 68 65 61 64 29 29 29 29 29 29 29 0a 09 20 20 20 head)))))))..
0e50: 20 28 72 65 61 64 2d 69 6e 73 69 64 65 2d 61 74 (read-inside-at
0e60: 2d 65 78 70 0a 09 20 20 20 20 20 28 6c 61 6d 62 -exp.. (lamb
0e70: 64 61 20 28 62 72 61 63 65 2d 6d 6f 64 65 20 70 da (brace-mode p
0e80: 6f 72 74 29 0a 09 20 20 20 20 20 20 20 28 61 70 ort).. (ap
0e90: 70 65 6e 64 21 0a 09 09 28 6c 65 74 20 28 28 68 pend!...(let ((h
0ea0: 65 61 64 0a 09 09 20 20 20 20 20 20 20 28 63 61 ead... (ca
0eb0: 73 65 20 62 72 61 63 65 2d 6d 6f 64 65 0a 09 09 se brace-mode...
0ec0: 09 20 28 28 6e 6f 6e 65 29 0a 09 09 09 20 20 27 . ((none).... '
0ed0: 28 29 29 0a 09 09 09 20 28 28 73 6b 69 70 29 0a ()).... ((skip).
0ee0: 09 09 09 20 20 28 61 6e 64 20 28 65 71 76 3f 20 ... (and (eqv?
0ef0: 28 70 65 65 6b 2d 63 68 61 72 20 70 6f 72 74 29 (peek-char port)
0f00: 20 23 5c 7b 29 0a 09 09 09 20 20 20 20 20 20 20 #\{)....
0f10: 28 62 65 67 69 6e 20 28 72 65 61 64 2d 63 68 61 (begin (read-cha
0f20: 72 20 70 6f 72 74 29 20 27 28 29 29 29 29 0a 09 r port) '())))..
0f30: 09 09 20 28 65 6c 73 65 0a 09 09 09 20 20 28 61 .. (else.... (a
0f40: 6e 64 20 28 65 71 76 3f 20 28 70 65 65 6b 2d 63 nd (eqv? (peek-c
0f50: 68 61 72 20 70 6f 72 74 29 20 23 5c 7b 29 0a 09 har port) #\{)..
0f60: 09 09 20 20 20 20 20 20 20 28 6c 69 73 74 20 28 .. (list (
0f70: 73 74 72 69 6e 67 20 28 72 65 61 64 2d 63 68 61 string (read-cha
0f80: 72 20 70 6f 72 74 29 29 29 29 29 29 29 29 0a 09 r port))))))))..
0f90: 09 20 20 28 69 66 20 68 65 61 64 0a 09 09 20 20 . (if head...
0fa0: 20 20 20 20 28 62 65 67 69 6e 0a 09 09 09 28 77 (begin....(w
0fb0: 68 65 6e 20 74 72 69 6d 2d 77 68 69 74 65 73 70 hen trim-whitesp
0fc0: 61 63 65 3f 20 28 73 6b 69 70 2d 77 68 69 74 65 ace? (skip-white
0fd0: 73 70 61 63 65 20 70 6f 72 74 29 29 0a 09 09 09 space port))....
0fe0: 68 65 61 64 29 0a 09 09 20 20 20 20 20 20 28 73 head)... (s
0ff0: 79 6e 74 61 78 2d 65 72 72 6f 72 0a 09 09 20 20 yntax-error...
1000: 20 20 20 20 20 27 72 65 61 64 2d 69 6e 73 69 64 'read-insid
1010: 65 2d 61 74 2d 65 78 70 20 22 65 78 70 65 63 74 e-at-exp "expect
1020: 65 64 20 40 2d 65 78 70 72 65 73 73 69 6f 6e 20 ed @-expression
1030: 62 6f 64 79 2c 20 66 6f 75 6e 64 22 0a 09 09 20 body, found"...
1040: 20 20 20 20 20 20 28 70 65 65 6b 2d 63 68 61 72 (peek-char
1050: 20 70 6f 72 74 29 29 29 29 0a 09 09 28 6c 65 74 port))))...(let
1060: 20 6d 6f 72 65 20 28 29 0a 09 09 20 20 28 6c 65 more ()... (le
1070: 74 20 28 28 63 68 61 72 20 28 70 65 65 6b 2d 63 t ((char (peek-c
1080: 68 61 72 20 70 6f 72 74 29 29 29 0a 09 09 20 20 har port)))...
1090: 20 20 28 63 6f 6e 64 0a 09 09 20 20 20 20 20 28 (cond... (
10a0: 28 65 71 76 3f 20 63 68 61 72 20 23 5c 7b 29 0a (eqv? char #\{).
10b0: 09 09 20 20 20 20 20 20 28 63 61 73 65 20 62 72 .. (case br
10c0: 61 63 65 2d 6d 6f 64 65 0a 09 09 09 28 28 6e 6f ace-mode....((no
10d0: 6e 65 29 0a 09 09 09 20 28 63 6f 6e 73 20 28 73 ne).... (cons (s
10e0: 74 72 69 6e 67 20 28 72 65 61 64 2d 63 68 61 72 tring (read-char
10f0: 20 70 6f 72 74 29 29 20 28 6d 6f 72 65 29 29 29 port)) (more)))
1100: 0a 09 09 09 28 65 6c 73 65 0a 09 09 09 20 28 61 ....(else.... (a
1110: 70 70 65 6e 64 21 20 28 72 65 61 64 2d 69 6e 73 ppend! (read-ins
1120: 69 64 65 2d 61 74 2d 65 78 70 20 27 6b 65 65 70 ide-at-exp 'keep
1130: 20 70 6f 72 74 29 20 28 6d 6f 72 65 29 29 29 29 port) (more))))
1140: 29 0a 09 09 20 20 20 20 20 28 28 65 71 76 3f 20 )... ((eqv?
1150: 63 68 61 72 20 23 5c 7d 29 0a 09 09 20 20 20 20 char #\})...
1160: 20 20 28 63 61 73 65 20 62 72 61 63 65 2d 6d 6f (case brace-mo
1170: 64 65 0a 09 09 09 28 28 6e 6f 6e 65 29 0a 09 09 de....((none)...
1180: 09 20 28 63 6f 6e 73 20 28 73 74 72 69 6e 67 20 . (cons (string
1190: 28 72 65 61 64 2d 63 68 61 72 20 70 6f 72 74 29 (read-char port)
11a0: 29 20 28 6d 6f 72 65 29 29 29 0a 09 09 09 28 28 ) (more)))....((
11b0: 73 6b 69 70 29 0a 09 09 09 20 28 72 65 61 64 2d skip).... (read-
11c0: 63 68 61 72 20 70 6f 72 74 29 0a 09 09 09 20 27 char port).... '
11d0: 28 29 29 0a 09 09 09 28 65 6c 73 65 0a 09 09 09 ())....(else....
11e0: 20 28 6c 69 73 74 20 28 73 74 72 69 6e 67 20 28 (list (string (
11f0: 72 65 61 64 2d 63 68 61 72 20 70 6f 72 74 29 29 read-char port))
1200: 29 29 29 29 0a 09 09 20 20 20 20 20 28 28 65 6f ))))... ((eo
1210: 66 2d 6f 62 6a 65 63 74 3f 20 63 68 61 72 29 0a f-object? char).
1220: 09 09 20 20 20 20 20 20 28 63 61 73 65 20 62 72 .. (case br
1230: 61 63 65 2d 6d 6f 64 65 0a 09 09 09 28 28 6e 6f ace-mode....((no
1240: 6e 65 29 0a 09 09 09 20 28 72 65 61 64 2d 63 68 ne).... (read-ch
1250: 61 72 20 70 6f 72 74 29 0a 09 09 09 20 27 28 29 ar port).... '()
1260: 29 0a 09 09 09 28 65 6c 73 65 0a 09 09 09 20 28 )....(else.... (
1270: 73 79 6e 74 61 78 2d 65 72 72 6f 72 0a 09 09 09 syntax-error....
1280: 20 20 27 72 65 61 64 2d 69 6e 73 69 64 65 2d 61 'read-inside-a
1290: 74 2d 65 78 70 20 22 40 2d 65 78 70 72 65 73 73 t-exp "@-express
12a0: 69 6f 6e 20 62 6f 64 79 20 6e 6f 74 20 63 6c 6f ion body not clo
12b0: 73 65 64 22 29 29 29 29 0a 09 09 20 20 20 20 20 sed"))))...
12c0: 28 28 65 71 76 3f 20 63 68 61 72 20 63 6f 6d 6d ((eqv? char comm
12d0: 61 6e 64 2d 63 68 61 72 29 0a 09 09 20 20 20 20 and-char)...
12e0: 20 20 28 63 6f 6e 73 20 28 72 65 61 64 2d 61 74 (cons (read-at
12f0: 2d 65 78 70 20 70 6f 72 74 29 20 28 6d 6f 72 65 -exp port) (more
1300: 29 29 29 0a 09 09 20 20 20 20 20 28 28 63 68 61 )))... ((cha
1310: 72 2d 77 68 69 74 65 73 70 61 63 65 3f 20 63 68 r-whitespace? ch
1320: 61 72 29 0a 09 09 20 20 20 20 20 20 28 6c 65 74 ar)... (let
1330: 2a 20 28 28 68 65 61 64 20 28 72 65 61 64 2d 77 * ((head (read-w
1340: 68 69 74 65 73 70 61 63 65 20 70 6f 72 74 29 29 hitespace port))
1350: 0a 09 09 09 20 20 20 20 20 28 74 61 69 6c 20 28 .... (tail (
1360: 6d 6f 72 65 29 29 29 0a 09 09 09 28 69 66 20 28 more)))....(if (
1370: 6f 72 20 28 70 61 69 72 3f 20 74 61 69 6c 29 20 or (pair? tail)
1380: 28 6e 6f 74 20 74 72 69 6d 2d 77 68 69 74 65 73 (not trim-whites
1390: 70 61 63 65 3f 29 29 0a 09 09 09 20 20 20 20 28 pace?)).... (
13a0: 63 6f 6e 73 20 68 65 61 64 20 74 61 69 6c 29 0a cons head tail).
13b0: 09 09 09 20 20 20 20 74 61 69 6c 29 29 29 0a 09 ... tail)))..
13c0: 09 20 20 20 20 20 28 65 6c 73 65 0a 09 09 20 20 . (else...
13d0: 20 20 20 20 28 63 6f 6e 73 20 28 72 65 61 64 2d (cons (read-
13e0: 74 6f 6b 65 6e 20 63 68 61 72 2d 6e 6f 72 6d 61 token char-norma
13f0: 6c 3f 20 70 6f 72 74 29 20 28 6d 6f 72 65 29 29 l? port) (more))
1400: 29 29 29 29 29 29 29 0a 09 20 20 20 20 28 72 65 ))))))).. (re
1410: 61 64 2d 74 61 62 6c 65 0a 09 20 20 20 20 20 28 ad-table.. (
1420: 67 65 74 2d 6b 65 79 77 6f 72 64 20 23 3a 72 65 get-keyword #:re
1430: 61 64 2d 74 61 62 6c 65 20 61 72 67 73 20 63 75 ad-table args cu
1440: 72 72 65 6e 74 2d 72 65 61 64 2d 74 61 62 6c 65 rrent-read-table
1450: 29 29 0a 09 20 20 20 20 28 61 74 2d 72 65 61 64 )).. (at-read
1460: 2d 74 61 62 6c 65 0a 09 20 20 20 20 20 28 70 61 -table.. (pa
1470: 72 61 6d 65 74 65 72 69 7a 65 20 28 28 63 75 72 rameterize ((cur
1480: 72 65 6e 74 2d 72 65 61 64 2d 74 61 62 6c 65 20 rent-read-table
1490: 28 63 6f 70 79 2d 72 65 61 64 2d 74 61 62 6c 65 (copy-read-table
14a0: 20 72 65 61 64 2d 74 61 62 6c 65 29 29 29 0a 09 read-table)))..
14b0: 20 20 20 20 20 20 20 28 73 65 74 2d 72 65 61 64 (set-read
14c0: 2d 73 79 6e 74 61 78 21 20 63 6f 6d 6d 61 6e 64 -syntax! command
14d0: 2d 63 68 61 72 20 72 65 61 64 2d 61 74 2d 65 78 -char read-at-ex
14e0: 70 29 0a 09 20 20 20 20 20 20 20 28 63 75 72 72 p).. (curr
14f0: 65 6e 74 2d 72 65 61 64 2d 74 61 62 6c 65 29 29 ent-read-table))
1500: 29 0a 09 20 20 20 20 28 64 61 74 75 6d 2d 72 65 ).. (datum-re
1510: 61 64 2d 74 61 62 6c 65 0a 09 20 20 20 20 20 28 ad-table.. (
1520: 6c 65 74 20 28 28 73 70 65 63 20 28 67 65 74 2d let ((spec (get-
1530: 6b 65 79 77 6f 72 64 20 23 3a 64 61 74 75 6d 2d keyword #:datum-
1540: 72 65 61 64 2d 74 61 62 6c 65 20 61 72 67 73 20 read-table args
1550: 28 63 6f 6e 73 74 61 6e 74 6c 79 20 23 74 29 29 (constantly #t))
1560: 29 29 0a 09 20 20 20 20 20 20 20 28 63 6f 6e 64 )).. (cond
1570: 0a 09 09 28 28 70 72 6f 63 65 64 75 72 65 3f 20 ...((procedure?
1580: 73 70 65 63 29 0a 09 09 20 28 73 70 65 63 20 61 spec)... (spec a
1590: 74 2d 72 65 61 64 2d 74 61 62 6c 65 29 29 0a 09 t-read-table))..
15a0: 09 28 73 70 65 63 0a 09 09 20 61 74 2d 72 65 61 .(spec... at-rea
15b0: 64 2d 74 61 62 6c 65 29 0a 09 09 28 65 6c 73 65 d-table)...(else
15c0: 0a 09 09 20 72 65 61 64 2d 74 61 62 6c 65 29 29 ... read-table))
15d0: 29 29 29 0a 20 20 20 20 28 76 61 6c 75 65 73 0a ))). (values.
15e0: 20 20 20 20 20 28 69 66 20 28 67 65 74 2d 6b 65 (if (get-ke
15f0: 79 77 6f 72 64 20 23 3a 69 6e 73 69 64 65 3f 20 yword #:inside?
1600: 61 72 67 73 29 0a 09 20 28 6c 61 6d 62 64 61 20 args).. (lambda
1610: 28 23 21 6f 70 74 69 6f 6e 61 6c 20 28 70 6f 72 (#!optional (por
1620: 74 20 28 63 75 72 72 65 6e 74 2d 69 6e 70 75 74 t (current-input
1630: 2d 70 6f 72 74 29 29 29 0a 09 20 20 20 28 72 65 -port))).. (re
1640: 61 64 2d 69 6e 73 69 64 65 2d 61 74 2d 65 78 70 ad-inside-at-exp
1650: 20 27 6e 6f 6e 65 20 70 6f 72 74 29 29 0a 09 20 'none port))..
1660: 28 6c 61 6d 62 64 61 20 28 23 21 6f 70 74 69 6f (lambda (#!optio
1670: 6e 61 6c 20 28 70 6f 72 74 20 28 63 75 72 72 65 nal (port (curre
1680: 6e 74 2d 69 6e 70 75 74 2d 70 6f 72 74 29 29 29 nt-input-port)))
1690: 0a 09 20 20 20 28 72 65 61 64 2d 61 74 2d 65 78 .. (read-at-ex
16a0: 70 20 70 6f 72 74 29 29 29 0a 20 20 20 20 20 61 p port))). a
16b0: 74 2d 72 65 61 64 2d 74 61 62 6c 65 29 29 29 0a t-read-table))).
16c0: 0a 28 64 65 66 69 6e 65 20 28 6d 61 6b 65 2d 61 .(define (make-a
16d0: 74 2d 72 65 61 64 65 72 20 2e 20 61 72 67 73 29 t-reader . args)
16e0: 0a 20 20 28 6e 74 68 2d 76 61 6c 75 65 20 30 20 . (nth-value 0
16f0: 28 6d 61 6b 65 2d 61 74 2d 72 65 61 64 65 72 2b (make-at-reader+
1700: 74 61 62 6c 65 20 61 72 67 73 29 29 29 0a 0a 28 table args)))..(
1710: 64 65 66 69 6e 65 20 28 6d 61 6b 65 2d 61 74 2d define (make-at-
1720: 72 65 61 64 2d 74 61 62 6c 65 20 2e 20 61 72 67 read-table . arg
1730: 73 29 0a 20 20 28 6e 74 68 2d 76 61 6c 75 65 20 s). (nth-value
1740: 31 20 28 6d 61 6b 65 2d 61 74 2d 72 65 61 64 65 1 (make-at-reade
1750: 72 2b 74 61 62 6c 65 20 61 72 67 73 29 29 29 0a r+table args))).
1760: 0a 28 64 65 66 69 6e 65 20 28 75 73 65 2d 61 74 .(define (use-at
1770: 2d 72 65 61 64 2d 74 61 62 6c 65 20 2e 20 61 72 -read-table . ar
1780: 67 73 29 0a 20 20 28 63 75 72 72 65 6e 74 2d 72 gs). (current-r
1790: 65 61 64 2d 74 61 62 6c 65 20 28 6e 74 68 2d 76 ead-table (nth-v
17a0: 61 6c 75 65 20 31 20 28 6d 61 6b 65 2d 61 74 2d alue 1 (make-at-
17b0: 72 65 61 64 65 72 2b 74 61 62 6c 65 20 61 72 67 reader+table arg
17c0: 73 29 29 29 29 0a 0a 3b 3b 3b 20 55 52 49 20 65 s))))..;;; URI e
17d0: 6e 63 6f 64 69 6e 67 0a 0a 28 64 65 66 69 6e 65 ncoding..(define
17e0: 20 75 72 69 2d 65 6e 63 6f 64 65 0a 20 20 28 6c uri-encode. (l
17f0: 65 74 20 28 28 70 72 6f 62 6c 65 6d 61 74 69 63 et ((problematic
1800: 2d 72 78 20 28 69 72 72 65 67 65 78 20 27 28 7e -rx (irregex '(~
1810: 20 28 6f 72 20 61 6c 70 68 61 6e 75 6d 65 72 69 (or alphanumeri
1820: 63 20 22 2d 2e 5f 7e 22 29 29 29 29 29 0a 20 20 c "-._~"))))).
1830: 20 20 28 6c 61 6d 62 64 61 20 28 73 29 0a 20 20 (lambda (s).
1840: 20 20 20 20 28 69 72 72 65 67 65 78 2d 72 65 70 (irregex-rep
1850: 6c 61 63 65 2f 61 6c 6c 0a 20 20 20 20 20 20 20 lace/all.
1860: 70 72 6f 62 6c 65 6d 61 74 69 63 2d 72 78 20 73 problematic-rx s
1870: 0a 20 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 . (lambda
1880: 28 6d 29 0a 09 20 28 73 74 72 69 6e 67 2d 61 70 (m).. (string-ap
1890: 70 65 6e 64 0a 09 20 20 22 25 22 0a 09 20 20 28 pend.. "%".. (
18a0: 73 74 72 69 6e 67 2d 70 61 64 0a 09 20 20 20 28 string-pad.. (
18b0: 6e 75 6d 62 65 72 2d 3e 73 74 72 69 6e 67 0a 09 number->string..
18c0: 20 20 20 20 28 63 68 61 72 2d 3e 69 6e 74 65 67 (char->integ
18d0: 65 72 20 28 73 74 72 69 6e 67 2d 72 65 66 20 28 er (string-ref (
18e0: 69 72 72 65 67 65 78 2d 6d 61 74 63 68 2d 73 75 irregex-match-su
18f0: 62 73 74 72 69 6e 67 20 6d 29 20 30 29 29 20 31 bstring m) 0)) 1
1900: 36 29 0a 09 20 20 20 32 20 23 5c 30 29 29 29 29 6).. 2 #\0))))
1910: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 75 72 69 )))..(define uri
1920: 2d 64 65 63 6f 64 65 0a 20 20 28 6c 65 74 20 28 -decode. (let (
1930: 28 65 73 63 61 70 65 2d 72 78 20 28 69 72 72 65 (escape-rx (irre
1940: 67 65 78 20 27 28 6f 72 20 23 5c 2b 20 28 3a 20 gex '(or #\+ (:
1950: 23 5c 25 20 28 24 20 28 3d 20 32 20 68 65 78 2d #\% ($ (= 2 hex-
1960: 64 69 67 69 74 29 29 29 29 29 29 29 0a 20 20 20 digit))))))).
1970: 20 28 6c 61 6d 62 64 61 20 28 73 29 0a 20 20 20 (lambda (s).
1980: 20 20 20 28 69 72 72 65 67 65 78 2d 72 65 70 6c (irregex-repl
1990: 61 63 65 2f 61 6c 6c 0a 20 20 20 20 20 20 20 65 ace/all. e
19a0: 73 63 61 70 65 2d 72 78 20 73 0a 20 20 20 20 20 scape-rx s.
19b0: 20 20 28 6c 61 6d 62 64 61 20 28 6d 29 0a 09 20 (lambda (m)..
19c0: 28 63 61 73 65 20 28 73 74 72 69 6e 67 2d 72 65 (case (string-re
19d0: 66 20 73 20 28 69 72 72 65 67 65 78 2d 6d 61 74 f s (irregex-mat
19e0: 63 68 2d 73 74 61 72 74 2d 69 6e 64 65 78 20 6d ch-start-index m
19f0: 29 29 0a 09 20 20 20 28 28 23 5c 2b 29 0a 09 20 )).. ((#\+)..
1a00: 20 20 20 22 20 22 29 0a 09 20 20 20 28 28 23 5c " ").. ((#\
1a10: 25 29 20 0a 09 20 20 20 20 28 73 74 72 69 6e 67 %) .. (string
1a20: 0a 09 20 20 20 20 20 28 69 6e 74 65 67 65 72 2d .. (integer-
1a30: 3e 63 68 61 72 0a 09 20 20 20 20 20 20 28 73 74 >char.. (st
1a40: 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 28 69 72 ring->number (ir
1a50: 72 65 67 65 78 2d 6d 61 74 63 68 2d 73 75 62 73 regex-match-subs
1a60: 74 72 69 6e 67 20 6d 20 31 29 20 31 36 29 29 29 tring m 1) 16)))
1a70: 29 29 29 29 29 29 29 0a 0a 3b 3b 3b 20 42 61 73 )))))))..;;; Bas
1a80: 65 36 34 55 52 49 20 65 6e 63 6f 64 69 6e 67 0a e64URI encoding.
1a90: 0a 28 64 65 66 69 6e 65 20 62 61 73 65 36 34 2d .(define base64-
1aa0: 61 6c 70 68 61 62 65 74 0a 20 20 22 41 42 43 44 alphabet. "ABCD
1ab0: 45 46 47 48 49 4a 4b 4c 4d 4e 4f 50 51 52 53 54 EFGHIJKLMNOPQRST
1ac0: 55 56 57 58 59 5a 61 62 63 64 65 66 67 68 69 6a UVWXYZabcdefghij
1ad0: 6b 6c 6d 6e 6f 70 71 72 73 74 75 76 77 78 79 7a klmnopqrstuvwxyz
1ae0: 30 31 32 33 34 35 36 37 38 39 2b 2f 22 29 0a 28 0123456789+/").(
1af0: 64 65 66 69 6e 65 20 62 61 73 65 36 34 2d 61 6c define base64-al
1b00: 70 68 61 62 65 74 2f 75 72 69 0a 20 20 22 41 42 phabet/uri. "AB
1b10: 43 44 45 46 47 48 49 4a 4b 4c 4d 4e 4f 50 51 52 CDEFGHIJKLMNOPQR
1b20: 53 54 55 56 57 58 59 5a 61 62 63 64 65 66 67 68 STUVWXYZabcdefgh
1b30: 69 6a 6b 6c 6d 6e 6f 70 71 72 73 74 75 76 77 78 ijklmnopqrstuvwx
1b40: 79 7a 30 31 32 33 34 35 36 37 38 39 2d 5f 22 29 yz0123456789-_")
1b50: 0a 0a 28 64 65 66 69 6e 65 20 28 62 61 73 65 36 ..(define (base6
1b60: 34 2d 65 6e 63 6f 64 65 20 73 20 23 21 6f 70 74 4-encode s #!opt
1b70: 69 6f 6e 61 6c 20 75 72 69 2d 73 61 66 65 3f 29 ional uri-safe?)
1b80: 0a 20 20 28 6c 65 74 2a 20 28 28 61 6c 70 68 61 . (let* ((alpha
1b90: 62 65 74 20 28 69 66 20 75 72 69 2d 73 61 66 65 bet (if uri-safe
1ba0: 3f 20 62 61 73 65 36 34 2d 61 6c 70 68 61 62 65 ? base64-alphabe
1bb0: 74 2f 75 72 69 20 62 61 73 65 36 34 2d 61 6c 70 t/uri base64-alp
1bc0: 68 61 62 65 74 29 29 0a 09 20 28 6e 20 28 73 74 habet)).. (n (st
1bd0: 72 69 6e 67 2d 6c 65 6e 67 74 68 20 73 29 29 0a ring-length s)).
1be0: 09 20 28 65 20 28 6d 61 6b 65 2d 73 74 72 69 6e . (e (make-strin
1bf0: 67 20 28 69 6e 65 78 61 63 74 2d 3e 65 78 61 63 g (inexact->exac
1c00: 74 20 28 63 65 69 6c 69 6e 67 20 28 2a 20 34 2f t (ceiling (* 4/
1c10: 33 20 6e 29 29 29 29 29 29 0a 20 20 20 20 28 64 3 n)))))). (d
1c20: 6f 20 28 28 69 73 20 30 20 28 66 78 2b 20 69 73 o ((is 0 (fx+ is
1c30: 20 33 29 29 20 28 69 65 20 30 20 28 66 78 2b 20 3)) (ie 0 (fx+
1c40: 69 65 20 34 29 29 29 20 28 28 66 78 3e 3d 20 69 ie 4))) ((fx>= i
1c50: 73 20 6e 29 20 65 29 0a 20 20 20 20 20 20 28 6c s n) e). (l
1c60: 65 74 20 28 28 69 20 28 66 78 69 6f 72 0a 09 09 et ((i (fxior...
1c70: 28 66 78 73 68 6c 20 28 63 68 61 72 2d 3e 69 6e (fxshl (char->in
1c80: 74 65 67 65 72 20 28 73 74 72 69 6e 67 2d 72 65 teger (string-re
1c90: 66 20 73 20 69 73 29 29 20 31 36 29 0a 09 09 28 f s is)) 16)...(
1ca0: 69 66 20 28 66 78 3c 20 28 66 78 2b 20 69 73 20 if (fx< (fx+ is
1cb0: 31 29 20 6e 29 0a 09 09 20 20 20 20 28 66 78 69 1) n)... (fxi
1cc0: 6f 72 0a 09 09 20 20 20 20 20 28 66 78 73 68 6c or... (fxshl
1cd0: 20 28 63 68 61 72 2d 3e 69 6e 74 65 67 65 72 20 (char->integer
1ce0: 28 73 74 72 69 6e 67 2d 72 65 66 20 73 20 28 66 (string-ref s (f
1cf0: 78 2b 20 69 73 20 31 29 29 29 20 38 29 0a 09 09 x+ is 1))) 8)...
1d00: 20 20 20 20 20 28 69 66 20 28 66 78 3c 20 28 66 (if (fx< (f
1d10: 78 2b 20 69 73 20 32 29 20 6e 29 0a 09 09 09 20 x+ is 2) n)....
1d20: 28 63 68 61 72 2d 3e 69 6e 74 65 67 65 72 20 28 (char->integer (
1d30: 73 74 72 69 6e 67 2d 72 65 66 20 73 20 28 66 78 string-ref s (fx
1d40: 2b 20 69 73 20 32 29 29 29 0a 09 09 09 20 30 29 + is 2))).... 0)
1d50: 29 0a 09 09 20 20 20 20 30 29 29 29 29 0a 09 28 )... 0))))..(
1d60: 73 74 72 69 6e 67 2d 73 65 74 21 0a 09 20 65 20 string-set!.. e
1d70: 69 65 0a 09 20 28 73 74 72 69 6e 67 2d 72 65 66 ie.. (string-ref
1d80: 20 61 6c 70 68 61 62 65 74 20 28 66 78 61 6e 64 alphabet (fxand
1d90: 20 28 66 78 73 68 72 20 69 20 31 38 29 20 23 62 (fxshr i 18) #b
1da0: 31 31 31 31 31 31 29 29 29 0a 09 28 73 74 72 69 111111)))..(stri
1db0: 6e 67 2d 73 65 74 21 0a 09 20 65 20 28 66 78 2b ng-set!.. e (fx+
1dc0: 20 69 65 20 31 29 0a 09 20 28 73 74 72 69 6e 67 ie 1).. (string
1dd0: 2d 72 65 66 20 61 6c 70 68 61 62 65 74 20 28 66 -ref alphabet (f
1de0: 78 61 6e 64 20 28 66 78 73 68 72 20 69 20 31 32 xand (fxshr i 12
1df0: 29 20 23 62 31 31 31 31 31 31 29 29 29 0a 09 28 ) #b111111)))..(
1e00: 77 68 65 6e 20 28 66 78 3c 20 28 66 78 2b 20 69 when (fx< (fx+ i
1e10: 73 20 31 29 20 6e 29 0a 09 20 20 28 73 74 72 69 s 1) n).. (stri
1e20: 6e 67 2d 73 65 74 21 0a 09 20 20 20 65 20 28 66 ng-set!.. e (f
1e30: 78 2b 20 69 65 20 32 29 0a 09 20 20 20 28 73 74 x+ ie 2).. (st
1e40: 72 69 6e 67 2d 72 65 66 20 61 6c 70 68 61 62 65 ring-ref alphabe
1e50: 74 20 28 66 78 61 6e 64 20 28 66 78 73 68 72 20 t (fxand (fxshr
1e60: 69 20 36 29 20 23 62 31 31 31 31 31 31 29 29 29 i 6) #b111111)))
1e70: 0a 09 20 20 28 77 68 65 6e 20 28 66 78 3c 20 28 .. (when (fx< (
1e80: 66 78 2b 20 69 73 20 32 29 20 6e 29 0a 09 20 20 fx+ is 2) n)..
1e90: 20 20 28 73 74 72 69 6e 67 2d 73 65 74 21 0a 09 (string-set!..
1ea0: 20 20 20 20 20 65 20 28 66 78 2b 20 69 65 20 33 e (fx+ ie 3
1eb0: 29 0a 09 20 20 20 20 20 28 73 74 72 69 6e 67 2d ).. (string-
1ec0: 72 65 66 20 61 6c 70 68 61 62 65 74 20 28 66 78 ref alphabet (fx
1ed0: 61 6e 64 20 69 20 23 62 31 31 31 31 31 31 29 29 and i #b111111))
1ee0: 29 29 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 )))))))..(define
1ef0: 20 62 61 73 65 36 34 2d 64 65 63 6f 64 65 0a 20 base64-decode.
1f00: 20 28 6c 65 74 20 28 28 61 6c 70 68 61 62 65 74 (let ((alphabet
1f10: 2d 72 65 66 0a 09 20 28 6c 65 74 2a 20 28 28 6e -ref.. (let* ((n
1f20: 20 28 73 74 72 69 6e 67 2d 6c 65 6e 67 74 68 20 (string-length
1f30: 62 61 73 65 36 34 2d 61 6c 70 68 61 62 65 74 29 base64-alphabet)
1f40: 29 0a 09 09 28 61 6c 70 68 61 62 65 74 20 28 6d )...(alphabet (m
1f50: 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 20 65 ake-hash-table e
1f60: 71 76 3f 20 65 71 76 3f 2d 68 61 73 68 20 28 66 qv? eqv?-hash (f
1f70: 78 2b 20 6e 20 32 29 29 29 29 0a 09 20 20 20 28 x+ n 2)))).. (
1f80: 64 6f 20 28 28 69 20 30 20 28 66 78 2b 20 69 20 do ((i 0 (fx+ i
1f90: 31 29 29 29 20 28 28 66 78 3e 3d 20 69 20 6e 29 1))) ((fx>= i n)
1fa0: 29 0a 09 20 20 20 20 20 28 68 61 73 68 2d 74 61 ).. (hash-ta
1fb0: 62 6c 65 2d 73 65 74 21 20 61 6c 70 68 61 62 65 ble-set! alphabe
1fc0: 74 20 28 73 74 72 69 6e 67 2d 72 65 66 20 62 61 t (string-ref ba
1fd0: 73 65 36 34 2d 61 6c 70 68 61 62 65 74 20 69 29 se64-alphabet i)
1fe0: 20 69 29 29 0a 09 20 20 20 28 64 6f 20 28 28 69 i)).. (do ((i
1ff0: 20 28 66 78 2d 20 6e 20 32 29 20 28 66 78 2b 20 (fx- n 2) (fx+
2000: 69 20 31 29 29 29 20 28 28 66 78 3e 3d 20 69 20 i 1))) ((fx>= i
2010: 6e 29 29 0a 09 20 20 20 20 20 28 68 61 73 68 2d n)).. (hash-
2020: 74 61 62 6c 65 2d 73 65 74 21 20 61 6c 70 68 61 table-set! alpha
2030: 62 65 74 20 28 73 74 72 69 6e 67 2d 72 65 66 20 bet (string-ref
2040: 62 61 73 65 36 34 2d 61 6c 70 68 61 62 65 74 2f base64-alphabet/
2050: 75 72 69 20 69 29 20 69 29 29 0a 09 20 20 20 28 uri i) i)).. (
2060: 6c 61 6d 62 64 61 20 28 63 68 72 29 0a 09 20 20 lambda (chr)..
2070: 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 (hash-table-r
2080: 65 66 0a 09 20 20 20 20 20 20 61 6c 70 68 61 62 ef.. alphab
2090: 65 74 20 63 68 72 0a 09 20 20 20 20 20 20 28 63 et chr.. (c
20a0: 75 74 20 73 79 6e 74 61 78 2d 65 72 72 6f 72 20 ut syntax-error
20b0: 27 62 61 73 65 36 34 2d 64 65 63 6f 64 65 20 22 'base64-decode "
20c0: 69 6c 6c 65 67 61 6c 20 63 68 61 72 61 63 74 65 illegal characte
20d0: 72 22 20 63 68 72 29 29 29 29 29 29 0a 20 20 20 r" chr)))))).
20e0: 20 28 6c 61 6d 62 64 61 20 28 65 29 0a 20 20 20 (lambda (e).
20f0: 20 20 20 28 6c 65 74 2a 20 28 28 6e 20 28 73 74 (let* ((n (st
2100: 72 69 6e 67 2d 6c 65 6e 67 74 68 20 65 29 29 0a ring-length e)).
2110: 09 20 20 20 20 20 28 73 20 28 6d 61 6b 65 2d 73 . (s (make-s
2120: 74 72 69 6e 67 20 28 69 6e 65 78 61 63 74 2d 3e tring (inexact->
2130: 65 78 61 63 74 20 28 66 6c 6f 6f 72 20 28 2a 20 exact (floor (*
2140: 33 2f 34 20 6e 29 29 29 29 29 29 0a 09 28 64 6f 3/4 n))))))..(do
2150: 20 28 28 69 65 20 30 20 28 66 78 2b 20 69 65 20 ((ie 0 (fx+ ie
2160: 34 29 29 20 28 69 73 20 30 20 28 66 78 2b 20 69 4)) (is 0 (fx+ i
2170: 73 20 33 29 29 29 20 28 28 66 78 3e 3d 20 69 65 s 3))) ((fx>= ie
2180: 20 6e 29 20 73 29 0a 09 20 20 28 6c 65 74 20 28 n) s).. (let (
2190: 28 69 20 28 66 78 69 6f 72 0a 09 09 20 20 20 20 (i (fxior...
21a0: 28 66 78 73 68 6c 0a 09 09 20 20 20 20 20 28 61 (fxshl... (a
21b0: 6c 70 68 61 62 65 74 2d 72 65 66 20 28 73 74 72 lphabet-ref (str
21c0: 69 6e 67 2d 72 65 66 20 65 20 69 65 29 29 20 31 ing-ref e ie)) 1
21d0: 38 29 0a 09 09 20 20 20 20 28 69 66 20 28 66 78 8)... (if (fx
21e0: 3c 20 28 66 78 2b 20 69 65 20 31 29 20 6e 29 0a < (fx+ ie 1) n).
21f0: 09 09 09 28 66 78 69 6f 72 0a 09 09 09 20 28 66 ...(fxior.... (f
2200: 78 73 68 6c 0a 09 09 09 20 20 28 61 6c 70 68 61 xshl.... (alpha
2210: 62 65 74 2d 72 65 66 20 28 73 74 72 69 6e 67 2d bet-ref (string-
2220: 72 65 66 20 65 20 28 66 78 2b 20 69 65 20 31 29 ref e (fx+ ie 1)
2230: 29 29 20 31 32 29 0a 09 09 09 20 28 69 66 20 28 )) 12).... (if (
2240: 66 78 3c 20 28 66 78 2b 20 69 65 20 32 29 20 6e fx< (fx+ ie 2) n
2250: 29 0a 09 09 09 20 20 20 20 20 28 66 78 69 6f 72 ).... (fxior
2260: 0a 09 09 09 20 20 20 20 20 20 28 66 78 73 68 6c .... (fxshl
2270: 0a 09 09 09 20 20 20 20 20 20 20 28 61 6c 70 68 .... (alph
2280: 61 62 65 74 2d 72 65 66 20 28 73 74 72 69 6e 67 abet-ref (string
2290: 2d 72 65 66 20 65 20 28 66 78 2b 20 69 65 20 32 -ref e (fx+ ie 2
22a0: 29 29 29 20 36 29 0a 09 09 09 20 20 20 20 20 20 ))) 6)....
22b0: 28 69 66 20 28 66 78 3c 20 28 66 78 2b 20 69 65 (if (fx< (fx+ ie
22c0: 20 33 29 20 6e 29 0a 09 09 09 09 20 20 28 61 6c 3) n)..... (al
22d0: 70 68 61 62 65 74 2d 72 65 66 20 28 73 74 72 69 phabet-ref (stri
22e0: 6e 67 2d 72 65 66 20 65 20 28 66 78 2b 20 69 65 ng-ref e (fx+ ie
22f0: 20 33 29 29 29 0a 09 09 09 09 20 20 30 29 29 0a 3)))..... 0)).
2300: 09 09 09 20 20 20 20 20 30 29 29 0a 09 09 09 30 ... 0))....0
2310: 29 29 29 29 0a 09 20 20 20 20 28 73 74 72 69 6e )))).. (strin
2320: 67 2d 73 65 74 21 0a 09 20 20 20 20 20 73 20 69 g-set!.. s i
2330: 73 20 28 69 6e 74 65 67 65 72 2d 3e 63 68 61 72 s (integer->char
2340: 20 28 66 78 61 6e 64 20 28 66 78 73 68 72 20 69 (fxand (fxshr i
2350: 20 31 36 29 20 23 78 66 66 29 29 29 0a 09 20 20 16) #xff)))..
2360: 20 20 28 77 68 65 6e 20 28 66 78 3c 20 28 66 78 (when (fx< (fx
2370: 2b 20 69 65 20 32 29 20 6e 29 0a 09 20 20 20 20 + ie 2) n)..
2380: 20 20 28 73 74 72 69 6e 67 2d 73 65 74 21 0a 09 (string-set!..
2390: 20 20 20 20 20 20 20 73 20 28 66 78 2b 20 69 73 s (fx+ is
23a0: 20 31 29 20 28 69 6e 74 65 67 65 72 2d 3e 63 68 1) (integer->ch
23b0: 61 72 20 28 66 78 61 6e 64 20 28 66 78 73 68 72 ar (fxand (fxshr
23c0: 20 69 20 38 29 20 23 78 66 66 29 29 29 0a 09 20 i 8) #xff)))..
23d0: 20 20 20 20 20 28 77 68 65 6e 20 28 66 78 3c 20 (when (fx<
23e0: 28 66 78 2b 20 69 65 20 33 29 20 6e 29 0a 09 09 (fx+ ie 3) n)...
23f0: 28 73 74 72 69 6e 67 2d 73 65 74 21 0a 09 09 20 (string-set!...
2400: 73 20 28 66 78 2b 20 69 73 20 32 29 20 28 69 6e s (fx+ is 2) (in
2410: 74 65 67 65 72 2d 3e 63 68 61 72 20 28 66 78 61 teger->char (fxa
2420: 6e 64 20 69 20 23 78 66 66 29 29 29 29 29 29 29 nd i #xff)))))))
2430: 29 29 29 29 0a 0a 3b 3b 3b 20 48 54 4d 4c 20 6f ))))..;;; HTML o
2440: 75 74 70 75 74 0a 0a 28 64 65 66 69 6e 65 20 77 utput..(define w
2450: 72 69 74 65 2d 68 74 6d 6c 0a 20 20 28 6c 65 74 rite-html. (let
2460: 72 65 63 20 28 28 74 61 67 2d 72 75 6c 65 73 0a rec ((tag-rules.
2470: 09 20 20 20 20 28 61 6c 69 73 74 2d 3e 68 61 73 . (alist->has
2480: 68 2d 74 61 62 6c 65 0a 09 20 20 20 20 20 27 28 h-table.. '(
2490: 28 61 72 65 61 20 2e 20 76 6f 69 64 29 0a 09 20 (area . void)..
24a0: 20 20 20 20 20 20 28 62 61 73 65 20 2e 20 76 6f (base . vo
24b0: 69 64 29 0a 09 20 20 20 20 20 20 20 28 62 72 20 id).. (br
24c0: 2e 20 76 6f 69 64 29 0a 09 20 20 20 20 20 20 20 . void)..
24d0: 28 63 6f 6c 20 2e 20 76 6f 69 64 29 0a 09 20 20 (col . void)..
24e0: 20 20 20 20 20 28 63 6f 6d 6d 61 6e 64 20 2e 20 (command .
24f0: 76 6f 69 64 29 0a 09 20 20 20 20 20 20 20 28 65 void).. (e
2500: 6d 62 65 64 20 2e 20 76 6f 69 64 29 0a 09 20 20 mbed . void)..
2510: 20 20 20 20 20 28 68 72 20 2e 20 76 6f 69 64 29 (hr . void)
2520: 0a 09 20 20 20 20 20 20 20 28 69 6d 67 20 2e 20 .. (img .
2530: 76 6f 69 64 29 0a 09 20 20 20 20 20 20 20 28 69 void).. (i
2540: 6e 70 75 74 20 2e 20 76 6f 69 64 29 0a 09 20 20 nput . void)..
2550: 20 20 20 20 20 28 6b 65 79 67 65 6e 20 2e 20 76 (keygen . v
2560: 6f 69 64 29 0a 09 20 20 20 20 20 20 20 28 6c 69 oid).. (li
2570: 6e 6b 20 2e 20 76 6f 69 64 29 0a 09 20 20 20 20 nk . void)..
2580: 20 20 20 28 6d 65 74 61 20 2e 20 76 6f 69 64 29 (meta . void)
2590: 0a 09 20 20 20 20 20 20 20 28 70 61 72 61 6d 20 .. (param
25a0: 2e 20 76 6f 69 64 29 0a 09 20 20 20 20 20 20 20 . void)..
25b0: 28 73 6f 75 72 63 65 20 2e 20 76 6f 69 64 29 0a (source . void).
25c0: 09 20 20 20 20 20 20 20 28 74 72 61 63 6b 20 2e . (track .
25d0: 20 76 6f 69 64 29 0a 09 20 20 20 20 20 20 20 28 void).. (
25e0: 77 62 72 20 2e 20 76 6f 69 64 29 0a 09 20 20 20 wbr . void)..
25f0: 20 20 20 20 28 73 63 72 69 70 74 20 2e 20 72 61 (script . ra
2600: 77 29 0a 09 20 20 20 20 20 20 20 28 73 74 79 6c w).. (styl
2610: 65 20 2e 20 72 61 77 29 29 0a 09 20 20 20 20 20 e . raw))..
2620: 23 3a 74 65 73 74 20 65 71 3f 20 23 3a 68 61 73 #:test eq? #:has
2630: 68 20 65 71 3f 2d 68 61 73 68 29 29 0a 09 20 20 h eq?-hash))..
2640: 20 28 70 72 6f 62 6c 65 6d 61 74 69 63 2d 72 78 (problematic-rx
2650: 0a 09 20 20 20 20 28 69 72 72 65 67 65 78 20 27 .. (irregex '
2660: 28 22 5c 22 26 3c 3e 22 29 29 29 0a 09 20 20 20 ("\"&<>")))..
2670: 28 68 74 6d 6c 2d 65 73 63 61 70 65 0a 09 20 20 (html-escape..
2680: 20 20 28 6c 61 6d 62 64 61 20 28 73 29 0a 09 20 (lambda (s)..
2690: 20 20 20 20 20 28 69 72 72 65 67 65 78 2d 72 65 (irregex-re
26a0: 70 6c 61 63 65 2f 61 6c 6c 0a 09 20 20 20 20 20 place/all..
26b0: 20 20 70 72 6f 62 6c 65 6d 61 74 69 63 2d 72 78 problematic-rx
26c0: 20 73 0a 09 20 20 20 20 20 20 20 28 6c 61 6d 62 s.. (lamb
26d0: 64 61 20 28 6d 29 0a 09 09 20 28 63 61 73 65 20 da (m)... (case
26e0: 28 73 74 72 69 6e 67 2d 72 65 66 20 28 69 72 72 (string-ref (irr
26f0: 65 67 65 78 2d 6d 61 74 63 68 2d 73 75 62 73 74 egex-match-subst
2700: 72 69 6e 67 20 6d 29 20 30 29 0a 09 09 20 20 20 ring m) 0)...
2710: 28 28 23 5c 22 29 20 22 26 71 75 6f 74 3b 22 29 ((#\") """)
2720: 0a 09 09 20 20 20 28 28 23 5c 26 29 20 22 26 61 ... ((#\&) "&a
2730: 6d 70 3b 22 29 0a 09 09 20 20 20 28 28 23 5c 3c mp;")... ((#\<
2740: 29 20 22 26 6c 74 3b 22 29 0a 09 09 20 20 20 28 ) "<")... (
2750: 28 23 5c 3e 29 20 22 26 67 74 3b 22 29 29 29 29 (#\>) ">"))))
2760: 29 29 0a 09 20 20 20 28 77 72 69 74 65 2d 65 6c )).. (write-el
2770: 65 6d 65 6e 74 0a 09 20 20 20 20 28 6c 61 6d 62 ement.. (lamb
2780: 64 61 20 28 65 6c 74 20 70 6f 72 74 29 0a 09 20 da (elt port)..
2790: 20 20 20 20 20 28 75 6e 6c 65 73 73 20 28 61 6e (unless (an
27a0: 64 20 28 70 61 69 72 3f 20 65 6c 74 29 20 28 73 d (pair? elt) (s
27b0: 79 6d 62 6f 6c 3f 20 28 63 61 72 20 65 6c 74 29 ymbol? (car elt)
27c0: 29 20 28 6c 69 73 74 3f 20 28 63 64 72 20 65 6c ) (list? (cdr el
27d0: 74 29 29 29 0a 09 09 28 65 72 72 6f 72 0a 09 09 t)))...(error...
27e0: 20 27 77 72 69 74 65 2d 68 74 6d 6c 20 22 6e 6f 'write-html "no
27f0: 74 20 61 20 70 72 6f 70 65 72 20 65 6c 65 6d 65 t a proper eleme
2800: 6e 74 22 0a 09 09 20 65 6c 74 29 29 0a 09 20 20 nt"... elt))..
2810: 20 20 20 20 28 6c 65 74 2d 76 61 6c 75 65 73 20 (let-values
2820: 28 28 28 74 61 67 20 61 74 74 72 69 62 75 74 65 (((tag attribute
2830: 73 2b 63 6f 6e 74 65 6e 74 73 29 0a 09 09 09 20 s+contents)....
2840: 20 20 20 28 63 61 72 2b 63 64 72 20 65 6c 74 29 (car+cdr elt)
2850: 29 29 0a 09 09 28 66 70 72 69 6e 74 66 20 70 6f ))...(fprintf po
2860: 72 74 20 22 3c 7e 61 22 20 74 61 67 29 0a 09 09 rt "<~a" tag)...
2870: 28 6c 65 74 2d 76 61 6c 75 65 73 20 28 28 28 72 (let-values (((r
2880: 75 6c 65 29 0a 09 09 09 20 20 20 20 20 20 28 68 ule).... (h
2890: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
28a0: 66 61 75 6c 74 20 74 61 67 2d 72 75 6c 65 73 20 fault tag-rules
28b0: 74 61 67 20 27 6e 6f 72 6d 61 6c 29 29 0a 09 09 tag 'normal))...
28c0: 09 20 20 20 20 20 28 28 61 74 74 72 69 62 75 74 . ((attribut
28d0: 65 73 20 63 6f 6e 74 65 6e 74 73 29 0a 09 09 09 es contents)....
28e0: 20 20 20 20 20 20 28 63 6f 6e 64 0a 09 09 09 20 (cond....
28f0: 20 20 20 20 20 20 28 28 6e 75 6c 6c 3f 20 61 74 ((null? at
2900: 74 72 69 62 75 74 65 73 2b 63 6f 6e 74 65 6e 74 tributes+content
2910: 73 29 0a 09 09 09 09 28 76 61 6c 75 65 73 20 27 s).....(values '
2920: 28 29 20 27 28 29 29 29 0a 09 09 09 20 20 20 20 () '()))....
2930: 20 20 20 28 28 61 6e 64 20 28 6c 69 73 74 3f 20 ((and (list?
2940: 28 63 61 72 20 61 74 74 72 69 62 75 74 65 73 2b (car attributes+
2950: 63 6f 6e 74 65 6e 74 73 29 29 0a 09 09 09 09 20 contents)).....
2960: 20 20 20 20 28 65 76 65 72 79 20 6c 69 73 74 3f (every list?
2970: 20 28 63 61 72 20 61 74 74 72 69 62 75 74 65 73 (car attributes
2980: 2b 63 6f 6e 74 65 6e 74 73 29 29 29 0a 09 09 09 +contents)))....
2990: 09 28 63 61 72 2b 63 64 72 20 61 74 74 72 69 62 .(car+cdr attrib
29a0: 75 74 65 73 2b 63 6f 6e 74 65 6e 74 73 29 29 0a utes+contents)).
29b0: 09 09 09 20 20 20 20 20 20 20 28 65 6c 73 65 0a ... (else.
29c0: 09 09 09 09 28 76 61 6c 75 65 73 20 27 28 29 20 ....(values '()
29d0: 61 74 74 72 69 62 75 74 65 73 2b 63 6f 6e 74 65 attributes+conte
29e0: 6e 74 73 29 29 29 29 29 0a 09 09 20 20 28 66 6f nts)))))... (fo
29f0: 72 2d 65 61 63 68 20 28 63 75 74 20 77 72 69 74 r-each (cut writ
2a00: 65 2d 61 74 74 72 69 62 75 74 65 20 3c 3e 20 70 e-attribute <> p
2a10: 6f 72 74 29 20 61 74 74 72 69 62 75 74 65 73 29 ort) attributes)
2a20: 0a 09 09 20 20 28 64 69 73 70 6c 61 79 20 23 5c ... (display #\
2a30: 3e 20 70 6f 72 74 29 0a 09 09 20 20 28 63 61 73 > port)... (cas
2a40: 65 20 72 75 6c 65 0a 09 09 20 20 20 20 28 28 6e e rule... ((n
2a50: 6f 72 6d 61 6c 29 0a 09 09 20 20 20 20 20 28 66 ormal)... (f
2a60: 6f 72 2d 65 61 63 68 20 28 63 75 74 20 77 72 69 or-each (cut wri
2a70: 74 65 2d 63 6f 6e 74 65 6e 74 20 23 74 20 3c 3e te-content #t <>
2a80: 20 70 6f 72 74 29 20 63 6f 6e 74 65 6e 74 73 29 port) contents)
2a90: 29 0a 09 09 20 20 20 20 28 28 72 61 77 29 0a 09 )... ((raw)..
2aa0: 09 20 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 . (for-each
2ab0: 28 63 75 74 20 77 72 69 74 65 2d 63 6f 6e 74 65 (cut write-conte
2ac0: 6e 74 20 23 66 20 3c 3e 20 70 6f 72 74 29 20 63 nt #f <> port) c
2ad0: 6f 6e 74 65 6e 74 73 29 29 0a 09 09 20 20 20 20 ontents))...
2ae0: 28 28 76 6f 69 64 29 0a 09 09 20 20 20 20 20 28 ((void)... (
2af0: 75 6e 6c 65 73 73 20 28 6e 75 6c 6c 3f 20 63 6f unless (null? co
2b00: 6e 74 65 6e 74 73 29 0a 09 09 20 20 20 20 20 20 ntents)...
2b10: 20 28 65 72 72 6f 72 0a 09 09 09 27 77 72 69 74 (error....'writ
2b20: 65 2d 68 74 6d 6c 20 22 76 6f 69 64 20 65 6c 65 e-html "void ele
2b30: 6d 65 6e 74 73 20 63 61 6e 6e 6f 74 20 68 61 76 ments cannot hav
2b40: 65 20 63 6f 6e 74 65 6e 74 73 22 0a 09 09 09 65 e contents"....e
2b50: 6c 74 29 29 29 29 0a 09 09 20 20 28 63 61 73 65 lt))))... (case
2b60: 20 72 75 6c 65 0a 09 09 20 20 20 20 28 28 6e 6f rule... ((no
2b70: 72 6d 61 6c 20 72 61 77 29 0a 09 09 20 20 20 20 rmal raw)...
2b80: 20 28 66 70 72 69 6e 74 66 20 70 6f 72 74 20 22 (fprintf port "
2b90: 3c 2f 7e 61 3e 22 20 74 61 67 29 29 29 29 29 29 </~a>" tag))))))
2ba0: 29 0a 09 20 20 20 28 77 72 69 74 65 2d 61 74 74 ).. (write-att
2bb0: 72 69 62 75 74 65 0a 09 20 20 20 20 28 6c 61 6d ribute.. (lam
2bc0: 62 64 61 20 28 61 74 74 72 20 70 6f 72 74 29 0a bda (attr port).
2bd0: 09 20 20 20 20 20 20 28 75 6e 6c 65 73 73 20 28 . (unless (
2be0: 61 6e 64 20 28 70 61 69 72 3f 20 61 74 74 72 29 and (pair? attr)
2bf0: 20 28 73 79 6d 62 6f 6c 3f 20 28 63 61 72 20 61 (symbol? (car a
2c00: 74 74 72 29 29 20 28 6c 69 73 74 3f 20 28 63 64 ttr)) (list? (cd
2c10: 72 20 61 74 74 72 29 29 29 0a 09 09 28 65 72 72 r attr)))...(err
2c20: 6f 72 0a 09 09 20 27 77 72 69 74 65 2d 68 74 6d or... 'write-htm
2c30: 6c 20 22 6e 6f 74 20 61 20 70 72 6f 70 65 72 20 l "not a proper
2c40: 61 74 74 72 69 62 75 74 65 22 0a 09 09 20 61 74 attribute"... at
2c50: 74 72 29 29 0a 09 20 20 20 20 20 20 28 6c 65 74 tr)).. (let
2c60: 2d 76 61 6c 75 65 73 20 28 28 28 6b 65 79 20 63 -values (((key c
2c70: 6f 6e 74 65 6e 74 73 29 20 28 63 61 72 2b 63 64 ontents) (car+cd
2c80: 72 20 61 74 74 72 29 29 29 0a 09 09 28 66 70 72 r attr)))...(fpr
2c90: 69 6e 74 66 20 70 6f 72 74 20 22 20 7e 61 3d 5c intf port " ~a=\
2ca0: 22 22 20 6b 65 79 29 0a 09 09 28 66 6f 72 2d 65 "" key)...(for-e
2cb0: 61 63 68 20 28 63 75 74 20 77 72 69 74 65 2d 63 ach (cut write-c
2cc0: 6f 6e 74 65 6e 74 20 23 66 20 3c 3e 20 70 6f 72 ontent #f <> por
2cd0: 74 29 20 63 6f 6e 74 65 6e 74 73 29 0a 09 09 28 t) contents)...(
2ce0: 64 69 73 70 6c 61 79 20 23 5c 22 20 70 6f 72 74 display #\" port
2cf0: 29 29 29 29 0a 09 20 20 20 28 77 72 69 74 65 2d )))).. (write-
2d00: 63 6f 6e 74 65 6e 74 0a 09 20 20 20 20 28 6c 61 content.. (la
2d10: 6d 62 64 61 20 28 61 6c 6c 6f 77 2d 65 6c 65 6d mbda (allow-elem
2d20: 65 6e 74 73 3f 20 76 20 70 6f 72 74 29 0a 09 20 ents? v port)..
2d30: 20 20 20 20 20 28 63 6f 6e 64 0a 09 20 20 20 20 (cond..
2d40: 20 20 20 28 28 73 79 6d 62 6f 6c 3f 20 76 29 0a ((symbol? v).
2d50: 09 09 28 66 70 72 69 6e 74 66 20 70 6f 72 74 20 ..(fprintf port
2d60: 22 26 7e 61 3b 22 20 76 29 29 0a 09 20 20 20 20 "&~a;" v))..
2d70: 20 20 20 28 28 61 6e 64 20 28 69 6e 74 65 67 65 ((and (intege
2d80: 72 3f 20 76 29 20 28 70 6f 73 69 74 69 76 65 3f r? v) (positive?
2d90: 20 76 29 29 0a 09 09 28 66 70 72 69 6e 74 66 20 v))...(fprintf
2da0: 70 6f 72 74 20 22 26 23 7e 61 3b 22 20 76 29 29 port "&#~a;" v))
2db0: 0a 09 20 20 20 20 20 20 20 28 28 73 74 72 69 6e .. ((strin
2dc0: 67 3f 20 76 29 0a 09 09 28 64 69 73 70 6c 61 79 g? v)...(display
2dd0: 20 28 68 74 6d 6c 2d 65 73 63 61 70 65 20 76 29 (html-escape v)
2de0: 20 70 6f 72 74 29 29 0a 09 20 20 20 20 20 20 20 port))..
2df0: 28 61 6c 6c 6f 77 2d 65 6c 65 6d 65 6e 74 73 3f (allow-elements?
2e00: 0a 09 09 28 77 72 69 74 65 2d 65 6c 65 6d 65 6e ...(write-elemen
2e10: 74 20 76 20 70 6f 72 74 29 29 0a 09 20 20 20 20 t v port))..
2e20: 20 20 20 28 65 6c 73 65 0a 09 09 28 65 72 72 6f (else...(erro
2e30: 72 0a 09 09 20 27 77 72 69 74 65 2d 68 74 6d 6c r... 'write-html
2e40: 20 22 65 6c 65 6d 65 6e 74 20 6e 6f 74 20 61 6c "element not al
2e50: 6c 6f 77 65 64 20 69 6e 20 74 68 69 73 20 63 6f lowed in this co
2e60: 6e 74 65 78 74 22 0a 09 09 20 76 29 29 29 29 29 ntext"... v)))))
2e70: 29 0a 20 20 20 20 28 6c 61 6d 62 64 61 20 28 68 ). (lambda (h
2e80: 74 6d 6c 20 23 21 6f 70 74 69 6f 6e 61 6c 20 28 tml #!optional (
2e90: 70 6f 72 74 20 28 63 75 72 72 65 6e 74 2d 6f 75 port (current-ou
2ea0: 74 70 75 74 2d 70 6f 72 74 29 29 29 0a 20 20 20 tput-port))).
2eb0: 20 20 20 28 64 69 73 70 6c 61 79 20 22 3c 21 44 (display "<!D
2ec0: 4f 43 54 59 50 45 20 68 74 6d 6c 3e 22 20 70 6f OCTYPE html>" po
2ed0: 72 74 29 0a 20 20 20 20 20 20 28 6e 65 77 6c 69 rt). (newli
2ee0: 6e 65 20 70 6f 72 74 29 0a 20 20 20 20 20 20 28 ne port). (
2ef0: 77 72 69 74 65 2d 65 6c 65 6d 65 6e 74 20 68 74 write-element ht
2f00: 6d 6c 20 70 6f 72 74 29 0a 20 20 20 20 20 20 28 ml port). (
2f10: 6e 65 77 6c 69 6e 65 20 70 6f 72 74 29 29 29 29 newline port))))
2f20: 0a .