0000: 3b 3b 3b 20 53 52 46 49 2d 31 34 20 63 68 61 72 ;;; SRFI-14 char
0010: 61 63 74 65 72 2d 73 65 74 73 20 6c 69 62 72 61 acter-sets libra
0020: 72 79 09 09 09 09 2d 2a 2d 20 53 63 68 65 6d 65 ry....-*- Scheme
0030: 20 2d 2a 2d 0a 3b 3b 3b 0a 3b 3b 3b 20 2d 20 50 -*-.;;;.;;; - P
0040: 6f 72 74 65 64 20 66 72 6f 6d 20 4d 49 54 20 53 orted from MIT S
0050: 63 68 65 6d 65 20 72 75 6e 74 69 6d 65 20 62 79 cheme runtime by
0060: 20 42 72 69 61 6e 20 44 2e 20 43 61 72 6c 73 74 Brian D. Carlst
0070: 72 6f 6d 2e 0a 3b 3b 3b 20 2d 20 4d 61 73 73 69 rom..;;; - Massi
0080: 76 65 6c 79 20 72 65 68 61 63 6b 65 64 20 26 20 vely rehacked &
0090: 65 78 74 65 6e 64 65 64 20 62 79 20 4f 6c 69 6e extended by Olin
00a0: 20 53 68 69 76 65 72 73 20 36 2f 39 38 2e 0a 3b Shivers 6/98..;
00b0: 3b 3b 20 2d 20 4d 61 73 73 69 76 65 6c 79 20 72 ;; - Massively r
00c0: 65 64 65 73 69 67 6e 65 64 20 61 6e 64 20 72 65 edesigned and re
00d0: 68 61 63 6b 65 64 20 35 2f 32 30 30 30 20 64 75 hacked 5/2000 du
00e0: 72 69 6e 67 20 53 52 46 49 20 70 72 6f 63 65 73 ring SRFI proces
00f0: 73 2e 0a 3b 3b 3b 20 41 74 20 74 68 69 73 20 70 s..;;; At this p
0100: 6f 69 6e 74 2c 20 74 68 65 20 63 6f 64 65 20 62 oint, the code b
0110: 65 61 72 73 20 74 68 65 20 66 6f 6c 6c 6f 77 69 ears the followi
0120: 6e 67 20 72 65 6c 61 74 69 6f 6e 73 68 69 70 20 ng relationship
0130: 74 6f 20 74 68 65 0a 3b 3b 3b 20 4d 49 54 20 53 to the.;;; MIT S
0140: 63 68 65 6d 65 20 63 6f 64 65 3a 20 22 54 68 69 cheme code: "Thi
0150: 73 20 69 73 20 6d 79 20 67 72 61 6e 64 66 61 74 s is my grandfat
0160: 68 65 72 27 73 20 61 78 65 2e 20 4d 79 20 66 61 her's axe. My fa
0170: 74 68 65 72 20 72 65 70 6c 61 63 65 64 0a 3b 3b ther replaced.;;
0180: 3b 20 74 68 65 20 68 65 61 64 2c 20 61 6e 64 20 ; the head, and
0190: 49 20 68 61 76 65 20 72 65 70 6c 61 63 65 64 20 I have replaced
01a0: 74 68 65 20 68 61 6e 64 6c 65 2e 22 20 4e 6f 6e the handle." Non
01b0: 65 74 68 65 6c 65 73 73 2c 20 77 65 20 70 72 65 etheless, we pre
01c0: 73 65 72 76 65 0a 3b 3b 3b 20 74 68 65 20 4d 49 serve.;;; the MI
01d0: 54 20 53 63 68 65 6d 65 20 63 6f 70 79 72 69 67 T Scheme copyrig
01e0: 68 74 3a 0a 3b 3b 3b 20 20 20 20 20 43 6f 70 79 ht:.;;; Copy
01f0: 72 69 67 68 74 20 28 63 29 20 31 39 38 38 2d 31 right (c) 1988-1
0200: 39 39 35 20 4d 61 73 73 61 63 68 75 73 65 74 74 995 Massachusett
0210: 73 20 49 6e 73 74 69 74 75 74 65 20 6f 66 20 54 s Institute of T
0220: 65 63 68 6e 6f 6c 6f 67 79 0a 3b 3b 3b 20 54 68 echnology.;;; Th
0230: 65 20 4d 49 54 20 53 63 68 65 6d 65 20 6c 69 63 e MIT Scheme lic
0240: 65 6e 73 65 20 69 73 20 61 20 22 66 72 65 65 20 ense is a "free
0250: 73 6f 66 74 77 61 72 65 22 20 6c 69 63 65 6e 73 software" licens
0260: 65 2e 20 53 65 65 20 74 68 65 20 65 6e 64 20 6f e. See the end o
0270: 66 0a 3b 3b 3b 20 74 68 69 73 20 66 69 6c 65 20 f.;;; this file
0280: 66 6f 72 20 74 68 65 20 74 65 64 69 6f 75 73 20 for the tedious
0290: 64 65 74 61 69 6c 73 2e 20 0a 0a 3b 3b 3b 20 45 details. ..;;; E
02a0: 78 70 6f 72 74 73 3a 0a 3b 3b 3b 20 63 68 61 72 xports:.;;; char
02b0: 2d 73 65 74 3f 20 63 68 61 72 2d 73 65 74 3d 20 -set? char-set=
02c0: 63 68 61 72 2d 73 65 74 3c 3d 0a 3b 3b 3b 20 63 char-set<=.;;; c
02d0: 68 61 72 2d 73 65 74 2d 68 61 73 68 20 0a 3b 3b har-set-hash .;;
02e0: 3b 20 63 68 61 72 2d 73 65 74 2d 63 75 72 73 6f ; char-set-curso
02f0: 72 20 63 68 61 72 2d 73 65 74 2d 72 65 66 20 63 r char-set-ref c
0300: 68 61 72 2d 73 65 74 2d 63 75 72 73 6f 72 2d 6e har-set-cursor-n
0310: 65 78 74 20 65 6e 64 2d 6f 66 2d 63 68 61 72 2d ext end-of-char-
0320: 73 65 74 3f 0a 3b 3b 3b 20 63 68 61 72 2d 73 65 set?.;;; char-se
0330: 74 2d 66 6f 6c 64 20 63 68 61 72 2d 73 65 74 2d t-fold char-set-
0340: 75 6e 66 6f 6c 64 20 63 68 61 72 2d 73 65 74 2d unfold char-set-
0350: 75 6e 66 6f 6c 64 21 0a 3b 3b 3b 20 63 68 61 72 unfold!.;;; char
0360: 2d 73 65 74 2d 66 6f 72 2d 65 61 63 68 20 63 68 -set-for-each ch
0370: 61 72 2d 73 65 74 2d 6d 61 70 0a 3b 3b 3b 20 63 ar-set-map.;;; c
0380: 68 61 72 2d 73 65 74 2d 63 6f 70 79 20 63 68 61 har-set-copy cha
0390: 72 2d 73 65 74 0a 3b 3b 3b 0a 3b 3b 3b 20 6c 69 r-set.;;;.;;; li
03a0: 73 74 2d 3e 63 68 61 72 2d 73 65 74 20 20 73 74 st->char-set st
03b0: 72 69 6e 67 2d 3e 63 68 61 72 2d 73 65 74 20 0a ring->char-set .
03c0: 3b 3b 3b 20 6c 69 73 74 2d 3e 63 68 61 72 2d 73 ;;; list->char-s
03d0: 65 74 21 20 73 74 72 69 6e 67 2d 3e 63 68 61 72 et! string->char
03e0: 2d 73 65 74 21 20 0a 3b 3b 3b 0a 3b 3b 3b 20 66 -set! .;;;.;;; f
03f0: 69 6c 74 65 72 63 68 61 72 2d 73 65 74 20 20 75 ilterchar-set u
0400: 63 73 2d 72 61 6e 67 65 2d 3e 63 68 61 72 2d 73 cs-range->char-s
0410: 65 74 20 20 2d 3e 63 68 61 72 2d 73 65 74 0a 3b et ->char-set.;
0420: 3b 3b 20 66 69 6c 74 65 72 63 68 61 72 2d 73 65 ;; filterchar-se
0430: 74 21 20 75 63 73 2d 72 61 6e 67 65 2d 3e 63 68 t! ucs-range->ch
0440: 61 72 2d 73 65 74 21 0a 3b 3b 3b 0a 3b 3b 3b 20 ar-set!.;;;.;;;
0450: 63 68 61 72 2d 73 65 74 2d 3e 6c 69 73 74 20 63 char-set->list c
0460: 68 61 72 2d 73 65 74 2d 3e 73 74 72 69 6e 67 0a har-set->string.
0470: 3b 3b 3b 0a 3b 3b 3b 20 63 68 61 72 2d 73 65 74 ;;;.;;; char-set
0480: 2d 73 69 7a 65 20 63 68 61 72 2d 73 65 74 2d 63 -size char-set-c
0490: 6f 75 6e 74 20 63 68 61 72 2d 73 65 74 2d 63 6f ount char-set-co
04a0: 6e 74 61 69 6e 73 3f 0a 3b 3b 3b 20 63 68 61 72 ntains?.;;; char
04b0: 2d 73 65 74 2d 65 76 65 72 79 20 63 68 61 72 2d -set-every char-
04c0: 73 65 74 2d 61 6e 79 0a 3b 3b 3b 0a 3b 3b 3b 20 set-any.;;;.;;;
04d0: 63 68 61 72 2d 73 65 74 2d 61 64 6a 6f 69 6e 20 char-set-adjoin
04e0: 20 63 68 61 72 2d 73 65 74 2d 64 65 6c 65 74 65 char-set-delete
04f0: 20 0a 3b 3b 3b 20 63 68 61 72 2d 73 65 74 2d 61 .;;; char-set-a
0500: 64 6a 6f 69 6e 21 20 63 68 61 72 2d 73 65 74 2d djoin! char-set-
0510: 64 65 6c 65 74 65 21 0a 3b 3b 3b 20 0a 0a 3b 3b delete!.;;; ..;;
0520: 3b 20 63 68 61 72 2d 73 65 74 2d 63 6f 6d 70 6c ; char-set-compl
0530: 65 6d 65 6e 74 20 20 63 68 61 72 2d 73 65 74 2d ement char-set-
0540: 75 6e 69 6f 6e 20 20 63 68 61 72 2d 73 65 74 2d union char-set-
0550: 69 6e 74 65 72 73 65 63 74 69 6f 6e 20 20 0a 3b intersection .;
0560: 3b 3b 20 63 68 61 72 2d 73 65 74 2d 63 6f 6d 70 ;; char-set-comp
0570: 6c 65 6d 65 6e 74 21 20 63 68 61 72 2d 73 65 74 lement! char-set
0580: 2d 75 6e 69 6f 6e 21 20 63 68 61 72 2d 73 65 74 -union! char-set
0590: 2d 69 6e 74 65 72 73 65 63 74 69 6f 6e 21 20 0a -intersection! .
05a0: 3b 3b 3b 0a 3b 3b 3b 20 63 68 61 72 2d 73 65 74 ;;;.;;; char-set
05b0: 2d 64 69 66 66 65 72 65 6e 63 65 20 20 63 68 61 -difference cha
05c0: 72 2d 73 65 74 2d 78 6f 72 20 20 63 68 61 72 2d r-set-xor char-
05d0: 73 65 74 2d 64 69 66 66 2b 69 6e 74 65 72 73 65 set-diff+interse
05e0: 63 74 69 6f 6e 0a 3b 3b 3b 20 63 68 61 72 2d 73 ction.;;; char-s
05f0: 65 74 2d 64 69 66 66 65 72 65 6e 63 65 21 20 63 et-difference! c
0600: 68 61 72 2d 73 65 74 2d 78 6f 72 21 20 63 68 61 har-set-xor! cha
0610: 72 2d 73 65 74 2d 64 69 66 66 2b 69 6e 74 65 72 r-set-diff+inter
0620: 73 65 63 74 69 6f 6e 21 0a 3b 3b 3b 0a 3b 3b 3b section!.;;;.;;;
0630: 20 63 68 61 72 2d 73 65 74 3a 6c 6f 77 65 72 2d char-set:lower-
0640: 63 61 73 65 09 09 63 68 61 72 2d 73 65 74 3a 75 case..char-set:u
0650: 70 70 65 72 2d 63 61 73 65 09 63 68 61 72 2d 73 pper-case.char-s
0660: 65 74 3a 74 69 74 6c 65 2d 63 61 73 65 0a 3b 3b et:title-case.;;
0670: 3b 20 63 68 61 72 2d 73 65 74 3a 6c 65 74 74 65 ; char-set:lette
0680: 72 09 09 63 68 61 72 2d 73 65 74 3a 64 69 67 69 r..char-set:digi
0690: 74 09 09 63 68 61 72 2d 73 65 74 3a 6c 65 74 74 t..char-set:lett
06a0: 65 72 2b 64 69 67 69 74 0a 3b 3b 3b 20 63 68 61 er+digit.;;; cha
06b0: 72 2d 73 65 74 3a 67 72 61 70 68 69 63 09 09 63 r-set:graphic..c
06c0: 68 61 72 2d 73 65 74 3a 70 72 69 6e 74 69 6e 67 har-set:printing
06d0: 09 63 68 61 72 2d 73 65 74 3a 77 68 69 74 65 73 .char-set:whites
06e0: 70 61 63 65 0a 3b 3b 3b 20 63 68 61 72 2d 73 65 pace.;;; char-se
06f0: 74 3a 69 73 6f 2d 63 6f 6e 74 72 6f 6c 09 63 68 t:iso-control.ch
0700: 61 72 2d 73 65 74 3a 70 75 6e 63 74 75 61 74 69 ar-set:punctuati
0710: 6f 6e 09 63 68 61 72 2d 73 65 74 3a 73 79 6d 62 on.char-set:symb
0720: 6f 6c 0a 3b 3b 3b 20 63 68 61 72 2d 73 65 74 3a ol.;;; char-set:
0730: 68 65 78 2d 64 69 67 69 74 09 09 63 68 61 72 2d hex-digit..char-
0740: 73 65 74 3a 62 6c 61 6e 6b 09 09 63 68 61 72 2d set:blank..char-
0750: 73 65 74 3a 61 73 63 69 69 0a 3b 3b 3b 20 63 68 set:ascii.;;; ch
0760: 61 72 2d 73 65 74 3a 65 6d 70 74 79 09 09 63 68 ar-set:empty..ch
0770: 61 72 2d 73 65 74 3a 66 75 6c 6c 0a 0a 3b 3b 3b ar-set:full..;;;
0780: 20 49 6d 70 6f 72 74 73 0a 3b 3b 3b 20 54 68 69 Imports.;;; Thi
0790: 73 20 63 6f 64 65 20 68 61 73 20 74 68 65 20 66 s code has the f
07a0: 6f 6c 6c 6f 77 69 6e 67 20 6e 6f 6e 2d 52 35 52 ollowing non-R5R
07b0: 53 20 64 65 70 65 6e 64 65 6e 63 69 65 73 3a 0a S dependencies:.
07c0: 3b 3b 3b 20 2d 20 45 52 52 4f 52 0a 3b 3b 3b 20 ;;; - ERROR.;;;
07d0: 2d 20 25 4c 41 54 49 4e 31 2d 3e 43 48 41 52 20 - %LATIN1->CHAR
07e0: 25 43 48 41 52 2d 3e 4c 41 54 49 4e 31 0a 3b 3b %CHAR->LATIN1.;;
07f0: 3b 20 2d 20 4c 45 54 2d 4f 50 54 49 4f 4e 41 4c ; - LET-OPTIONAL
0800: 53 2a 20 61 6e 64 20 3a 4f 50 54 49 4f 4e 41 4c S* and :OPTIONAL
0810: 20 6d 61 63 72 6f 73 20 66 6f 72 20 70 61 72 73 macros for pars
0820: 69 6e 67 2c 20 63 68 65 63 6b 69 6e 67 20 26 20 ing, checking &
0830: 64 65 66 61 75 6c 74 69 6e 67 0a 3b 3b 3b 20 20 defaulting.;;;
0840: 20 6f 70 74 69 6f 6e 61 6c 20 61 72 67 75 6d 65 optional argume
0850: 6e 74 73 20 66 72 6f 6d 20 72 65 73 74 20 6c 69 nts from rest li
0860: 73 74 73 2e 0a 3b 3b 3b 20 2d 20 42 49 54 57 49 sts..;;; - BITWI
0870: 53 45 2d 41 4e 44 20 66 6f 72 20 43 48 41 52 2d SE-AND for CHAR-
0880: 53 45 54 2d 48 41 53 48 0a 3b 3b 3b 20 2d 20 54 SET-HASH.;;; - T
0890: 68 65 20 53 52 46 49 2d 31 39 20 44 45 46 49 4e he SRFI-19 DEFIN
08a0: 45 2d 52 45 43 4f 52 44 2d 54 59 50 45 20 72 65 E-RECORD-TYPE re
08b0: 63 6f 72 64 20 6d 61 63 72 6f 0a 3b 3b 3b 20 2d cord macro.;;; -
08c0: 20 41 20 73 69 6d 70 6c 65 20 43 48 45 43 4b 2d A simple CHECK-
08d0: 41 52 47 20 70 72 6f 63 65 64 75 72 65 3a 20 0a ARG procedure: .
08e0: 3b 3b 3b 20 20 20 28 6c 61 6d 62 64 61 20 28 70 ;;; (lambda (p
08f0: 72 65 64 20 76 61 6c 20 63 61 6c 6c 65 72 29 20 red val caller)
0900: 28 69 66 20 28 6e 6f 74 20 28 70 72 65 64 20 76 (if (not (pred v
0910: 61 6c 29 29 20 28 65 72 72 6f 72 20 76 61 6c 20 al)) (error val
0920: 63 61 6c 6c 65 72 29 29 29 0a 0a 3b 3b 3b 20 54 caller)))..;;; T
0930: 68 69 73 20 69 73 20 73 69 6d 70 6c 65 20 63 6f his is simple co
0940: 64 65 2c 20 6e 6f 74 20 67 72 65 61 74 20 63 6f de, not great co
0950: 64 65 2e 20 43 68 61 72 20 73 65 74 73 20 61 72 de. Char sets ar
0960: 65 20 72 65 70 72 65 73 65 6e 74 65 64 20 61 73 e represented as
0970: 20 32 35 36 2d 63 68 61 72 0a 3b 3b 3b 20 73 74 256-char.;;; st
0980: 72 69 6e 67 73 2e 20 49 66 20 63 68 61 72 20 49 rings. If char I
0990: 20 69 73 20 41 53 43 49 49 2f 4c 61 74 69 6e 2d is ASCII/Latin-
09a0: 31 20 30 2c 20 74 68 65 6e 20 69 74 20 69 73 6e 1 0, then it isn
09b0: 27 74 20 69 6e 20 74 68 65 20 73 65 74 3b 20 69 't in the set; i
09c0: 66 20 63 68 61 72 20 49 0a 3b 3b 3b 20 69 73 20 f char I.;;; is
09d0: 41 53 43 49 49 2f 4c 61 74 69 6e 2d 31 20 31 2c ASCII/Latin-1 1,
09e0: 20 74 68 65 6e 20 69 74 20 69 73 20 69 6e 20 74 then it is in t
09f0: 68 65 20 73 65 74 2e 0a 3b 3b 3b 20 2d 20 53 68 he set..;;; - Sh
0a00: 6f 75 6c 64 20 62 65 20 72 65 77 72 69 74 74 65 ould be rewritte
0a10: 6e 20 74 6f 20 75 73 65 20 62 69 74 20 73 74 72 n to use bit str
0a20: 69 6e 67 73 20 6f 72 20 62 79 74 65 20 76 65 63 ings or byte vec
0a30: 73 2e 0a 3b 3b 3b 20 2d 20 49 73 20 4c 61 74 69 s..;;; - Is Lati
0a40: 6e 2d 31 20 73 70 65 63 69 66 69 63 2e 20 57 6f n-1 specific. Wo
0a50: 75 6c 64 20 63 65 72 74 61 69 6e 6c 79 20 68 61 uld certainly ha
0a60: 76 65 20 74 6f 20 62 65 20 72 65 77 72 69 74 74 ve to be rewritt
0a70: 65 6e 20 66 6f 72 20 55 6e 69 63 6f 64 65 2e 0a en for Unicode..
0a80: 0a 3b 3b 3b 20 53 65 65 20 74 68 65 20 65 6e 64 .;;; See the end
0a90: 20 6f 66 20 74 68 65 20 66 69 6c 65 20 66 6f 72 of the file for
0aa0: 20 70 6f 72 74 69 6e 67 20 61 6e 64 20 70 65 72 porting and per
0ab0: 66 6f 72 6d 61 6e 63 65 2d 74 75 6e 69 6e 67 20 formance-tuning
0ac0: 6e 6f 74 65 73 2e 0a 3b 3b 3b 3b 3b 3b 3b 3b 3b notes..;;;;;;;;;
0ad0: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
0ae0: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
0af0: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
0b00: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
0b10: 3b 3b 3b 3b 3b 3b 0a 0a 28 64 65 66 69 6e 65 2d ;;;;;;..(define-
0b20: 72 65 63 6f 72 64 2d 74 79 70 65 20 3a 63 68 61 record-type :cha
0b30: 72 2d 73 65 74 0a 20 20 28 6d 61 6b 65 2d 63 68 r-set. (make-ch
0b40: 61 72 2d 73 65 74 20 73 29 0a 20 20 63 68 61 72 ar-set s). char
0b50: 2d 73 65 74 3f 0a 20 20 28 73 20 63 68 61 72 2d -set?. (s char-
0b60: 73 65 74 3a 73 29 29 0a 0a 0a 28 64 65 66 69 6e set:s))...(defin
0b70: 65 20 28 25 73 74 72 69 6e 67 2d 63 6f 70 79 20 e (%string-copy
0b80: 73 29 20 28 73 75 62 73 74 72 69 6e 67 20 73 20 s) (substring s
0b90: 30 20 28 73 74 72 69 6e 67 2d 6c 65 6e 67 74 68 0 (string-length
0ba0: 20 73 29 29 29 0a 0a 3b 3b 3b 20 50 61 72 73 65 s)))..;;; Parse
0bb0: 2c 20 74 79 70 65 2d 63 68 65 63 6b 20 26 20 64 , type-check & d
0bc0: 65 66 61 75 6c 74 20 61 20 66 69 6e 61 6c 20 6f efault a final o
0bd0: 70 74 69 6f 6e 61 6c 20 42 41 53 45 2d 43 53 20 ptional BASE-CS
0be0: 70 61 72 61 6d 65 74 65 72 20 66 72 6f 6d 0a 3b parameter from.;
0bf0: 3b 3b 20 61 20 72 65 73 74 20 61 72 67 75 6d 65 ;; a rest argume
0c00: 6e 74 2e 20 52 65 74 75 72 6e 20 61 20 2a 66 72 nt. Return a *fr
0c10: 65 73 68 20 63 6f 70 79 2a 20 6f 66 20 74 68 65 esh copy* of the
0c20: 20 75 6e 64 65 72 6c 79 69 6e 67 20 73 74 72 69 underlying stri
0c30: 6e 67 2e 0a 3b 3b 3b 20 54 68 65 20 64 65 66 61 ng..;;; The defa
0c40: 75 6c 74 20 69 73 20 74 68 65 20 65 6d 70 74 79 ult is the empty
0c50: 20 73 65 74 2e 20 54 68 65 20 50 52 4f 43 20 61 set. The PROC a
0c60: 72 67 75 6d 65 6e 74 20 69 73 20 74 6f 20 68 65 rgument is to he
0c70: 6c 70 20 75 73 0a 3b 3b 3b 20 67 65 6e 65 72 61 lp us.;;; genera
0c80: 74 65 20 69 6e 66 6f 72 6d 61 74 69 76 65 20 65 te informative e
0c90: 72 72 6f 72 20 65 78 63 65 70 74 69 6f 6e 73 2e rror exceptions.
0ca0: 0a 0a 28 64 65 66 69 6e 65 20 28 25 64 65 66 61 ..(define (%defa
0cb0: 75 6c 74 2d 62 61 73 65 20 6d 61 79 62 65 2d 62 ult-base maybe-b
0cc0: 61 73 65 20 70 72 6f 63 29 0a 20 20 28 69 66 20 ase proc). (if
0cd0: 28 70 61 69 72 3f 20 6d 61 79 62 65 2d 62 61 73 (pair? maybe-bas
0ce0: 65 29 0a 20 20 20 20 20 20 28 6c 65 74 20 28 28 e). (let ((
0cf0: 62 63 73 20 20 28 63 61 72 20 6d 61 79 62 65 2d bcs (car maybe-
0d00: 62 61 73 65 29 29 0a 09 20 20 20 20 28 74 61 69 base)).. (tai
0d10: 6c 20 28 63 64 72 20 6d 61 79 62 65 2d 62 61 73 l (cdr maybe-bas
0d20: 65 29 29 29 0a 09 28 69 66 20 28 6e 75 6c 6c 3f e)))..(if (null?
0d30: 20 74 61 69 6c 29 0a 09 20 20 20 20 28 69 66 20 tail).. (if
0d40: 28 63 68 61 72 2d 73 65 74 3f 20 62 63 73 29 20 (char-set? bcs)
0d50: 28 25 73 74 72 69 6e 67 2d 63 6f 70 79 20 28 63 (%string-copy (c
0d60: 68 61 72 2d 73 65 74 3a 73 20 62 63 73 29 29 0a har-set:s bcs)).
0d70: 09 09 28 61 73 73 65 72 74 69 6f 6e 2d 76 69 6f ..(assertion-vio
0d80: 6c 61 74 69 6f 6e 20 70 72 6f 63 20 22 42 41 53 lation proc "BAS
0d90: 45 2d 43 53 20 70 61 72 61 6d 65 74 65 72 20 6e E-CS parameter n
0da0: 6f 74 20 61 20 63 68 61 72 2d 73 65 74 22 20 62 ot a char-set" b
0db0: 63 73 29 29 0a 09 20 20 20 20 28 61 73 73 65 72 cs)).. (asser
0dc0: 74 69 6f 6e 2d 76 69 6f 6c 61 74 69 6f 6e 20 70 tion-violation p
0dd0: 72 6f 63 0a 20 20 20 20 20 20 20 20 20 20 20 20 roc.
0de0: 20 22 45 78 70 65 63 74 65 64 20 66 69 6e 61 6c "Expected final
0df0: 20 62 61 73 65 20 63 68 61 72 20 73 65 74 20 2d base char set -
0e00: 2d 20 74 6f 6f 20 6d 61 6e 79 20 70 61 72 61 6d - too many param
0e10: 65 74 65 72 73 22 20 6d 61 79 62 65 2d 62 61 73 eters" maybe-bas
0e20: 65 29 29 29 0a 20 20 20 20 20 20 28 6d 61 6b 65 e))). (make
0e30: 2d 73 74 72 69 6e 67 20 32 35 36 20 28 25 6c 61 -string 256 (%la
0e40: 74 69 6e 31 2d 3e 63 68 61 72 20 30 29 29 29 29 tin1->char 0))))
0e50: 0a 0a 3b 3b 3b 20 49 66 20 43 53 20 69 73 20 72 ..;;; If CS is r
0e60: 65 61 6c 6c 79 20 61 20 63 68 61 72 2d 73 65 74 eally a char-set
0e70: 2c 20 64 6f 20 43 48 41 52 2d 53 45 54 3a 53 2c , do CHAR-SET:S,
0e80: 20 6f 74 77 20 72 65 70 6f 72 74 20 61 6e 20 65 otw report an e
0e90: 72 72 6f 72 20 6d 73 67 20 6f 6e 0a 3b 3b 3b 20 rror msg on.;;;
0ea0: 62 65 68 61 6c 66 20 6f 66 20 6f 75 72 20 63 61 behalf of our ca
0eb0: 6c 6c 65 72 2c 20 50 52 4f 43 2e 20 54 68 69 73 ller, PROC. This
0ec0: 20 70 72 6f 63 65 64 75 72 65 20 65 78 69 73 74 procedure exist
0ed0: 73 20 62 61 73 69 63 61 6c 6c 79 20 74 6f 20 70 s basically to p
0ee0: 72 6f 76 69 64 65 0a 3b 3b 3b 20 65 78 70 6c 69 rovide.;;; expli
0ef0: 63 69 74 20 65 72 72 6f 72 2d 63 68 65 63 6b 69 cit error-checki
0f00: 6e 67 20 26 20 72 65 70 6f 72 74 69 6e 67 2e 0a ng & reporting..
0f10: 0a 28 64 65 66 69 6e 65 20 28 25 63 68 61 72 2d .(define (%char-
0f20: 73 65 74 3a 73 2f 63 68 65 63 6b 20 63 73 20 70 set:s/check cs p
0f30: 72 6f 63 29 0a 20 20 28 6c 65 74 20 6c 70 20 28 roc). (let lp (
0f40: 28 63 73 20 63 73 29 29 0a 20 20 20 20 28 69 66 (cs cs)). (if
0f50: 20 28 63 68 61 72 2d 73 65 74 3f 20 63 73 29 20 (char-set? cs)
0f60: 28 63 68 61 72 2d 73 65 74 3a 73 20 63 73 29 0a (char-set:s cs).
0f70: 09 28 6c 70 20 28 61 73 73 65 72 74 69 6f 6e 2d .(lp (assertion-
0f80: 76 69 6f 6c 61 74 69 6f 6e 20 70 72 6f 63 20 22 violation proc "
0f90: 4e 6f 74 20 61 20 63 68 61 72 2d 73 65 74 22 20 Not a char-set"
0fa0: 63 73 29 29 29 29 29 0a 0a 0a 0a 3b 3b 3b 20 54 cs)))))....;;; T
0fb0: 68 65 73 65 20 69 6e 74 65 72 6e 61 6c 20 66 75 hese internal fu
0fc0: 6e 63 74 69 6f 6e 73 20 68 69 64 65 20 61 20 6c nctions hide a l
0fd0: 6f 74 20 6f 66 20 74 68 65 20 64 65 70 65 6e 64 ot of the depend
0fe0: 65 6e 63 79 20 6f 6e 20 74 68 65 0a 3b 3b 3b 20 ency on the.;;;
0ff0: 75 6e 64 65 72 6c 79 69 6e 67 20 73 74 72 69 6e underlying strin
1000: 67 20 72 65 70 72 65 73 65 6e 74 61 74 69 6f 6e g representation
1010: 20 6f 66 20 63 68 61 72 20 73 65 74 73 2e 20 54 of char sets. T
1020: 68 65 79 20 73 68 6f 75 6c 64 20 62 65 0a 3b 3b hey should be.;;
1030: 3b 20 69 6e 6c 69 6e 65 64 20 69 66 20 70 6f 73 ; inlined if pos
1040: 73 69 62 6c 65 2e 0a 0a 28 64 65 66 69 6e 65 20 sible...(define
1050: 28 73 69 3d 30 3f 20 73 20 69 29 20 28 7a 65 72 (si=0? s i) (zer
1060: 6f 3f 20 28 25 63 68 61 72 2d 3e 6c 61 74 69 6e o? (%char->latin
1070: 31 20 28 73 74 72 69 6e 67 2d 72 65 66 20 73 20 1 (string-ref s
1080: 69 29 29 29 29 0a 28 64 65 66 69 6e 65 20 28 73 i)))).(define (s
1090: 69 3d 31 3f 20 73 20 69 29 20 28 6e 6f 74 20 28 i=1? s i) (not (
10a0: 73 69 3d 30 3f 20 73 20 69 29 29 29 0a 28 64 65 si=0? s i))).(de
10b0: 66 69 6e 65 20 63 30 20 28 25 6c 61 74 69 6e 31 fine c0 (%latin1
10c0: 2d 3e 63 68 61 72 20 30 29 29 0a 28 64 65 66 69 ->char 0)).(defi
10d0: 6e 65 20 63 31 20 28 25 6c 61 74 69 6e 31 2d 3e ne c1 (%latin1->
10e0: 63 68 61 72 20 31 29 29 0a 28 64 65 66 69 6e 65 char 1)).(define
10f0: 20 28 73 69 20 73 20 69 29 20 28 25 63 68 61 72 (si s i) (%char
1100: 2d 3e 6c 61 74 69 6e 31 20 28 73 74 72 69 6e 67 ->latin1 (string
1110: 2d 72 65 66 20 73 20 69 29 29 29 0a 28 64 65 66 -ref s i))).(def
1120: 69 6e 65 20 28 25 73 65 74 30 21 20 73 20 69 29 ine (%set0! s i)
1130: 20 28 73 74 72 69 6e 67 2d 73 65 74 21 20 73 20 (string-set! s
1140: 69 20 63 30 29 29 0a 28 64 65 66 69 6e 65 20 28 i c0)).(define (
1150: 25 73 65 74 31 21 20 73 20 69 29 20 28 73 74 72 %set1! s i) (str
1160: 69 6e 67 2d 73 65 74 21 20 73 20 69 20 63 31 29 ing-set! s i c1)
1170: 29 0a 0a 3b 3b 3b 20 54 68 65 73 65 20 64 6f 20 )..;;; These do
1180: 76 61 72 69 6f 75 73 20 22 73 5b 69 5d 20 3a 3d various "s[i] :=
1190: 20 73 5b 69 5d 20 6f 70 20 76 61 6c 22 20 6f 70 s[i] op val" op
11a0: 65 72 61 74 69 6f 6e 73 20 2d 2d 20 73 65 65 20 erations -- see
11b0: 0a 3b 3b 3b 20 25 43 48 41 52 2d 53 45 54 2d 41 .;;; %CHAR-SET-A
11c0: 4c 47 45 42 52 41 2e 20 54 68 65 79 20 61 72 65 LGEBRA. They are
11d0: 20 75 73 65 64 20 74 6f 20 69 6d 70 6c 65 6d 65 used to impleme
11e0: 6e 74 20 74 68 65 20 76 61 72 69 6f 75 73 0a 3b nt the various.;
11f0: 3b 3b 20 73 65 74 2d 61 6c 67 65 62 72 61 20 70 ;; set-algebra p
1200: 72 6f 63 65 64 75 72 65 73 2e 0a 28 64 65 66 69 rocedures..(defi
1210: 6e 65 20 28 73 65 74 76 21 20 20 20 73 20 69 20 ne (setv! s i
1220: 76 29 20 28 73 74 72 69 6e 67 2d 73 65 74 21 20 v) (string-set!
1230: 73 20 69 20 28 25 6c 61 74 69 6e 31 2d 3e 63 68 s i (%latin1->ch
1240: 61 72 20 76 29 29 29 20 3b 20 53 45 54 20 74 6f ar v))) ; SET to
1250: 20 61 20 56 61 6c 75 65 2e 0a 28 64 65 66 69 6e a Value..(defin
1260: 65 20 28 25 6e 6f 74 21 20 20 20 73 20 69 20 76 e (%not! s i v
1270: 29 20 28 73 65 74 76 21 20 73 20 69 20 28 2d 20 ) (setv! s i (-
1280: 31 20 76 29 29 29 0a 28 64 65 66 69 6e 65 20 28 1 v))).(define (
1290: 25 61 6e 64 21 20 20 20 73 20 69 20 76 29 20 28 %and! s i v) (
12a0: 69 66 20 28 7a 65 72 6f 3f 20 76 29 20 28 25 73 if (zero? v) (%s
12b0: 65 74 30 21 20 73 20 69 29 29 29 0a 28 64 65 66 et0! s i))).(def
12c0: 69 6e 65 20 28 25 6f 72 21 20 20 20 20 73 20 69 ine (%or! s i
12d0: 20 76 29 20 28 69 66 20 28 6e 6f 74 20 28 7a 65 v) (if (not (ze
12e0: 72 6f 3f 20 76 29 29 20 28 25 73 65 74 31 21 20 ro? v)) (%set1!
12f0: 73 20 69 29 29 29 0a 28 64 65 66 69 6e 65 20 28 s i))).(define (
1300: 25 6d 69 6e 75 73 21 20 73 20 69 20 76 29 20 28 %minus! s i v) (
1310: 69 66 20 28 6e 6f 74 20 28 7a 65 72 6f 3f 20 76 if (not (zero? v
1320: 29 29 20 28 25 73 65 74 30 21 20 73 20 69 29 29 )) (%set0! s i))
1330: 29 0a 28 64 65 66 69 6e 65 20 28 25 78 6f 72 21 ).(define (%xor!
1340: 20 20 20 73 20 69 20 76 29 20 28 69 66 20 28 6e s i v) (if (n
1350: 6f 74 20 28 7a 65 72 6f 3f 20 76 29 29 20 28 73 ot (zero? v)) (s
1360: 65 74 76 21 20 73 20 69 20 28 2d 20 31 20 28 73 etv! s i (- 1 (s
1370: 69 20 73 20 69 29 29 29 29 29 0a 0a 0a 28 64 65 i s i)))))...(de
1380: 66 69 6e 65 20 28 63 68 61 72 2d 73 65 74 2d 63 fine (char-set-c
1390: 6f 70 79 20 63 73 29 0a 20 20 28 6d 61 6b 65 2d opy cs). (make-
13a0: 63 68 61 72 2d 73 65 74 20 28 25 73 74 72 69 6e char-set (%strin
13b0: 67 2d 63 6f 70 79 20 28 25 63 68 61 72 2d 73 65 g-copy (%char-se
13c0: 74 3a 73 2f 63 68 65 63 6b 20 63 73 20 27 63 68 t:s/check cs 'ch
13d0: 61 72 2d 73 65 74 2d 63 6f 70 79 29 29 29 29 0a ar-set-copy)))).
13e0: 0a 28 64 65 66 69 6e 65 20 28 63 68 61 72 2d 73 .(define (char-s
13f0: 65 74 3d 20 2e 20 72 65 73 74 29 0a 20 20 28 6f et= . rest). (o
1400: 72 20 28 6e 75 6c 6c 3f 20 72 65 73 74 29 0a 20 r (null? rest).
1410: 20 20 20 20 20 28 6c 65 74 2a 20 28 28 63 73 31 (let* ((cs1
1420: 20 20 28 63 61 72 20 72 65 73 74 29 29 0a 09 20 (car rest))..
1430: 20 20 20 20 28 72 65 73 74 20 28 63 64 72 20 72 (rest (cdr r
1440: 65 73 74 29 29 0a 09 20 20 20 20 20 28 73 31 20 est)).. (s1
1450: 28 25 63 68 61 72 2d 73 65 74 3a 73 2f 63 68 65 (%char-set:s/che
1460: 63 6b 20 63 73 31 20 27 63 68 61 72 2d 73 65 74 ck cs1 'char-set
1470: 3d 29 29 29 0a 09 28 6c 65 74 20 6c 70 20 28 28 =)))..(let lp ((
1480: 72 65 73 74 20 72 65 73 74 29 29 0a 09 20 20 28 rest rest)).. (
1490: 6f 72 20 28 6e 6f 74 20 28 70 61 69 72 3f 20 72 or (not (pair? r
14a0: 65 73 74 29 29 0a 09 20 20 20 20 20 20 28 61 6e est)).. (an
14b0: 64 20 28 73 74 72 69 6e 67 3d 3f 20 73 31 20 28 d (string=? s1 (
14c0: 25 63 68 61 72 2d 73 65 74 3a 73 2f 63 68 65 63 %char-set:s/chec
14d0: 6b 20 28 63 61 72 20 72 65 73 74 29 20 27 63 68 k (car rest) 'ch
14e0: 61 72 2d 73 65 74 3d 29 29 0a 09 09 20 20 20 28 ar-set=))... (
14f0: 6c 70 20 28 63 64 72 20 72 65 73 74 29 29 29 29 lp (cdr rest))))
1500: 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 ))))..(define (c
1510: 68 61 72 2d 73 65 74 3c 3d 20 2e 20 72 65 73 74 har-set<= . rest
1520: 29 0a 20 20 28 6f 72 20 28 6e 75 6c 6c 3f 20 72 ). (or (null? r
1530: 65 73 74 29 0a 20 20 20 20 20 20 28 6c 65 74 20 est). (let
1540: 28 28 63 73 31 20 20 28 63 61 72 20 72 65 73 74 ((cs1 (car rest
1550: 29 29 0a 09 20 20 20 20 28 72 65 73 74 20 28 63 )).. (rest (c
1560: 64 72 20 72 65 73 74 29 29 29 0a 09 28 6c 65 74 dr rest)))..(let
1570: 20 6c 70 20 28 28 73 31 20 28 25 63 68 61 72 2d lp ((s1 (%char-
1580: 73 65 74 3a 73 2f 63 68 65 63 6b 20 63 73 31 20 set:s/check cs1
1590: 27 63 68 61 72 2d 73 65 74 3c 3d 29 29 20 20 28 'char-set<=)) (
15a0: 72 65 73 74 20 72 65 73 74 29 29 0a 09 20 20 28 rest rest)).. (
15b0: 6f 72 20 28 6e 6f 74 20 28 70 61 69 72 3f 20 72 or (not (pair? r
15c0: 65 73 74 29 29 0a 09 20 20 20 20 20 20 28 6c 65 est)).. (le
15d0: 74 20 28 28 73 32 20 28 25 63 68 61 72 2d 73 65 t ((s2 (%char-se
15e0: 74 3a 73 2f 63 68 65 63 6b 20 28 63 61 72 20 72 t:s/check (car r
15f0: 65 73 74 29 20 27 63 68 61 72 2d 73 65 74 3c 3d est) 'char-set<=
1600: 29 29 0a 09 09 20 20 20 20 28 72 65 73 74 20 28 ))... (rest (
1610: 63 64 72 20 72 65 73 74 29 29 29 0a 09 09 28 69 cdr rest)))...(i
1620: 66 20 28 65 71 3f 20 73 31 20 73 32 29 20 28 6c f (eq? s1 s2) (l
1630: 70 20 73 32 20 72 65 73 74 29 09 3b 20 46 61 73 p s2 rest).; Fas
1640: 74 20 70 61 74 68 0a 09 09 20 20 20 20 28 6c 65 t path... (le
1650: 74 20 6c 70 32 20 28 28 69 20 32 35 35 29 29 09 t lp2 ((i 255)).
1660: 09 3b 20 52 65 61 6c 20 74 65 73 74 0a 09 09 20 .; Real test...
1670: 20 20 20 20 20 28 69 66 20 28 3c 20 69 20 30 29 (if (< i 0)
1680: 20 28 6c 70 20 73 32 20 72 65 73 74 29 0a 09 09 (lp s2 rest)...
1690: 09 20 20 28 61 6e 64 20 28 3c 3d 20 28 73 69 20 . (and (<= (si
16a0: 73 31 20 69 29 20 28 73 69 20 73 32 20 69 29 29 s1 i) (si s2 i))
16b0: 0a 09 09 09 20 20 20 20 20 20 20 28 6c 70 32 20 .... (lp2
16c0: 28 2d 20 69 20 31 29 29 29 29 29 29 29 29 29 29 (- i 1))))))))))
16d0: 29 29 0a 0a 3b 3b 3b 20 48 61 73 68 0a 3b 3b 3b ))..;;; Hash.;;;
16e0: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
16f0: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
1700: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
1710: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
1720: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 0a 3b 3b 3b ;;;;;;;;;;;;.;;;
1730: 20 43 6f 6d 70 75 74 65 20 28 63 20 2b 20 33 37 Compute (c + 37
1740: 20 63 20 2b 20 33 37 5e 32 20 63 20 2b 20 2e 2e c + 37^2 c + ..
1750: 2e 29 20 6d 6f 64 75 6c 6f 20 42 4f 55 4e 44 2c .) modulo BOUND,
1760: 20 77 69 74 68 20 73 6c 65 61 7a 65 20 74 68 72 with sleaze thr
1770: 6f 77 6e 20 69 6e 0a 3b 3b 3b 20 74 6f 20 6b 65 own in.;;; to ke
1780: 65 70 20 74 68 65 20 69 6e 74 65 72 6d 65 64 69 ep the intermedi
1790: 61 74 65 20 76 61 6c 75 65 73 20 73 6d 61 6c 6c ate values small
17a0: 2e 20 28 57 65 20 64 6f 20 74 68 65 20 63 61 6c . (We do the cal
17b0: 63 75 6c 61 74 69 6f 6e 20 77 69 74 68 20 6a 75 culation with ju
17c0: 73 74 0a 3b 3b 3b 20 65 6e 6f 75 67 68 20 62 69 st.;;; enough bi
17d0: 74 73 20 74 6f 20 72 65 70 72 65 73 65 6e 74 20 ts to represent
17e0: 42 4f 55 4e 44 2c 20 6d 61 73 6b 69 6e 67 20 6f BOUND, masking o
17f0: 66 66 20 68 69 67 68 20 62 69 74 73 20 61 74 20 ff high bits at
1800: 65 61 63 68 20 73 74 65 70 20 69 6e 0a 3b 3b 3b each step in.;;;
1810: 20 63 61 6c 63 75 6c 61 74 69 6f 6e 2e 20 49 66 calculation. If
1820: 20 74 68 69 73 20 73 63 72 65 77 73 20 75 70 20 this screws up
1830: 61 6e 79 20 69 6d 70 6f 72 74 61 6e 74 20 70 72 any important pr
1840: 6f 70 65 72 74 69 65 73 20 6f 66 20 74 68 65 20 operties of the
1850: 68 61 73 68 0a 3b 3b 3b 20 66 75 6e 63 74 69 6f hash.;;; functio
1860: 6e 20 49 27 64 20 6c 69 6b 65 20 74 6f 20 68 65 n I'd like to he
1870: 61 72 20 61 62 6f 75 74 20 69 74 2e 20 2d 4f 6c ar about it. -Ol
1880: 69 6e 29 0a 3b 3b 3b 0a 3b 3b 3b 20 49 66 20 79 in).;;;.;;; If y
1890: 6f 75 20 6b 65 65 70 20 42 4f 55 4e 44 20 73 6d ou keep BOUND sm
18a0: 61 6c 6c 20 65 6e 6f 75 67 68 2c 20 74 68 65 20 all enough, the
18b0: 69 6e 74 65 72 6d 65 64 69 61 74 65 20 63 61 6c intermediate cal
18c0: 63 75 6c 61 74 69 6f 6e 73 20 77 69 6c 6c 20 0a culations will .
18d0: 3b 3b 3b 20 61 6c 77 61 79 73 20 62 65 20 66 69 ;;; always be fi
18e0: 78 6e 75 6d 73 2e 20 48 6f 77 20 73 6d 61 6c 6c xnums. How small
18f0: 20 69 73 20 64 65 70 65 6e 64 65 6e 74 20 6f 6e is dependent on
1900: 20 74 68 65 20 75 6e 64 65 72 6c 79 69 6e 67 20 the underlying
1910: 53 63 68 65 6d 65 20 73 79 73 74 65 6d 3b 20 0a Scheme system; .
1920: 3b 3b 3b 20 77 65 20 75 73 65 20 61 20 64 65 66 ;;; we use a def
1930: 61 75 6c 74 20 42 4f 55 4e 44 20 6f 66 20 32 5e ault BOUND of 2^
1940: 32 32 20 3d 20 34 31 39 34 33 30 34 2c 20 77 68 22 = 4194304, wh
1950: 69 63 68 20 73 68 6f 75 6c 64 20 68 61 63 6b 20 ich should hack
1960: 69 74 20 69 6e 0a 3b 3b 3b 20 53 63 68 65 6d 65 it in.;;; Scheme
1970: 73 20 74 68 61 74 20 67 69 76 65 20 79 6f 75 20 s that give you
1980: 61 74 20 6c 65 61 73 74 20 32 39 20 73 69 67 6e at least 29 sign
1990: 65 64 20 62 69 74 73 20 66 6f 72 20 66 69 78 6e ed bits for fixn
19a0: 75 6d 73 2e 20 54 68 65 20 63 6f 72 65 20 0a 3b ums. The core .;
19b0: 3b 3b 20 63 61 6c 63 75 6c 61 74 69 6f 6e 20 74 ;; calculation t
19c0: 68 61 74 20 79 6f 75 20 64 6f 6e 27 74 20 77 61 hat you don't wa
19d0: 6e 74 20 74 6f 20 6f 76 65 72 66 6c 6f 77 20 69 nt to overflow i
19e0: 73 2c 20 77 6f 72 73 74 20 63 61 73 65 2c 0a 3b s, worst case,.;
19f0: 3b 3b 20 20 20 20 20 28 2b 20 36 35 35 33 35 20 ;; (+ 65535
1a00: 28 2a 20 33 37 20 28 2d 20 62 6f 75 6e 64 20 31 (* 37 (- bound 1
1a10: 29 29 29 0a 3b 3b 3b 20 77 68 65 72 65 20 36 35 ))).;;; where 65
1a20: 35 33 35 20 69 73 20 74 68 65 20 6d 61 78 20 63 535 is the max c
1a30: 68 61 72 61 63 74 65 72 20 63 6f 64 65 2e 20 43 haracter code. C
1a40: 68 6f 6f 73 65 20 74 68 65 20 64 65 66 61 75 6c hoose the defaul
1a50: 74 20 42 4f 55 4e 44 20 74 6f 20 62 65 20 74 68 t BOUND to be th
1a60: 65 0a 3b 3b 3b 20 62 69 67 67 65 73 74 20 70 6f e.;;; biggest po
1a70: 77 65 72 20 6f 66 20 74 77 6f 20 74 68 61 74 20 wer of two that
1a80: 77 6f 6e 27 74 20 63 61 75 73 65 20 74 68 69 73 won't cause this
1a90: 20 65 78 70 72 65 73 73 69 6f 6e 20 74 6f 20 66 expression to f
1aa0: 69 78 6e 75 6d 20 6f 76 65 72 66 6c 6f 77 2c 20 ixnum overflow,
1ab0: 0a 3b 3b 3b 20 61 6e 64 20 65 76 65 72 79 74 68 .;;; and everyth
1ac0: 69 6e 67 20 77 69 6c 6c 20 62 65 20 63 6f 70 61 ing will be copa
1ad0: 63 65 74 69 63 2e 0a 0a 28 64 65 66 69 6e 65 20 cetic...(define
1ae0: 28 63 68 61 72 2d 73 65 74 2d 68 61 73 68 20 63 (char-set-hash c
1af0: 73 20 2e 20 6d 61 79 62 65 2d 62 6f 75 6e 64 29 s . maybe-bound)
1b00: 0a 20 20 28 6c 65 74 2a 20 28 28 62 6f 75 6e 64 . (let* ((bound
1b10: 20 28 3a 6f 70 74 69 6f 6e 61 6c 20 6d 61 79 62 (:optional mayb
1b20: 65 2d 62 6f 75 6e 64 20 34 31 39 34 33 30 34 20 e-bound 4194304
1b30: 28 6c 61 6d 62 64 61 20 28 6e 29 20 28 61 6e 64 (lambda (n) (and
1b40: 20 28 69 6e 74 65 67 65 72 3f 20 6e 29 0a 09 09 (integer? n)...
1b50: 09 09 09 09 09 09 28 65 78 61 63 74 3f 20 6e 29 ......(exact? n)
1b60: 0a 09 09 09 09 09 09 09 09 28 3c 3d 20 30 20 6e .........(<= 0 n
1b70: 29 29 29 29 29 0a 09 20 28 62 6f 75 6e 64 20 28 ))))).. (bound (
1b80: 69 66 20 28 7a 65 72 6f 3f 20 62 6f 75 6e 64 29 if (zero? bound)
1b90: 20 34 31 39 34 33 30 34 20 62 6f 75 6e 64 29 29 4194304 bound))
1ba0: 09 3b 20 30 20 6d 65 61 6e 73 20 64 65 66 61 75 .; 0 means defau
1bb0: 6c 74 2e 0a 09 20 28 73 20 28 25 63 68 61 72 2d lt... (s (%char-
1bc0: 73 65 74 3a 73 2f 63 68 65 63 6b 20 63 73 20 27 set:s/check cs '
1bd0: 63 68 61 72 2d 73 65 74 2d 68 61 73 68 29 29 0a char-set-hash)).
1be0: 09 20 3b 3b 20 43 6f 6d 70 75 74 65 20 61 20 31 . ;; Compute a 1
1bf0: 31 31 2e 2e 2e 31 20 6d 61 73 6b 20 74 68 61 74 11...1 mask that
1c00: 20 77 69 6c 6c 20 63 6f 76 65 72 20 42 4f 55 4e will cover BOUN
1c10: 44 2d 31 3a 0a 09 20 28 6d 61 73 6b 20 28 6c 65 D-1:.. (mask (le
1c20: 74 20 6c 70 20 28 28 69 20 23 78 31 30 30 30 30 t lp ((i #x10000
1c30: 29 29 20 3b 20 4c 65 74 27 73 20 73 6b 69 70 20 )) ; Let's skip
1c40: 66 69 72 73 74 20 31 36 20 69 74 65 72 61 74 69 first 16 iterati
1c50: 6f 6e 73 2c 20 65 68 3f 0a 09 09 20 28 69 66 20 ons, eh?... (if
1c60: 28 3e 3d 20 69 20 62 6f 75 6e 64 29 20 28 2d 20 (>= i bound) (-
1c70: 69 20 31 29 20 28 6c 70 20 28 2b 20 69 20 69 29 i 1) (lp (+ i i)
1c80: 29 29 29 29 29 0a 0a 20 20 20 20 20 20 28 6c 65 ))))).. (le
1c90: 74 20 6c 70 20 28 28 69 20 32 35 35 29 20 28 61 t lp ((i 255) (a
1ca0: 6e 73 20 30 29 29 0a 09 28 69 66 20 28 3c 20 69 ns 0))..(if (< i
1cb0: 20 30 29 20 28 6d 6f 64 75 6c 6f 20 61 6e 73 20 0) (modulo ans
1cc0: 62 6f 75 6e 64 29 0a 09 20 20 20 20 28 6c 70 20 bound).. (lp
1cd0: 28 2d 20 69 20 31 29 0a 09 09 28 69 66 20 28 73 (- i 1)...(if (s
1ce0: 69 3d 30 3f 20 73 20 69 29 20 61 6e 73 0a 09 09 i=0? s i) ans...
1cf0: 20 20 20 20 28 62 69 74 77 69 73 65 2d 61 6e 64 (bitwise-and
1d00: 20 6d 61 73 6b 20 28 2b 20 28 2a 20 33 37 20 61 mask (+ (* 37 a
1d10: 6e 73 29 20 69 29 29 29 29 29 29 29 29 0a 0a 0a ns) i))))))))...
1d20: 28 64 65 66 69 6e 65 20 28 63 68 61 72 2d 73 65 (define (char-se
1d30: 74 2d 63 6f 6e 74 61 69 6e 73 3f 20 63 73 20 63 t-contains? cs c
1d40: 68 61 72 29 0a 20 20 28 63 68 65 63 6b 2d 61 72 har). (check-ar
1d50: 67 20 63 68 61 72 3f 20 63 68 61 72 20 27 63 68 g char? char 'ch
1d60: 61 72 2d 73 65 74 2d 63 6f 6e 74 61 69 6e 73 3f ar-set-contains?
1d70: 29 0a 20 20 28 73 69 3d 31 3f 20 28 25 63 68 61 ). (si=1? (%cha
1d80: 72 2d 73 65 74 3a 73 2f 63 68 65 63 6b 20 63 73 r-set:s/check cs
1d90: 20 27 63 68 61 72 2d 73 65 74 2d 63 6f 6e 74 61 'char-set-conta
1da0: 69 6e 73 3f 29 0a 09 20 28 25 63 68 61 72 2d 3e ins?).. (%char->
1db0: 6c 61 74 69 6e 31 20 63 68 61 72 29 29 29 0a 0a latin1 char)))..
1dc0: 28 64 65 66 69 6e 65 20 28 63 68 61 72 2d 73 65 (define (char-se
1dd0: 74 2d 73 69 7a 65 20 63 73 29 0a 20 20 28 6c 65 t-size cs). (le
1de0: 74 20 28 28 73 20 28 25 63 68 61 72 2d 73 65 74 t ((s (%char-set
1df0: 3a 73 2f 63 68 65 63 6b 20 63 73 20 27 63 68 61 :s/check cs 'cha
1e00: 72 2d 73 65 74 2d 73 69 7a 65 29 29 29 0a 20 20 r-set-size))).
1e10: 20 20 28 6c 65 74 20 6c 70 20 28 28 69 20 32 35 (let lp ((i 25
1e20: 35 29 20 28 73 69 7a 65 20 30 29 29 0a 20 20 20 5) (size 0)).
1e30: 20 20 20 28 69 66 20 28 3c 20 69 20 30 29 20 73 (if (< i 0) s
1e40: 69 7a 65 0a 09 20 20 28 6c 70 20 28 2d 20 69 20 ize.. (lp (- i
1e50: 31 29 20 28 2b 20 73 69 7a 65 20 28 73 69 20 73 1) (+ size (si s
1e60: 20 69 29 29 29 29 29 29 29 0a 0a 28 64 65 66 69 i)))))))..(defi
1e70: 6e 65 20 28 63 68 61 72 2d 73 65 74 2d 63 6f 75 ne (char-set-cou
1e80: 6e 74 20 70 72 65 64 20 63 73 65 74 29 0a 20 20 nt pred cset).
1e90: 28 63 68 65 63 6b 2d 61 72 67 20 70 72 6f 63 65 (check-arg proce
1ea0: 64 75 72 65 3f 20 70 72 65 64 20 27 63 68 61 72 dure? pred 'char
1eb0: 2d 73 65 74 2d 63 6f 75 6e 74 29 0a 20 20 28 6c -set-count). (l
1ec0: 65 74 20 28 28 73 20 28 25 63 68 61 72 2d 73 65 et ((s (%char-se
1ed0: 74 3a 73 2f 63 68 65 63 6b 20 63 73 65 74 20 27 t:s/check cset '
1ee0: 63 68 61 72 2d 73 65 74 2d 63 6f 75 6e 74 29 29 char-set-count))
1ef0: 29 0a 20 20 20 20 28 6c 65 74 20 6c 70 20 28 28 ). (let lp ((
1f00: 69 20 32 35 35 29 20 28 63 6f 75 6e 74 20 30 29 i 255) (count 0)
1f10: 29 0a 20 20 20 20 20 20 28 69 66 20 28 3c 20 69 ). (if (< i
1f20: 20 30 29 20 63 6f 75 6e 74 0a 09 20 20 28 6c 70 0) count.. (lp
1f30: 20 28 2d 20 69 20 31 29 0a 09 20 20 20 20 20 20 (- i 1)..
1f40: 28 69 66 20 28 61 6e 64 20 28 73 69 3d 31 3f 20 (if (and (si=1?
1f50: 73 20 69 29 20 28 70 72 65 64 20 28 25 6c 61 74 s i) (pred (%lat
1f60: 69 6e 31 2d 3e 63 68 61 72 20 69 29 29 29 0a 09 in1->char i)))..
1f70: 09 20 20 28 2b 20 63 6f 75 6e 74 20 31 29 0a 09 . (+ count 1)..
1f80: 09 20 20 63 6f 75 6e 74 29 29 29 29 29 29 0a 0a . count))))))..
1f90: 0a 3b 3b 3b 20 2d 2d 20 41 64 6a 6f 69 6e 20 26 .;;; -- Adjoin &
1fa0: 20 64 65 6c 65 74 65 0a 0a 28 64 65 66 69 6e 65 delete..(define
1fb0: 20 28 25 73 65 74 2d 63 68 61 72 2d 73 65 74 20 (%set-char-set
1fc0: 73 65 74 20 70 72 6f 63 20 63 73 20 63 68 61 72 set proc cs char
1fd0: 73 29 0a 20 20 28 6c 65 74 20 28 28 73 20 28 25 s). (let ((s (%
1fe0: 73 74 72 69 6e 67 2d 63 6f 70 79 20 28 25 63 68 string-copy (%ch
1ff0: 61 72 2d 73 65 74 3a 73 2f 63 68 65 63 6b 20 63 ar-set:s/check c
2000: 73 20 70 72 6f 63 29 29 29 29 0a 20 20 20 20 28 s proc)))). (
2010: 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 for-each (lambda
2020: 20 28 63 29 20 28 73 65 74 20 73 20 28 25 63 68 (c) (set s (%ch
2030: 61 72 2d 3e 6c 61 74 69 6e 31 20 63 29 29 29 0a ar->latin1 c))).
2040: 09 20 20 20 20 20 20 63 68 61 72 73 29 0a 20 20 . chars).
2050: 20 20 28 6d 61 6b 65 2d 63 68 61 72 2d 73 65 74 (make-char-set
2060: 20 73 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 s)))..(define (
2070: 25 73 65 74 2d 63 68 61 72 2d 73 65 74 21 20 73 %set-char-set! s
2080: 65 74 20 70 72 6f 63 20 63 73 20 63 68 61 72 73 et proc cs chars
2090: 29 0a 20 20 28 6c 65 74 20 28 28 73 20 28 25 63 ). (let ((s (%c
20a0: 68 61 72 2d 73 65 74 3a 73 2f 63 68 65 63 6b 20 har-set:s/check
20b0: 63 73 20 70 72 6f 63 29 29 29 0a 20 20 20 20 28 cs proc))). (
20c0: 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 for-each (lambda
20d0: 20 28 63 29 20 28 73 65 74 20 73 20 28 25 63 68 (c) (set s (%ch
20e0: 61 72 2d 3e 6c 61 74 69 6e 31 20 63 29 29 29 0a ar->latin1 c))).
20f0: 09 20 20 20 20 20 20 63 68 61 72 73 29 29 0a 20 . chars)).
2100: 20 63 73 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 cs)..(define (c
2110: 68 61 72 2d 73 65 74 2d 61 64 6a 6f 69 6e 20 63 har-set-adjoin c
2120: 73 20 2e 20 63 68 61 72 73 29 0a 20 20 28 25 73 s . chars). (%s
2130: 65 74 2d 63 68 61 72 2d 73 65 74 20 20 25 73 65 et-char-set %se
2140: 74 31 21 20 27 63 68 61 72 2d 73 65 74 2d 61 64 t1! 'char-set-ad
2150: 6a 6f 69 6e 20 63 73 20 63 68 61 72 73 29 29 0a join cs chars)).
2160: 28 64 65 66 69 6e 65 20 28 63 68 61 72 2d 73 65 (define (char-se
2170: 74 2d 61 64 6a 6f 69 6e 21 20 63 73 20 2e 20 63 t-adjoin! cs . c
2180: 68 61 72 73 29 0a 20 20 28 25 73 65 74 2d 63 68 hars). (%set-ch
2190: 61 72 2d 73 65 74 21 20 25 73 65 74 31 21 20 27 ar-set! %set1! '
21a0: 63 68 61 72 2d 73 65 74 2d 61 64 6a 6f 69 6e 21 char-set-adjoin!
21b0: 20 63 73 20 63 68 61 72 73 29 29 0a 28 64 65 66 cs chars)).(def
21c0: 69 6e 65 20 28 63 68 61 72 2d 73 65 74 2d 64 65 ine (char-set-de
21d0: 6c 65 74 65 20 63 73 20 2e 20 63 68 61 72 73 29 lete cs . chars)
21e0: 0a 20 20 28 25 73 65 74 2d 63 68 61 72 2d 73 65 . (%set-char-se
21f0: 74 20 20 25 73 65 74 30 21 20 27 63 68 61 72 2d t %set0! 'char-
2200: 73 65 74 2d 64 65 6c 65 74 65 20 63 73 20 63 68 set-delete cs ch
2210: 61 72 73 29 29 0a 28 64 65 66 69 6e 65 20 28 63 ars)).(define (c
2220: 68 61 72 2d 73 65 74 2d 64 65 6c 65 74 65 21 20 har-set-delete!
2230: 63 73 20 2e 20 63 68 61 72 73 29 0a 20 20 28 25 cs . chars). (%
2240: 73 65 74 2d 63 68 61 72 2d 73 65 74 21 20 25 73 set-char-set! %s
2250: 65 74 30 21 20 27 63 68 61 72 2d 73 65 74 2d 64 et0! 'char-set-d
2260: 65 6c 65 74 65 21 20 63 73 20 63 68 61 72 73 29 elete! cs chars)
2270: 29 0a 0a 0a 3b 3b 3b 20 43 75 72 73 6f 72 73 0a )...;;; Cursors.
2280: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
2290: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
22a0: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
22b0: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
22c0: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 0a ;;;;;;;;;;;;;;;.
22d0: 3b 3b 3b 20 53 69 6d 70 6c 65 20 69 6d 70 6c 65 ;;; Simple imple
22e0: 6d 65 6e 74 61 74 69 6f 6e 2e 20 41 20 63 75 72 mentation. A cur
22f0: 73 6f 72 73 20 69 73 20 61 6e 20 69 6e 74 65 67 sors is an integ
2300: 65 72 20 69 6e 64 65 78 20 69 6e 74 6f 20 74 68 er index into th
2310: 65 0a 3b 3b 3b 20 6d 61 72 6b 20 76 65 63 74 6f e.;;; mark vecto
2320: 72 2c 20 61 6e 64 20 2d 31 20 66 6f 72 20 74 68 r, and -1 for th
2330: 65 20 65 6e 64 2d 6f 66 2d 63 68 61 72 2d 73 65 e end-of-char-se
2340: 74 20 63 75 72 73 6f 72 2e 0a 3b 3b 3b 0a 3b 3b t cursor..;;;.;;
2350: 3b 20 49 66 20 77 65 20 72 65 70 72 65 73 65 6e ; If we represen
2360: 74 65 64 20 63 68 61 72 20 73 65 74 73 20 61 73 ted char sets as
2370: 20 61 20 62 69 74 20 73 65 74 2c 20 77 65 20 63 a bit set, we c
2380: 6f 75 6c 64 20 64 6f 20 74 68 65 20 66 6f 6c 6c ould do the foll
2390: 6f 77 69 6e 67 0a 3b 3b 3b 20 74 72 69 63 6b 20 owing.;;; trick
23a0: 74 6f 20 70 69 63 6b 20 74 68 65 20 6c 6f 77 65 to pick the lowe
23b0: 73 74 20 62 69 74 20 6f 75 74 20 6f 66 20 74 68 st bit out of th
23c0: 65 20 73 65 74 3a 20 0a 3b 3b 3b 20 20 20 28 63 e set: .;;; (c
23d0: 6f 75 6e 74 2d 62 69 74 73 20 28 78 6f 72 20 28 ount-bits (xor (
23e0: 2d 20 63 73 65 74 20 31 29 20 63 73 65 74 29 29 - cset 1) cset))
23f0: 0a 3b 3b 3b 20 28 42 75 74 20 66 69 72 73 74 20 .;;; (But first
2400: 6d 61 73 6b 20 6f 75 74 20 74 68 65 20 62 69 74 mask out the bit
2410: 73 20 61 6c 72 65 61 64 79 20 73 63 61 6e 6e 65 s already scanne
2420: 64 20 62 79 20 74 68 65 20 63 75 72 73 6f 72 20 d by the cursor
2430: 66 69 72 73 74 2e 29 0a 0a 28 64 65 66 69 6e 65 first.)..(define
2440: 20 28 63 68 61 72 2d 73 65 74 2d 63 75 72 73 6f (char-set-curso
2450: 72 20 63 73 65 74 29 0a 20 20 28 25 63 68 61 72 r cset). (%char
2460: 2d 73 65 74 2d 63 75 72 73 6f 72 2d 6e 65 78 74 -set-cursor-next
2470: 20 63 73 65 74 20 32 35 36 20 27 63 68 61 72 2d cset 256 'char-
2480: 73 65 74 2d 63 75 72 73 6f 72 29 29 0a 20 20 0a set-cursor)). .
2490: 28 64 65 66 69 6e 65 20 28 65 6e 64 2d 6f 66 2d (define (end-of-
24a0: 63 68 61 72 2d 73 65 74 3f 20 63 75 72 73 6f 72 char-set? cursor
24b0: 29 20 28 3c 20 63 75 72 73 6f 72 20 30 29 29 0a ) (< cursor 0)).
24c0: 0a 28 64 65 66 69 6e 65 20 28 63 68 61 72 2d 73 .(define (char-s
24d0: 65 74 2d 72 65 66 20 63 73 65 74 20 63 75 72 73 et-ref cset curs
24e0: 6f 72 29 20 28 25 6c 61 74 69 6e 31 2d 3e 63 68 or) (%latin1->ch
24f0: 61 72 20 63 75 72 73 6f 72 29 29 0a 0a 28 64 65 ar cursor))..(de
2500: 66 69 6e 65 20 28 63 68 61 72 2d 73 65 74 2d 63 fine (char-set-c
2510: 75 72 73 6f 72 2d 6e 65 78 74 20 63 73 65 74 20 ursor-next cset
2520: 63 75 72 73 6f 72 29 0a 20 20 28 63 68 65 63 6b cursor). (check
2530: 2d 61 72 67 20 28 6c 61 6d 62 64 61 20 28 69 29 -arg (lambda (i)
2540: 20 28 61 6e 64 20 28 69 6e 74 65 67 65 72 3f 20 (and (integer?
2550: 69 29 20 28 65 78 61 63 74 3f 20 69 29 20 28 3c i) (exact? i) (<
2560: 3d 20 30 20 69 20 32 35 35 29 29 29 20 63 75 72 = 0 i 255))) cur
2570: 73 6f 72 0a 09 20 20 20 20 20 27 63 68 61 72 2d sor.. 'char-
2580: 73 65 74 2d 63 75 72 73 6f 72 2d 6e 65 78 74 29 set-cursor-next)
2590: 0a 20 20 28 25 63 68 61 72 2d 73 65 74 2d 63 75 . (%char-set-cu
25a0: 72 73 6f 72 2d 6e 65 78 74 20 63 73 65 74 20 63 rsor-next cset c
25b0: 75 72 73 6f 72 20 27 63 68 61 72 2d 73 65 74 2d ursor 'char-set-
25c0: 63 75 72 73 6f 72 2d 6e 65 78 74 29 29 0a 0a 28 cursor-next))..(
25d0: 64 65 66 69 6e 65 20 28 25 63 68 61 72 2d 73 65 define (%char-se
25e0: 74 2d 63 75 72 73 6f 72 2d 6e 65 78 74 20 63 73 t-cursor-next cs
25f0: 65 74 20 63 75 72 73 6f 72 20 70 72 6f 63 29 09 et cursor proc).
2600: 3b 20 49 6e 74 65 72 6e 61 6c 0a 20 20 28 6c 65 ; Internal. (le
2610: 74 20 28 28 73 20 28 25 63 68 61 72 2d 73 65 74 t ((s (%char-set
2620: 3a 73 2f 63 68 65 63 6b 20 63 73 65 74 20 70 72 :s/check cset pr
2630: 6f 63 29 29 29 0a 20 20 20 20 28 6c 65 74 20 6c oc))). (let l
2640: 70 20 28 28 63 75 72 20 63 75 72 73 6f 72 29 29 p ((cur cursor))
2650: 0a 20 20 20 20 20 20 28 6c 65 74 20 28 28 63 75 . (let ((cu
2660: 72 20 28 2d 20 63 75 72 20 31 29 29 29 0a 09 28 r (- cur 1)))..(
2670: 69 66 20 28 6f 72 20 28 3c 20 63 75 72 20 30 29 if (or (< cur 0)
2680: 20 28 73 69 3d 31 3f 20 73 20 63 75 72 29 29 20 (si=1? s cur))
2690: 63 75 72 0a 09 20 20 20 20 28 6c 70 20 63 75 72 cur.. (lp cur
26a0: 29 29 29 29 29 29 0a 0a 0a 3b 3b 3b 20 2d 2d 20 ))))))...;;; --
26b0: 66 6f 72 2d 65 61 63 68 20 6d 61 70 20 66 6f 6c for-each map fol
26c0: 64 20 75 6e 66 6f 6c 64 20 65 76 65 72 79 20 61 d unfold every a
26d0: 6e 79 0a 0a 28 64 65 66 69 6e 65 20 28 63 68 61 ny..(define (cha
26e0: 72 2d 73 65 74 2d 66 6f 72 2d 65 61 63 68 20 70 r-set-for-each p
26f0: 72 6f 63 20 63 73 29 0a 20 20 28 63 68 65 63 6b roc cs). (check
2700: 2d 61 72 67 20 70 72 6f 63 65 64 75 72 65 3f 20 -arg procedure?
2710: 70 72 6f 63 20 27 63 68 61 72 2d 73 65 74 2d 66 proc 'char-set-f
2720: 6f 72 2d 65 61 63 68 29 0a 20 20 28 6c 65 74 20 or-each). (let
2730: 28 28 73 20 28 25 63 68 61 72 2d 73 65 74 3a 73 ((s (%char-set:s
2740: 2f 63 68 65 63 6b 20 63 73 20 27 63 68 61 72 2d /check cs 'char-
2750: 73 65 74 2d 66 6f 72 2d 65 61 63 68 29 29 29 0a set-for-each))).
2760: 20 20 20 20 28 6c 65 74 20 6c 70 20 28 28 69 20 (let lp ((i
2770: 32 35 35 29 29 0a 20 20 20 20 20 20 28 63 6f 6e 255)). (con
2780: 64 20 28 28 3e 3d 20 69 20 30 29 0a 09 20 20 20 d ((>= i 0)..
2790: 20 20 28 69 66 20 28 73 69 3d 31 3f 20 73 20 69 (if (si=1? s i
27a0: 29 20 28 70 72 6f 63 20 28 25 6c 61 74 69 6e 31 ) (proc (%latin1
27b0: 2d 3e 63 68 61 72 20 69 29 29 29 0a 09 20 20 20 ->char i)))..
27c0: 20 20 28 6c 70 20 28 2d 20 69 20 31 29 29 29 29 (lp (- i 1))))
27d0: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 68 )))..(define (ch
27e0: 61 72 2d 73 65 74 2d 6d 61 70 20 70 72 6f 63 20 ar-set-map proc
27f0: 63 73 29 0a 20 20 28 63 68 65 63 6b 2d 61 72 67 cs). (check-arg
2800: 20 70 72 6f 63 65 64 75 72 65 3f 20 70 72 6f 63 procedure? proc
2810: 20 27 63 68 61 72 2d 73 65 74 2d 6d 61 70 29 0a 'char-set-map).
2820: 20 20 28 6c 65 74 20 28 28 73 20 28 25 63 68 61 (let ((s (%cha
2830: 72 2d 73 65 74 3a 73 2f 63 68 65 63 6b 20 63 73 r-set:s/check cs
2840: 20 27 63 68 61 72 2d 73 65 74 2d 6d 61 70 29 29 'char-set-map))
2850: 0a 09 28 61 6e 73 20 28 6d 61 6b 65 2d 73 74 72 ..(ans (make-str
2860: 69 6e 67 20 32 35 36 20 63 30 29 29 29 0a 20 20 ing 256 c0))).
2870: 20 20 28 6c 65 74 20 6c 70 20 28 28 69 20 32 35 (let lp ((i 25
2880: 35 29 29 0a 20 20 20 20 20 20 28 63 6f 6e 64 20 5)). (cond
2890: 28 28 3e 3d 20 69 20 30 29 0a 09 20 20 20 20 20 ((>= i 0)..
28a0: 28 69 66 20 28 73 69 3d 31 3f 20 73 20 69 29 0a (if (si=1? s i).
28b0: 09 09 20 28 25 73 65 74 31 21 20 61 6e 73 20 28 .. (%set1! ans (
28c0: 25 63 68 61 72 2d 3e 6c 61 74 69 6e 31 20 28 70 %char->latin1 (p
28d0: 72 6f 63 20 28 25 6c 61 74 69 6e 31 2d 3e 63 68 roc (%latin1->ch
28e0: 61 72 20 69 29 29 29 29 29 0a 09 20 20 20 20 20 ar i)))))..
28f0: 28 6c 70 20 28 2d 20 69 20 31 29 29 29 29 29 0a (lp (- i 1))))).
2900: 20 20 20 20 28 6d 61 6b 65 2d 63 68 61 72 2d 73 (make-char-s
2910: 65 74 20 61 6e 73 29 29 29 0a 0a 28 64 65 66 69 et ans)))..(defi
2920: 6e 65 20 28 63 68 61 72 2d 73 65 74 2d 66 6f 6c ne (char-set-fol
2930: 64 20 6b 6f 6e 73 20 6b 6e 69 6c 20 63 73 29 0a d kons knil cs).
2940: 20 20 28 63 68 65 63 6b 2d 61 72 67 20 70 72 6f (check-arg pro
2950: 63 65 64 75 72 65 3f 20 6b 6f 6e 73 20 27 63 68 cedure? kons 'ch
2960: 61 72 2d 73 65 74 2d 66 6f 6c 64 29 0a 20 20 28 ar-set-fold). (
2970: 6c 65 74 20 28 28 73 20 28 25 63 68 61 72 2d 73 let ((s (%char-s
2980: 65 74 3a 73 2f 63 68 65 63 6b 20 63 73 20 27 63 et:s/check cs 'c
2990: 68 61 72 2d 73 65 74 2d 66 6f 6c 64 29 29 29 0a har-set-fold))).
29a0: 20 20 20 20 28 6c 65 74 20 6c 70 20 28 28 69 20 (let lp ((i
29b0: 32 35 35 29 20 28 61 6e 73 20 6b 6e 69 6c 29 29 255) (ans knil))
29c0: 0a 20 20 20 20 20 20 28 69 66 20 28 3c 20 69 20 . (if (< i
29d0: 30 29 20 61 6e 73 0a 09 20 20 28 6c 70 20 28 2d 0) ans.. (lp (-
29e0: 20 69 20 31 29 0a 09 20 20 20 20 20 20 28 69 66 i 1).. (if
29f0: 20 28 73 69 3d 30 3f 20 73 20 69 29 20 61 6e 73 (si=0? s i) ans
2a00: 0a 09 09 20 20 28 6b 6f 6e 73 20 28 25 6c 61 74 ... (kons (%lat
2a10: 69 6e 31 2d 3e 63 68 61 72 20 69 29 20 61 6e 73 in1->char i) ans
2a20: 29 29 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 )))))))..(define
2a30: 20 28 63 68 61 72 2d 73 65 74 2d 65 76 65 72 79 (char-set-every
2a40: 20 70 72 65 64 20 63 73 29 0a 20 20 28 63 68 65 pred cs). (che
2a50: 63 6b 2d 61 72 67 20 70 72 6f 63 65 64 75 72 65 ck-arg procedure
2a60: 3f 20 70 72 65 64 20 27 63 68 61 72 2d 73 65 74 ? pred 'char-set
2a70: 2d 65 76 65 72 79 29 0a 20 20 28 6c 65 74 20 28 -every). (let (
2a80: 28 73 20 28 25 63 68 61 72 2d 73 65 74 3a 73 2f (s (%char-set:s/
2a90: 63 68 65 63 6b 20 63 73 20 27 63 68 61 72 2d 73 check cs 'char-s
2aa0: 65 74 2d 65 76 65 72 79 29 29 29 0a 20 20 20 20 et-every))).
2ab0: 28 6c 65 74 20 6c 70 20 28 28 69 20 32 35 35 29 (let lp ((i 255)
2ac0: 29 0a 20 20 20 20 20 20 28 6f 72 20 28 3c 20 69 ). (or (< i
2ad0: 20 30 29 0a 09 20 20 28 61 6e 64 20 28 6f 72 20 0).. (and (or
2ae0: 28 73 69 3d 30 3f 20 73 20 69 29 20 28 70 72 65 (si=0? s i) (pre
2af0: 64 20 28 25 6c 61 74 69 6e 31 2d 3e 63 68 61 72 d (%latin1->char
2b00: 20 69 29 29 29 0a 09 20 20 20 20 20 20 20 28 6c i))).. (l
2b10: 70 20 28 2d 20 69 20 31 29 29 29 29 29 29 29 0a p (- i 1))))))).
2b20: 0a 28 64 65 66 69 6e 65 20 28 63 68 61 72 2d 73 .(define (char-s
2b30: 65 74 2d 61 6e 79 20 70 72 65 64 20 63 73 29 0a et-any pred cs).
2b40: 20 20 28 63 68 65 63 6b 2d 61 72 67 20 70 72 6f (check-arg pro
2b50: 63 65 64 75 72 65 3f 20 70 72 65 64 20 27 63 68 cedure? pred 'ch
2b60: 61 72 2d 73 65 74 2d 61 6e 79 29 0a 20 20 28 6c ar-set-any). (l
2b70: 65 74 20 28 28 73 20 28 25 63 68 61 72 2d 73 65 et ((s (%char-se
2b80: 74 3a 73 2f 63 68 65 63 6b 20 63 73 20 27 63 68 t:s/check cs 'ch
2b90: 61 72 2d 73 65 74 2d 61 6e 79 29 29 29 0a 20 20 ar-set-any))).
2ba0: 20 20 28 6c 65 74 20 6c 70 20 28 28 69 20 32 35 (let lp ((i 25
2bb0: 35 29 29 0a 20 20 20 20 20 20 28 61 6e 64 20 28 5)). (and (
2bc0: 3e 3d 20 69 20 30 29 0a 09 20 20 20 28 6f 72 20 >= i 0).. (or
2bd0: 28 61 6e 64 20 28 73 69 3d 31 3f 20 73 20 69 29 (and (si=1? s i)
2be0: 20 28 70 72 65 64 20 28 25 6c 61 74 69 6e 31 2d (pred (%latin1-
2bf0: 3e 63 68 61 72 20 69 29 29 29 0a 09 20 20 20 20 >char i)))..
2c00: 20 20 20 28 6c 70 20 28 2d 20 69 20 31 29 29 29 (lp (- i 1)))
2c10: 29 29 29 29 0a 0a 0a 28 64 65 66 69 6e 65 20 28 ))))...(define (
2c20: 25 63 68 61 72 2d 73 65 74 2d 75 6e 66 6f 6c 64 %char-set-unfold
2c30: 21 20 70 72 6f 63 20 70 20 66 20 67 20 73 20 73 ! proc p f g s s
2c40: 65 65 64 29 0a 20 20 28 63 68 65 63 6b 2d 61 72 eed). (check-ar
2c50: 67 20 70 72 6f 63 65 64 75 72 65 3f 20 70 20 70 g procedure? p p
2c60: 72 6f 63 29 0a 20 20 28 63 68 65 63 6b 2d 61 72 roc). (check-ar
2c70: 67 20 70 72 6f 63 65 64 75 72 65 3f 20 66 20 70 g procedure? f p
2c80: 72 6f 63 29 0a 20 20 28 63 68 65 63 6b 2d 61 72 roc). (check-ar
2c90: 67 20 70 72 6f 63 65 64 75 72 65 3f 20 67 20 70 g procedure? g p
2ca0: 72 6f 63 29 0a 20 20 28 6c 65 74 20 6c 70 20 28 roc). (let lp (
2cb0: 28 73 65 65 64 20 73 65 65 64 29 29 0a 20 20 20 (seed seed)).
2cc0: 20 28 63 6f 6e 64 20 28 28 6e 6f 74 20 28 70 20 (cond ((not (p
2cd0: 73 65 65 64 29 29 09 09 09 3b 20 50 20 73 61 79 seed))...; P say
2ce0: 73 20 77 65 20 61 72 65 20 64 6f 6e 65 2e 0a 09 s we are done...
2cf0: 20 20 20 28 25 73 65 74 31 21 20 73 20 28 25 63 (%set1! s (%c
2d00: 68 61 72 2d 3e 6c 61 74 69 6e 31 20 28 66 20 73 har->latin1 (f s
2d10: 65 65 64 29 29 29 09 3b 20 41 64 64 20 28 46 20 eed))).; Add (F
2d20: 53 45 45 44 29 20 74 6f 20 73 65 74 2e 0a 09 20 SEED) to set...
2d30: 20 20 28 6c 70 20 28 67 20 73 65 65 64 29 29 29 (lp (g seed)))
2d40: 29 29 29 09 09 09 3b 20 4c 6f 6f 70 20 6f 6e 20 )))...; Loop on
2d50: 28 47 20 53 45 45 44 29 2e 0a 0a 28 64 65 66 69 (G SEED)...(defi
2d60: 6e 65 20 28 63 68 61 72 2d 73 65 74 2d 75 6e 66 ne (char-set-unf
2d70: 6f 6c 64 20 70 20 66 20 67 20 73 65 65 64 20 2e old p f g seed .
2d80: 20 6d 61 79 62 65 2d 62 61 73 65 29 0a 20 20 28 maybe-base). (
2d90: 6c 65 74 20 28 28 62 73 20 28 25 64 65 66 61 75 let ((bs (%defau
2da0: 6c 74 2d 62 61 73 65 20 6d 61 79 62 65 2d 62 61 lt-base maybe-ba
2db0: 73 65 20 27 63 68 61 72 2d 73 65 74 2d 75 6e 66 se 'char-set-unf
2dc0: 6f 6c 64 29 29 29 0a 20 20 20 20 28 25 63 68 61 old))). (%cha
2dd0: 72 2d 73 65 74 2d 75 6e 66 6f 6c 64 21 20 27 63 r-set-unfold! 'c
2de0: 68 61 72 2d 73 65 74 2d 75 6e 66 6f 6c 64 20 70 har-set-unfold p
2df0: 20 66 20 67 20 62 73 20 73 65 65 64 29 0a 20 20 f g bs seed).
2e00: 20 20 28 6d 61 6b 65 2d 63 68 61 72 2d 73 65 74 (make-char-set
2e10: 20 62 73 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 bs)))..(define
2e20: 28 63 68 61 72 2d 73 65 74 2d 75 6e 66 6f 6c 64 (char-set-unfold
2e30: 21 20 70 20 66 20 67 20 73 65 65 64 20 62 61 73 ! p f g seed bas
2e40: 65 2d 63 73 65 74 29 0a 20 20 28 25 63 68 61 72 e-cset). (%char
2e50: 2d 73 65 74 2d 75 6e 66 6f 6c 64 21 20 27 63 68 -set-unfold! 'ch
2e60: 61 72 2d 73 65 74 2d 75 6e 66 6f 6c 64 21 20 70 ar-set-unfold! p
2e70: 20 66 20 67 0a 09 09 20 20 20 20 20 28 25 63 68 f g... (%ch
2e80: 61 72 2d 73 65 74 3a 73 2f 63 68 65 63 6b 20 62 ar-set:s/check b
2e90: 61 73 65 2d 63 73 65 74 20 27 63 68 61 72 2d 73 ase-cset 'char-s
2ea0: 65 74 2d 75 6e 66 6f 6c 64 21 29 0a 09 09 20 20 et-unfold!)...
2eb0: 20 20 20 73 65 65 64 29 0a 20 20 62 61 73 65 2d seed). base-
2ec0: 63 73 65 74 29 0a 0a 0a 0a 3b 3b 3b 20 6c 69 73 cset)....;;; lis
2ed0: 74 20 3c 2d 2d 3e 20 63 68 61 72 2d 73 65 74 0a t <--> char-set.
2ee0: 0a 28 64 65 66 69 6e 65 20 28 25 6c 69 73 74 2d .(define (%list-
2ef0: 3e 63 68 61 72 2d 73 65 74 21 20 63 68 61 72 73 >char-set! chars
2f00: 20 73 29 0a 20 20 28 66 6f 72 2d 65 61 63 68 20 s). (for-each
2f10: 28 6c 61 6d 62 64 61 20 28 63 68 61 72 29 20 28 (lambda (char) (
2f20: 25 73 65 74 31 21 20 73 20 28 25 63 68 61 72 2d %set1! s (%char-
2f30: 3e 6c 61 74 69 6e 31 20 63 68 61 72 29 29 29 0a >latin1 char))).
2f40: 09 20 20 20 20 63 68 61 72 73 29 29 0a 0a 28 64 . chars))..(d
2f50: 65 66 69 6e 65 20 28 63 68 61 72 2d 73 65 74 20 efine (char-set
2f60: 2e 20 63 68 61 72 73 29 0a 20 20 28 6c 65 74 20 . chars). (let
2f70: 28 28 73 20 28 6d 61 6b 65 2d 73 74 72 69 6e 67 ((s (make-string
2f80: 20 32 35 36 20 63 30 29 29 29 0a 20 20 20 20 28 256 c0))). (
2f90: 25 6c 69 73 74 2d 3e 63 68 61 72 2d 73 65 74 21 %list->char-set!
2fa0: 20 63 68 61 72 73 20 73 29 0a 20 20 20 20 28 6d chars s). (m
2fb0: 61 6b 65 2d 63 68 61 72 2d 73 65 74 20 73 29 29 ake-char-set s))
2fc0: 29 0a 0a 28 64 65 66 69 6e 65 20 28 6c 69 73 74 )..(define (list
2fd0: 2d 3e 63 68 61 72 2d 73 65 74 20 63 68 61 72 73 ->char-set chars
2fe0: 20 2e 20 6d 61 79 62 65 2d 62 61 73 65 29 0a 20 . maybe-base).
2ff0: 20 28 6c 65 74 20 28 28 62 73 20 28 25 64 65 66 (let ((bs (%def
3000: 61 75 6c 74 2d 62 61 73 65 20 6d 61 79 62 65 2d ault-base maybe-
3010: 62 61 73 65 20 27 6c 69 73 74 2d 3e 63 68 61 72 base 'list->char
3020: 2d 73 65 74 29 29 29 0a 20 20 20 20 28 25 6c 69 -set))). (%li
3030: 73 74 2d 3e 63 68 61 72 2d 73 65 74 21 20 63 68 st->char-set! ch
3040: 61 72 73 20 62 73 29 0a 20 20 20 20 28 6d 61 6b ars bs). (mak
3050: 65 2d 63 68 61 72 2d 73 65 74 20 62 73 29 29 29 e-char-set bs)))
3060: 0a 0a 28 64 65 66 69 6e 65 20 28 6c 69 73 74 2d ..(define (list-
3070: 3e 63 68 61 72 2d 73 65 74 21 20 63 68 61 72 73 >char-set! chars
3080: 20 62 61 73 65 2d 63 73 29 0a 20 20 28 25 6c 69 base-cs). (%li
3090: 73 74 2d 3e 63 68 61 72 2d 73 65 74 21 20 63 68 st->char-set! ch
30a0: 61 72 73 20 28 25 63 68 61 72 2d 73 65 74 3a 73 ars (%char-set:s
30b0: 2f 63 68 65 63 6b 20 62 61 73 65 2d 63 73 20 27 /check base-cs '
30c0: 6c 69 73 74 2d 3e 63 68 61 72 2d 73 65 74 21 29 list->char-set!)
30d0: 29 0a 20 20 62 61 73 65 2d 63 73 29 0a 0a 0a 28 ). base-cs)...(
30e0: 64 65 66 69 6e 65 20 28 63 68 61 72 2d 73 65 74 define (char-set
30f0: 2d 3e 6c 69 73 74 20 63 73 29 0a 20 20 28 6c 65 ->list cs). (le
3100: 74 20 28 28 73 20 28 25 63 68 61 72 2d 73 65 74 t ((s (%char-set
3110: 3a 73 2f 63 68 65 63 6b 20 63 73 20 27 63 68 61 :s/check cs 'cha
3120: 72 2d 73 65 74 2d 3e 6c 69 73 74 29 29 29 0a 20 r-set->list))).
3130: 20 20 20 28 6c 65 74 20 6c 70 20 28 28 69 20 32 (let lp ((i 2
3140: 35 35 29 20 28 61 6e 73 20 27 28 29 29 29 0a 20 55) (ans '())).
3150: 20 20 20 20 20 28 69 66 20 28 3c 20 69 20 30 29 (if (< i 0)
3160: 20 61 6e 73 0a 09 20 20 28 6c 70 20 28 2d 20 69 ans.. (lp (- i
3170: 20 31 29 0a 09 20 20 20 20 20 20 28 69 66 20 28 1).. (if (
3180: 73 69 3d 30 3f 20 73 20 69 29 20 61 6e 73 0a 09 si=0? s i) ans..
3190: 09 20 20 28 63 6f 6e 73 20 28 25 6c 61 74 69 6e . (cons (%latin
31a0: 31 2d 3e 63 68 61 72 20 69 29 20 61 6e 73 29 29 1->char i) ans))
31b0: 29 29 29 29 29 0a 0a 0a 0a 3b 3b 3b 20 73 74 72 )))))....;;; str
31c0: 69 6e 67 20 3c 2d 2d 3e 20 63 68 61 72 2d 73 65 ing <--> char-se
31d0: 74 0a 0a 28 64 65 66 69 6e 65 20 28 25 73 74 72 t..(define (%str
31e0: 69 6e 67 2d 3e 63 68 61 72 2d 73 65 74 21 20 73 ing->char-set! s
31f0: 74 72 20 62 73 20 70 72 6f 63 29 0a 20 20 28 63 tr bs proc). (c
3200: 68 65 63 6b 2d 61 72 67 20 73 74 72 69 6e 67 3f heck-arg string?
3210: 20 73 74 72 20 70 72 6f 63 29 0a 20 20 28 64 6f str proc). (do
3220: 20 28 28 69 20 28 2d 20 28 73 74 72 69 6e 67 2d ((i (- (string-
3230: 6c 65 6e 67 74 68 20 73 74 72 29 20 31 29 20 28 length str) 1) (
3240: 2d 20 69 20 31 29 29 29 0a 20 20 20 20 20 20 28 - i 1))). (
3250: 28 3c 20 69 20 30 29 29 0a 20 20 20 20 28 25 73 (< i 0)). (%s
3260: 65 74 31 21 20 62 73 20 28 25 63 68 61 72 2d 3e et1! bs (%char->
3270: 6c 61 74 69 6e 31 20 28 73 74 72 69 6e 67 2d 72 latin1 (string-r
3280: 65 66 20 73 74 72 20 69 29 29 29 29 29 0a 0a 28 ef str i)))))..(
3290: 64 65 66 69 6e 65 20 28 73 74 72 69 6e 67 2d 3e define (string->
32a0: 63 68 61 72 2d 73 65 74 20 73 74 72 20 2e 20 6d char-set str . m
32b0: 61 79 62 65 2d 62 61 73 65 29 0a 20 20 28 6c 65 aybe-base). (le
32c0: 74 20 28 28 62 73 20 28 25 64 65 66 61 75 6c 74 t ((bs (%default
32d0: 2d 62 61 73 65 20 6d 61 79 62 65 2d 62 61 73 65 -base maybe-base
32e0: 20 27 73 74 72 69 6e 67 2d 3e 63 68 61 72 2d 73 'string->char-s
32f0: 65 74 29 29 29 0a 20 20 20 20 28 25 73 74 72 69 et))). (%stri
3300: 6e 67 2d 3e 63 68 61 72 2d 73 65 74 21 20 73 74 ng->char-set! st
3310: 72 20 62 73 20 27 73 74 72 69 6e 67 2d 3e 63 68 r bs 'string->ch
3320: 61 72 2d 73 65 74 29 0a 20 20 20 20 28 6d 61 6b ar-set). (mak
3330: 65 2d 63 68 61 72 2d 73 65 74 20 62 73 29 29 29 e-char-set bs)))
3340: 0a 0a 28 64 65 66 69 6e 65 20 28 73 74 72 69 6e ..(define (strin
3350: 67 2d 3e 63 68 61 72 2d 73 65 74 21 20 73 74 72 g->char-set! str
3360: 20 62 61 73 65 2d 63 73 29 0a 20 20 28 25 73 74 base-cs). (%st
3370: 72 69 6e 67 2d 3e 63 68 61 72 2d 73 65 74 21 20 ring->char-set!
3380: 73 74 72 20 28 25 63 68 61 72 2d 73 65 74 3a 73 str (%char-set:s
3390: 2f 63 68 65 63 6b 20 62 61 73 65 2d 63 73 20 27 /check base-cs '
33a0: 73 74 72 69 6e 67 2d 3e 63 68 61 72 2d 73 65 74 string->char-set
33b0: 21 29 0a 09 09 20 20 20 20 20 20 27 73 74 72 69 !)... 'stri
33c0: 6e 67 2d 3e 63 68 61 72 2d 73 65 74 21 29 0a 20 ng->char-set!).
33d0: 20 62 61 73 65 2d 63 73 29 0a 0a 0a 28 64 65 66 base-cs)...(def
33e0: 69 6e 65 20 28 63 68 61 72 2d 73 65 74 2d 3e 73 ine (char-set->s
33f0: 74 72 69 6e 67 20 63 73 29 0a 20 20 28 6c 65 74 tring cs). (let
3400: 2a 20 28 28 73 20 28 25 63 68 61 72 2d 73 65 74 * ((s (%char-set
3410: 3a 73 2f 63 68 65 63 6b 20 63 73 20 27 63 68 61 :s/check cs 'cha
3420: 72 2d 73 65 74 2d 3e 73 74 72 69 6e 67 29 29 0a r-set->string)).
3430: 09 20 28 61 6e 73 20 28 6d 61 6b 65 2d 73 74 72 . (ans (make-str
3440: 69 6e 67 20 28 63 68 61 72 2d 73 65 74 2d 73 69 ing (char-set-si
3450: 7a 65 20 63 73 29 29 29 29 0a 20 20 20 20 28 6c ze cs)))). (l
3460: 65 74 20 6c 70 20 28 28 69 20 32 35 35 29 20 28 et lp ((i 255) (
3470: 6a 20 30 29 29 0a 20 20 20 20 20 20 28 69 66 20 j 0)). (if
3480: 28 3c 20 69 20 30 29 20 61 6e 73 0a 09 20 20 28 (< i 0) ans.. (
3490: 6c 65 74 20 28 28 6a 20 28 69 66 20 28 73 69 3d let ((j (if (si=
34a0: 30 3f 20 73 20 69 29 20 6a 0a 09 09 20 20 20 20 0? s i) j...
34b0: 20 20 20 28 62 65 67 69 6e 20 28 73 74 72 69 6e (begin (strin
34c0: 67 2d 73 65 74 21 20 61 6e 73 20 6a 20 28 25 6c g-set! ans j (%l
34d0: 61 74 69 6e 31 2d 3e 63 68 61 72 20 69 29 29 0a atin1->char i)).
34e0: 09 09 09 20 20 20 20 20 20 28 2b 20 6a 20 31 29 ... (+ j 1)
34f0: 29 29 29 29 0a 09 20 20 20 20 28 6c 70 20 28 2d )))).. (lp (-
3500: 20 69 20 31 29 20 6a 29 29 29 29 29 29 0a 0a 0a i 1) j))))))...
3510: 3b 3b 3b 20 2d 2d 20 55 43 53 2d 72 61 6e 67 65 ;;; -- UCS-range
3520: 20 2d 3e 20 63 68 61 72 2d 73 65 74 0a 0a 28 64 -> char-set..(d
3530: 65 66 69 6e 65 20 28 25 75 63 73 2d 72 61 6e 67 efine (%ucs-rang
3540: 65 2d 3e 63 68 61 72 2d 73 65 74 21 20 6c 6f 77 e->char-set! low
3550: 65 72 20 75 70 70 65 72 20 65 72 72 6f 72 3f 20 er upper error?
3560: 62 73 20 70 72 6f 63 29 0a 20 20 28 63 68 65 63 bs proc). (chec
3570: 6b 2d 61 72 67 20 28 6c 61 6d 62 64 61 20 28 78 k-arg (lambda (x
3580: 29 20 28 61 6e 64 20 28 69 6e 74 65 67 65 72 3f ) (and (integer?
3590: 20 78 29 20 28 65 78 61 63 74 3f 20 78 29 20 28 x) (exact? x) (
35a0: 3c 3d 20 30 20 78 29 29 29 20 6c 6f 77 65 72 20 <= 0 x))) lower
35b0: 70 72 6f 63 29 0a 20 20 28 63 68 65 63 6b 2d 61 proc). (check-a
35c0: 72 67 20 28 6c 61 6d 62 64 61 20 28 78 29 20 28 rg (lambda (x) (
35d0: 61 6e 64 20 28 69 6e 74 65 67 65 72 3f 20 78 29 and (integer? x)
35e0: 20 28 65 78 61 63 74 3f 20 78 29 20 28 3c 3d 20 (exact? x) (<=
35f0: 6c 6f 77 65 72 20 78 29 29 29 20 75 70 70 65 72 lower x))) upper
3600: 20 70 72 6f 63 29 0a 0a 20 20 28 69 66 20 28 61 proc).. (if (a
3610: 6e 64 20 28 3c 20 6c 6f 77 65 72 20 75 70 70 65 nd (< lower uppe
3620: 72 29 20 28 3c 20 32 35 36 20 75 70 70 65 72 29 r) (< 256 upper)
3630: 20 65 72 72 6f 72 3f 29 0a 20 20 20 20 20 20 28 error?). (
3640: 61 73 73 65 72 74 69 6f 6e 2d 76 69 6f 6c 61 74 assertion-violat
3650: 69 6f 6e 20 70 72 6f 63 0a 20 20 20 20 20 20 20 ion proc.
3660: 22 52 65 71 75 65 73 74 65 64 20 55 43 53 20 72 "Requested UCS r
3670: 61 6e 67 65 20 63 6f 6e 74 61 69 6e 73 20 75 6e ange contains un
3680: 61 76 61 69 6c 61 62 6c 65 20 63 68 61 72 61 63 available charac
3690: 74 65 72 73 20 2d 2d 20 74 68 69 73 20 69 6d 70 ters -- this imp
36a0: 6c 65 6d 65 6e 74 61 74 69 6f 6e 20 6f 6e 6c 79 lementation only
36b0: 20 73 75 70 70 6f 72 74 73 20 4c 61 74 69 6e 2d supports Latin-
36c0: 31 22 0a 09 20 20 20 20 20 6c 6f 77 65 72 20 75 1".. lower u
36d0: 70 70 65 72 29 29 0a 0a 20 20 28 6c 65 74 20 6c pper)).. (let l
36e0: 70 20 28 28 69 20 28 2d 20 28 6d 69 6e 20 75 70 p ((i (- (min up
36f0: 70 65 72 20 32 35 36 29 20 31 29 29 29 0a 20 20 per 256) 1))).
3700: 20 20 28 63 6f 6e 64 20 28 28 3c 3d 20 6c 6f 77 (cond ((<= low
3710: 65 72 20 69 29 20 28 25 73 65 74 31 21 20 62 73 er i) (%set1! bs
3720: 20 69 29 20 28 6c 70 20 28 2d 20 69 20 31 29 29 i) (lp (- i 1))
3730: 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 75 ))))..(define (u
3740: 63 73 2d 72 61 6e 67 65 2d 3e 63 68 61 72 2d 73 cs-range->char-s
3750: 65 74 20 6c 6f 77 65 72 20 75 70 70 65 72 20 2e et lower upper .
3760: 20 72 65 73 74 29 0a 20 20 28 6c 65 74 2d 6f 70 rest). (let-op
3770: 74 69 6f 6e 61 6c 73 2a 20 72 65 73 74 20 28 28 tionals* rest ((
3780: 65 72 72 6f 72 3f 20 23 66 29 20 72 65 73 74 29 error? #f) rest)
3790: 0a 20 20 20 20 28 6c 65 74 20 28 28 62 73 20 28 . (let ((bs (
37a0: 25 64 65 66 61 75 6c 74 2d 62 61 73 65 20 72 65 %default-base re
37b0: 73 74 20 27 75 63 73 2d 72 61 6e 67 65 2d 3e 63 st 'ucs-range->c
37c0: 68 61 72 2d 73 65 74 29 29 29 0a 20 20 20 20 20 har-set))).
37d0: 20 28 25 75 63 73 2d 72 61 6e 67 65 2d 3e 63 68 (%ucs-range->ch
37e0: 61 72 2d 73 65 74 21 20 6c 6f 77 65 72 20 75 70 ar-set! lower up
37f0: 70 65 72 20 65 72 72 6f 72 3f 20 62 73 20 27 75 per error? bs 'u
3800: 63 73 2d 72 61 6e 67 65 2d 3e 63 68 61 72 2d 73 cs-range->char-s
3810: 65 74 29 0a 20 20 20 20 20 20 28 6d 61 6b 65 2d et). (make-
3820: 63 68 61 72 2d 73 65 74 20 62 73 29 29 29 29 0a char-set bs)))).
3830: 0a 28 64 65 66 69 6e 65 20 28 75 63 73 2d 72 61 .(define (ucs-ra
3840: 6e 67 65 2d 3e 63 68 61 72 2d 73 65 74 21 20 6c nge->char-set! l
3850: 6f 77 65 72 20 75 70 70 65 72 20 65 72 72 6f 72 ower upper error
3860: 3f 20 62 61 73 65 2d 63 73 29 0a 20 20 28 25 75 ? base-cs). (%u
3870: 63 73 2d 72 61 6e 67 65 2d 3e 63 68 61 72 2d 73 cs-range->char-s
3880: 65 74 21 20 6c 6f 77 65 72 20 75 70 70 65 72 20 et! lower upper
3890: 65 72 72 6f 72 3f 0a 09 09 09 20 28 25 63 68 61 error?.... (%cha
38a0: 72 2d 73 65 74 3a 73 2f 63 68 65 63 6b 20 62 61 r-set:s/check ba
38b0: 73 65 2d 63 73 20 27 75 63 73 2d 72 61 6e 67 65 se-cs 'ucs-range
38c0: 2d 3e 63 68 61 72 2d 73 65 74 21 29 0a 09 09 09 ->char-set!)....
38d0: 20 27 75 63 73 2d 72 61 6e 67 65 2d 3e 63 68 61 'ucs-range->cha
38e0: 72 2d 73 65 74 29 0a 20 20 62 61 73 65 2d 63 73 r-set). base-cs
38f0: 29 0a 0a 0a 3b 3b 3b 20 2d 2d 20 70 72 65 64 69 )...;;; -- predi
3900: 63 61 74 65 20 2d 3e 20 63 68 61 72 2d 73 65 74 cate -> char-set
3910: 0a 0a 28 64 65 66 69 6e 65 20 28 25 63 68 61 72 ..(define (%char
3920: 2d 73 65 74 2d 66 69 6c 74 65 72 21 20 70 72 65 -set-filter! pre
3930: 64 20 64 73 20 62 73 20 70 72 6f 63 29 0a 20 20 d ds bs proc).
3940: 28 63 68 65 63 6b 2d 61 72 67 20 70 72 6f 63 65 (check-arg proce
3950: 64 75 72 65 3f 20 70 72 65 64 20 70 72 6f 63 29 dure? pred proc)
3960: 0a 20 20 28 6c 65 74 20 6c 70 20 28 28 69 20 32 . (let lp ((i 2
3970: 35 35 29 29 0a 20 20 20 20 28 63 6f 6e 64 20 28 55)). (cond (
3980: 28 3e 3d 20 69 20 30 29 0a 09 20 20 20 28 69 66 (>= i 0).. (if
3990: 20 28 61 6e 64 20 28 73 69 3d 31 3f 20 64 73 20 (and (si=1? ds
39a0: 69 29 20 28 70 72 65 64 20 28 25 6c 61 74 69 6e i) (pred (%latin
39b0: 31 2d 3e 63 68 61 72 20 69 29 29 29 0a 09 20 20 1->char i)))..
39c0: 20 20 20 20 20 28 25 73 65 74 31 21 20 62 73 20 (%set1! bs
39d0: 69 29 29 0a 09 20 20 20 28 6c 70 20 28 2d 20 69 i)).. (lp (- i
39e0: 20 31 29 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 1))))))..(defin
39f0: 65 20 28 63 68 61 72 2d 73 65 74 2d 66 69 6c 74 e (char-set-filt
3a00: 65 72 20 70 72 65 64 69 63 61 74 65 20 64 6f 6d er predicate dom
3a10: 61 69 6e 20 2e 20 6d 61 79 62 65 2d 62 61 73 65 ain . maybe-base
3a20: 29 0a 20 20 28 6c 65 74 20 28 28 62 73 20 28 25 ). (let ((bs (%
3a30: 64 65 66 61 75 6c 74 2d 62 61 73 65 20 6d 61 79 default-base may
3a40: 62 65 2d 62 61 73 65 20 27 63 68 61 72 2d 73 65 be-base 'char-se
3a50: 74 2d 66 69 6c 74 65 72 29 29 29 0a 20 20 20 20 t-filter))).
3a60: 28 25 63 68 61 72 2d 73 65 74 2d 66 69 6c 74 65 (%char-set-filte
3a70: 72 21 20 70 72 65 64 69 63 61 74 65 0a 09 09 20 r! predicate...
3a80: 20 20 20 20 20 20 28 25 63 68 61 72 2d 73 65 74 (%char-set
3a90: 3a 73 2f 63 68 65 63 6b 20 64 6f 6d 61 69 6e 20 :s/check domain
3aa0: 27 63 68 61 72 2d 73 65 74 2d 66 69 6c 74 65 72 'char-set-filter
3ab0: 21 29 0a 09 09 20 20 20 20 20 20 20 62 73 0a 09 !)... bs..
3ac0: 09 20 20 20 20 20 20 20 27 63 68 61 72 2d 73 65 . 'char-se
3ad0: 74 2d 66 69 6c 74 65 72 29 0a 20 20 20 20 28 6d t-filter). (m
3ae0: 61 6b 65 2d 63 68 61 72 2d 73 65 74 20 62 73 29 ake-char-set bs)
3af0: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 68 61 ))..(define (cha
3b00: 72 2d 73 65 74 2d 66 69 6c 74 65 72 21 20 70 72 r-set-filter! pr
3b10: 65 64 69 63 61 74 65 20 64 6f 6d 61 69 6e 20 62 edicate domain b
3b20: 61 73 65 2d 63 73 29 0a 20 20 28 25 63 68 61 72 ase-cs). (%char
3b30: 2d 73 65 74 2d 66 69 6c 74 65 72 21 20 70 72 65 -set-filter! pre
3b40: 64 69 63 61 74 65 0a 09 09 20 20 20 20 20 28 25 dicate... (%
3b50: 63 68 61 72 2d 73 65 74 3a 73 2f 63 68 65 63 6b char-set:s/check
3b60: 20 64 6f 6d 61 69 6e 20 27 63 68 61 72 2d 73 65 domain 'char-se
3b70: 74 2d 66 69 6c 74 65 72 21 29 0a 09 09 20 20 20 t-filter!)...
3b80: 20 20 28 25 63 68 61 72 2d 73 65 74 3a 73 2f 63 (%char-set:s/c
3b90: 68 65 63 6b 20 62 61 73 65 2d 63 73 20 27 63 68 heck base-cs 'ch
3ba0: 61 72 2d 73 65 74 2d 66 69 6c 74 65 72 21 29 0a ar-set-filter!).
3bb0: 09 09 20 20 20 20 20 27 63 68 61 72 2d 73 65 74 .. 'char-set
3bc0: 2d 66 69 6c 74 65 72 21 29 0a 20 20 62 61 73 65 -filter!). base
3bd0: 2d 63 73 29 0a 0a 0a 3b 3b 3b 20 7b 73 74 72 69 -cs)...;;; {stri
3be0: 6e 67 2c 20 63 68 61 72 2c 20 63 68 61 72 2d 73 ng, char, char-s
3bf0: 65 74 2c 20 63 68 61 72 20 70 72 65 64 69 63 61 et, char predica
3c00: 74 65 7d 20 2d 3e 20 63 68 61 72 2d 73 65 74 0a te} -> char-set.
3c10: 0a 28 64 65 66 69 6e 65 20 28 2d 3e 63 68 61 72 .(define (->char
3c20: 2d 73 65 74 20 78 29 0a 20 20 28 63 6f 6e 64 20 -set x). (cond
3c30: 28 28 63 68 61 72 2d 73 65 74 3f 20 78 29 20 78 ((char-set? x) x
3c40: 29 0a 09 28 28 73 74 72 69 6e 67 3f 20 78 29 20 )..((string? x)
3c50: 28 73 74 72 69 6e 67 2d 3e 63 68 61 72 2d 73 65 (string->char-se
3c60: 74 20 78 29 29 0a 09 28 28 63 68 61 72 3f 20 78 t x))..((char? x
3c70: 29 20 28 63 68 61 72 2d 73 65 74 20 78 29 29 0a ) (char-set x)).
3c80: 09 28 65 6c 73 65 20 28 65 72 72 6f 72 20 22 4e .(else (error "N
3c90: 6f 74 20 61 20 63 68 61 72 73 65 74 2c 20 73 74 ot a charset, st
3ca0: 72 69 6e 67 20 6f 72 20 63 68 61 72 2e 22 20 78 ring or char." x
3cb0: 29 29 29 29 0a 0a 0a 0a 3b 3b 3b 20 53 65 74 20 ))))....;;; Set
3cc0: 61 6c 67 65 62 72 61 0a 3b 3b 3b 3b 3b 3b 3b 3b algebra.;;;;;;;;
3cd0: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
3ce0: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
3cf0: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
3d00: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
3d10: 3b 3b 3b 3b 3b 3b 3b 0a 3b 3b 3b 20 54 68 65 20 ;;;;;;;.;;; The
3d20: 65 78 70 6f 72 74 65 64 20 21 20 70 72 6f 63 73 exported ! procs
3d30: 20 61 72 65 20 22 6c 69 6e 65 61 72 20 75 70 64 are "linear upd
3d40: 61 74 65 22 20 2d 2d 20 61 6c 6c 6f 77 65 64 2c ate" -- allowed,
3d50: 20 62 75 74 20 6e 6f 74 20 72 65 71 75 69 72 65 but not require
3d60: 64 2c 20 74 6f 0a 3b 3b 3b 20 73 69 64 65 2d 65 d, to.;;; side-e
3d70: 66 66 65 63 74 20 74 68 65 69 72 20 66 69 72 73 ffect their firs
3d80: 74 20 61 72 67 75 6d 65 6e 74 20 77 68 65 6e 20 t argument when
3d90: 63 6f 6d 70 75 74 69 6e 67 20 74 68 65 69 72 20 computing their
3da0: 72 65 73 75 6c 74 2e 20 49 6e 20 6f 74 68 65 72 result. In other
3db0: 0a 3b 3b 3b 20 77 6f 72 64 73 2c 20 79 6f 75 20 .;;; words, you
3dc0: 6d 75 73 74 20 75 73 65 20 74 68 65 6d 20 61 73 must use them as
3dd0: 20 69 66 20 74 68 65 79 20 77 65 72 65 20 63 6f if they were co
3de0: 6d 70 6c 65 74 65 6c 79 20 66 75 6e 63 74 69 6f mpletely functio
3df0: 6e 61 6c 2c 20 6a 75 73 74 20 6c 69 6b 65 0a 3b nal, just like.;
3e00: 3b 3b 20 74 68 65 69 72 20 6e 6f 6e 2d 21 20 63 ;; their non-! c
3e10: 6f 75 6e 74 65 72 70 61 72 74 73 2c 20 61 6e 64 ounterparts, and
3e20: 20 79 6f 75 20 6d 75 73 74 20 61 64 64 69 74 69 you must additi
3e30: 6f 6e 61 6c 6c 79 20 65 6e 73 75 72 65 20 74 68 onally ensure th
3e40: 61 74 20 74 68 65 69 72 0a 3b 3b 3b 20 66 69 72 at their.;;; fir
3e50: 73 74 20 61 72 67 75 6d 65 6e 74 73 20 61 72 65 st arguments are
3e60: 20 22 64 65 61 64 22 20 61 74 20 74 68 65 20 70 "dead" at the p
3e70: 6f 69 6e 74 20 6f 66 20 63 61 6c 6c 2e 20 49 6e oint of call. In
3e80: 20 72 65 74 75 72 6e 2c 20 77 65 20 70 72 6f 6d return, we prom
3e90: 69 73 65 20 61 0a 3b 3b 3b 20 6d 6f 72 65 20 65 ise a.;;; more e
3ea0: 66 66 69 63 69 65 6e 74 20 72 65 73 75 6c 74 2c fficient result,
3eb0: 20 70 6c 75 73 20 61 6c 6c 6f 77 69 6e 67 20 79 plus allowing y
3ec0: 6f 75 20 74 6f 20 61 6c 77 61 79 73 20 61 73 73 ou to always ass
3ed0: 75 6d 65 20 63 68 61 72 2d 73 65 74 73 20 61 72 ume char-sets ar
3ee0: 65 0a 3b 3b 3b 20 75 6e 63 68 61 6e 67 65 61 62 e.;;; unchangeab
3ef0: 6c 65 20 76 61 6c 75 65 73 2e 0a 0a 3b 3b 3b 20 le values...;;;
3f00: 41 70 70 6c 79 20 50 20 74 6f 20 65 61 63 68 20 Apply P to each
3f10: 69 6e 64 65 78 20 61 6e 64 20 69 74 73 20 63 68 index and its ch
3f20: 61 72 20 63 6f 64 65 20 69 6e 20 53 3a 20 28 50 ar code in S: (P
3f30: 20 49 20 56 41 4c 29 2e 0a 3b 3b 3b 20 55 73 65 I VAL)..;;; Use
3f40: 64 20 62 79 20 74 68 65 20 73 65 74 2d 61 6c 67 d by the set-alg
3f50: 65 62 72 61 20 6f 70 73 2e 0a 0a 28 64 65 66 69 ebra ops...(defi
3f60: 6e 65 20 28 25 73 74 72 69 6e 67 2d 69 74 65 72 ne (%string-iter
3f70: 20 70 20 73 29 0a 20 20 28 6c 65 74 20 6c 70 20 p s). (let lp
3f80: 28 28 69 20 28 2d 20 28 73 74 72 69 6e 67 2d 6c ((i (- (string-l
3f90: 65 6e 67 74 68 20 73 29 20 31 29 29 29 0a 20 20 ength s) 1))).
3fa0: 20 20 28 63 6f 6e 64 20 28 28 3e 3d 20 69 20 30 (cond ((>= i 0
3fb0: 29 0a 09 20 20 20 28 70 20 69 20 28 25 63 68 61 ).. (p i (%cha
3fc0: 72 2d 3e 6c 61 74 69 6e 31 20 28 73 74 72 69 6e r->latin1 (strin
3fd0: 67 2d 72 65 66 20 73 20 69 29 29 29 0a 09 20 20 g-ref s i)))..
3fe0: 20 28 6c 70 20 28 2d 20 69 20 31 29 29 29 29 29 (lp (- i 1)))))
3ff0: 29 0a 0a 3b 3b 3b 20 53 74 72 69 6e 67 20 53 20 )..;;; String S
4000: 72 65 70 72 65 73 65 6e 74 73 20 73 6f 6d 65 20 represents some
4010: 69 6e 69 74 69 61 6c 20 63 68 61 72 2d 73 65 74 initial char-set
4020: 2e 20 28 4f 50 20 73 20 69 20 76 61 6c 29 20 64 . (OP s i val) d
4030: 6f 65 73 20 73 6f 6d 65 0a 3b 3b 3b 20 6b 69 6e oes some.;;; kin
4040: 64 20 6f 66 20 73 5b 69 5d 20 3a 3d 20 73 5b 69 d of s[i] := s[i
4050: 5d 20 6f 70 20 76 61 6c 20 75 70 64 61 74 65 2e ] op val update.
4060: 20 44 6f 0a 3b 3b 3b 20 20 20 20 20 53 20 3a 3d Do.;;; S :=
4070: 20 53 20 4f 50 20 43 53 45 54 69 0a 3b 3b 3b 20 S OP CSETi.;;;
4080: 66 6f 72 20 61 6c 6c 20 74 68 65 20 63 68 61 72 for all the char
4090: 2d 73 65 74 73 20 69 6e 20 74 68 65 20 6c 69 73 -sets in the lis
40a0: 74 20 43 53 45 54 53 2e 20 54 68 65 20 6e 2d 61 t CSETS. The n-a
40b0: 72 79 20 73 65 74 2d 61 6c 67 65 62 72 61 20 6f ry set-algebra o
40c0: 70 73 0a 3b 3b 3b 20 61 6c 6c 20 75 73 65 20 74 ps.;;; all use t
40d0: 68 69 73 20 69 6e 74 65 72 6e 61 6c 20 70 72 6f his internal pro
40e0: 63 2e 0a 0a 28 64 65 66 69 6e 65 20 28 25 63 68 c...(define (%ch
40f0: 61 72 2d 73 65 74 2d 61 6c 67 65 62 72 61 20 73 ar-set-algebra s
4100: 20 63 73 65 74 73 20 6f 70 20 70 72 6f 63 29 0a csets op proc).
4110: 20 20 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d (for-each (lam
4120: 62 64 61 20 28 63 73 65 74 29 0a 09 20 20 20 20 bda (cset)..
4130: 20 20 28 6c 65 74 20 28 28 73 32 20 28 25 63 68 (let ((s2 (%ch
4140: 61 72 2d 73 65 74 3a 73 2f 63 68 65 63 6b 20 63 ar-set:s/check c
4150: 73 65 74 20 70 72 6f 63 29 29 29 0a 09 09 28 6c set proc)))...(l
4160: 65 74 20 6c 70 20 28 28 69 20 32 35 35 29 29 0a et lp ((i 255)).
4170: 09 09 20 20 28 63 6f 6e 64 20 28 28 3e 3d 20 69 .. (cond ((>= i
4180: 20 30 29 0a 09 09 09 20 28 6f 70 20 73 20 69 20 0).... (op s i
4190: 28 73 69 20 73 32 20 69 29 29 0a 09 09 09 20 28 (si s2 i)).... (
41a0: 6c 70 20 28 2d 20 69 20 31 29 29 29 29 29 29 29 lp (- i 1)))))))
41b0: 0a 09 20 20 20 20 63 73 65 74 73 29 29 0a 0a 0a .. csets))...
41c0: 3b 3b 3b 20 2d 2d 20 43 6f 6d 70 6c 65 6d 65 6e ;;; -- Complemen
41d0: 74 0a 0a 28 64 65 66 69 6e 65 20 28 63 68 61 72 t..(define (char
41e0: 2d 73 65 74 2d 63 6f 6d 70 6c 65 6d 65 6e 74 20 -set-complement
41f0: 63 73 29 0a 20 20 28 6c 65 74 20 28 28 73 20 28 cs). (let ((s (
4200: 25 63 68 61 72 2d 73 65 74 3a 73 2f 63 68 65 63 %char-set:s/chec
4210: 6b 20 63 73 20 27 63 68 61 72 2d 73 65 74 2d 63 k cs 'char-set-c
4220: 6f 6d 70 6c 65 6d 65 6e 74 29 29 0a 09 28 61 6e omplement))..(an
4230: 73 20 28 6d 61 6b 65 2d 73 74 72 69 6e 67 20 32 s (make-string 2
4240: 35 36 29 29 29 0a 20 20 20 20 28 25 73 74 72 69 56))). (%stri
4250: 6e 67 2d 69 74 65 72 20 28 6c 61 6d 62 64 61 20 ng-iter (lambda
4260: 28 69 20 76 29 20 28 25 6e 6f 74 21 20 61 6e 73 (i v) (%not! ans
4270: 20 69 20 76 29 29 20 73 29 0a 20 20 20 20 28 6d i v)) s). (m
4280: 61 6b 65 2d 63 68 61 72 2d 73 65 74 20 61 6e 73 ake-char-set ans
4290: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 68 )))..(define (ch
42a0: 61 72 2d 73 65 74 2d 63 6f 6d 70 6c 65 6d 65 6e ar-set-complemen
42b0: 74 21 20 63 73 65 74 29 0a 20 20 28 6c 65 74 20 t! cset). (let
42c0: 28 28 73 20 28 25 63 68 61 72 2d 73 65 74 3a 73 ((s (%char-set:s
42d0: 2f 63 68 65 63 6b 20 63 73 65 74 20 27 63 68 61 /check cset 'cha
42e0: 72 2d 73 65 74 2d 63 6f 6d 70 6c 65 6d 65 6e 74 r-set-complement
42f0: 21 29 29 29 0a 20 20 20 20 28 25 73 74 72 69 6e !))). (%strin
4300: 67 2d 69 74 65 72 20 28 6c 61 6d 62 64 61 20 28 g-iter (lambda (
4310: 69 20 76 29 20 28 25 6e 6f 74 21 20 73 20 69 20 i v) (%not! s i
4320: 76 29 29 20 73 29 29 0a 20 20 63 73 65 74 29 0a v)) s)). cset).
4330: 0a 0a 3b 3b 3b 20 2d 2d 20 55 6e 69 6f 6e 0a 0a ..;;; -- Union..
4340: 28 64 65 66 69 6e 65 20 28 63 68 61 72 2d 73 65 (define (char-se
4350: 74 2d 75 6e 69 6f 6e 21 20 63 73 65 74 31 20 2e t-union! cset1 .
4360: 20 63 73 65 74 73 29 0a 20 20 28 25 63 68 61 72 csets). (%char
4370: 2d 73 65 74 2d 61 6c 67 65 62 72 61 20 28 25 63 -set-algebra (%c
4380: 68 61 72 2d 73 65 74 3a 73 2f 63 68 65 63 6b 20 har-set:s/check
4390: 63 73 65 74 31 20 27 63 68 61 72 2d 73 65 74 2d cset1 'char-set-
43a0: 75 6e 69 6f 6e 21 29 0a 09 09 20 20 20 20 20 63 union!)... c
43b0: 73 65 74 73 20 25 6f 72 21 20 27 63 68 61 72 2d sets %or! 'char-
43c0: 73 65 74 2d 75 6e 69 6f 6e 21 29 0a 20 20 63 73 set-union!). cs
43d0: 65 74 31 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 et1)..(define (c
43e0: 68 61 72 2d 73 65 74 2d 75 6e 69 6f 6e 20 2e 20 har-set-union .
43f0: 63 73 65 74 73 29 0a 20 20 28 69 66 20 28 70 61 csets). (if (pa
4400: 69 72 3f 20 63 73 65 74 73 29 0a 20 20 20 20 20 ir? csets).
4410: 20 28 6c 65 74 20 28 28 73 20 28 25 73 74 72 69 (let ((s (%stri
4420: 6e 67 2d 63 6f 70 79 20 28 25 63 68 61 72 2d 73 ng-copy (%char-s
4430: 65 74 3a 73 2f 63 68 65 63 6b 20 28 63 61 72 20 et:s/check (car
4440: 63 73 65 74 73 29 20 27 63 68 61 72 2d 73 65 74 csets) 'char-set
4450: 2d 75 6e 69 6f 6e 29 29 29 29 0a 09 28 25 63 68 -union))))..(%ch
4460: 61 72 2d 73 65 74 2d 61 6c 67 65 62 72 61 20 73 ar-set-algebra s
4470: 20 28 63 64 72 20 63 73 65 74 73 29 20 25 6f 72 (cdr csets) %or
4480: 21 20 27 63 68 61 72 2d 73 65 74 2d 75 6e 69 6f ! 'char-set-unio
4490: 6e 29 0a 09 28 6d 61 6b 65 2d 63 68 61 72 2d 73 n)..(make-char-s
44a0: 65 74 20 73 29 29 0a 20 20 20 20 20 20 28 63 68 et s)). (ch
44b0: 61 72 2d 73 65 74 2d 63 6f 70 79 20 63 68 61 72 ar-set-copy char
44c0: 2d 73 65 74 3a 65 6d 70 74 79 29 29 29 0a 0a 0a -set:empty)))...
44d0: 3b 3b 3b 20 2d 2d 20 49 6e 74 65 72 73 65 63 74 ;;; -- Intersect
44e0: 69 6f 6e 0a 0a 28 64 65 66 69 6e 65 20 28 63 68 ion..(define (ch
44f0: 61 72 2d 73 65 74 2d 69 6e 74 65 72 73 65 63 74 ar-set-intersect
4500: 69 6f 6e 21 20 63 73 65 74 31 20 2e 20 63 73 65 ion! cset1 . cse
4510: 74 73 29 0a 20 20 28 25 63 68 61 72 2d 73 65 74 ts). (%char-set
4520: 2d 61 6c 67 65 62 72 61 20 28 25 63 68 61 72 2d -algebra (%char-
4530: 73 65 74 3a 73 2f 63 68 65 63 6b 20 63 73 65 74 set:s/check cset
4540: 31 20 27 63 68 61 72 2d 73 65 74 2d 69 6e 74 65 1 'char-set-inte
4550: 72 73 65 63 74 69 6f 6e 21 29 0a 09 09 20 20 20 rsection!)...
4560: 20 20 63 73 65 74 73 20 25 61 6e 64 21 20 27 63 csets %and! 'c
4570: 68 61 72 2d 73 65 74 2d 69 6e 74 65 72 73 65 63 har-set-intersec
4580: 74 69 6f 6e 21 29 0a 20 20 63 73 65 74 31 29 0a tion!). cset1).
4590: 0a 28 64 65 66 69 6e 65 20 28 63 68 61 72 2d 73 .(define (char-s
45a0: 65 74 2d 69 6e 74 65 72 73 65 63 74 69 6f 6e 20 et-intersection
45b0: 2e 20 63 73 65 74 73 29 0a 20 20 28 69 66 20 28 . csets). (if (
45c0: 70 61 69 72 3f 20 63 73 65 74 73 29 0a 20 20 20 pair? csets).
45d0: 20 20 20 28 6c 65 74 20 28 28 73 20 28 25 73 74 (let ((s (%st
45e0: 72 69 6e 67 2d 63 6f 70 79 20 28 25 63 68 61 72 ring-copy (%char
45f0: 2d 73 65 74 3a 73 2f 63 68 65 63 6b 20 28 63 61 -set:s/check (ca
4600: 72 20 63 73 65 74 73 29 20 27 63 68 61 72 2d 73 r csets) 'char-s
4610: 65 74 2d 69 6e 74 65 72 73 65 63 74 69 6f 6e 29 et-intersection)
4620: 29 29 29 0a 09 28 25 63 68 61 72 2d 73 65 74 2d )))..(%char-set-
4630: 61 6c 67 65 62 72 61 20 73 20 28 63 64 72 20 63 algebra s (cdr c
4640: 73 65 74 73 29 20 25 61 6e 64 21 20 27 63 68 61 sets) %and! 'cha
4650: 72 2d 73 65 74 2d 69 6e 74 65 72 73 65 63 74 69 r-set-intersecti
4660: 6f 6e 29 0a 09 28 6d 61 6b 65 2d 63 68 61 72 2d on)..(make-char-
4670: 73 65 74 20 73 29 29 0a 20 20 20 20 20 20 28 63 set s)). (c
4680: 68 61 72 2d 73 65 74 2d 63 6f 70 79 20 63 68 61 har-set-copy cha
4690: 72 2d 73 65 74 3a 66 75 6c 6c 29 29 29 0a 0a 0a r-set:full)))...
46a0: 3b 3b 3b 20 2d 2d 20 44 69 66 66 65 72 65 6e 63 ;;; -- Differenc
46b0: 65 0a 0a 28 64 65 66 69 6e 65 20 28 63 68 61 72 e..(define (char
46c0: 2d 73 65 74 2d 64 69 66 66 65 72 65 6e 63 65 21 -set-difference!
46d0: 20 63 73 65 74 31 20 2e 20 63 73 65 74 73 29 0a cset1 . csets).
46e0: 20 20 28 25 63 68 61 72 2d 73 65 74 2d 61 6c 67 (%char-set-alg
46f0: 65 62 72 61 20 28 25 63 68 61 72 2d 73 65 74 3a ebra (%char-set:
4700: 73 2f 63 68 65 63 6b 20 63 73 65 74 31 20 27 63 s/check cset1 'c
4710: 68 61 72 2d 73 65 74 2d 64 69 66 66 65 72 65 6e har-set-differen
4720: 63 65 21 29 0a 09 09 20 20 20 20 20 63 73 65 74 ce!)... cset
4730: 73 20 25 6d 69 6e 75 73 21 20 27 63 68 61 72 2d s %minus! 'char-
4740: 73 65 74 2d 64 69 66 66 65 72 65 6e 63 65 21 29 set-difference!)
4750: 0a 20 20 63 73 65 74 31 29 0a 0a 28 64 65 66 69 . cset1)..(defi
4760: 6e 65 20 28 63 68 61 72 2d 73 65 74 2d 64 69 66 ne (char-set-dif
4770: 66 65 72 65 6e 63 65 20 63 73 31 20 2e 20 63 73 ference cs1 . cs
4780: 65 74 73 29 0a 20 20 28 69 66 20 28 70 61 69 72 ets). (if (pair
4790: 3f 20 63 73 65 74 73 29 0a 20 20 20 20 20 20 28 ? csets). (
47a0: 6c 65 74 20 28 28 73 20 28 25 73 74 72 69 6e 67 let ((s (%string
47b0: 2d 63 6f 70 79 20 28 25 63 68 61 72 2d 73 65 74 -copy (%char-set
47c0: 3a 73 2f 63 68 65 63 6b 20 63 73 31 20 27 63 68 :s/check cs1 'ch
47d0: 61 72 2d 73 65 74 2d 64 69 66 66 65 72 65 6e 63 ar-set-differenc
47e0: 65 29 29 29 29 0a 09 28 25 63 68 61 72 2d 73 65 e))))..(%char-se
47f0: 74 2d 61 6c 67 65 62 72 61 20 73 20 63 73 65 74 t-algebra s cset
4800: 73 20 25 6d 69 6e 75 73 21 20 27 63 68 61 72 2d s %minus! 'char-
4810: 73 65 74 2d 64 69 66 66 65 72 65 6e 63 65 29 0a set-difference).
4820: 09 28 6d 61 6b 65 2d 63 68 61 72 2d 73 65 74 20 .(make-char-set
4830: 73 29 29 0a 20 20 20 20 20 20 28 63 68 61 72 2d s)). (char-
4840: 73 65 74 2d 63 6f 70 79 20 63 73 31 29 29 29 0a set-copy cs1))).
4850: 0a 0a 3b 3b 3b 20 2d 2d 20 58 6f 72 0a 0a 28 64 ..;;; -- Xor..(d
4860: 65 66 69 6e 65 20 28 63 68 61 72 2d 73 65 74 2d efine (char-set-
4870: 78 6f 72 21 20 63 73 65 74 31 20 2e 20 63 73 65 xor! cset1 . cse
4880: 74 73 29 0a 20 20 28 25 63 68 61 72 2d 73 65 74 ts). (%char-set
4890: 2d 61 6c 67 65 62 72 61 20 28 25 63 68 61 72 2d -algebra (%char-
48a0: 73 65 74 3a 73 2f 63 68 65 63 6b 20 63 73 65 74 set:s/check cset
48b0: 31 20 27 63 68 61 72 2d 73 65 74 2d 78 6f 72 21 1 'char-set-xor!
48c0: 29 0a 09 09 20 20 20 20 20 20 63 73 65 74 73 20 )... csets
48d0: 25 78 6f 72 21 20 27 63 68 61 72 2d 73 65 74 2d %xor! 'char-set-
48e0: 78 6f 72 21 29 0a 20 20 63 73 65 74 31 29 0a 0a xor!). cset1)..
48f0: 28 64 65 66 69 6e 65 20 28 63 68 61 72 2d 73 65 (define (char-se
4900: 74 2d 78 6f 72 20 2e 20 63 73 65 74 73 29 0a 20 t-xor . csets).
4910: 20 28 69 66 20 28 70 61 69 72 3f 20 63 73 65 74 (if (pair? cset
4920: 73 29 0a 20 20 20 20 20 20 28 6c 65 74 20 28 28 s). (let ((
4930: 73 20 28 25 73 74 72 69 6e 67 2d 63 6f 70 79 20 s (%string-copy
4940: 28 25 63 68 61 72 2d 73 65 74 3a 73 2f 63 68 65 (%char-set:s/che
4950: 63 6b 20 28 63 61 72 20 63 73 65 74 73 29 20 27 ck (car csets) '
4960: 63 68 61 72 2d 73 65 74 2d 78 6f 72 29 29 29 29 char-set-xor))))
4970: 0a 09 28 25 63 68 61 72 2d 73 65 74 2d 61 6c 67 ..(%char-set-alg
4980: 65 62 72 61 20 73 20 28 63 64 72 20 63 73 65 74 ebra s (cdr cset
4990: 73 29 20 25 78 6f 72 21 20 27 63 68 61 72 2d 73 s) %xor! 'char-s
49a0: 65 74 2d 78 6f 72 29 0a 09 28 6d 61 6b 65 2d 63 et-xor)..(make-c
49b0: 68 61 72 2d 73 65 74 20 73 29 29 0a 20 20 20 20 har-set s)).
49c0: 20 20 28 63 68 61 72 2d 73 65 74 2d 63 6f 70 79 (char-set-copy
49d0: 20 63 68 61 72 2d 73 65 74 3a 65 6d 70 74 79 29 char-set:empty)
49e0: 29 29 0a 0a 0a 3b 3b 3b 20 2d 2d 20 44 69 66 66 ))...;;; -- Diff
49f0: 65 72 65 6e 63 65 20 26 20 69 6e 74 65 72 73 65 erence & interse
4a00: 63 74 69 6f 6e 0a 0a 28 64 65 66 69 6e 65 20 28 ction..(define (
4a10: 25 63 68 61 72 2d 73 65 74 2d 64 69 66 66 2b 69 %char-set-diff+i
4a20: 6e 74 65 72 73 65 63 74 69 6f 6e 21 20 64 69 66 ntersection! dif
4a30: 66 20 69 6e 74 20 63 73 65 74 73 20 70 72 6f 63 f int csets proc
4a40: 29 0a 20 20 28 66 6f 72 2d 65 61 63 68 20 28 6c ). (for-each (l
4a50: 61 6d 62 64 61 20 28 63 73 29 0a 09 20 20 20 20 ambda (cs)..
4a60: 20 20 28 25 73 74 72 69 6e 67 2d 69 74 65 72 20 (%string-iter
4a70: 28 6c 61 6d 62 64 61 20 28 69 20 76 29 0a 09 09 (lambda (i v)...
4a80: 09 20 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 . (if (not
4a90: 28 7a 65 72 6f 3f 20 76 29 29 0a 09 09 09 09 20 (zero? v)).....
4aa0: 20 28 63 6f 6e 64 20 28 28 73 69 3d 31 3f 20 64 (cond ((si=1? d
4ab0: 69 66 66 20 69 29 0a 09 09 09 09 09 20 28 25 73 iff i)...... (%s
4ac0: 65 74 30 21 20 64 69 66 66 20 69 29 0a 09 09 09 et0! diff i)....
4ad0: 09 09 20 28 25 73 65 74 31 21 20 69 6e 74 20 20 .. (%set1! int
4ae0: 69 29 29 29 29 29 0a 09 09 09 20 20 20 20 28 25 i))))).... (%
4af0: 63 68 61 72 2d 73 65 74 3a 73 2f 63 68 65 63 6b char-set:s/check
4b00: 20 63 73 20 70 72 6f 63 29 29 29 0a 09 20 20 20 cs proc)))..
4b10: 20 63 73 65 74 73 29 29 0a 0a 28 64 65 66 69 6e csets))..(defin
4b20: 65 20 28 63 68 61 72 2d 73 65 74 2d 64 69 66 66 e (char-set-diff
4b30: 2b 69 6e 74 65 72 73 65 63 74 69 6f 6e 21 20 63 +intersection! c
4b40: 73 31 20 63 73 32 20 2e 20 63 73 65 74 73 29 0a s1 cs2 . csets).
4b50: 20 20 28 6c 65 74 20 28 28 73 31 20 28 25 63 68 (let ((s1 (%ch
4b60: 61 72 2d 73 65 74 3a 73 2f 63 68 65 63 6b 20 63 ar-set:s/check c
4b70: 73 31 20 27 63 68 61 72 2d 73 65 74 2d 64 69 66 s1 'char-set-dif
4b80: 66 2b 69 6e 74 65 72 73 65 63 74 69 6f 6e 21 29 f+intersection!)
4b90: 29 0a 09 28 73 32 20 28 25 63 68 61 72 2d 73 65 )..(s2 (%char-se
4ba0: 74 3a 73 2f 63 68 65 63 6b 20 63 73 32 20 27 63 t:s/check cs2 'c
4bb0: 68 61 72 2d 73 65 74 2d 64 69 66 66 2b 69 6e 74 har-set-diff+int
4bc0: 65 72 73 65 63 74 69 6f 6e 21 29 29 29 0a 20 20 ersection!))).
4bd0: 20 20 28 25 73 74 72 69 6e 67 2d 69 74 65 72 20 (%string-iter
4be0: 28 6c 61 6d 62 64 61 20 28 69 20 76 29 20 28 69 (lambda (i v) (i
4bf0: 66 20 28 7a 65 72 6f 3f 20 76 29 0a 09 09 09 09 f (zero? v).....
4c00: 20 20 20 20 28 25 73 65 74 30 21 20 73 32 20 69 (%set0! s2 i
4c10: 29 0a 09 09 09 09 20 20 20 20 28 69 66 20 28 73 )..... (if (s
4c20: 69 3d 31 3f 20 73 32 20 69 29 20 28 25 73 65 74 i=1? s2 i) (%set
4c30: 30 21 20 73 31 20 69 29 29 29 29 0a 09 09 20 20 0! s1 i))))...
4c40: 73 31 29 0a 20 20 20 20 28 25 63 68 61 72 2d 73 s1). (%char-s
4c50: 65 74 2d 64 69 66 66 2b 69 6e 74 65 72 73 65 63 et-diff+intersec
4c60: 74 69 6f 6e 21 20 73 31 20 73 32 20 63 73 65 74 tion! s1 s2 cset
4c70: 73 20 27 63 68 61 72 2d 73 65 74 2d 64 69 66 66 s 'char-set-diff
4c80: 2b 69 6e 74 65 72 73 65 63 74 69 6f 6e 21 29 29 +intersection!))
4c90: 0a 20 20 28 76 61 6c 75 65 73 20 63 73 31 20 63 . (values cs1 c
4ca0: 73 32 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 s2))..(define (c
4cb0: 68 61 72 2d 73 65 74 2d 64 69 66 66 2b 69 6e 74 har-set-diff+int
4cc0: 65 72 73 65 63 74 69 6f 6e 20 63 73 31 20 2e 20 ersection cs1 .
4cd0: 63 73 65 74 73 29 0a 20 20 28 6c 65 74 20 28 28 csets). (let ((
4ce0: 64 69 66 66 20 28 73 74 72 69 6e 67 2d 63 6f 70 diff (string-cop
4cf0: 79 20 28 25 63 68 61 72 2d 73 65 74 3a 73 2f 63 y (%char-set:s/c
4d00: 68 65 63 6b 20 63 73 31 20 27 63 68 61 72 2d 73 heck cs1 'char-s
4d10: 65 74 2d 64 69 66 66 2b 69 6e 74 65 72 73 65 63 et-diff+intersec
4d20: 74 69 6f 6e 29 29 29 0a 09 28 69 6e 74 20 20 28 tion)))..(int (
4d30: 6d 61 6b 65 2d 73 74 72 69 6e 67 20 32 35 36 20 make-string 256
4d40: 63 30 29 29 29 0a 20 20 20 20 28 25 63 68 61 72 c0))). (%char
4d50: 2d 73 65 74 2d 64 69 66 66 2b 69 6e 74 65 72 73 -set-diff+inters
4d60: 65 63 74 69 6f 6e 21 20 64 69 66 66 20 69 6e 74 ection! diff int
4d70: 20 63 73 65 74 73 20 27 63 68 61 72 2d 73 65 74 csets 'char-set
4d80: 2d 64 69 66 66 2b 69 6e 74 65 72 73 65 63 74 69 -diff+intersecti
4d90: 6f 6e 29 0a 20 20 20 20 28 76 61 6c 75 65 73 20 on). (values
4da0: 28 6d 61 6b 65 2d 63 68 61 72 2d 73 65 74 20 64 (make-char-set d
4db0: 69 66 66 29 20 28 6d 61 6b 65 2d 63 68 61 72 2d iff) (make-char-
4dc0: 73 65 74 20 69 6e 74 29 29 29 29 0a 0a 0a 3b 3b set int))))...;;
4dd0: 3b 3b 20 53 79 73 74 65 6d 20 63 68 61 72 61 63 ;; System charac
4de0: 74 65 72 20 73 65 74 73 0a 3b 3b 3b 3b 3b 3b 3b ter sets.;;;;;;;
4df0: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
4e00: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
4e10: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
4e20: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
4e30: 3b 3b 3b 3b 3b 3b 3b 3b 0a 3b 3b 3b 20 54 68 65 ;;;;;;;;.;;; The
4e40: 73 65 20 64 65 66 69 6e 69 74 69 6f 6e 73 20 61 se definitions a
4e50: 72 65 20 66 6f 72 20 4c 61 74 69 6e 2d 31 2e 0a re for Latin-1..
4e60: 3b 3b 3b 0a 3b 3b 3b 20 49 66 20 79 6f 75 72 20 ;;;.;;; If your
4e70: 53 63 68 65 6d 65 20 69 6d 70 6c 65 6d 65 6e 74 Scheme implement
4e80: 61 74 69 6f 6e 20 61 6c 6c 6f 77 73 20 79 6f 75 ation allows you
4e90: 20 74 6f 20 6d 61 72 6b 20 74 68 65 20 75 6e 64 to mark the und
4ea0: 65 72 6c 79 69 6e 67 20 73 74 72 69 6e 67 73 0a erlying strings.
4eb0: 3b 3b 3b 20 61 73 20 69 6d 6d 75 74 61 62 6c 65 ;;; as immutable
4ec0: 2c 20 79 6f 75 20 73 68 6f 75 6c 64 20 64 6f 20 , you should do
4ed0: 73 6f 20 2d 2d 20 69 74 20 77 6f 75 6c 64 20 62 so -- it would b
4ee0: 65 20 76 65 72 79 2c 20 76 65 72 79 20 62 61 64 e very, very bad
4ef0: 20 69 66 20 61 20 63 6c 69 65 6e 74 27 73 0a 3b if a client's.;
4f00: 3b 3b 20 62 75 67 67 79 20 63 6f 64 65 20 63 6f ;; buggy code co
4f10: 72 72 75 70 74 65 64 20 74 68 65 73 65 20 63 6f rrupted these co
4f20: 6e 73 74 61 6e 74 73 2e 0a 0a 28 64 65 66 69 6e nstants...(defin
4f30: 65 20 63 68 61 72 2d 73 65 74 3a 65 6d 70 74 79 e char-set:empty
4f40: 20 28 63 68 61 72 2d 73 65 74 29 29 0a 28 64 65 (char-set)).(de
4f50: 66 69 6e 65 20 63 68 61 72 2d 73 65 74 3a 66 75 fine char-set:fu
4f60: 6c 6c 20 28 63 68 61 72 2d 73 65 74 2d 63 6f 6d ll (char-set-com
4f70: 70 6c 65 6d 65 6e 74 20 63 68 61 72 2d 73 65 74 plement char-set
4f80: 3a 65 6d 70 74 79 29 29 0a 0a 28 64 65 66 69 6e :empty))..(defin
4f90: 65 20 63 68 61 72 2d 73 65 74 3a 6c 6f 77 65 72 e char-set:lower
4fa0: 2d 63 61 73 65 0a 20 20 28 6c 65 74 2a 20 28 28 -case. (let* ((
4fb0: 61 2d 7a 20 28 75 63 73 2d 72 61 6e 67 65 2d 3e a-z (ucs-range->
4fc0: 63 68 61 72 2d 73 65 74 20 23 78 36 31 20 23 78 char-set #x61 #x
4fd0: 37 42 29 29 0a 09 20 28 6c 61 74 69 6e 31 20 28 7B)).. (latin1 (
4fe0: 75 63 73 2d 72 61 6e 67 65 2d 3e 63 68 61 72 2d ucs-range->char-
4ff0: 73 65 74 21 20 23 78 64 66 20 23 78 66 37 20 20 set! #xdf #xf7
5000: 23 74 20 61 2d 7a 29 29 0a 09 20 28 6c 61 74 69 #t a-z)).. (lati
5010: 6e 32 20 28 75 63 73 2d 72 61 6e 67 65 2d 3e 63 n2 (ucs-range->c
5020: 68 61 72 2d 73 65 74 21 20 23 78 66 38 20 23 78 har-set! #xf8 #x
5030: 31 30 30 20 23 74 20 6c 61 74 69 6e 31 29 29 29 100 #t latin1)))
5040: 0a 20 20 20 20 28 63 68 61 72 2d 73 65 74 2d 61 . (char-set-a
5050: 64 6a 6f 69 6e 21 20 6c 61 74 69 6e 32 20 28 25 djoin! latin2 (%
5060: 6c 61 74 69 6e 31 2d 3e 63 68 61 72 20 23 78 62 latin1->char #xb
5070: 35 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 63 5))))..(define c
5080: 68 61 72 2d 73 65 74 3a 75 70 70 65 72 2d 63 61 har-set:upper-ca
5090: 73 65 0a 20 20 28 6c 65 74 20 28 28 41 2d 5a 20 se. (let ((A-Z
50a0: 28 75 63 73 2d 72 61 6e 67 65 2d 3e 63 68 61 72 (ucs-range->char
50b0: 2d 73 65 74 20 23 78 34 31 20 23 78 35 42 29 29 -set #x41 #x5B))
50c0: 29 0a 20 20 20 20 3b 3b 20 41 64 64 20 69 6e 20 ). ;; Add in
50d0: 74 68 65 20 4c 61 74 69 6e 2d 31 20 75 70 70 65 the Latin-1 uppe
50e0: 72 2d 63 61 73 65 20 63 68 61 72 73 2e 0a 20 20 r-case chars..
50f0: 20 20 28 75 63 73 2d 72 61 6e 67 65 2d 3e 63 68 (ucs-range->ch
5100: 61 72 2d 73 65 74 21 20 23 78 64 38 20 23 78 64 ar-set! #xd8 #xd
5110: 66 20 23 74 0a 09 09 09 20 20 28 75 63 73 2d 72 f #t.... (ucs-r
5120: 61 6e 67 65 2d 3e 63 68 61 72 2d 73 65 74 21 20 ange->char-set!
5130: 23 78 63 30 20 23 78 64 37 20 23 74 20 41 2d 5a #xc0 #xd7 #t A-Z
5140: 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 63 68 ))))..(define ch
5150: 61 72 2d 73 65 74 3a 74 69 74 6c 65 2d 63 61 73 ar-set:title-cas
5160: 65 20 63 68 61 72 2d 73 65 74 3a 65 6d 70 74 79 e char-set:empty
5170: 29 0a 0a 28 64 65 66 69 6e 65 20 63 68 61 72 2d )..(define char-
5180: 73 65 74 3a 6c 65 74 74 65 72 0a 20 20 28 6c 65 set:letter. (le
5190: 74 20 28 28 75 2f 6c 20 28 63 68 61 72 2d 73 65 t ((u/l (char-se
51a0: 74 2d 75 6e 69 6f 6e 20 63 68 61 72 2d 73 65 74 t-union char-set
51b0: 3a 75 70 70 65 72 2d 63 61 73 65 20 63 68 61 72 :upper-case char
51c0: 2d 73 65 74 3a 6c 6f 77 65 72 2d 63 61 73 65 29 -set:lower-case)
51d0: 29 29 0a 20 20 20 20 28 63 68 61 72 2d 73 65 74 )). (char-set
51e0: 2d 61 64 6a 6f 69 6e 21 20 75 2f 6c 0a 09 09 20 -adjoin! u/l...
51f0: 20 20 20 20 20 28 25 6c 61 74 69 6e 31 2d 3e 63 (%latin1->c
5200: 68 61 72 20 23 78 61 61 29 09 3b 20 46 45 4d 49 har #xaa).; FEMI
5210: 4e 49 4e 45 20 4f 52 44 49 4e 41 4c 20 49 4e 44 NINE ORDINAL IND
5220: 49 43 41 54 4f 52 0a 09 09 20 20 20 20 20 20 28 ICATOR... (
5230: 25 6c 61 74 69 6e 31 2d 3e 63 68 61 72 20 23 78 %latin1->char #x
5240: 62 61 29 29 29 29 09 3b 20 4d 41 53 43 55 4c 49 ba)))).; MASCULI
5250: 4e 45 20 4f 52 44 49 4e 41 4c 20 49 4e 44 49 43 NE ORDINAL INDIC
5260: 41 54 4f 52 0a 0a 28 64 65 66 69 6e 65 20 63 68 ATOR..(define ch
5270: 61 72 2d 73 65 74 3a 64 69 67 69 74 20 20 20 20 ar-set:digit
5280: 20 28 73 74 72 69 6e 67 2d 3e 63 68 61 72 2d 73 (string->char-s
5290: 65 74 20 22 30 31 32 33 34 35 36 37 38 39 22 29 et "0123456789")
52a0: 29 0a 28 64 65 66 69 6e 65 20 63 68 61 72 2d 73 ).(define char-s
52b0: 65 74 3a 68 65 78 2d 64 69 67 69 74 20 28 73 74 et:hex-digit (st
52c0: 72 69 6e 67 2d 3e 63 68 61 72 2d 73 65 74 20 22 ring->char-set "
52d0: 30 31 32 33 34 35 36 37 38 39 61 62 63 64 65 66 0123456789abcdef
52e0: 41 42 43 44 45 46 22 29 29 0a 0a 28 64 65 66 69 ABCDEF"))..(defi
52f0: 6e 65 20 63 68 61 72 2d 73 65 74 3a 6c 65 74 74 ne char-set:lett
5300: 65 72 2b 64 69 67 69 74 0a 20 20 28 63 68 61 72 er+digit. (char
5310: 2d 73 65 74 2d 75 6e 69 6f 6e 20 63 68 61 72 2d -set-union char-
5320: 73 65 74 3a 6c 65 74 74 65 72 20 63 68 61 72 2d set:letter char-
5330: 73 65 74 3a 64 69 67 69 74 29 29 0a 0a 28 64 65 set:digit))..(de
5340: 66 69 6e 65 20 63 68 61 72 2d 73 65 74 3a 70 75 fine char-set:pu
5350: 6e 63 74 75 61 74 69 6f 6e 0a 20 20 28 6c 65 74 nctuation. (let
5360: 20 28 28 61 73 63 69 69 20 28 73 74 72 69 6e 67 ((ascii (string
5370: 2d 3e 63 68 61 72 2d 73 65 74 20 22 21 5c 22 23 ->char-set "!\"#
5380: 25 26 27 28 29 2a 2c 2d 2e 2f 3a 3b 3f 40 5b 5c %&'()*,-./:;?@[\
5390: 5c 5d 5f 7b 7d 22 29 29 0a 09 28 6c 61 74 69 6e \]_{}"))..(latin
53a0: 2d 31 2d 63 68 61 72 73 20 28 6d 61 70 20 25 6c -1-chars (map %l
53b0: 61 74 69 6e 31 2d 3e 63 68 61 72 20 27 28 23 78 atin1->char '(#x
53c0: 41 31 20 3b 20 49 4e 56 45 52 54 45 44 20 45 58 A1 ; INVERTED EX
53d0: 43 4c 41 4d 41 54 49 4f 4e 20 4d 41 52 4b 0a 09 CLAMATION MARK..
53e0: 09 09 09 09 20 20 20 20 23 78 41 42 20 3b 20 4c .... #xAB ; L
53f0: 45 46 54 2d 50 4f 49 4e 54 49 4e 47 20 44 4f 55 EFT-POINTING DOU
5400: 42 4c 45 20 41 4e 47 4c 45 20 51 55 4f 54 41 54 BLE ANGLE QUOTAT
5410: 49 4f 4e 20 4d 41 52 4b 0a 09 09 09 09 09 20 20 ION MARK......
5420: 20 20 23 78 41 44 20 3b 20 53 4f 46 54 20 48 59 #xAD ; SOFT HY
5430: 50 48 45 4e 0a 09 09 09 09 09 20 20 20 20 23 78 PHEN...... #x
5440: 42 37 20 3b 20 4d 49 44 44 4c 45 20 44 4f 54 0a B7 ; MIDDLE DOT.
5450: 09 09 09 09 09 20 20 20 20 23 78 42 42 20 3b 20 ..... #xBB ;
5460: 52 49 47 48 54 2d 50 4f 49 4e 54 49 4e 47 20 44 RIGHT-POINTING D
5470: 4f 55 42 4c 45 20 41 4e 47 4c 45 20 51 55 4f 54 OUBLE ANGLE QUOT
5480: 41 54 49 4f 4e 20 4d 41 52 4b 0a 09 09 09 09 09 ATION MARK......
5490: 20 20 20 20 23 78 42 46 29 29 29 29 20 3b 20 49 #xBF)))) ; I
54a0: 4e 56 45 52 54 45 44 20 51 55 45 53 54 49 4f 4e NVERTED QUESTION
54b0: 20 4d 41 52 4b 0a 20 20 20 20 28 6c 69 73 74 2d MARK. (list-
54c0: 3e 63 68 61 72 2d 73 65 74 21 20 6c 61 74 69 6e >char-set! latin
54d0: 2d 31 2d 63 68 61 72 73 20 61 73 63 69 69 29 29 -1-chars ascii))
54e0: 29 0a 0a 28 64 65 66 69 6e 65 20 63 68 61 72 2d )..(define char-
54f0: 73 65 74 3a 73 79 6d 62 6f 6c 0a 20 20 28 6c 65 set:symbol. (le
5500: 74 20 28 28 61 73 63 69 69 20 28 73 74 72 69 6e t ((ascii (strin
5510: 67 2d 3e 63 68 61 72 2d 73 65 74 20 22 24 2b 3c g->char-set "$+<
5520: 3d 3e 5e 60 7c 7e 22 29 29 0a 09 28 6c 61 74 69 =>^`|~"))..(lati
5530: 6e 2d 31 2d 63 68 61 72 73 20 28 6d 61 70 20 25 n-1-chars (map %
5540: 6c 61 74 69 6e 31 2d 3e 63 68 61 72 20 27 28 23 latin1->char '(#
5550: 78 30 30 41 32 20 3b 20 43 45 4e 54 20 53 49 47 x00A2 ; CENT SIG
5560: 4e 0a 09 09 09 09 09 20 20 20 20 23 78 30 30 41 N...... #x00A
5570: 33 20 3b 20 50 4f 55 4e 44 20 53 49 47 4e 0a 09 3 ; POUND SIGN..
5580: 09 09 09 09 20 20 20 20 23 78 30 30 41 34 20 3b .... #x00A4 ;
5590: 20 43 55 52 52 45 4e 43 59 20 53 49 47 4e 0a 09 CURRENCY SIGN..
55a0: 09 09 09 09 20 20 20 20 23 78 30 30 41 35 20 3b .... #x00A5 ;
55b0: 20 59 45 4e 20 53 49 47 4e 0a 09 09 09 09 09 20 YEN SIGN......
55c0: 20 20 20 23 78 30 30 41 36 20 3b 20 42 52 4f 4b #x00A6 ; BROK
55d0: 45 4e 20 42 41 52 0a 09 09 09 09 09 20 20 20 20 EN BAR......
55e0: 23 78 30 30 41 37 20 3b 20 53 45 43 54 49 4f 4e #x00A7 ; SECTION
55f0: 20 53 49 47 4e 0a 09 09 09 09 09 20 20 20 20 23 SIGN...... #
5600: 78 30 30 41 38 20 3b 20 44 49 41 45 52 45 53 49 x00A8 ; DIAERESI
5610: 53 0a 09 09 09 09 09 20 20 20 20 23 78 30 30 41 S...... #x00A
5620: 39 20 3b 20 43 4f 50 59 52 49 47 48 54 20 53 49 9 ; COPYRIGHT SI
5630: 47 4e 0a 09 09 09 09 09 20 20 20 20 23 78 30 30 GN...... #x00
5640: 41 43 20 3b 20 4e 4f 54 20 53 49 47 4e 0a 09 09 AC ; NOT SIGN...
5650: 09 09 09 20 20 20 20 23 78 30 30 41 45 20 3b 20 ... #x00AE ;
5660: 52 45 47 49 53 54 45 52 45 44 20 53 49 47 4e 0a REGISTERED SIGN.
5670: 09 09 09 09 09 20 20 20 20 23 78 30 30 41 46 20 ..... #x00AF
5680: 3b 20 4d 41 43 52 4f 4e 0a 09 09 09 09 09 20 20 ; MACRON......
5690: 20 20 23 78 30 30 42 30 20 3b 20 44 45 47 52 45 #x00B0 ; DEGRE
56a0: 45 20 53 49 47 4e 0a 09 09 09 09 09 20 20 20 20 E SIGN......
56b0: 23 78 30 30 42 31 20 3b 20 50 4c 55 53 2d 4d 49 #x00B1 ; PLUS-MI
56c0: 4e 55 53 20 53 49 47 4e 0a 09 09 09 09 09 20 20 NUS SIGN......
56d0: 20 20 23 78 30 30 42 34 20 3b 20 41 43 55 54 45 #x00B4 ; ACUTE
56e0: 20 41 43 43 45 4e 54 0a 09 09 09 09 09 20 20 20 ACCENT......
56f0: 20 23 78 30 30 42 36 20 3b 20 50 49 4c 43 52 4f #x00B6 ; PILCRO
5700: 57 20 53 49 47 4e 0a 09 09 09 09 09 20 20 20 20 W SIGN......
5710: 23 78 30 30 42 38 20 3b 20 43 45 44 49 4c 4c 41 #x00B8 ; CEDILLA
5720: 0a 09 09 09 09 09 20 20 20 20 23 78 30 30 44 37 ...... #x00D7
5730: 20 3b 20 4d 55 4c 54 49 50 4c 49 43 41 54 49 4f ; MULTIPLICATIO
5740: 4e 20 53 49 47 4e 0a 09 09 09 09 09 20 20 20 20 N SIGN......
5750: 23 78 30 30 46 37 29 29 29 29 20 3b 20 44 49 56 #x00F7)))) ; DIV
5760: 49 53 49 4f 4e 20 53 49 47 4e 0a 20 20 20 20 28 ISION SIGN. (
5770: 6c 69 73 74 2d 3e 63 68 61 72 2d 73 65 74 21 20 list->char-set!
5780: 6c 61 74 69 6e 2d 31 2d 63 68 61 72 73 20 61 73 latin-1-chars as
5790: 63 69 69 29 29 29 0a 20 20 0a 0a 28 64 65 66 69 cii))). ..(defi
57a0: 6e 65 20 63 68 61 72 2d 73 65 74 3a 67 72 61 70 ne char-set:grap
57b0: 68 69 63 0a 20 20 28 63 68 61 72 2d 73 65 74 2d hic. (char-set-
57c0: 75 6e 69 6f 6e 20 63 68 61 72 2d 73 65 74 3a 6c union char-set:l
57d0: 65 74 74 65 72 2b 64 69 67 69 74 20 63 68 61 72 etter+digit char
57e0: 2d 73 65 74 3a 70 75 6e 63 74 75 61 74 69 6f 6e -set:punctuation
57f0: 20 63 68 61 72 2d 73 65 74 3a 73 79 6d 62 6f 6c char-set:symbol
5800: 29 29 0a 0a 28 64 65 66 69 6e 65 20 63 68 61 72 ))..(define char
5810: 2d 73 65 74 3a 77 68 69 74 65 73 70 61 63 65 0a -set:whitespace.
5820: 20 20 28 6c 69 73 74 2d 3e 63 68 61 72 2d 73 65 (list->char-se
5830: 74 20 28 6d 61 70 20 25 6c 61 74 69 6e 31 2d 3e t (map %latin1->
5840: 63 68 61 72 20 27 28 23 78 30 39 20 3b 20 48 4f char '(#x09 ; HO
5850: 52 49 5a 4f 4e 54 41 4c 20 54 41 42 55 4c 41 54 RIZONTAL TABULAT
5860: 49 4f 4e 0a 09 09 09 09 20 20 20 20 20 20 20 23 ION..... #
5870: 78 30 41 20 3b 20 4c 49 4e 45 20 46 45 45 44 09 x0A ; LINE FEED.
5880: 09 0a 09 09 09 09 20 20 20 20 20 20 20 23 78 30 ...... #x0
5890: 42 20 3b 20 56 45 52 54 49 43 41 4c 20 54 41 42 B ; VERTICAL TAB
58a0: 55 4c 41 54 49 4f 4e 0a 09 09 09 09 20 20 20 20 ULATION.....
58b0: 20 20 20 23 78 30 43 20 3b 20 46 4f 52 4d 20 46 #x0C ; FORM F
58c0: 45 45 44 0a 09 09 09 09 20 20 20 20 20 20 20 23 EED..... #
58d0: 78 30 44 20 3b 20 43 41 52 52 49 41 47 45 20 52 x0D ; CARRIAGE R
58e0: 45 54 55 52 4e 0a 09 09 09 09 20 20 20 20 20 20 ETURN.....
58f0: 20 23 78 32 30 20 3b 20 53 50 41 43 45 0a 09 09 #x20 ; SPACE...
5900: 09 09 20 20 20 20 20 20 20 23 78 41 30 29 29 29 .. #xA0)))
5910: 29 0a 0a 28 64 65 66 69 6e 65 20 63 68 61 72 2d )..(define char-
5920: 73 65 74 3a 70 72 69 6e 74 69 6e 67 20 28 63 68 set:printing (ch
5930: 61 72 2d 73 65 74 2d 75 6e 69 6f 6e 20 63 68 61 ar-set-union cha
5940: 72 2d 73 65 74 3a 77 68 69 74 65 73 70 61 63 65 r-set:whitespace
5950: 20 63 68 61 72 2d 73 65 74 3a 67 72 61 70 68 69 char-set:graphi
5960: 63 29 29 20 3b 20 4e 4f 2d 42 52 45 41 4b 20 53 c)) ; NO-BREAK S
5970: 50 41 43 45 0a 0a 28 64 65 66 69 6e 65 20 63 68 PACE..(define ch
5980: 61 72 2d 73 65 74 3a 62 6c 61 6e 6b 0a 20 20 28 ar-set:blank. (
5990: 6c 69 73 74 2d 3e 63 68 61 72 2d 73 65 74 20 28 list->char-set (
59a0: 6d 61 70 20 25 6c 61 74 69 6e 31 2d 3e 63 68 61 map %latin1->cha
59b0: 72 20 27 28 23 78 30 39 20 3b 20 48 4f 52 49 5a r '(#x09 ; HORIZ
59c0: 4f 4e 54 41 4c 20 54 41 42 55 4c 41 54 49 4f 4e ONTAL TABULATION
59d0: 0a 09 09 09 09 20 20 20 20 20 20 20 23 78 32 30 ..... #x20
59e0: 20 3b 20 53 50 41 43 45 0a 09 09 09 09 20 20 20 ; SPACE.....
59f0: 20 20 20 20 23 78 41 30 29 29 29 29 20 3b 20 4e #xA0)))) ; N
5a00: 4f 2d 42 52 45 41 4b 20 53 50 41 43 45 0a 0a 0a O-BREAK SPACE...
5a10: 28 64 65 66 69 6e 65 20 63 68 61 72 2d 73 65 74 (define char-set
5a20: 3a 69 73 6f 2d 63 6f 6e 74 72 6f 6c 0a 20 20 28 :iso-control. (
5a30: 75 63 73 2d 72 61 6e 67 65 2d 3e 63 68 61 72 2d ucs-range->char-
5a40: 73 65 74 21 20 23 78 37 46 20 23 78 41 30 20 23 set! #x7F #xA0 #
5a50: 74 20 28 75 63 73 2d 72 61 6e 67 65 2d 3e 63 68 t (ucs-range->ch
5a60: 61 72 2d 73 65 74 20 30 20 33 32 29 29 29 0a 0a ar-set 0 32)))..
5a70: 28 64 65 66 69 6e 65 20 63 68 61 72 2d 73 65 74 (define char-set
5a80: 3a 61 73 63 69 69 20 28 75 63 73 2d 72 61 6e 67 :ascii (ucs-rang
5a90: 65 2d 3e 63 68 61 72 2d 73 65 74 20 30 20 31 32 e->char-set 0 12
5aa0: 38 29 29 0a 0a 0c 0a 3b 3b 3b 20 50 6f 72 74 69 8))....;;; Porti
5ab0: 6e 67 20 26 20 70 65 72 66 6f 72 6d 61 6e 63 65 ng & performance
5ac0: 2d 74 75 6e 69 6e 67 20 6e 6f 74 65 73 0a 3b 3b -tuning notes.;;
5ad0: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
5ae0: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
5af0: 3b 3b 3b 3b 0a 3b 3b 3b 20 53 65 65 20 74 68 65 ;;;;.;;; See the
5b00: 20 73 65 63 74 69 6f 6e 20 61 74 20 74 68 65 20 section at the
5b10: 62 65 67 69 6e 6e 69 6e 67 20 6f 66 20 74 68 69 beginning of thi
5b20: 73 20 66 69 6c 65 20 6f 6e 20 65 78 74 65 72 6e s file on extern
5b30: 61 6c 20 64 65 70 65 6e 64 65 6e 63 69 65 73 2e al dependencies.
5b40: 0a 3b 3b 3b 0a 3b 3b 3b 20 46 69 72 73 74 20 61 .;;;.;;; First a
5b50: 6e 64 20 66 6f 72 65 6d 6f 73 74 2c 20 72 65 77 nd foremost, rew
5b60: 72 69 74 65 20 74 68 69 73 20 63 6f 64 65 20 74 rite this code t
5b70: 6f 20 75 73 65 20 62 69 74 20 76 65 63 74 6f 72 o use bit vector
5b80: 73 20 6f 66 20 73 6f 6d 65 20 73 6f 72 74 2e 0a s of some sort..
5b90: 3b 3b 3b 20 54 68 69 73 20 77 69 6c 6c 20 67 69 ;;; This will gi
5ba0: 76 65 20 62 69 67 20 73 70 65 65 64 75 70 20 61 ve big speedup a
5bb0: 6e 64 20 6d 65 6d 6f 72 79 20 73 61 76 69 6e 67 nd memory saving
5bc0: 73 2e 0a 3b 3b 3b 0a 3b 3b 3b 20 2d 20 4c 45 54 s..;;;.;;; - LET
5bd0: 2d 4f 50 54 49 4f 4e 41 4c 53 2a 20 6d 61 63 72 -OPTIONALS* macr
5be0: 6f 2e 0a 3b 3b 3b 20 54 68 69 73 20 69 73 20 6f o..;;; This is o
5bf0: 6e 6c 79 20 75 73 65 64 20 6f 6e 63 65 2e 20 59 nly used once. Y
5c00: 6f 75 20 63 61 6e 20 72 65 77 72 69 74 65 20 74 ou can rewrite t
5c10: 68 65 20 75 73 65 2c 20 70 6f 72 74 20 74 68 65 he use, port the
5c20: 20 68 61 69 72 79 20 6d 61 63 72 6f 0a 3b 3b 3b hairy macro.;;;
5c30: 20 64 65 66 69 6e 69 74 69 6f 6e 20 28 77 68 69 definition (whi
5c40: 63 68 20 69 73 20 69 6d 70 6c 65 6d 65 6e 74 65 ch is implemente
5c50: 64 20 75 73 69 6e 67 20 61 20 43 6c 69 6e 67 65 d using a Clinge
5c60: 72 2d 52 65 65 73 20 6c 6f 77 2d 6c 65 76 65 6c r-Rees low-level
5c70: 0a 3b 3b 3b 20 65 78 70 6c 69 63 69 74 2d 72 65 .;;; explicit-re
5c80: 6e 61 6d 69 6e 67 20 6d 61 63 72 6f 20 73 79 73 naming macro sys
5c90: 74 65 6d 29 2c 20 6f 72 20 70 6f 72 74 20 74 68 tem), or port th
5ca0: 65 20 73 69 6d 70 6c 65 2c 20 68 69 67 68 2d 6c e simple, high-l
5cb0: 65 76 65 6c 0a 3b 3b 3b 20 64 65 66 69 6e 69 74 evel.;;; definit
5cc0: 69 6f 6e 2c 20 77 68 69 63 68 20 69 73 20 6c 65 ion, which is le
5cd0: 73 73 20 65 66 66 69 63 69 65 6e 74 2e 0a 3b 3b ss efficient..;;
5ce0: 3b 0a 3b 3b 3b 20 2d 20 3a 4f 50 54 49 4f 4e 41 ;.;;; - :OPTIONA
5cf0: 4c 20 6d 61 63 72 6f 0a 3b 3b 3b 20 56 65 72 79 L macro.;;; Very
5d00: 20 73 69 6d 70 6c 79 20 64 65 66 69 6e 65 64 20 simply defined
5d10: 75 73 69 6e 67 20 61 6e 20 52 35 52 53 20 68 69 using an R5RS hi
5d20: 67 68 2d 6c 65 76 65 6c 20 6d 61 63 72 6f 2e 0a gh-level macro..
5d30: 3b 3b 3b 0a 3b 3b 3b 20 49 6d 70 6c 65 6d 65 6e ;;;.;;; Implemen
5d40: 74 61 74 69 6f 6e 73 20 74 68 61 74 20 63 61 6e tations that can
5d50: 20 61 72 72 61 6e 67 65 20 66 6f 72 20 74 68 65 arrange for the
5d60: 20 62 61 73 65 20 63 68 61 72 20 73 65 74 73 20 base char sets
5d70: 74 6f 20 62 65 20 69 6d 6d 75 74 61 62 6c 65 0a to be immutable.
5d80: 3b 3b 3b 20 73 68 6f 75 6c 64 20 64 6f 20 73 6f ;;; should do so
5d90: 2e 20 28 45 2e 67 2e 2c 20 53 63 68 65 6d 65 20 . (E.g., Scheme
5da0: 34 38 20 61 6c 6c 6f 77 73 20 6f 6e 65 20 74 6f 48 allows one to
5db0: 20 6d 61 72 6b 20 61 20 73 74 72 69 6e 67 20 61 mark a string a
5dc0: 73 20 69 6d 6d 75 74 61 62 6c 65 2c 0a 3b 3b 3b s immutable,.;;;
5dd0: 20 77 68 69 63 68 20 63 61 6e 20 62 65 20 75 73 which can be us
5de0: 65 64 20 74 6f 20 70 72 6f 74 65 63 74 20 74 68 ed to protect th
5df0: 65 20 75 6e 64 65 72 6c 79 69 6e 67 20 73 74 72 e underlying str
5e00: 69 6e 67 73 2e 29 20 49 74 20 77 6f 75 6c 64 20 ings.) It would
5e10: 62 65 20 76 65 72 79 2c 0a 3b 3b 3b 20 76 65 72 be very,.;;; ver
5e20: 79 20 62 61 64 20 69 66 20 61 20 63 6c 69 65 6e y bad if a clien
5e30: 74 27 73 20 62 75 67 67 79 20 63 6f 64 65 20 63 t's buggy code c
5e40: 6f 72 72 75 70 74 65 64 20 74 68 65 73 65 20 63 orrupted these c
5e50: 6f 6e 73 74 61 6e 74 73 2e 0a 3b 3b 3b 0a 3b 3b onstants..;;;.;;
5e60: 3b 20 54 68 65 72 65 20 69 73 20 61 20 66 61 69 ; There is a fai
5e70: 72 20 61 6d 6f 75 6e 74 20 6f 66 20 61 72 67 75 r amount of argu
5e80: 6d 65 6e 74 20 63 68 65 63 6b 69 6e 67 2e 20 54 ment checking. T
5e90: 68 69 73 20 69 73 2c 20 73 74 72 69 63 74 6c 79 his is, strictly
5ea0: 20 73 70 65 61 6b 69 6e 67 2c 0a 3b 3b 3b 20 75 speaking,.;;; u
5eb0: 6e 6e 65 63 65 73 73 61 72 79 20 2d 2d 20 74 68 nnecessary -- th
5ec0: 65 20 61 63 74 75 61 6c 20 62 6f 64 79 20 6f 66 e actual body of
5ed0: 20 74 68 65 20 70 72 6f 63 65 64 75 72 65 73 20 the procedures
5ee0: 77 69 6c 6c 20 62 6c 6f 77 20 75 70 20 69 66 20 will blow up if
5ef0: 61 6e 0a 3b 3b 3b 20 69 6c 6c 65 67 61 6c 20 76 an.;;; illegal v
5f00: 61 6c 75 65 20 69 73 20 70 61 73 73 65 64 20 69 alue is passed i
5f10: 6e 2e 20 48 6f 77 65 76 65 72 2c 20 74 68 65 20 n. However, the
5f20: 65 72 72 6f 72 20 6d 65 73 73 61 67 65 20 77 69 error message wi
5f30: 6c 6c 20 6e 6f 74 20 62 65 20 61 73 20 67 6f 6f ll not be as goo
5f40: 64 0a 3b 3b 3b 20 61 73 20 69 66 20 74 68 65 20 d.;;; as if the
5f50: 65 72 72 6f 72 20 77 65 72 65 20 63 61 75 67 68 error were caugh
5f60: 74 20 61 74 20 74 68 65 20 22 68 69 67 68 65 72 t at the "higher
5f70: 20 6c 65 76 65 6c 2e 22 20 41 6c 73 6f 2c 20 61 level." Also, a
5f80: 20 76 65 72 79 2c 20 76 65 72 79 0a 3b 3b 3b 20 very, very.;;;
5f90: 73 6d 61 72 74 20 53 63 68 65 6d 65 20 63 6f 6d smart Scheme com
5fa0: 70 69 6c 65 72 20 6d 61 79 20 62 65 20 61 62 6c piler may be abl
5fb0: 65 20 74 6f 20 65 78 70 6c 6f 69 74 20 68 61 76 e to exploit hav
5fc0: 69 6e 67 20 74 68 65 20 74 79 70 65 20 63 68 65 ing the type che
5fd0: 63 6b 73 20 64 6f 6e 65 0a 3b 3b 3b 20 65 61 72 cks done.;;; ear
5fe0: 6c 79 2c 20 73 6f 20 74 68 61 74 20 74 68 65 20 ly, so that the
5ff0: 61 63 74 75 61 6c 20 62 6f 64 79 20 6f 66 20 74 actual body of t
6000: 68 65 20 70 72 6f 63 65 64 75 72 65 73 20 63 61 he procedures ca
6010: 6e 20 61 73 73 75 6d 65 20 70 72 6f 70 65 72 20 n assume proper
6020: 76 61 6c 75 65 73 2e 0a 3b 3b 3b 20 54 68 69 73 values..;;; This
6030: 20 69 73 6e 27 74 20 6c 69 6b 65 6c 79 3b 20 74 isn't likely; t
6040: 68 69 73 20 6b 69 6e 64 20 6f 66 20 63 6f 6d 70 his kind of comp
6050: 69 6c 65 72 20 74 65 63 68 6e 6f 6c 6f 67 79 20 iler technology
6060: 69 73 6e 27 74 20 63 6f 6d 6d 6f 6e 20 61 6e 79 isn't common any
6070: 0a 3b 3b 3b 20 6c 6f 6e 67 65 72 2e 0a 3b 3b 3b .;;; longer..;;;
6080: 20 0a 3b 3b 3b 20 54 68 65 20 6f 76 65 72 68 65 .;;; The overhe
6090: 61 64 20 6f 66 20 6f 70 74 69 6f 6e 61 6c 2d 61 ad of optional-a
60a0: 72 67 75 6d 65 6e 74 20 70 61 72 73 69 6e 67 20 rgument parsing
60b0: 69 73 20 69 72 72 69 74 61 74 69 6e 67 2e 20 54 is irritating. T
60c0: 68 65 20 6f 70 74 69 6f 6e 61 6c 0a 3b 3b 3b 20 he optional.;;;
60d0: 61 72 67 75 6d 65 6e 74 73 20 6d 75 73 74 20 62 arguments must b
60e0: 65 20 63 6f 6e 73 65 64 20 69 6e 74 6f 20 61 20 e consed into a
60f0: 72 65 73 74 20 6c 69 73 74 20 6f 6e 20 65 6e 74 rest list on ent
6100: 72 79 2c 20 61 6e 64 20 74 68 65 6e 20 70 61 72 ry, and then par
6110: 73 65 64 20 6f 75 74 2e 0a 3b 3b 3b 20 46 75 6e sed out..;;; Fun
6120: 63 74 69 6f 6e 20 63 61 6c 6c 20 73 68 6f 75 6c ction call shoul
6130: 64 20 62 65 20 61 20 6d 61 74 74 65 72 20 6f 66 d be a matter of
6140: 20 61 20 66 65 77 20 72 65 67 69 73 74 65 72 20 a few register
6150: 6d 6f 76 65 73 20 61 6e 64 20 61 20 6a 75 6d 70 moves and a jump
6160: 3b 20 69 74 0a 3b 3b 3b 20 73 68 6f 75 6c 64 20 ; it.;;; should
6170: 6e 6f 74 20 69 6e 76 6f 6c 76 65 20 68 65 61 70 not involve heap
6180: 20 61 6c 6c 6f 63 61 74 69 6f 6e 21 20 59 6f 75 allocation! You
6190: 72 20 53 63 68 65 6d 65 20 73 79 73 74 65 6d 20 r Scheme system
61a0: 6d 61 79 20 68 61 76 65 20 61 20 73 75 70 65 72 may have a super
61b0: 69 6f 72 0a 3b 3b 3b 20 6e 6f 6e 2d 52 35 52 53 ior.;;; non-R5RS
61c0: 20 6f 70 74 69 6f 6e 61 6c 2d 61 72 67 75 6d 65 optional-argume
61d0: 6e 74 20 73 79 73 74 65 6d 20 74 68 61 74 20 63 nt system that c
61e0: 61 6e 20 65 6c 69 6d 69 6e 61 74 65 20 74 68 69 an eliminate thi
61f0: 73 20 6f 76 65 72 68 65 61 64 2e 20 49 66 20 73 s overhead. If s
6200: 6f 2c 0a 3b 3b 3b 20 74 68 65 6e 20 74 68 69 73 o,.;;; then this
6210: 20 69 73 20 61 20 70 72 69 6d 65 20 63 61 6e 64 is a prime cand
6220: 69 64 61 74 65 20 66 6f 72 20 6f 70 74 69 6d 69 idate for optimi
6230: 73 69 6e 67 20 74 68 65 73 65 20 70 72 6f 63 65 sing these proce
6240: 64 75 72 65 73 2c 0a 3b 3b 3b 20 2a 65 73 70 65 dures,.;;; *espe
6250: 63 69 61 6c 6c 79 2a 20 74 68 65 20 6d 61 6e 79 cially* the many
6260: 20 6f 70 74 69 6f 6e 61 6c 20 42 41 53 45 2d 43 optional BASE-C
6270: 53 20 70 61 72 61 6d 65 74 65 72 73 2e 0a 3b 3b S parameters..;;
6280: 3b 0a 3b 3b 3b 20 4e 6f 74 65 20 74 68 61 74 20 ;.;;; Note that
6290: 6f 70 74 69 6f 6e 61 6c 20 61 72 67 75 6d 65 6e optional argumen
62a0: 74 73 20 61 72 65 20 61 6c 73 6f 20 61 20 62 61 ts are also a ba
62b0: 72 72 69 65 72 20 74 6f 20 70 72 6f 63 65 64 75 rrier to procedu
62c0: 72 65 20 69 6e 74 65 67 72 61 74 69 6f 6e 2e 0a re integration..
62d0: 3b 3b 3b 20 49 66 20 79 6f 75 72 20 53 63 68 65 ;;; If your Sche
62e0: 6d 65 20 73 79 73 74 65 6d 20 70 65 72 6d 69 74 me system permit
62f0: 73 20 79 6f 75 20 74 6f 20 73 70 65 63 69 66 79 s you to specify
6300: 20 61 6c 74 65 72 6e 61 74 65 20 65 6e 74 72 79 alternate entry
6310: 20 70 6f 69 6e 74 73 0a 3b 3b 3b 20 66 6f 72 20 points.;;; for
6320: 61 20 63 61 6c 6c 20 77 68 65 6e 20 74 68 65 20 a call when the
6330: 6e 75 6d 62 65 72 20 6f 66 20 6f 70 74 69 6f 6e number of option
6340: 61 6c 20 61 72 67 75 6d 65 6e 74 73 20 69 73 20 al arguments is
6350: 6b 6e 6f 77 6e 20 69 6e 20 61 20 6d 61 6e 6e 65 known in a manne
6360: 72 0a 3b 3b 3b 20 74 68 61 74 20 65 6e 61 62 6c r.;;; that enabl
6370: 65 73 20 69 6e 6c 69 6e 69 6e 67 2f 69 6e 74 65 es inlining/inte
6380: 67 72 61 74 69 6f 6e 2c 20 74 68 69 73 20 63 61 gration, this ca
6390: 6e 20 70 72 6f 76 69 64 65 20 70 65 72 66 6f 72 n provide perfor
63a0: 6d 61 6e 63 65 20 0a 3b 3b 3b 20 69 6d 70 72 6f mance .;;; impro
63b0: 76 65 6d 65 6e 74 73 2e 0a 3b 3b 3b 0a 3b 3b 3b vements..;;;.;;;
63c0: 20 54 68 65 72 65 20 69 73 20 65 6e 6f 75 67 68 There is enough
63d0: 20 2a 65 78 70 6c 69 63 69 74 2a 20 65 72 72 6f *explicit* erro
63e0: 72 20 63 68 65 63 6b 69 6e 67 20 74 68 61 74 20 r checking that
63f0: 2a 61 6c 6c 2a 20 69 6e 74 65 72 6e 61 6c 20 6f *all* internal o
6400: 70 65 72 61 74 69 6f 6e 73 0a 3b 3b 3b 20 73 68 perations.;;; sh
6410: 6f 75 6c 64 20 2a 6e 65 76 65 72 2a 20 70 72 6f ould *never* pro
6420: 64 75 63 65 20 61 20 74 79 70 65 20 6f 72 20 69 duce a type or i
6430: 6e 64 65 78 2d 72 61 6e 67 65 20 65 72 72 6f 72 ndex-range error
6440: 2e 20 50 65 72 69 6f 64 2e 20 46 65 65 6c 20 6c . Period. Feel l
6450: 69 6b 65 0a 3b 3b 3b 20 6c 69 76 69 6e 67 20 64 ike.;;; living d
6460: 61 6e 67 65 72 6f 75 73 6c 79 3f 20 2a 42 69 67 angerously? *Big
6470: 2a 20 70 65 72 66 6f 72 6d 61 6e 63 65 20 77 69 * performance wi
6480: 6e 20 74 6f 20 62 65 20 68 61 64 20 62 79 20 72 n to be had by r
6490: 65 70 6c 61 63 69 6e 67 20 73 74 72 69 6e 67 0a eplacing string.
64a0: 3b 3b 3b 20 61 6e 64 20 72 65 63 6f 72 64 2d 66 ;;; and record-f
64b0: 69 65 6c 64 20 61 63 63 65 73 73 6f 72 73 20 61 ield accessors a
64c0: 6e 64 20 73 65 74 74 65 72 73 20 77 69 74 68 20 nd setters with
64d0: 75 6e 73 61 66 65 20 65 71 75 69 76 61 6c 65 6e unsafe equivalen
64e0: 74 73 20 69 6e 20 74 68 65 0a 3b 3b 3b 20 63 6f ts in the.;;; co
64f0: 64 65 2e 20 53 69 6d 69 6c 61 72 6c 79 2c 20 66 de. Similarly, f
6500: 69 78 6e 75 6d 2d 73 70 65 63 69 66 69 63 20 6f ixnum-specific o
6510: 70 65 72 61 74 6f 72 73 20 63 61 6e 20 73 70 65 perators can spe
6520: 65 64 20 75 70 20 74 68 65 20 61 72 69 74 68 6d ed up the arithm
6530: 65 74 69 63 0a 3b 3b 3b 20 64 6f 6e 65 20 6f 6e etic.;;; done on
6540: 20 74 68 65 20 69 6e 64 65 78 20 76 61 6c 75 65 the index value
6550: 73 20 69 6e 20 74 68 65 20 69 6e 6e 65 72 20 6c s in the inner l
6560: 6f 6f 70 73 2e 20 54 68 65 20 6f 6e 6c 79 20 61 oops. The only a
6570: 72 67 75 6d 65 6e 74 73 20 74 68 61 74 20 61 72 rguments that ar
6580: 65 0a 3b 3b 3b 20 6e 6f 74 20 63 6f 6d 70 6c 65 e.;;; not comple
6590: 74 65 6c 79 20 65 72 72 6f 72 20 63 68 65 63 6b tely error check
65a0: 65 64 20 61 72 65 0a 3b 3b 3b 20 20 20 2d 20 73 ed are.;;; - s
65b0: 74 72 69 6e 67 20 6c 69 73 74 73 20 28 63 6f 6d tring lists (com
65c0: 70 6c 65 74 65 20 63 68 65 63 6b 69 6e 67 20 72 plete checking r
65d0: 65 71 75 69 72 65 73 20 74 69 6d 65 20 70 72 6f equires time pro
65e0: 70 6f 72 74 69 6f 6e 61 6c 20 74 6f 20 74 68 65 portional to the
65f0: 0a 3b 3b 3b 20 20 20 20 20 6c 65 6e 67 74 68 20 .;;; length
6600: 6f 66 20 74 68 65 20 6c 69 73 74 29 0a 3b 3b 3b of the list).;;;
6610: 20 20 20 2d 20 70 72 6f 63 65 64 75 72 65 20 61 - procedure a
6620: 72 67 75 6d 65 6e 74 73 2c 20 73 75 63 68 20 61 rguments, such a
6630: 73 20 63 68 61 72 2d 3e 63 68 61 72 20 6d 61 70 s char->char map
6640: 73 20 26 20 70 72 65 64 69 63 61 74 65 73 2e 0a s & predicates..
6650: 3b 3b 3b 20 20 20 20 20 54 68 65 72 65 20 69 73 ;;; There is
6660: 20 6e 6f 20 77 61 79 20 74 6f 20 63 68 65 63 6b no way to check
6670: 20 74 68 65 20 72 61 6e 67 65 20 26 20 64 6f 6d the range & dom
6680: 61 69 6e 20 6f 66 20 70 72 6f 63 65 64 75 72 65 ain of procedure
6690: 73 20 69 6e 20 53 63 68 65 6d 65 2e 0a 3b 3b 3b s in Scheme..;;;
66a0: 20 50 72 6f 63 65 64 75 72 65 73 20 74 68 61 74 Procedures that
66b0: 20 74 61 6b 65 20 74 68 65 73 65 20 70 61 72 61 take these para
66c0: 6d 65 74 65 72 73 20 63 61 6e 6e 6f 74 20 66 75 meters cannot fu
66d0: 6c 6c 79 20 63 68 65 63 6b 20 74 68 65 69 72 0a lly check their.
66e0: 3b 3b 3b 20 61 72 67 75 6d 65 6e 74 73 2e 20 42 ;;; arguments. B
66f0: 75 74 20 61 6c 6c 20 6f 74 68 65 72 20 74 79 70 ut all other typ
6700: 65 73 20 74 6f 20 61 6c 6c 20 6f 74 68 65 72 20 es to all other
6710: 70 72 6f 63 65 64 75 72 65 73 20 61 72 65 20 66 procedures are f
6720: 75 6c 6c 79 0a 3b 3b 3b 20 63 68 65 63 6b 65 64 ully.;;; checked
6730: 2e 0a 3b 3b 3b 0a 3b 3b 3b 20 54 68 69 73 20 64 ..;;;.;;; This d
6740: 6f 65 73 20 6f 70 65 6e 20 75 70 20 74 68 65 20 oes open up the
6750: 61 6c 74 65 72 6e 61 74 65 20 70 6f 73 73 69 62 alternate possib
6760: 69 6c 69 74 79 20 6f 66 20 73 69 6d 70 6c 79 20 ility of simply
6770: 2a 72 65 6d 6f 76 69 6e 67 2a 20 74 68 65 73 65 *removing* these
6780: 20 0a 3b 3b 3b 20 63 68 65 63 6b 73 2c 20 61 6e .;;; checks, an
6790: 64 20 6c 65 74 74 69 6e 67 20 74 68 65 20 73 61 d letting the sa
67a0: 66 65 20 70 72 69 6d 69 74 69 76 65 73 20 72 61 fe primitives ra
67b0: 69 73 65 20 74 68 65 20 65 72 72 6f 72 73 2e 20 ise the errors.
67c0: 4f 6e 20 61 20 64 75 6d 62 0a 3b 3b 3b 20 53 63 On a dumb.;;; Sc
67d0: 68 65 6d 65 20 73 79 73 74 65 6d 2c 20 74 68 69 heme system, thi
67e0: 73 20 77 6f 75 6c 64 20 70 72 6f 76 69 64 65 20 s would provide
67f0: 73 70 65 65 64 20 28 62 79 20 65 6c 69 6d 69 6e speed (by elimin
6800: 61 74 69 6e 67 20 74 68 65 20 72 65 64 75 6e 64 ating the redund
6810: 61 6e 74 0a 3b 3b 3b 20 65 72 72 6f 72 20 63 68 ant.;;; error ch
6820: 65 63 6b 73 29 20 61 74 20 74 68 65 20 63 6f 73 ecks) at the cos
6830: 74 20 6f 66 20 65 72 72 6f 72 2d 6d 65 73 73 61 t of error-messa
6840: 67 65 20 63 6c 61 72 69 74 79 2e 0a 3b 3b 3b 0a ge clarity..;;;.
6850: 3b 3b 3b 20 49 6e 20 61 6e 20 69 6e 74 65 72 70 ;;; In an interp
6860: 72 65 74 65 64 20 53 63 68 65 6d 65 2c 20 73 6f reted Scheme, so
6870: 6d 65 20 6f 66 20 74 68 65 73 65 20 70 72 6f 63 me of these proc
6880: 65 64 75 72 65 73 2c 20 6f 72 20 74 68 65 20 69 edures, or the i
6890: 6e 74 65 72 6e 61 6c 0a 3b 3b 3b 20 72 6f 75 74 nternal.;;; rout
68a0: 69 6e 65 73 20 77 69 74 68 20 25 20 70 72 65 66 ines with % pref
68b0: 69 78 65 73 2c 20 61 72 65 20 65 78 63 65 6c 6c ixes, are excell
68c0: 65 6e 74 20 63 61 6e 64 69 64 61 74 65 73 20 66 ent candidates f
68d0: 6f 72 20 62 65 69 6e 67 20 72 65 77 72 69 74 74 or being rewritt
68e0: 65 6e 0a 3b 3b 3b 20 69 6e 20 43 2e 0a 3b 3b 3b en.;;; in C..;;;
68f0: 0a 3b 3b 3b 20 49 74 20 77 6f 75 6c 64 20 61 6c .;;; It would al
6900: 73 6f 20 62 65 20 6e 69 63 65 20 74 6f 20 68 61 so be nice to ha
6910: 76 65 20 74 68 65 20 61 62 69 6c 69 74 79 20 74 ve the ability t
6920: 6f 20 6d 61 72 6b 20 73 6f 6d 65 20 6f 66 20 74 o mark some of t
6930: 68 65 73 65 0a 3b 3b 3b 20 72 6f 75 74 69 6e 65 hese.;;; routine
6940: 73 20 61 73 20 63 61 6e 64 69 64 61 74 65 73 20 s as candidates
6950: 66 6f 72 20 69 6e 6c 69 6e 69 6e 67 2f 69 6e 74 for inlining/int
6960: 65 67 72 61 74 69 6f 6e 2e 0a 3b 3b 3b 20 0a 3b egration..;;; .;
6970: 3b 3b 20 53 65 65 20 74 68 65 20 63 6f 6d 6d 65 ;; See the comme
6980: 6e 74 73 20 70 72 65 63 65 64 69 6e 67 20 74 68 nts preceding th
6990: 65 20 68 61 73 68 20 66 75 6e 63 74 69 6f 6e 20 e hash function
69a0: 63 6f 64 65 20 66 6f 72 20 6e 6f 74 65 73 20 6f code for notes o
69b0: 6e 20 74 75 6e 69 6e 67 0a 3b 3b 3b 20 74 68 65 n tuning.;;; the
69c0: 20 64 65 66 61 75 6c 74 20 62 6f 75 6e 64 20 73 default bound s
69d0: 6f 20 74 68 61 74 20 74 68 65 20 63 6f 64 65 20 o that the code
69e0: 6e 65 76 65 72 20 6f 76 65 72 66 6c 6f 77 73 20 never overflows
69f0: 79 6f 75 72 20 69 6d 70 6c 65 6d 65 6e 74 61 74 your implementat
6a00: 69 6f 6e 27 73 0a 3b 3b 3b 20 66 69 78 6e 75 6d ion's.;;; fixnum
6a10: 20 73 69 7a 65 20 69 6e 74 6f 20 62 69 67 6e 75 size into bignu
6a20: 6d 20 63 61 6c 63 75 6c 61 74 69 6f 6e 2e 0a 3b m calculation..;
6a30: 3b 3b 0a 3b 3b 3b 20 41 6c 6c 20 74 68 65 20 25 ;;.;;; All the %
6a40: 2d 70 72 65 66 69 78 65 64 20 72 6f 75 74 69 6e -prefixed routin
6a50: 65 73 20 69 6e 20 74 68 69 73 20 73 6f 75 72 63 es in this sourc
6a60: 65 20 63 6f 64 65 20 61 72 65 20 77 72 69 74 74 e code are writt
6a70: 65 6e 0a 3b 3b 3b 20 74 6f 20 62 65 20 63 61 6c en.;;; to be cal
6a80: 6c 65 64 20 69 6e 74 65 72 6e 61 6c 6c 79 20 74 led internally t
6a90: 6f 20 74 68 69 73 20 6c 69 62 72 61 72 79 2e 20 o this library.
6aa0: 54 68 65 79 20 64 6f 20 2a 6e 6f 74 2a 20 70 65 They do *not* pe
6ab0: 72 66 6f 72 6d 0a 3b 3b 3b 20 66 72 69 65 6e 64 rform.;;; friend
6ac0: 6c 79 20 65 72 72 6f 72 20 63 68 65 63 6b 73 20 ly error checks
6ad0: 6f 6e 20 74 68 65 20 69 6e 70 75 74 73 3b 20 74 on the inputs; t
6ae0: 68 65 79 20 61 73 73 75 6d 65 20 65 76 65 72 79 hey assume every
6af0: 74 68 69 6e 67 20 69 73 0a 3b 3b 3b 20 70 72 6f thing is.;;; pro
6b00: 70 65 72 2e 20 54 68 65 79 20 61 6c 73 6f 20 64 per. They also d
6b10: 6f 20 6e 6f 74 20 74 61 6b 65 20 6f 70 74 69 6f o not take optio
6b20: 6e 61 6c 20 61 72 67 75 6d 65 6e 74 73 2e 20 54 nal arguments. T
6b30: 68 65 73 65 20 74 77 6f 20 70 72 6f 70 65 72 74 hese two propert
6b40: 69 65 73 0a 3b 3b 3b 20 73 61 76 65 20 63 61 6c ies.;;; save cal
6b50: 6c 69 6e 67 20 6f 76 65 72 68 65 61 64 20 61 6e ling overhead an
6b60: 64 20 65 6e 61 62 6c 65 20 70 72 6f 63 65 64 75 d enable procedu
6b70: 72 65 20 69 6e 74 65 67 72 61 74 69 6f 6e 20 2d re integration -
6b80: 2d 20 62 75 74 20 74 68 65 79 0a 3b 3b 3b 20 61 - but they.;;; a
6b90: 72 65 20 6e 6f 74 20 61 70 70 72 6f 70 72 69 61 re not appropria
6ba0: 74 65 20 66 6f 72 20 65 78 70 6f 72 74 65 64 20 te for exported
6bb0: 72 6f 75 74 69 6e 65 73 2e 0a 0a 3b 3b 3b 20 43 routines...;;; C
6bc0: 6f 70 79 72 69 67 68 74 20 6e 6f 74 69 63 65 0a opyright notice.
6bd0: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
6be0: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
6bf0: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
6c00: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
6c10: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 0a ;;;;;;;;;;;;;;;.
6c20: 3b 3b 3b 20 43 6f 70 79 72 69 67 68 74 20 28 63 ;;; Copyright (c
6c30: 29 20 31 39 38 38 2d 31 39 39 35 20 4d 61 73 73 ) 1988-1995 Mass
6c40: 61 63 68 75 73 65 74 74 73 20 49 6e 73 74 69 74 achusetts Instit
6c50: 75 74 65 20 6f 66 20 54 65 63 68 6e 6f 6c 6f 67 ute of Technolog
6c60: 79 0a 3b 3b 3b 20 0a 3b 3b 3b 20 54 68 69 73 20 y.;;; .;;; This
6c70: 6d 61 74 65 72 69 61 6c 20 77 61 73 20 64 65 76 material was dev
6c80: 65 6c 6f 70 65 64 20 62 79 20 74 68 65 20 53 63 eloped by the Sc
6c90: 68 65 6d 65 20 70 72 6f 6a 65 63 74 20 61 74 20 heme project at
6ca0: 74 68 65 20 4d 61 73 73 61 63 68 75 73 65 74 74 the Massachusett
6cb0: 73 0a 3b 3b 3b 20 49 6e 73 74 69 74 75 74 65 20 s.;;; Institute
6cc0: 6f 66 20 54 65 63 68 6e 6f 6c 6f 67 79 2c 20 44 of Technology, D
6cd0: 65 70 61 72 74 6d 65 6e 74 20 6f 66 20 45 6c 65 epartment of Ele
6ce0: 63 74 72 69 63 61 6c 20 45 6e 67 69 6e 65 65 72 ctrical Engineer
6cf0: 69 6e 67 20 61 6e 64 0a 3b 3b 3b 20 43 6f 6d 70 ing and.;;; Comp
6d00: 75 74 65 72 20 53 63 69 65 6e 63 65 2e 20 20 50 uter Science. P
6d10: 65 72 6d 69 73 73 69 6f 6e 20 74 6f 20 63 6f 70 ermission to cop
6d20: 79 20 61 6e 64 20 6d 6f 64 69 66 79 20 74 68 69 y and modify thi
6d30: 73 20 73 6f 66 74 77 61 72 65 2c 20 74 6f 0a 3b s software, to.;
6d40: 3b 3b 20 72 65 64 69 73 74 72 69 62 75 74 65 20 ;; redistribute
6d50: 65 69 74 68 65 72 20 74 68 65 20 6f 72 69 67 69 either the origi
6d60: 6e 61 6c 20 73 6f 66 74 77 61 72 65 20 6f 72 20 nal software or
6d70: 61 20 6d 6f 64 69 66 69 65 64 20 76 65 72 73 69 a modified versi
6d80: 6f 6e 2c 20 61 6e 64 0a 3b 3b 3b 20 74 6f 20 75 on, and.;;; to u
6d90: 73 65 20 74 68 69 73 20 73 6f 66 74 77 61 72 65 se this software
6da0: 20 66 6f 72 20 61 6e 79 20 70 75 72 70 6f 73 65 for any purpose
6db0: 20 69 73 20 67 72 61 6e 74 65 64 2c 20 73 75 62 is granted, sub
6dc0: 6a 65 63 74 20 74 6f 20 74 68 65 0a 3b 3b 3b 20 ject to the.;;;
6dd0: 66 6f 6c 6c 6f 77 69 6e 67 20 72 65 73 74 72 69 following restri
6de0: 63 74 69 6f 6e 73 20 61 6e 64 20 75 6e 64 65 72 ctions and under
6df0: 73 74 61 6e 64 69 6e 67 73 2e 0a 3b 3b 3b 20 0a standings..;;; .
6e00: 3b 3b 3b 20 31 2e 20 41 6e 79 20 63 6f 70 79 20 ;;; 1. Any copy
6e10: 6d 61 64 65 20 6f 66 20 74 68 69 73 20 73 6f 66 made of this sof
6e20: 74 77 61 72 65 20 6d 75 73 74 20 69 6e 63 6c 75 tware must inclu
6e30: 64 65 20 74 68 69 73 20 63 6f 70 79 72 69 67 68 de this copyrigh
6e40: 74 20 6e 6f 74 69 63 65 0a 3b 3b 3b 20 69 6e 20 t notice.;;; in
6e50: 66 75 6c 6c 2e 0a 3b 3b 3b 20 0a 3b 3b 3b 20 32 full..;;; .;;; 2
6e60: 2e 20 55 73 65 72 73 20 6f 66 20 74 68 69 73 20 . Users of this
6e70: 73 6f 66 74 77 61 72 65 20 61 67 72 65 65 20 74 software agree t
6e80: 6f 20 6d 61 6b 65 20 74 68 65 69 72 20 62 65 73 o make their bes
6e90: 74 20 65 66 66 6f 72 74 73 20 28 61 29 20 74 6f t efforts (a) to
6ea0: 0a 3b 3b 3b 20 72 65 74 75 72 6e 20 74 6f 20 74 .;;; return to t
6eb0: 68 65 20 4d 49 54 20 53 63 68 65 6d 65 20 70 72 he MIT Scheme pr
6ec0: 6f 6a 65 63 74 20 61 6e 79 20 69 6d 70 72 6f 76 oject any improv
6ed0: 65 6d 65 6e 74 73 20 6f 72 20 65 78 74 65 6e 73 ements or extens
6ee0: 69 6f 6e 73 20 74 68 61 74 0a 3b 3b 3b 20 74 68 ions that.;;; th
6ef0: 65 79 20 6d 61 6b 65 2c 20 73 6f 20 74 68 61 74 ey make, so that
6f00: 20 74 68 65 73 65 20 6d 61 79 20 62 65 20 69 6e these may be in
6f10: 63 6c 75 64 65 64 20 69 6e 20 66 75 74 75 72 65 cluded in future
6f20: 20 72 65 6c 65 61 73 65 73 3b 20 61 6e 64 20 28 releases; and (
6f30: 62 29 0a 3b 3b 3b 20 74 6f 20 69 6e 66 6f 72 6d b).;;; to inform
6f40: 20 4d 49 54 20 6f 66 20 6e 6f 74 65 77 6f 72 74 MIT of notewort
6f50: 68 79 20 75 73 65 73 20 6f 66 20 74 68 69 73 20 hy uses of this
6f60: 73 6f 66 74 77 61 72 65 2e 0a 3b 3b 3b 20 0a 3b software..;;; .;
6f70: 3b 3b 20 33 2e 20 41 6c 6c 20 6d 61 74 65 72 69 ;; 3. All materi
6f80: 61 6c 73 20 64 65 76 65 6c 6f 70 65 64 20 61 73 als developed as
6f90: 20 61 20 63 6f 6e 73 65 71 75 65 6e 63 65 20 6f a consequence o
6fa0: 66 20 74 68 65 20 75 73 65 20 6f 66 20 74 68 69 f the use of thi
6fb0: 73 0a 3b 3b 3b 20 73 6f 66 74 77 61 72 65 20 73 s.;;; software s
6fc0: 68 61 6c 6c 20 64 75 6c 79 20 61 63 6b 6e 6f 77 hall duly acknow
6fd0: 6c 65 64 67 65 20 73 75 63 68 20 75 73 65 2c 20 ledge such use,
6fe0: 69 6e 20 61 63 63 6f 72 64 61 6e 63 65 20 77 69 in accordance wi
6ff0: 74 68 20 74 68 65 20 75 73 75 61 6c 0a 3b 3b 3b th the usual.;;;
7000: 20 73 74 61 6e 64 61 72 64 73 20 6f 66 20 61 63 standards of ac
7010: 6b 6e 6f 77 6c 65 64 67 69 6e 67 20 63 72 65 64 knowledging cred
7020: 69 74 20 69 6e 20 61 63 61 64 65 6d 69 63 20 72 it in academic r
7030: 65 73 65 61 72 63 68 2e 0a 3b 3b 3b 20 0a 3b 3b esearch..;;; .;;
7040: 3b 20 34 2e 20 4d 49 54 20 68 61 73 20 6d 61 64 ; 4. MIT has mad
7050: 65 20 6e 6f 20 77 61 72 72 61 6e 74 65 65 20 6f e no warrantee o
7060: 72 20 72 65 70 72 65 73 65 6e 74 61 74 69 6f 6e r representation
7070: 20 74 68 61 74 20 74 68 65 20 6f 70 65 72 61 74 that the operat
7080: 69 6f 6e 20 6f 66 0a 3b 3b 3b 20 74 68 69 73 20 ion of.;;; this
7090: 73 6f 66 74 77 61 72 65 20 77 69 6c 6c 20 62 65 software will be
70a0: 20 65 72 72 6f 72 2d 66 72 65 65 2c 20 61 6e 64 error-free, and
70b0: 20 4d 49 54 20 69 73 20 75 6e 64 65 72 20 6e 6f MIT is under no
70c0: 20 6f 62 6c 69 67 61 74 69 6f 6e 20 74 6f 0a 3b obligation to.;
70d0: 3b 3b 20 70 72 6f 76 69 64 65 20 61 6e 79 20 73 ;; provide any s
70e0: 65 72 76 69 63 65 73 2c 20 62 79 20 77 61 79 20 ervices, by way
70f0: 6f 66 20 6d 61 69 6e 74 65 6e 61 6e 63 65 2c 20 of maintenance,
7100: 75 70 64 61 74 65 2c 20 6f 72 20 6f 74 68 65 72 update, or other
7110: 77 69 73 65 2e 0a 3b 3b 3b 20 0a 3b 3b 3b 20 35 wise..;;; .;;; 5
7120: 2e 20 49 6e 20 63 6f 6e 6a 75 6e 63 74 69 6f 6e . In conjunction
7130: 20 77 69 74 68 20 70 72 6f 64 75 63 74 73 20 61 with products a
7140: 72 69 73 69 6e 67 20 66 72 6f 6d 20 74 68 65 20 rising from the
7150: 75 73 65 20 6f 66 20 74 68 69 73 20 6d 61 74 65 use of this mate
7160: 72 69 61 6c 2c 0a 3b 3b 3b 20 74 68 65 72 65 20 rial,.;;; there
7170: 73 68 61 6c 6c 20 62 65 20 6e 6f 20 75 73 65 20 shall be no use
7180: 6f 66 20 74 68 65 20 6e 61 6d 65 20 6f 66 20 74 of the name of t
7190: 68 65 20 4d 61 73 73 61 63 68 75 73 65 74 74 73 he Massachusetts
71a0: 20 49 6e 73 74 69 74 75 74 65 20 6f 66 0a 3b 3b Institute of.;;
71b0: 3b 20 54 65 63 68 6e 6f 6c 6f 67 79 20 6e 6f 72 ; Technology nor
71c0: 20 6f 66 20 61 6e 79 20 61 64 61 70 74 61 74 69 of any adaptati
71d0: 6f 6e 20 74 68 65 72 65 6f 66 20 69 6e 20 61 6e on thereof in an
71e0: 79 20 61 64 76 65 72 74 69 73 69 6e 67 2c 0a 3b y advertising,.;
71f0: 3b 3b 20 70 72 6f 6d 6f 74 69 6f 6e 61 6c 2c 20 ;; promotional,
7200: 6f 72 20 73 61 6c 65 73 20 6c 69 74 65 72 61 74 or sales literat
7210: 75 72 65 20 77 69 74 68 6f 75 74 20 70 72 69 6f ure without prio
7220: 72 20 77 72 69 74 74 65 6e 20 63 6f 6e 73 65 6e r written consen
7230: 74 20 66 72 6f 6d 0a 3b 3b 3b 20 4d 49 54 20 69 t from.;;; MIT i
7240: 6e 20 65 61 63 68 20 63 61 73 65 2e 0a n each case..