0000: 3b 3b 3b 20 53 52 46 49 20 31 33 20 73 74 72 69 ;;; SRFI 13 stri
0010: 6e 67 20 6c 69 62 72 61 72 79 20 72 65 66 65 72 ng library refer
0020: 65 6e 63 65 20 69 6d 70 6c 65 6d 65 6e 74 61 74 ence implementat
0030: 69 6f 6e 09 09 2d 2a 2d 20 53 63 68 65 6d 65 20 ion..-*- Scheme
0040: 2d 2a 2d 0a 3b 3b 3b 20 4f 6c 69 6e 20 53 68 69 -*-.;;; Olin Shi
0050: 76 65 72 73 20 37 2f 32 30 30 30 0a 3b 3b 3b 0a vers 7/2000.;;;.
0060: 3b 3b 3b 20 43 6f 70 79 72 69 67 68 74 20 28 63 ;;; Copyright (c
0070: 29 20 31 39 38 38 2d 31 39 39 34 20 4d 61 73 73 ) 1988-1994 Mass
0080: 61 63 68 75 73 65 74 74 73 20 49 6e 73 74 69 74 achusetts Instit
0090: 75 74 65 20 6f 66 20 54 65 63 68 6e 6f 6c 6f 67 ute of Technolog
00a0: 79 2e 0a 3b 3b 3b 20 43 6f 70 79 72 69 67 68 74 y..;;; Copyright
00b0: 20 28 63 29 20 31 39 39 38 2c 20 31 39 39 39 2c (c) 1998, 1999,
00c0: 20 32 30 30 30 20 4f 6c 69 6e 20 53 68 69 76 65 2000 Olin Shive
00d0: 72 73 2e 20 41 6c 6c 20 72 69 67 68 74 73 20 72 rs. All rights r
00e0: 65 73 65 72 76 65 64 2e 0a 3b 3b 3b 20 20 20 54 eserved..;;; T
00f0: 68 65 20 64 65 74 61 69 6c 73 20 6f 66 20 74 68 he details of th
0100: 65 20 63 6f 70 79 72 69 67 68 74 73 20 61 70 70 e copyrights app
0110: 65 61 72 20 61 74 20 74 68 65 20 65 6e 64 20 6f ear at the end o
0120: 66 20 74 68 65 20 66 69 6c 65 2e 20 53 68 6f 72 f the file. Shor
0130: 74 0a 3b 3b 3b 20 20 20 73 75 6d 6d 61 72 79 3a t.;;; summary:
0140: 20 42 53 44 2d 73 74 79 6c 65 20 6f 70 65 6e 20 BSD-style open
0150: 73 6f 75 72 63 65 2e 0a 0a 3b 3b 3b 20 45 78 70 source...;;; Exp
0160: 6f 72 74 73 3a 0a 3b 3b 3b 20 73 74 72 69 6e 67 orts:.;;; string
0170: 2d 6d 61 70 20 73 74 72 69 6e 67 2d 6d 61 70 21 -map string-map!
0180: 0a 3b 3b 3b 20 73 74 72 69 6e 67 2d 66 6f 6c 64 .;;; string-fold
0190: 20 20 20 20 20 20 20 73 74 72 69 6e 67 2d 75 6e string-un
01a0: 66 6f 6c 64 0a 3b 3b 3b 20 73 74 72 69 6e 67 2d fold.;;; string-
01b0: 66 6f 6c 64 2d 72 69 67 68 74 20 73 74 72 69 6e fold-right strin
01c0: 67 2d 75 6e 66 6f 6c 64 2d 72 69 67 68 74 20 0a g-unfold-right .
01d0: 3b 3b 3b 20 73 74 72 69 6e 67 2d 74 61 62 75 6c ;;; string-tabul
01e0: 61 74 65 20 73 74 72 69 6e 67 2d 66 6f 72 2d 65 ate string-for-e
01f0: 61 63 68 20 73 74 72 69 6e 67 2d 66 6f 72 2d 65 ach string-for-e
0200: 61 63 68 2d 69 6e 64 65 78 0a 3b 3b 3b 20 73 74 ach-index.;;; st
0210: 72 69 6e 67 2d 65 76 65 72 79 20 73 74 72 69 6e ring-every strin
0220: 67 2d 61 6e 79 0a 3b 3b 3b 20 73 74 72 69 6e 67 g-any.;;; string
0230: 2d 68 61 73 68 20 73 74 72 69 6e 67 2d 68 61 73 -hash string-has
0240: 68 2d 63 69 0a 3b 3b 3b 20 73 74 72 69 6e 67 2d h-ci.;;; string-
0250: 63 6f 6d 70 61 72 65 20 73 74 72 69 6e 67 2d 63 compare string-c
0260: 6f 6d 70 61 72 65 2d 63 69 0a 3b 3b 3b 20 73 74 ompare-ci.;;; st
0270: 72 69 6e 67 3d 20 20 20 20 73 74 72 69 6e 67 3c ring= string<
0280: 20 20 20 20 73 74 72 69 6e 67 3e 20 20 20 20 73 string> s
0290: 74 72 69 6e 67 3c 3d 20 20 20 20 73 74 72 69 6e tring<= strin
02a0: 67 3e 3d 20 20 20 20 73 74 72 69 6e 67 3c 3e 0a g>= string<>.
02b0: 3b 3b 3b 20 73 74 72 69 6e 67 2d 63 69 3d 20 73 ;;; string-ci= s
02c0: 74 72 69 6e 67 2d 63 69 3c 20 73 74 72 69 6e 67 tring-ci< string
02d0: 2d 63 69 3e 20 73 74 72 69 6e 67 2d 63 69 3c 3d -ci> string-ci<=
02e0: 20 73 74 72 69 6e 67 2d 63 69 3e 3d 20 73 74 72 string-ci>= str
02f0: 69 6e 67 2d 63 69 3c 3e 20 0a 3b 3b 3b 20 73 74 ing-ci<> .;;; st
0300: 72 69 6e 67 2d 64 6f 77 6e 63 61 73 65 20 20 73 ring-downcase s
0310: 74 72 69 6e 67 2d 75 70 63 61 73 65 20 20 73 74 tring-upcase st
0320: 72 69 6e 67 2d 74 69 74 6c 65 63 61 73 65 20 20 ring-titlecase
0330: 0a 3b 3b 3b 20 73 74 72 69 6e 67 2d 64 6f 77 6e .;;; string-down
0340: 63 61 73 65 21 20 73 74 72 69 6e 67 2d 75 70 63 case! string-upc
0350: 61 73 65 21 20 73 74 72 69 6e 67 2d 74 69 74 6c ase! string-titl
0360: 65 63 61 73 65 21 20 0a 3b 3b 3b 20 73 74 72 69 ecase! .;;; stri
0370: 6e 67 2d 74 61 6b 65 20 73 74 72 69 6e 67 2d 74 ng-take string-t
0380: 61 6b 65 2d 72 69 67 68 74 0a 3b 3b 3b 20 73 74 ake-right.;;; st
0390: 72 69 6e 67 2d 64 72 6f 70 20 73 74 72 69 6e 67 ring-drop string
03a0: 2d 64 72 6f 70 2d 72 69 67 68 74 0a 3b 3b 3b 20 -drop-right.;;;
03b0: 73 74 72 69 6e 67 2d 70 61 64 20 73 74 72 69 6e string-pad strin
03c0: 67 2d 70 61 64 2d 72 69 67 68 74 0a 3b 3b 3b 20 g-pad-right.;;;
03d0: 73 74 72 69 6e 67 2d 74 72 69 6d 20 73 74 72 69 string-trim stri
03e0: 6e 67 2d 74 72 69 6d 2d 72 69 67 68 74 20 73 74 ng-trim-right st
03f0: 72 69 6e 67 2d 74 72 69 6d 2d 62 6f 74 68 0a 3b ring-trim-both.;
0400: 3b 3b 20 73 74 72 69 6e 67 2d 66 69 6c 74 65 72 ;; string-filter
0410: 20 73 74 72 69 6e 67 2d 64 65 6c 65 74 65 0a 3b string-delete.;
0420: 3b 3b 20 73 74 72 69 6e 67 2d 69 6e 64 65 78 20 ;; string-index
0430: 73 74 72 69 6e 67 2d 69 6e 64 65 78 2d 72 69 67 string-index-rig
0440: 68 74 20 0a 3b 3b 3b 20 73 74 72 69 6e 67 2d 73 ht .;;; string-s
0450: 6b 69 70 20 20 73 74 72 69 6e 67 2d 73 6b 69 70 kip string-skip
0460: 2d 72 69 67 68 74 0a 3b 3b 3b 20 73 74 72 69 6e -right.;;; strin
0470: 67 2d 63 6f 75 6e 74 0a 3b 3b 3b 20 73 74 72 69 g-count.;;; stri
0480: 6e 67 2d 70 72 65 66 69 78 2d 6c 65 6e 67 74 68 ng-prefix-length
0490: 20 73 74 72 69 6e 67 2d 70 72 65 66 69 78 2d 6c string-prefix-l
04a0: 65 6e 67 74 68 2d 63 69 0a 3b 3b 3b 20 73 74 72 ength-ci.;;; str
04b0: 69 6e 67 2d 73 75 66 66 69 78 2d 6c 65 6e 67 74 ing-suffix-lengt
04c0: 68 20 73 74 72 69 6e 67 2d 73 75 66 66 69 78 2d h string-suffix-
04d0: 6c 65 6e 67 74 68 2d 63 69 0a 3b 3b 3b 20 73 74 length-ci.;;; st
04e0: 72 69 6e 67 2d 70 72 65 66 69 78 3f 20 73 74 72 ring-prefix? str
04f0: 69 6e 67 2d 70 72 65 66 69 78 2d 63 69 3f 0a 3b ing-prefix-ci?.;
0500: 3b 3b 20 73 74 72 69 6e 67 2d 73 75 66 66 69 78 ;; string-suffix
0510: 3f 20 73 74 72 69 6e 67 2d 73 75 66 66 69 78 2d ? string-suffix-
0520: 63 69 3f 0a 3b 3b 3b 20 73 74 72 69 6e 67 2d 63 ci?.;;; string-c
0530: 6f 6e 74 61 69 6e 73 20 73 74 72 69 6e 67 2d 63 ontains string-c
0540: 6f 6e 74 61 69 6e 73 2d 63 69 0a 3b 3b 3b 20 73 ontains-ci.;;; s
0550: 74 72 69 6e 67 2d 63 6f 70 79 21 20 73 75 62 73 tring-copy! subs
0560: 74 72 69 6e 67 2f 73 68 61 72 65 64 0a 3b 3b 3b tring/shared.;;;
0570: 20 73 74 72 69 6e 67 2d 72 65 76 65 72 73 65 20 string-reverse
0580: 73 74 72 69 6e 67 2d 72 65 76 65 72 73 65 21 20 string-reverse!
0590: 72 65 76 65 72 73 65 2d 6c 69 73 74 2d 3e 73 74 reverse-list->st
05a0: 72 69 6e 67 0a 3b 3b 3b 20 73 74 72 69 6e 67 2d ring.;;; string-
05b0: 63 6f 6e 63 61 74 65 6e 61 74 65 20 73 74 72 69 concatenate stri
05c0: 6e 67 2d 63 6f 6e 63 61 74 65 6e 61 74 65 2f 73 ng-concatenate/s
05d0: 68 61 72 65 64 20 73 74 72 69 6e 67 2d 63 6f 6e hared string-con
05e0: 63 61 74 65 6e 61 74 65 2d 72 65 76 65 72 73 65 catenate-reverse
05f0: 0a 3b 3b 3b 20 73 74 72 69 6e 67 2d 61 70 70 65 .;;; string-appe
0600: 6e 64 2f 73 68 61 72 65 64 0a 3b 3b 3b 20 78 73 nd/shared.;;; xs
0610: 75 62 73 74 72 69 6e 67 20 73 74 72 69 6e 67 2d ubstring string-
0620: 78 63 6f 70 79 21 0a 3b 3b 3b 20 73 74 72 69 6e xcopy!.;;; strin
0630: 67 2d 6e 75 6c 6c 3f 0a 3b 3b 3b 20 73 74 72 69 g-null?.;;; stri
0640: 6e 67 2d 6a 6f 69 6e 0a 3b 3b 3b 20 73 74 72 69 ng-join.;;; stri
0650: 6e 67 2d 74 6f 6b 65 6e 69 7a 65 0a 3b 3b 3b 20 ng-tokenize.;;;
0660: 73 74 72 69 6e 67 2d 72 65 70 6c 61 63 65 0a 3b string-replace.;
0670: 3b 3b 20 0a 3b 3b 3b 20 52 35 52 53 20 65 78 74 ;; .;;; R5RS ext
0680: 65 6e 64 65 64 3a 0a 3b 3b 3b 20 73 74 72 69 6e ended:.;;; strin
0690: 67 2d 3e 6c 69 73 74 20 73 74 72 69 6e 67 2d 63 g->list string-c
06a0: 6f 70 79 20 73 74 72 69 6e 67 2d 66 69 6c 6c 21 opy string-fill!
06b0: 20 0a 3b 3b 3b 0a 3b 3b 3b 20 52 35 52 53 20 72 .;;;.;;; R5RS r
06c0: 65 2d 65 78 70 6f 72 74 73 3a 0a 3b 3b 3b 20 73 e-exports:.;;; s
06d0: 74 72 69 6e 67 3f 20 6d 61 6b 65 2d 73 74 72 69 tring? make-stri
06e0: 6e 67 20 73 74 72 69 6e 67 2d 6c 65 6e 67 74 68 ng string-length
06f0: 20 73 74 72 69 6e 67 2d 72 65 66 20 73 74 72 69 string-ref stri
0700: 6e 67 2d 73 65 74 21 20 0a 3b 3b 3b 0a 3b 3b 3b ng-set! .;;;.;;;
0710: 20 52 35 52 53 20 72 65 2d 65 78 70 6f 72 74 73 R5RS re-exports
0720: 20 28 61 6c 73 6f 20 64 65 66 69 6e 65 64 20 68 (also defined h
0730: 65 72 65 20 62 75 74 20 63 6f 6d 6d 65 6e 74 65 ere but commente
0740: 64 2d 6f 75 74 29 3a 0a 3b 3b 3b 20 73 74 72 69 d-out):.;;; stri
0750: 6e 67 20 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 ng string-append
0760: 20 6c 69 73 74 2d 3e 73 74 72 69 6e 67 0a 3b 3b list->string.;;
0770: 3b 0a 3b 3b 3b 20 4c 6f 77 2d 6c 65 76 65 6c 20 ;.;;; Low-level
0780: 72 6f 75 74 69 6e 65 73 3a 0a 3b 3b 3b 20 6d 61 routines:.;;; ma
0790: 6b 65 2d 6b 6d 70 2d 72 65 73 74 61 72 74 2d 76 ke-kmp-restart-v
07a0: 65 63 74 6f 72 20 73 74 72 69 6e 67 2d 6b 6d 70 ector string-kmp
07b0: 2d 70 61 72 74 69 61 6c 2d 73 65 61 72 63 68 20 -partial-search
07c0: 6b 6d 70 2d 73 74 65 70 0a 3b 3b 3b 20 73 74 72 kmp-step.;;; str
07d0: 69 6e 67 2d 70 61 72 73 65 2d 73 74 61 72 74 2b ing-parse-start+
07e0: 65 6e 64 0a 3b 3b 3b 20 73 74 72 69 6e 67 2d 70 end.;;; string-p
07f0: 61 72 73 65 2d 66 69 6e 61 6c 2d 73 74 61 72 74 arse-final-start
0800: 2b 65 6e 64 0a 3b 3b 3b 20 6c 65 74 2d 73 74 72 +end.;;; let-str
0810: 69 6e 67 2d 73 74 61 72 74 2b 65 6e 64 0a 3b 3b ing-start+end.;;
0820: 3b 20 63 68 65 63 6b 2d 73 75 62 73 74 72 69 6e ; check-substrin
0830: 67 2d 73 70 65 63 0a 3b 3b 3b 20 73 75 62 73 74 g-spec.;;; subst
0840: 72 69 6e 67 2d 73 70 65 63 2d 6f 6b 3f 0a 0a 3b ring-spec-ok?..;
0850: 3b 3b 20 49 6d 70 6f 72 74 73 0a 3b 3b 3b 20 54 ;; Imports.;;; T
0860: 68 69 73 20 69 73 20 61 20 66 61 69 72 6c 79 20 his is a fairly
0870: 6c 61 72 67 65 20 6c 69 62 72 61 72 79 2e 20 57 large library. W
0880: 68 69 6c 65 20 69 74 20 77 61 73 20 77 72 69 74 hile it was writ
0890: 74 65 6e 20 66 6f 72 20 70 6f 72 74 61 62 69 6c ten for portabil
08a0: 69 74 79 2c 20 79 6f 75 0a 3b 3b 3b 20 6d 75 73 ity, you.;;; mus
08b0: 74 20 62 65 20 61 77 61 72 65 20 6f 66 20 69 74 t be aware of it
08c0: 73 20 64 65 70 65 6e 64 65 6e 63 69 65 73 20 69 s dependencies i
08d0: 6e 20 6f 72 64 65 72 20 74 6f 20 72 75 6e 20 69 n order to run i
08e0: 74 20 69 6e 20 61 20 67 69 76 65 6e 20 73 63 68 t in a given sch
08f0: 65 6d 65 0a 3b 3b 3b 20 69 6d 70 6c 65 6d 65 6e eme.;;; implemen
0900: 74 61 74 69 6f 6e 2e 20 48 65 72 65 20 69 73 20 tation. Here is
0910: 61 20 63 6f 6d 70 6c 65 74 65 20 6c 69 73 74 20 a complete list
0920: 6f 66 20 74 68 65 20 64 65 70 65 6e 64 65 6e 63 of the dependenc
0930: 69 65 73 20 69 74 20 68 61 73 20 61 6e 64 20 74 ies it has and t
0940: 68 65 0a 3b 3b 3b 20 61 73 73 75 6d 70 74 69 6f he.;;; assumptio
0950: 6e 73 20 69 74 20 6d 61 6b 65 73 20 62 65 79 6f ns it makes beyo
0960: 6e 64 20 73 74 6f 63 6b 20 52 35 52 53 20 53 63 nd stock R5RS Sc
0970: 68 65 6d 65 3a 0a 3b 3b 3b 0a 3b 3b 3b 20 54 68 heme:.;;;.;;; Th
0980: 69 73 20 63 6f 64 65 20 68 61 73 20 74 68 65 20 is code has the
0990: 66 6f 6c 6c 6f 77 69 6e 67 20 6e 6f 6e 2d 52 35 following non-R5
09a0: 52 53 20 64 65 70 65 6e 64 65 6e 63 69 65 73 3a RS dependencies:
09b0: 0a 3b 3b 3b 20 2d 20 28 52 45 43 45 49 56 45 20 .;;; - (RECEIVE
09c0: 28 76 61 72 20 2e 2e 2e 29 20 6d 76 2d 65 78 70 (var ...) mv-exp
09d0: 20 62 6f 64 79 20 2e 2e 2e 29 20 6d 75 6c 74 69 body ...) multi
09e0: 70 6c 65 2d 76 61 6c 75 65 20 62 69 6e 64 69 6e ple-value bindin
09f0: 67 20 6d 61 63 72 6f 3b 0a 3b 3b 3b 0a 3b 3b 3b g macro;.;;;.;;;
0a00: 20 2d 20 56 61 72 69 6f 75 73 20 69 6d 70 6f 72 - Various impor
0a10: 74 73 20 66 72 6f 6d 20 74 68 65 20 63 68 61 72 ts from the char
0a20: 2d 73 65 74 20 6c 69 62 72 61 72 79 20 66 6f 72 -set library for
0a30: 20 74 68 65 20 72 6f 75 74 69 6e 65 73 20 74 68 the routines th
0a40: 61 74 20 63 61 6e 0a 3b 3b 3b 20 20 20 74 61 6b at can.;;; tak
0a50: 65 20 63 68 61 72 2d 73 65 74 20 61 72 67 75 6d e char-set argum
0a60: 65 6e 74 73 3b 0a 3b 3b 3b 20 20 20 0a 3b 3b 3b ents;.;;; .;;;
0a70: 20 2d 20 41 6e 20 6e 2d 61 72 79 20 45 52 52 4f - An n-ary ERRO
0a80: 52 20 70 72 6f 63 65 64 75 72 65 3b 0a 3b 3b 3b R procedure;.;;;
0a90: 20 20 20 0a 3b 3b 3b 20 2d 20 42 49 54 57 49 53 .;;; - BITWIS
0aa0: 45 2d 41 4e 44 20 66 6f 72 20 74 68 65 20 68 61 E-AND for the ha
0ab0: 73 68 20 66 75 6e 63 74 69 6f 6e 73 3b 0a 3b 3b sh functions;.;;
0ac0: 3b 20 20 20 0a 3b 3b 3b 20 2d 20 41 20 73 69 6d ; .;;; - A sim
0ad0: 70 6c 65 20 43 48 45 43 4b 2d 41 52 47 20 70 72 ple CHECK-ARG pr
0ae0: 6f 63 65 64 75 72 65 20 66 6f 72 20 63 68 65 63 ocedure for chec
0af0: 6b 69 6e 67 20 70 61 72 61 6d 65 74 65 72 20 76 king parameter v
0b00: 61 6c 75 65 73 3b 20 69 74 20 69 73 20 0a 3b 3b alues; it is .;;
0b10: 3b 20 20 20 28 6c 61 6d 62 64 61 20 28 70 72 65 ; (lambda (pre
0b20: 64 20 76 61 6c 20 70 72 6f 63 29 20 0a 3b 3b 3b d val proc) .;;;
0b30: 20 20 20 20 20 28 69 66 20 28 70 72 65 64 20 76 (if (pred v
0b40: 61 6c 29 20 76 61 6c 20 28 65 72 72 6f 72 20 22 al) val (error "
0b50: 42 61 64 20 61 72 67 22 20 76 61 6c 20 70 72 65 Bad arg" val pre
0b60: 64 20 70 72 6f 63 29 29 29 0a 3b 3b 3b 20 20 20 d proc))).;;;
0b70: 0a 3b 3b 3b 20 2d 20 3a 4f 50 54 49 4f 4e 41 4c .;;; - :OPTIONAL
0b80: 20 61 6e 64 20 4c 45 54 2d 4f 50 54 49 4f 4e 41 and LET-OPTIONA
0b90: 4c 53 2a 20 6d 61 63 72 6f 73 20 66 6f 72 20 70 LS* macros for p
0ba0: 61 72 73 69 6e 67 2c 20 64 65 66 61 75 6c 74 69 arsing, defaulti
0bb0: 6e 67 20 26 20 0a 3b 3b 3b 20 20 20 74 79 70 65 ng & .;;; type
0bc0: 2d 63 68 65 63 6b 69 6e 67 20 6f 70 74 69 6f 6e -checking option
0bd0: 61 6c 20 70 61 72 61 6d 65 74 65 72 73 20 66 72 al parameters fr
0be0: 6f 6d 20 61 20 72 65 73 74 20 61 72 67 75 6d 65 om a rest argume
0bf0: 6e 74 3b 0a 3b 3b 3b 20 20 20 0a 3b 3b 3b 20 2d nt;.;;; .;;; -
0c00: 20 43 48 41 52 2d 43 41 53 45 44 3f 20 61 6e 64 CHAR-CASED? and
0c10: 20 43 48 41 52 2d 54 49 54 4c 45 43 41 53 45 20 CHAR-TITLECASE
0c20: 66 6f 72 20 74 68 65 20 53 54 52 49 4e 47 2d 54 for the STRING-T
0c30: 49 54 4c 45 43 41 53 45 20 26 20 0a 3b 3b 3b 20 ITLECASE & .;;;
0c40: 20 20 53 54 52 49 4e 47 2d 54 49 54 4c 45 43 41 STRING-TITLECA
0c50: 53 45 21 20 70 72 6f 63 65 64 75 72 65 73 2e 20 SE! procedures.
0c60: 54 68 65 20 66 6f 72 6d 65 72 20 72 65 74 75 72 The former retur
0c70: 6e 73 20 74 72 75 65 20 69 66 66 20 61 20 63 68 ns true iff a ch
0c80: 61 72 61 63 74 65 72 20 69 73 0a 3b 3b 3b 20 20 aracter is.;;;
0c90: 20 6f 6e 65 20 74 68 61 74 20 68 61 73 20 63 61 one that has ca
0ca0: 73 65 20 64 69 73 74 69 6e 63 74 69 6f 6e 73 3b se distinctions;
0cb0: 20 69 6e 20 41 53 43 49 49 20 69 74 20 72 65 74 in ASCII it ret
0cc0: 75 72 6e 73 20 74 72 75 65 20 6f 6e 20 61 2d 7a urns true on a-z
0cd0: 20 61 6e 64 20 41 2d 5a 2e 0a 3b 3b 3b 20 20 20 and A-Z..;;;
0ce0: 43 48 41 52 2d 54 49 54 4c 45 43 41 53 45 20 69 CHAR-TITLECASE i
0cf0: 73 20 61 6e 61 6c 61 67 6f 75 73 20 74 6f 20 43 s analagous to C
0d00: 48 41 52 2d 55 50 43 41 53 45 20 61 6e 64 20 43 HAR-UPCASE and C
0d10: 48 41 52 2d 44 4f 57 4e 43 41 53 45 2e 20 49 6e HAR-DOWNCASE. In
0d20: 20 41 53 43 49 49 20 26 0a 3b 3b 3b 20 20 20 4c ASCII &.;;; L
0d30: 61 74 69 6e 2d 31 2c 20 69 74 20 69 73 20 74 68 atin-1, it is th
0d40: 65 20 73 61 6d 65 20 61 73 20 43 48 41 52 2d 55 e same as CHAR-U
0d50: 50 43 41 53 45 2e 0a 3b 3b 3b 0a 3b 3b 3b 20 54 PCASE..;;;.;;; T
0d60: 68 65 20 63 6f 64 65 20 64 65 70 65 6e 64 73 20 he code depends
0d70: 75 70 6f 6e 20 61 20 73 6d 61 6c 6c 20 73 65 74 upon a small set
0d80: 20 6f 66 20 63 6f 72 65 20 73 74 72 69 6e 67 20 of core string
0d90: 70 72 69 6d 69 74 69 76 65 73 20 66 72 6f 6d 20 primitives from
0da0: 52 35 52 53 3a 0a 3b 3b 3b 20 20 20 20 20 4d 41 R5RS:.;;; MA
0db0: 4b 45 2d 53 54 52 49 4e 47 20 53 54 52 49 4e 47 KE-STRING STRING
0dc0: 2d 52 45 46 20 53 54 52 49 4e 47 2d 53 45 54 21 -REF STRING-SET!
0dd0: 20 53 54 52 49 4e 47 3f 20 53 54 52 49 4e 47 2d STRING? STRING-
0de0: 4c 45 4e 47 54 48 20 53 55 42 53 54 52 49 4e 47 LENGTH SUBSTRING
0df0: 20 0a 3b 3b 3b 20 28 41 63 74 75 61 6c 6c 79 2c .;;; (Actually,
0e00: 20 53 55 42 53 54 52 49 4e 47 20 69 73 20 6e 6f SUBSTRING is no
0e10: 74 20 61 20 70 72 69 6d 69 74 69 76 65 2c 20 62 t a primitive, b
0e20: 75 74 20 77 65 20 61 73 73 75 6d 65 20 74 68 61 ut we assume tha
0e30: 74 20 61 6e 20 0a 3b 3b 3b 20 69 6d 70 6c 65 6d t an .;;; implem
0e40: 65 6e 74 61 74 69 6f 6e 27 73 20 6e 61 74 69 76 entation's nativ
0e50: 65 20 76 65 72 73 69 6f 6e 20 69 73 20 70 72 6f e version is pro
0e60: 62 61 62 6c 79 20 66 61 73 74 65 72 20 74 68 61 bably faster tha
0e70: 6e 20 6f 6e 65 20 77 65 20 63 6f 75 6c 64 0a 3b n one we could.;
0e80: 3b 3b 20 64 65 66 69 6e 65 2c 20 73 6f 20 77 65 ;; define, so we
0e90: 20 69 6d 70 6f 72 74 20 69 74 20 66 72 6f 6d 20 import it from
0ea0: 52 35 52 53 2e 29 0a 3b 3b 3b 0a 3b 3b 3b 20 54 R5RS.).;;;.;;; T
0eb0: 68 65 20 63 6f 64 65 20 64 65 70 65 6e 64 73 20 he code depends
0ec0: 75 70 6f 6e 20 61 20 73 6d 61 6c 6c 20 73 65 74 upon a small set
0ed0: 20 6f 66 20 52 35 52 53 20 63 68 61 72 61 63 74 of R5RS charact
0ee0: 65 72 20 70 72 69 6d 69 74 69 76 65 73 3a 0a 3b er primitives:.;
0ef0: 3b 3b 20 20 20 63 68 61 72 3f 20 63 68 61 72 3d ;; char? char=
0f00: 3f 20 63 68 61 72 2d 63 69 3d 3f 20 63 68 61 72 ? char-ci=? char
0f10: 3c 3f 20 63 68 61 72 2d 63 69 3c 3f 0a 3b 3b 3b <? char-ci<?.;;;
0f20: 20 20 20 63 68 61 72 2d 75 70 63 61 73 65 20 63 char-upcase c
0f30: 68 61 72 2d 64 6f 77 6e 63 61 73 65 0a 3b 3b 3b har-downcase.;;;
0f40: 20 20 20 63 68 61 72 2d 3e 69 6e 74 65 67 65 72 char->integer
0f50: 20 28 66 6f 72 20 74 68 65 20 68 61 73 68 20 66 (for the hash f
0f60: 75 6e 63 74 69 6f 6e 73 29 0a 3b 3b 3b 20 20 20 unctions).;;;
0f70: 0a 3b 3b 3b 20 57 65 20 61 73 73 75 6d 65 20 74 .;;; We assume t
0f80: 68 65 20 66 6f 6c 6c 6f 77 69 6e 67 3a 0a 3b 3b he following:.;;
0f90: 3b 20 2d 20 43 48 41 52 2d 44 4f 57 4e 43 41 53 ; - CHAR-DOWNCAS
0fa0: 45 20 6f 20 43 48 41 52 2d 55 50 43 41 53 45 20 E o CHAR-UPCASE
0fb0: 3d 20 43 48 41 52 2d 44 4f 57 4e 43 41 53 45 0a = CHAR-DOWNCASE.
0fc0: 3b 3b 3b 20 2d 20 43 48 41 52 2d 43 49 3d 3f 20 ;;; - CHAR-CI=?
0fd0: 69 73 20 65 71 75 69 76 61 6c 65 6e 74 20 74 6f is equivalent to
0fe0: 0a 3b 3b 3b 20 20 20 20 20 28 6c 61 6d 62 64 61 .;;; (lambda
0ff0: 20 28 63 31 20 63 32 29 20 28 63 68 61 72 3d 3f (c1 c2) (char=?
1000: 20 28 63 68 61 72 2d 64 6f 77 6e 63 61 73 65 20 (char-downcase
1010: 28 63 68 61 72 2d 75 70 63 61 73 65 20 63 31 29 (char-upcase c1)
1020: 29 0a 3b 3b 3b 20 20 20 20 20 20 20 20 20 20 20 ).;;;
1030: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1040: 20 20 28 63 68 61 72 2d 64 6f 77 6e 63 61 73 65 (char-downcase
1050: 20 28 63 68 61 72 2d 75 70 63 61 73 65 20 63 32 (char-upcase c2
1060: 29 29 29 29 0a 3b 3b 3b 20 2d 20 43 48 41 52 2d )))).;;; - CHAR-
1070: 55 50 43 41 53 45 2c 20 43 48 41 52 2d 44 4f 57 UPCASE, CHAR-DOW
1080: 4e 43 41 53 45 20 61 6e 64 20 43 48 41 52 2d 54 NCASE and CHAR-T
1090: 49 54 4c 45 43 41 53 45 20 61 72 65 20 6c 6f 63 ITLECASE are loc
10a0: 61 6c 65 2d 69 6e 73 65 6e 73 69 74 69 76 65 0a ale-insensitive.
10b0: 3b 3b 3b 20 20 20 61 6e 64 20 63 6f 6e 73 69 73 ;;; and consis
10c0: 74 65 6e 74 20 77 69 74 68 20 55 6e 69 63 6f 64 tent with Unicod
10d0: 65 27 73 20 31 2d 31 20 63 68 61 72 2d 6d 61 70 e's 1-1 char-map
10e0: 70 69 6e 67 20 73 70 65 63 2e 0a 3b 3b 3b 20 54 ping spec..;;; T
10f0: 68 65 73 65 20 74 68 69 6e 67 73 20 61 72 65 20 hese things are
1100: 74 79 70 69 63 61 6c 6c 79 20 74 72 75 65 2c 20 typically true,
1110: 62 75 74 20 69 66 20 6e 6f 74 2c 20 79 6f 75 20 but if not, you
1120: 77 6f 75 6c 64 20 6e 65 65 64 20 74 6f 20 6d 6f would need to mo
1130: 64 69 66 79 0a 3b 3b 3b 20 74 68 65 20 63 61 73 dify.;;; the cas
1140: 65 2d 6d 61 70 70 69 6e 67 20 61 6e 64 20 63 61 e-mapping and ca
1150: 73 65 2d 69 6e 73 65 6e 73 69 74 69 76 65 20 72 se-insensitive r
1160: 6f 75 74 69 6e 65 73 2e 0a 0a 3b 3b 3b 20 45 6e outines...;;; En
1170: 6f 75 67 68 20 69 6e 74 72 6f 64 75 63 74 6f 72 ough introductor
1180: 79 20 62 6c 61 74 68 65 72 2e 20 4f 6e 20 74 6f y blather. On to
1190: 20 74 68 65 20 73 6f 75 72 63 65 20 63 6f 64 65 the source code
11a0: 2e 20 28 42 75 74 20 73 65 65 20 74 68 65 20 65 . (But see the e
11b0: 6e 64 20 6f 66 0a 3b 3b 3b 20 74 68 65 20 66 69 nd of.;;; the fi
11c0: 6c 65 20 66 6f 72 20 66 75 72 74 68 65 72 20 6e le for further n
11d0: 6f 74 65 73 20 6f 6e 20 70 6f 72 74 69 6e 67 20 otes on porting
11e0: 26 20 70 65 72 66 6f 72 6d 61 6e 63 65 20 74 75 & performance tu
11f0: 6e 69 6e 67 2e 29 0a 0a 0c 0a 3b 3b 3b 20 53 75 ning.)....;;; Su
1200: 70 70 6f 72 74 20 66 6f 72 20 53 54 41 52 54 2f pport for START/
1210: 45 4e 44 20 73 75 62 73 74 72 69 6e 67 20 73 70 END substring sp
1220: 65 63 73 0a 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ecs.;;;;;;;;;;;;
1230: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
1240: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
1250: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
1260: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
1270: 3b 3b 3b 0a 3b 3b 3b 20 54 68 69 73 20 6d 61 63 ;;;.;;; This mac
1280: 72 6f 20 70 61 72 73 65 73 20 6f 70 74 69 6f 6e ro parses option
1290: 61 6c 20 73 74 61 72 74 2f 65 6e 64 20 61 72 67 al start/end arg
12a0: 75 6d 65 6e 74 73 20 66 72 6f 6d 20 61 72 67 20 uments from arg
12b0: 6c 69 73 74 73 2c 20 64 65 66 61 75 6c 74 69 6e lists, defaultin
12c0: 67 0a 3b 3b 3b 20 74 68 65 6d 20 74 6f 20 30 2f g.;;; them to 0/
12d0: 28 73 74 72 69 6e 67 2d 6c 65 6e 67 74 68 20 73 (string-length s
12e0: 29 2c 20 61 6e 64 20 63 68 65 63 6b 73 20 74 68 ), and checks th
12f0: 65 6d 20 66 6f 72 20 63 6f 72 72 65 63 74 6e 65 em for correctne
1300: 73 73 2e 0a 0a 28 64 65 66 69 6e 65 2d 73 79 6e ss...(define-syn
1310: 74 61 78 20 6c 65 74 2d 73 74 72 69 6e 67 2d 73 tax let-string-s
1320: 74 61 72 74 2b 65 6e 64 0a 20 20 28 73 79 6e 74 tart+end. (synt
1330: 61 78 2d 72 75 6c 65 73 20 28 29 0a 20 20 20 20 ax-rules ().
1340: 28 28 6c 65 74 2d 73 74 72 69 6e 67 2d 73 74 61 ((let-string-sta
1350: 72 74 2b 65 6e 64 20 28 73 74 61 72 74 20 65 6e rt+end (start en
1360: 64 29 20 70 72 6f 63 20 73 2d 65 78 70 20 61 72 d) proc s-exp ar
1370: 67 73 2d 65 78 70 20 62 6f 64 79 20 2e 2e 2e 29 gs-exp body ...)
1380: 0a 20 20 20 20 20 28 72 65 63 65 69 76 65 20 28 . (receive (
1390: 73 74 61 72 74 20 65 6e 64 29 20 28 73 74 72 69 start end) (stri
13a0: 6e 67 2d 70 61 72 73 65 2d 66 69 6e 61 6c 2d 73 ng-parse-final-s
13b0: 74 61 72 74 2b 65 6e 64 20 70 72 6f 63 20 73 2d tart+end proc s-
13c0: 65 78 70 20 61 72 67 73 2d 65 78 70 29 0a 20 20 exp args-exp).
13d0: 20 20 20 20 20 62 6f 64 79 20 2e 2e 2e 29 29 0a body ...)).
13e0: 20 20 20 20 28 28 6c 65 74 2d 73 74 72 69 6e 67 ((let-string
13f0: 2d 73 74 61 72 74 2b 65 6e 64 20 28 73 74 61 72 -start+end (star
1400: 74 20 65 6e 64 20 72 65 73 74 29 20 70 72 6f 63 t end rest) proc
1410: 20 73 2d 65 78 70 20 61 72 67 73 2d 65 78 70 20 s-exp args-exp
1420: 62 6f 64 79 20 2e 2e 2e 29 0a 20 20 20 20 20 28 body ...). (
1430: 72 65 63 65 69 76 65 20 28 72 65 73 74 20 73 74 receive (rest st
1440: 61 72 74 20 65 6e 64 29 20 28 73 74 72 69 6e 67 art end) (string
1450: 2d 70 61 72 73 65 2d 73 74 61 72 74 2b 65 6e 64 -parse-start+end
1460: 20 70 72 6f 63 20 73 2d 65 78 70 20 61 72 67 73 proc s-exp args
1470: 2d 65 78 70 29 0a 20 20 20 20 20 20 20 62 6f 64 -exp). bod
1480: 79 20 2e 2e 2e 29 29 29 29 0a 0a 3b 3b 3b 20 54 y ...))))..;;; T
1490: 68 69 73 20 6f 6e 65 20 70 61 72 73 65 73 20 6f his one parses o
14a0: 75 74 20 61 20 2a 70 61 69 72 2a 20 6f 66 20 66 ut a *pair* of f
14b0: 69 6e 61 6c 20 73 74 61 72 74 2f 65 6e 64 20 69 inal start/end i
14c0: 6e 64 69 63 65 73 2e 20 0a 3b 3b 3b 20 4e 6f 74 ndices. .;;; Not
14d0: 20 65 78 70 6f 72 74 65 64 3b 20 66 6f 72 20 69 exported; for i
14e0: 6e 74 65 72 6e 61 6c 20 75 73 65 2e 0a 28 64 65 nternal use..(de
14f0: 66 69 6e 65 2d 73 79 6e 74 61 78 20 6c 65 74 2d fine-syntax let-
1500: 73 74 72 69 6e 67 2d 73 74 61 72 74 2b 65 6e 64 string-start+end
1510: 32 0a 20 20 28 73 79 6e 74 61 78 2d 72 75 6c 65 2. (syntax-rule
1520: 73 20 28 29 0a 20 20 20 20 28 28 6c 2d 73 2d 73 s (). ((l-s-s
1530: 2b 65 32 20 28 73 74 61 72 74 31 20 65 6e 64 31 +e2 (start1 end1
1540: 20 73 74 61 72 74 32 20 65 6e 64 32 29 20 70 72 start2 end2) pr
1550: 6f 63 20 73 31 20 73 32 20 61 72 67 73 20 62 6f oc s1 s2 args bo
1560: 64 79 20 2e 2e 2e 29 0a 20 20 20 20 20 28 6c 65 dy ...). (le
1570: 74 20 28 28 70 72 6f 63 76 20 70 72 6f 63 29 29 t ((procv proc))
1580: 20 3b 20 4d 61 6b 65 20 73 75 72 65 20 50 52 4f ; Make sure PRO
1590: 43 20 69 73 20 6f 6e 6c 79 20 65 76 61 6c 75 61 C is only evalua
15a0: 74 65 64 20 6f 6e 63 65 2e 0a 20 20 20 20 20 20 ted once..
15b0: 20 28 6c 65 74 2d 73 74 72 69 6e 67 2d 73 74 61 (let-string-sta
15c0: 72 74 2b 65 6e 64 20 28 73 74 61 72 74 31 20 65 rt+end (start1 e
15d0: 6e 64 31 20 72 65 73 74 29 20 70 72 6f 63 76 20 nd1 rest) procv
15e0: 73 31 20 61 72 67 73 0a 20 20 20 20 20 20 20 20 s1 args.
15f0: 20 28 6c 65 74 2d 73 74 72 69 6e 67 2d 73 74 61 (let-string-sta
1600: 72 74 2b 65 6e 64 20 28 73 74 61 72 74 32 20 65 rt+end (start2 e
1610: 6e 64 32 29 20 70 72 6f 63 76 20 73 32 20 72 65 nd2) procv s2 re
1620: 73 74 0a 20 20 20 20 20 20 20 20 20 20 20 62 6f st. bo
1630: 64 79 20 2e 2e 2e 29 29 29 29 29 29 0a 0a 0a 3b dy ...))))))...;
1640: 3b 3b 20 52 65 74 75 72 6e 73 20 74 68 72 65 65 ;; Returns three
1650: 20 76 61 6c 75 65 73 3a 20 72 65 73 74 20 73 74 values: rest st
1660: 61 72 74 20 65 6e 64 0a 0a 28 64 65 66 69 6e 65 art end..(define
1670: 20 28 73 74 72 69 6e 67 2d 70 61 72 73 65 2d 73 (string-parse-s
1680: 74 61 72 74 2b 65 6e 64 20 70 72 6f 63 20 73 20 tart+end proc s
1690: 61 72 67 73 29 0a 20 20 28 69 66 20 28 6e 6f 74 args). (if (not
16a0: 20 28 73 74 72 69 6e 67 3f 20 73 29 29 20 28 65 (string? s)) (e
16b0: 72 72 6f 72 20 22 4e 6f 6e 2d 73 74 72 69 6e 67 rror "Non-string
16c0: 20 76 61 6c 75 65 22 20 70 72 6f 63 20 73 29 29 value" proc s))
16d0: 0a 20 20 28 6c 65 74 20 28 28 73 6c 65 6e 20 28 . (let ((slen (
16e0: 73 74 72 69 6e 67 2d 6c 65 6e 67 74 68 20 73 29 string-length s)
16f0: 29 29 0a 20 20 20 20 28 69 66 20 28 70 61 69 72 )). (if (pair
1700: 3f 20 61 72 67 73 29 0a 0a 09 28 6c 65 74 20 28 ? args)...(let (
1710: 28 73 74 61 72 74 20 28 63 61 72 20 61 72 67 73 (start (car args
1720: 29 29 0a 09 20 20 20 20 20 20 28 61 72 67 73 20 )).. (args
1730: 28 63 64 72 20 61 72 67 73 29 29 29 0a 09 20 20 (cdr args)))..
1740: 28 69 66 20 28 61 6e 64 20 28 69 6e 74 65 67 65 (if (and (intege
1750: 72 3f 20 73 74 61 72 74 29 20 28 65 78 61 63 74 r? start) (exact
1760: 3f 20 73 74 61 72 74 29 20 28 3e 3d 20 73 74 61 ? start) (>= sta
1770: 72 74 20 30 29 29 0a 09 20 20 20 20 20 20 28 72 rt 0)).. (r
1780: 65 63 65 69 76 65 20 28 65 6e 64 20 61 72 67 73 eceive (end args
1790: 29 0a 09 09 20 20 28 69 66 20 28 70 61 69 72 3f )... (if (pair?
17a0: 20 61 72 67 73 29 0a 09 09 20 20 20 20 20 20 28 args)... (
17b0: 6c 65 74 20 28 28 65 6e 64 20 28 63 61 72 20 61 let ((end (car a
17c0: 72 67 73 29 29 0a 09 09 09 20 20 20 20 28 61 72 rgs)).... (ar
17d0: 67 73 20 28 63 64 72 20 61 72 67 73 29 29 29 0a gs (cdr args))).
17e0: 09 09 09 28 69 66 20 28 61 6e 64 20 28 69 6e 74 ...(if (and (int
17f0: 65 67 65 72 3f 20 65 6e 64 29 20 28 65 78 61 63 eger? end) (exac
1800: 74 3f 20 65 6e 64 29 20 28 3c 3d 20 65 6e 64 20 t? end) (<= end
1810: 73 6c 65 6e 29 29 0a 09 09 09 20 20 20 20 28 76 slen)).... (v
1820: 61 6c 75 65 73 20 65 6e 64 20 61 72 67 73 29 0a alues end args).
1830: 09 09 09 20 20 20 20 28 65 72 72 6f 72 20 22 49 ... (error "I
1840: 6c 6c 65 67 61 6c 20 73 75 62 73 74 72 69 6e 67 llegal substring
1850: 20 45 4e 44 20 73 70 65 63 22 20 70 72 6f 63 20 END spec" proc
1860: 65 6e 64 20 73 29 29 29 0a 09 09 20 20 20 20 20 end s)))...
1870: 20 28 76 61 6c 75 65 73 20 73 6c 65 6e 20 61 72 (values slen ar
1880: 67 73 29 29 0a 09 09 28 69 66 20 28 3c 3d 20 73 gs))...(if (<= s
1890: 74 61 72 74 20 65 6e 64 29 20 28 76 61 6c 75 65 tart end) (value
18a0: 73 20 61 72 67 73 20 73 74 61 72 74 20 65 6e 64 s args start end
18b0: 29 0a 09 09 20 20 20 20 28 65 72 72 6f 72 20 22 )... (error "
18c0: 49 6c 6c 65 67 61 6c 20 73 75 62 73 74 72 69 6e Illegal substrin
18d0: 67 20 53 54 41 52 54 2f 45 4e 44 20 73 70 65 63 g START/END spec
18e0: 22 0a 09 09 09 20 20 20 70 72 6f 63 20 73 74 61 ".... proc sta
18f0: 72 74 20 65 6e 64 20 73 29 29 29 0a 09 20 20 20 rt end s)))..
1900: 20 20 20 28 65 72 72 6f 72 20 22 49 6c 6c 65 67 (error "Illeg
1910: 61 6c 20 73 75 62 73 74 72 69 6e 67 20 53 54 41 al substring STA
1920: 52 54 20 73 70 65 63 22 20 70 72 6f 63 20 73 74 RT spec" proc st
1930: 61 72 74 20 73 29 29 29 0a 0a 09 28 76 61 6c 75 art s)))...(valu
1940: 65 73 20 27 28 29 20 30 20 73 6c 65 6e 29 29 29 es '() 0 slen)))
1950: 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 74 72 69 )..(define (stri
1960: 6e 67 2d 70 61 72 73 65 2d 66 69 6e 61 6c 2d 73 ng-parse-final-s
1970: 74 61 72 74 2b 65 6e 64 20 70 72 6f 63 20 73 20 tart+end proc s
1980: 61 72 67 73 29 0a 20 20 28 72 65 63 65 69 76 65 args). (receive
1990: 20 28 72 65 73 74 20 73 74 61 72 74 20 65 6e 64 (rest start end
19a0: 29 20 28 73 74 72 69 6e 67 2d 70 61 72 73 65 2d ) (string-parse-
19b0: 73 74 61 72 74 2b 65 6e 64 20 70 72 6f 63 20 73 start+end proc s
19c0: 20 61 72 67 73 29 0a 20 20 20 20 28 69 66 20 28 args). (if (
19d0: 70 61 69 72 3f 20 72 65 73 74 29 20 28 65 72 72 pair? rest) (err
19e0: 6f 72 20 22 45 78 74 72 61 20 61 72 67 75 6d 65 or "Extra argume
19f0: 6e 74 73 20 74 6f 20 70 72 6f 63 65 64 75 72 65 nts to procedure
1a00: 22 20 70 72 6f 63 20 72 65 73 74 29 0a 09 28 76 " proc rest)..(v
1a10: 61 6c 75 65 73 20 73 74 61 72 74 20 65 6e 64 29 alues start end)
1a20: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 75 )))..(define (su
1a30: 62 73 74 72 69 6e 67 2d 73 70 65 63 2d 6f 6b 3f bstring-spec-ok?
1a40: 20 73 20 73 74 61 72 74 20 65 6e 64 29 0a 20 20 s start end).
1a50: 28 61 6e 64 20 28 73 74 72 69 6e 67 3f 20 73 29 (and (string? s)
1a60: 0a 20 20 20 20 20 20 20 28 69 6e 74 65 67 65 72 . (integer
1a70: 3f 20 73 74 61 72 74 29 0a 20 20 20 20 20 20 20 ? start).
1a80: 28 65 78 61 63 74 3f 20 73 74 61 72 74 29 0a 20 (exact? start).
1a90: 20 20 20 20 20 20 28 69 6e 74 65 67 65 72 3f 20 (integer?
1aa0: 65 6e 64 29 0a 20 20 20 20 20 20 20 28 65 78 61 end). (exa
1ab0: 63 74 3f 20 65 6e 64 29 0a 20 20 20 20 20 20 20 ct? end).
1ac0: 28 3c 3d 20 30 20 73 74 61 72 74 29 0a 20 20 20 (<= 0 start).
1ad0: 20 20 20 20 28 3c 3d 20 73 74 61 72 74 20 65 6e (<= start en
1ae0: 64 29 0a 20 20 20 20 20 20 20 28 3c 3d 20 65 6e d). (<= en
1af0: 64 20 28 73 74 72 69 6e 67 2d 6c 65 6e 67 74 68 d (string-length
1b00: 20 73 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 s))))..(define
1b10: 28 63 68 65 63 6b 2d 73 75 62 73 74 72 69 6e 67 (check-substring
1b20: 2d 73 70 65 63 20 70 72 6f 63 20 73 20 73 74 61 -spec proc s sta
1b30: 72 74 20 65 6e 64 29 0a 20 20 28 69 66 20 28 6e rt end). (if (n
1b40: 6f 74 20 28 73 75 62 73 74 72 69 6e 67 2d 73 70 ot (substring-sp
1b50: 65 63 2d 6f 6b 3f 20 73 20 73 74 61 72 74 20 65 ec-ok? s start e
1b60: 6e 64 29 29 0a 20 20 20 20 20 20 28 65 72 72 6f nd)). (erro
1b70: 72 20 22 49 6c 6c 65 67 61 6c 20 73 75 62 73 74 r "Illegal subst
1b80: 72 69 6e 67 20 73 70 65 63 2e 22 20 70 72 6f 63 ring spec." proc
1b90: 20 73 20 73 74 61 72 74 20 65 6e 64 29 29 29 0a s start end))).
1ba0: 0a 0a 3b 3b 3b 20 44 65 66 69 6e 65 64 20 62 79 ..;;; Defined by
1bb0: 20 52 35 52 53 2c 20 73 6f 20 63 6f 6d 6d 65 6e R5RS, so commen
1bc0: 74 65 64 20 6f 75 74 20 68 65 72 65 2e 0a 3b 28 ted out here..;(
1bd0: 64 65 66 69 6e 65 20 28 73 74 72 69 6e 67 20 2e define (string .
1be0: 20 63 68 61 72 73 29 0a 3b 20 20 28 6c 65 74 2a chars).; (let*
1bf0: 20 28 28 6c 65 6e 20 28 6c 65 6e 67 74 68 20 63 ((len (length c
1c00: 68 61 72 73 29 29 0a 3b 20 20 20 20 20 20 20 20 hars)).;
1c10: 20 28 61 6e 73 20 28 6d 61 6b 65 2d 73 74 72 69 (ans (make-stri
1c20: 6e 67 20 6c 65 6e 29 29 29 0a 3b 20 20 20 20 28 ng len))).; (
1c30: 64 6f 20 28 28 69 20 30 20 28 2b 20 69 20 31 29 do ((i 0 (+ i 1)
1c40: 29 0a 3b 09 20 28 63 68 61 72 73 20 63 68 61 72 ).;. (chars char
1c50: 73 20 28 63 64 72 20 63 68 61 72 73 29 29 29 0a s (cdr chars))).
1c60: 3b 09 28 28 3e 3d 20 69 20 6c 65 6e 29 29 0a 3b ;.((>= i len)).;
1c70: 20 20 20 20 20 20 28 73 74 72 69 6e 67 2d 73 65 (string-se
1c80: 74 21 20 61 6e 73 20 69 20 28 63 61 72 20 63 68 t! ans i (car ch
1c90: 61 72 73 29 29 29 0a 3b 20 20 20 20 61 6e 73 29 ars))).; ans)
1ca0: 29 0a 3b 0a 3b 28 64 65 66 69 6e 65 20 28 73 74 ).;.;(define (st
1cb0: 72 69 6e 67 20 2e 20 63 68 61 72 73 29 20 28 73 ring . chars) (s
1cc0: 74 72 69 6e 67 2d 75 6e 66 6f 6c 64 20 6e 75 6c tring-unfold nul
1cd0: 6c 3f 20 63 61 72 20 63 64 72 20 63 68 61 72 73 l? car cdr chars
1ce0: 29 29 0a 0a 0a 0c 0a 3b 3b 3b 20 73 75 62 73 74 )).....;;; subst
1cf0: 72 69 6e 67 2f 73 68 61 72 65 64 20 53 20 53 54 ring/shared S ST
1d00: 41 52 54 20 5b 45 4e 44 5d 20 0a 3b 3b 3b 20 73 ART [END] .;;; s
1d10: 74 72 69 6e 67 2d 63 6f 70 79 20 20 20 20 20 20 tring-copy
1d20: 53 20 5b 53 54 41 52 54 20 45 4e 44 5d 0a 3b 3b S [START END].;;
1d30: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
1d40: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
1d50: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
1d60: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
1d70: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 0a 0a 3b ;;;;;;;;;;;;;..;
1d80: 3b 3b 20 41 6c 6c 20 74 68 69 73 20 67 6f 6f 70 ;; All this goop
1d90: 20 69 73 20 6a 75 73 74 20 61 72 67 20 70 61 72 is just arg par
1da0: 73 69 6e 67 20 26 20 63 68 65 63 6b 69 6e 67 20 sing & checking
1db0: 73 75 72 72 6f 75 6e 64 69 6e 67 20 61 20 63 61 surrounding a ca
1dc0: 6c 6c 20 74 6f 20 74 68 65 0a 3b 3b 3b 20 61 63 ll to the.;;; ac
1dd0: 74 75 61 6c 20 70 72 69 6d 69 74 69 76 65 2c 20 tual primitive,
1de0: 25 53 55 42 53 54 52 49 4e 47 2f 53 48 41 52 45 %SUBSTRING/SHARE
1df0: 44 2e 0a 0a 28 64 65 66 69 6e 65 20 28 73 75 62 D...(define (sub
1e00: 73 74 72 69 6e 67 2f 73 68 61 72 65 64 20 73 20 string/shared s
1e10: 73 74 61 72 74 20 2e 20 6d 61 79 62 65 2d 65 6e start . maybe-en
1e20: 64 29 0a 20 20 28 63 68 65 63 6b 2d 61 72 67 20 d). (check-arg
1e30: 73 74 72 69 6e 67 3f 20 73 20 73 75 62 73 74 72 string? s substr
1e40: 69 6e 67 2f 73 68 61 72 65 64 29 0a 20 20 28 6c ing/shared). (l
1e50: 65 74 20 28 28 73 6c 65 6e 20 28 73 74 72 69 6e et ((slen (strin
1e60: 67 2d 6c 65 6e 67 74 68 20 73 29 29 29 0a 20 20 g-length s))).
1e70: 20 20 28 63 68 65 63 6b 2d 61 72 67 20 28 6c 61 (check-arg (la
1e80: 6d 62 64 61 20 28 73 74 61 72 74 29 20 28 61 6e mbda (start) (an
1e90: 64 20 28 69 6e 74 65 67 65 72 3f 20 73 74 61 72 d (integer? star
1ea0: 74 29 20 28 65 78 61 63 74 3f 20 73 74 61 72 74 t) (exact? start
1eb0: 29 20 28 3c 3d 20 30 20 73 74 61 72 74 29 29 29 ) (<= 0 start)))
1ec0: 0a 09 20 20 20 20 20 20 20 73 74 61 72 74 20 73 .. start s
1ed0: 75 62 73 74 72 69 6e 67 2f 73 68 61 72 65 64 29 ubstring/shared)
1ee0: 0a 20 20 20 20 28 25 73 75 62 73 74 72 69 6e 67 . (%substring
1ef0: 2f 73 68 61 72 65 64 20 73 20 73 74 61 72 74 0a /shared s start.
1f00: 09 09 20 20 20 20 20 20 20 28 3a 6f 70 74 69 6f .. (:optio
1f10: 6e 61 6c 20 6d 61 79 62 65 2d 65 6e 64 20 73 6c nal maybe-end sl
1f20: 65 6e 0a 09 09 09 09 20 20 28 6c 61 6d 62 64 61 en..... (lambda
1f30: 20 28 65 6e 64 29 20 28 61 6e 64 20 28 69 6e 74 (end) (and (int
1f40: 65 67 65 72 3f 20 65 6e 64 29 0a 09 09 09 09 09 eger? end)......
1f50: 09 20 20 20 20 20 28 65 78 61 63 74 3f 20 65 6e . (exact? en
1f60: 64 29 0a 09 09 09 09 09 09 20 20 20 20 20 28 3c d)....... (<
1f70: 3d 20 73 74 61 72 74 20 65 6e 64 29 0a 09 09 09 = start end)....
1f80: 09 09 09 20 20 20 20 20 28 3c 3d 20 65 6e 64 20 ... (<= end
1f90: 73 6c 65 6e 29 29 29 29 29 29 29 0a 0a 3b 3b 3b slen)))))))..;;;
1fa0: 20 53 70 6c 69 74 20 6f 75 74 20 73 6f 20 74 68 Split out so th
1fb0: 61 74 20 6f 74 68 65 72 20 72 6f 75 74 69 6e 65 at other routine
1fc0: 73 20 69 6e 20 74 68 69 73 20 6c 69 62 72 61 72 s in this librar
1fd0: 79 20 63 61 6e 20 61 76 6f 69 64 20 61 72 67 2d y can avoid arg-
1fe0: 70 61 72 73 69 6e 67 0a 3b 3b 3b 20 6f 76 65 72 parsing.;;; over
1ff0: 68 65 61 64 20 66 6f 72 20 45 4e 44 20 70 61 72 head for END par
2000: 61 6d 65 74 65 72 2e 0a 28 64 65 66 69 6e 65 20 ameter..(define
2010: 28 25 73 75 62 73 74 72 69 6e 67 2f 73 68 61 72 (%substring/shar
2020: 65 64 20 73 20 73 74 61 72 74 20 65 6e 64 29 0a ed s start end).
2030: 20 20 28 69 66 20 28 61 6e 64 20 28 7a 65 72 6f (if (and (zero
2040: 3f 20 73 74 61 72 74 29 20 28 3d 20 65 6e 64 20 ? start) (= end
2050: 28 73 74 72 69 6e 67 2d 6c 65 6e 67 74 68 20 73 (string-length s
2060: 29 29 29 20 73 0a 20 20 20 20 20 20 28 73 75 62 ))) s. (sub
2070: 73 74 72 69 6e 67 20 73 20 73 74 61 72 74 20 65 string s start e
2080: 6e 64 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 nd)))..(define (
2090: 73 74 72 69 6e 67 2d 63 6f 70 79 20 73 20 2e 20 string-copy s .
20a0: 6d 61 79 62 65 2d 73 74 61 72 74 2b 65 6e 64 29 maybe-start+end)
20b0: 0a 20 20 28 6c 65 74 2d 73 74 72 69 6e 67 2d 73 . (let-string-s
20c0: 74 61 72 74 2b 65 6e 64 20 28 73 74 61 72 74 20 tart+end (start
20d0: 65 6e 64 29 20 73 74 72 69 6e 67 2d 63 6f 70 79 end) string-copy
20e0: 20 73 20 6d 61 79 62 65 2d 73 74 61 72 74 2b 65 s maybe-start+e
20f0: 6e 64 0a 20 20 20 20 28 73 75 62 73 74 72 69 6e nd. (substrin
2100: 67 20 73 20 73 74 61 72 74 20 65 6e 64 29 29 29 g s start end)))
2110: 0a 0a 3b 54 68 69 73 20 6c 69 62 72 61 72 79 20 ..;This library
2120: 75 73 65 73 20 74 68 65 20 52 35 52 53 20 53 55 uses the R5RS SU
2130: 42 53 54 52 49 4e 47 2c 20 62 75 74 20 64 6f 65 BSTRING, but doe
2140: 73 6e 27 74 20 65 78 70 6f 72 74 20 69 74 2e 0a sn't export it..
2150: 3b 48 65 72 65 20 69 73 20 61 20 64 65 66 69 6e ;Here is a defin
2160: 69 74 69 6f 6e 2c 20 6a 75 73 74 20 66 6f 72 20 ition, just for
2170: 63 6f 6d 70 6c 65 74 65 6e 65 73 73 2e 0a 3b 28 completeness..;(
2180: 64 65 66 69 6e 65 20 28 73 75 62 73 74 72 69 6e define (substrin
2190: 67 20 73 20 73 74 61 72 74 20 65 6e 64 29 0a 3b g s start end).;
21a0: 20 20 28 63 68 65 63 6b 2d 73 75 62 73 74 72 69 (check-substri
21b0: 6e 67 2d 73 70 65 63 20 73 75 62 73 74 72 69 6e ng-spec substrin
21c0: 67 20 73 20 73 74 61 72 74 20 65 6e 64 29 0a 3b g s start end).;
21d0: 20 20 28 6c 65 74 2a 20 28 28 73 6c 65 6e 20 28 (let* ((slen (
21e0: 2d 20 65 6e 64 20 73 74 61 72 74 29 29 0a 3b 20 - end start)).;
21f0: 20 20 20 20 20 20 20 20 28 61 6e 73 20 28 6d 61 (ans (ma
2200: 6b 65 2d 73 74 72 69 6e 67 20 73 6c 65 6e 29 29 ke-string slen))
2210: 29 0a 3b 20 20 20 20 28 64 6f 20 28 28 69 20 30 ).; (do ((i 0
2220: 20 28 2b 20 69 20 31 29 29 0a 3b 20 20 20 20 20 (+ i 1)).;
2230: 20 20 20 20 28 6a 20 73 74 61 72 74 20 28 2b 20 (j start (+
2240: 6a 20 31 29 29 29 0a 3b 20 20 20 20 20 20 20 20 j 1))).;
2250: 28 28 3e 3d 20 69 20 73 6c 65 6e 29 20 61 6e 73 ((>= i slen) ans
2260: 29 0a 3b 20 20 20 20 20 20 28 73 74 72 69 6e 67 ).; (string
2270: 2d 73 65 74 21 20 61 6e 73 20 69 20 28 73 74 72 -set! ans i (str
2280: 69 6e 67 2d 72 65 66 20 73 20 6a 29 29 29 29 29 ing-ref s j)))))
2290: 0a 0a 3b 3b 3b 20 42 61 73 69 63 20 69 74 65 72 ..;;; Basic iter
22a0: 61 74 6f 72 73 20 61 6e 64 20 6f 74 68 65 72 20 ators and other
22b0: 68 69 67 68 65 72 2d 6f 72 64 65 72 20 61 62 73 higher-order abs
22c0: 74 72 61 63 74 69 6f 6e 73 0a 3b 3b 3b 20 28 73 tractions.;;; (s
22d0: 74 72 69 6e 67 2d 6d 61 70 20 70 72 6f 63 20 73 tring-map proc s
22e0: 20 5b 73 74 61 72 74 20 65 6e 64 5d 29 0a 3b 3b [start end]).;;
22f0: 3b 20 28 73 74 72 69 6e 67 2d 6d 61 70 21 20 70 ; (string-map! p
2300: 72 6f 63 20 73 20 5b 73 74 61 72 74 20 65 6e 64 roc s [start end
2310: 5d 29 0a 3b 3b 3b 20 28 73 74 72 69 6e 67 2d 66 ]).;;; (string-f
2320: 6f 6c 64 20 6b 6f 6e 73 20 6b 6e 69 6c 20 73 20 old kons knil s
2330: 5b 73 74 61 72 74 20 65 6e 64 5d 29 0a 3b 3b 3b [start end]).;;;
2340: 20 28 73 74 72 69 6e 67 2d 66 6f 6c 64 2d 72 69 (string-fold-ri
2350: 67 68 74 20 6b 6f 6e 73 20 6b 6e 69 6c 20 73 20 ght kons knil s
2360: 5b 73 74 61 72 74 20 65 6e 64 5d 29 0a 3b 3b 3b [start end]).;;;
2370: 20 28 73 74 72 69 6e 67 2d 75 6e 66 6f 6c 64 20 (string-unfold
2380: 20 20 20 20 20 20 70 20 66 20 67 20 73 65 65 64 p f g seed
2390: 20 5b 62 61 73 65 20 6d 61 6b 65 2d 66 69 6e 61 [base make-fina
23a0: 6c 5d 29 0a 3b 3b 3b 20 28 73 74 72 69 6e 67 2d l]).;;; (string-
23b0: 75 6e 66 6f 6c 64 2d 72 69 67 68 74 20 70 20 66 unfold-right p f
23c0: 20 67 20 73 65 65 64 20 5b 62 61 73 65 20 6d 61 g seed [base ma
23d0: 6b 65 2d 66 69 6e 61 6c 5d 29 0a 3b 3b 3b 20 28 ke-final]).;;; (
23e0: 73 74 72 69 6e 67 2d 66 6f 72 2d 65 61 63 68 20 string-for-each
23f0: 20 20 20 20 20 20 70 72 6f 63 20 73 20 5b 73 74 proc s [st
2400: 61 72 74 20 65 6e 64 5d 29 0a 3b 3b 3b 20 28 73 art end]).;;; (s
2410: 74 72 69 6e 67 2d 66 6f 72 2d 65 61 63 68 2d 69 tring-for-each-i
2420: 6e 64 65 78 20 70 72 6f 63 20 73 20 5b 73 74 61 ndex proc s [sta
2430: 72 74 20 65 6e 64 5d 29 0a 3b 3b 3b 20 28 73 74 rt end]).;;; (st
2440: 72 69 6e 67 2d 65 76 65 72 79 20 63 68 61 72 2d ring-every char-
2450: 73 65 74 2f 63 68 61 72 2f 70 72 65 64 20 73 20 set/char/pred s
2460: 5b 73 74 61 72 74 20 65 6e 64 5d 29 0a 3b 3b 3b [start end]).;;;
2470: 20 28 73 74 72 69 6e 67 2d 61 6e 79 20 20 20 63 (string-any c
2480: 68 61 72 2d 73 65 74 2f 63 68 61 72 2f 70 72 65 har-set/char/pre
2490: 64 20 73 20 5b 73 74 61 72 74 20 65 6e 64 5d 29 d s [start end])
24a0: 0a 3b 3b 3b 20 28 73 74 72 69 6e 67 2d 74 61 62 .;;; (string-tab
24b0: 75 6c 61 74 65 20 70 72 6f 63 20 6c 65 6e 29 0a ulate proc len).
24c0: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
24d0: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
24e0: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
24f0: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
2500: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 0a ;;;;;;;;;;;;;;;.
2510: 3b 3b 3b 20 59 6f 75 20 77 61 6e 74 20 63 6f 6d ;;; You want com
2520: 70 69 6c 65 72 20 73 75 70 70 6f 72 74 20 66 6f piler support fo
2530: 72 20 68 69 67 68 2d 6c 65 76 65 6c 20 74 72 61 r high-level tra
2540: 6e 73 66 6f 72 6d 73 20 6f 6e 20 66 6f 6c 64 20 nsforms on fold
2550: 61 6e 64 20 75 6e 66 6f 6c 64 20 6f 70 73 2e 0a and unfold ops..
2560: 3b 3b 3b 20 59 6f 75 27 64 20 61 74 20 6c 65 61 ;;; You'd at lea
2570: 73 74 20 6c 69 6b 65 20 61 20 6c 6f 74 20 6f 66 st like a lot of
2580: 20 69 6e 6c 69 6e 69 6e 67 20 66 6f 72 20 63 6c inlining for cl
2590: 69 65 6e 74 73 20 6f 66 20 74 68 65 73 65 20 70 ients of these p
25a0: 72 6f 63 65 64 75 72 65 73 2e 0a 3b 3b 3b 20 44 rocedures..;;; D
25b0: 6f 6e 27 74 20 68 6f 6c 64 20 79 6f 75 72 20 62 on't hold your b
25c0: 72 65 61 74 68 2e 0a 0a 28 64 65 66 69 6e 65 20 reath...(define
25d0: 28 73 74 72 69 6e 67 2d 6d 61 70 20 70 72 6f 63 (string-map proc
25e0: 20 73 20 2e 20 6d 61 79 62 65 2d 73 74 61 72 74 s . maybe-start
25f0: 2b 65 6e 64 29 0a 20 20 28 63 68 65 63 6b 2d 61 +end). (check-a
2600: 72 67 20 70 72 6f 63 65 64 75 72 65 3f 20 70 72 rg procedure? pr
2610: 6f 63 20 73 74 72 69 6e 67 2d 6d 61 70 29 0a 20 oc string-map).
2620: 20 28 6c 65 74 2d 73 74 72 69 6e 67 2d 73 74 61 (let-string-sta
2630: 72 74 2b 65 6e 64 20 28 73 74 61 72 74 20 65 6e rt+end (start en
2640: 64 29 20 73 74 72 69 6e 67 2d 6d 61 70 20 73 20 d) string-map s
2650: 6d 61 79 62 65 2d 73 74 61 72 74 2b 65 6e 64 0a maybe-start+end.
2660: 20 20 20 20 28 25 73 74 72 69 6e 67 2d 6d 61 70 (%string-map
2670: 20 70 72 6f 63 20 73 20 73 74 61 72 74 20 65 6e proc s start en
2680: 64 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 25 d)))..(define (%
2690: 73 74 72 69 6e 67 2d 6d 61 70 20 70 72 6f 63 20 string-map proc
26a0: 73 20 73 74 61 72 74 20 65 6e 64 29 09 3b 20 49 s start end).; I
26b0: 6e 74 65 72 6e 61 6c 20 75 74 69 6c 69 74 79 0a nternal utility.
26c0: 20 20 28 6c 65 74 2a 20 28 28 6c 65 6e 20 28 2d (let* ((len (-
26d0: 20 65 6e 64 20 73 74 61 72 74 29 29 0a 09 20 28 end start)).. (
26e0: 61 6e 73 20 28 6d 61 6b 65 2d 73 74 72 69 6e 67 ans (make-string
26f0: 20 6c 65 6e 29 29 29 0a 20 20 20 20 28 64 6f 20 len))). (do
2700: 28 28 69 20 28 2d 20 65 6e 64 20 31 29 20 28 2d ((i (- end 1) (-
2710: 20 69 20 31 29 29 0a 09 20 28 6a 20 28 2d 20 6c i 1)).. (j (- l
2720: 65 6e 20 31 29 20 28 2d 20 6a 20 31 29 29 29 0a en 1) (- j 1))).
2730: 09 28 28 3c 20 6a 20 30 29 29 0a 20 20 20 20 20 .((< j 0)).
2740: 20 28 73 74 72 69 6e 67 2d 73 65 74 21 20 61 6e (string-set! an
2750: 73 20 6a 20 28 70 72 6f 63 20 28 73 74 72 69 6e s j (proc (strin
2760: 67 2d 72 65 66 20 73 20 69 29 29 29 29 0a 20 20 g-ref s i)))).
2770: 20 20 61 6e 73 29 29 0a 0a 28 64 65 66 69 6e 65 ans))..(define
2780: 20 28 73 74 72 69 6e 67 2d 6d 61 70 21 20 70 72 (string-map! pr
2790: 6f 63 20 73 20 2e 20 6d 61 79 62 65 2d 73 74 61 oc s . maybe-sta
27a0: 72 74 2b 65 6e 64 29 0a 20 20 28 63 68 65 63 6b rt+end). (check
27b0: 2d 61 72 67 20 70 72 6f 63 65 64 75 72 65 3f 20 -arg procedure?
27c0: 70 72 6f 63 20 73 74 72 69 6e 67 2d 6d 61 70 21 proc string-map!
27d0: 29 0a 20 20 28 6c 65 74 2d 73 74 72 69 6e 67 2d ). (let-string-
27e0: 73 74 61 72 74 2b 65 6e 64 20 28 73 74 61 72 74 start+end (start
27f0: 20 65 6e 64 29 20 73 74 72 69 6e 67 2d 6d 61 70 end) string-map
2800: 21 20 73 20 6d 61 79 62 65 2d 73 74 61 72 74 2b ! s maybe-start+
2810: 65 6e 64 0a 20 20 20 20 28 25 73 74 72 69 6e 67 end. (%string
2820: 2d 6d 61 70 21 20 70 72 6f 63 20 73 20 73 74 61 -map! proc s sta
2830: 72 74 20 65 6e 64 29 29 29 0a 0a 28 64 65 66 69 rt end)))..(defi
2840: 6e 65 20 28 25 73 74 72 69 6e 67 2d 6d 61 70 21 ne (%string-map!
2850: 20 70 72 6f 63 20 73 20 73 74 61 72 74 20 65 6e proc s start en
2860: 64 29 0a 20 20 28 64 6f 20 28 28 69 20 28 2d 20 d). (do ((i (-
2870: 65 6e 64 20 31 29 20 28 2d 20 69 20 31 29 29 29 end 1) (- i 1)))
2880: 0a 20 20 20 20 20 20 28 28 3c 20 69 20 73 74 61 . ((< i sta
2890: 72 74 29 29 0a 20 20 20 20 28 73 74 72 69 6e 67 rt)). (string
28a0: 2d 73 65 74 21 20 73 20 69 20 28 70 72 6f 63 20 -set! s i (proc
28b0: 28 73 74 72 69 6e 67 2d 72 65 66 20 73 20 69 29 (string-ref s i)
28c0: 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 ))))..(define (s
28d0: 74 72 69 6e 67 2d 66 6f 6c 64 20 6b 6f 6e 73 20 tring-fold kons
28e0: 6b 6e 69 6c 20 73 20 2e 20 6d 61 79 62 65 2d 73 knil s . maybe-s
28f0: 74 61 72 74 2b 65 6e 64 29 0a 20 20 28 63 68 65 tart+end). (che
2900: 63 6b 2d 61 72 67 20 70 72 6f 63 65 64 75 72 65 ck-arg procedure
2910: 3f 20 6b 6f 6e 73 20 73 74 72 69 6e 67 2d 66 6f ? kons string-fo
2920: 6c 64 29 0a 20 20 28 6c 65 74 2d 73 74 72 69 6e ld). (let-strin
2930: 67 2d 73 74 61 72 74 2b 65 6e 64 20 28 73 74 61 g-start+end (sta
2940: 72 74 20 65 6e 64 29 20 73 74 72 69 6e 67 2d 66 rt end) string-f
2950: 6f 6c 64 20 73 20 6d 61 79 62 65 2d 73 74 61 72 old s maybe-star
2960: 74 2b 65 6e 64 0a 20 20 20 20 28 6c 65 74 20 6c t+end. (let l
2970: 70 20 28 28 76 20 6b 6e 69 6c 29 20 28 69 20 73 p ((v knil) (i s
2980: 74 61 72 74 29 29 0a 20 20 20 20 20 20 28 69 66 tart)). (if
2990: 20 28 3c 20 69 20 65 6e 64 29 20 28 6c 70 20 28 (< i end) (lp (
29a0: 6b 6f 6e 73 20 28 73 74 72 69 6e 67 2d 72 65 66 kons (string-ref
29b0: 20 73 20 69 29 20 76 29 20 28 2b 20 69 20 31 29 s i) v) (+ i 1)
29c0: 29 0a 09 20 20 76 29 29 29 29 0a 0a 28 64 65 66 ).. v))))..(def
29d0: 69 6e 65 20 28 73 74 72 69 6e 67 2d 66 6f 6c 64 ine (string-fold
29e0: 2d 72 69 67 68 74 20 6b 6f 6e 73 20 6b 6e 69 6c -right kons knil
29f0: 20 73 20 2e 20 6d 61 79 62 65 2d 73 74 61 72 74 s . maybe-start
2a00: 2b 65 6e 64 29 0a 20 20 28 63 68 65 63 6b 2d 61 +end). (check-a
2a10: 72 67 20 70 72 6f 63 65 64 75 72 65 3f 20 6b 6f rg procedure? ko
2a20: 6e 73 20 73 74 72 69 6e 67 2d 66 6f 6c 64 2d 72 ns string-fold-r
2a30: 69 67 68 74 29 0a 20 20 28 6c 65 74 2d 73 74 72 ight). (let-str
2a40: 69 6e 67 2d 73 74 61 72 74 2b 65 6e 64 20 28 73 ing-start+end (s
2a50: 74 61 72 74 20 65 6e 64 29 20 73 74 72 69 6e 67 tart end) string
2a60: 2d 66 6f 6c 64 2d 72 69 67 68 74 20 73 20 6d 61 -fold-right s ma
2a70: 79 62 65 2d 73 74 61 72 74 2b 65 6e 64 0a 20 20 ybe-start+end.
2a80: 20 20 28 6c 65 74 20 6c 70 20 28 28 76 20 6b 6e (let lp ((v kn
2a90: 69 6c 29 20 28 69 20 28 2d 20 65 6e 64 20 31 29 il) (i (- end 1)
2aa0: 29 29 0a 20 20 20 20 20 20 28 69 66 20 28 3e 3d )). (if (>=
2ab0: 20 69 20 73 74 61 72 74 29 20 28 6c 70 20 28 6b i start) (lp (k
2ac0: 6f 6e 73 20 28 73 74 72 69 6e 67 2d 72 65 66 20 ons (string-ref
2ad0: 73 20 69 29 20 76 29 20 28 2d 20 69 20 31 29 29 s i) v) (- i 1))
2ae0: 0a 09 20 20 76 29 29 29 29 0a 0a 3b 3b 3b 20 28 .. v))))..;;; (
2af0: 73 74 72 69 6e 67 2d 75 6e 66 6f 6c 64 20 70 20 string-unfold p
2b00: 66 20 67 20 73 65 65 64 20 5b 62 61 73 65 20 6d f g seed [base m
2b10: 61 6b 65 2d 66 69 6e 61 6c 5d 29 0a 3b 3b 3b 20 ake-final]).;;;
2b20: 54 68 69 73 20 69 73 20 74 68 65 20 66 75 6e 64 This is the fund
2b30: 61 6d 65 6e 74 61 6c 20 63 6f 6e 73 74 72 75 63 amental construc
2b40: 74 6f 72 20 66 6f 72 20 73 74 72 69 6e 67 73 2e tor for strings.
2b50: 20 0a 3b 3b 3b 20 2d 20 47 20 69 73 20 75 73 65 .;;; - G is use
2b60: 64 20 74 6f 20 67 65 6e 65 72 61 74 65 20 61 20 d to generate a
2b70: 73 65 72 69 65 73 20 6f 66 20 22 73 65 65 64 22 series of "seed"
2b80: 20 76 61 6c 75 65 73 20 66 72 6f 6d 20 74 68 65 values from the
2b90: 20 69 6e 69 74 69 61 6c 20 73 65 65 64 3a 0a 3b initial seed:.;
2ba0: 3b 3b 20 20 20 20 20 53 45 45 44 2c 20 28 47 20 ;; SEED, (G
2bb0: 53 45 45 44 29 2c 20 28 47 5e 32 20 53 45 45 44 SEED), (G^2 SEED
2bc0: 29 2c 20 28 47 5e 33 20 53 45 45 44 29 2c 20 2e ), (G^3 SEED), .
2bd0: 2e 2e 0a 3b 3b 3b 20 2d 20 50 20 74 65 6c 6c 73 ...;;; - P tells
2be0: 20 75 73 20 77 68 65 6e 20 74 6f 20 73 74 6f 70 us when to stop
2bf0: 20 2d 2d 20 77 68 65 6e 20 69 74 20 72 65 74 75 -- when it retu
2c00: 72 6e 73 20 74 72 75 65 20 77 68 65 6e 20 61 70 rns true when ap
2c10: 70 6c 69 65 64 20 74 6f 20 6f 6e 65 20 0a 3b 3b plied to one .;;
2c20: 3b 20 20 20 6f 66 20 74 68 65 73 65 20 73 65 65 ; of these see
2c30: 64 20 76 61 6c 75 65 73 2e 0a 3b 3b 3b 20 2d 20 d values..;;; -
2c40: 46 20 6d 61 70 73 20 65 61 63 68 20 73 65 65 64 F maps each seed
2c50: 20 76 61 6c 75 65 20 74 6f 20 74 68 65 20 63 6f value to the co
2c60: 72 72 65 73 70 6f 6e 64 69 6e 67 20 63 68 61 72 rresponding char
2c70: 61 63 74 65 72 20 0a 3b 3b 3b 20 20 20 69 6e 20 acter .;;; in
2c80: 74 68 65 20 72 65 73 75 6c 74 20 73 74 72 69 6e the result strin
2c90: 67 2e 20 54 68 65 73 65 20 63 68 61 72 73 20 61 g. These chars a
2ca0: 72 65 20 61 73 73 65 6d 62 6c 65 64 20 69 6e 74 re assembled int
2cb0: 6f 20 74 68 65 0a 3b 3b 3b 20 20 20 73 74 72 69 o the.;;; stri
2cc0: 6e 67 20 69 6e 20 61 20 6c 65 66 74 2d 74 6f 2d ng in a left-to-
2cd0: 72 69 67 68 74 20 6f 72 64 65 72 2e 0a 3b 3b 3b right order..;;;
2ce0: 20 2d 20 42 41 53 45 20 69 73 20 74 68 65 20 6f - BASE is the o
2cf0: 70 74 69 6f 6e 61 6c 20 69 6e 69 74 69 61 6c 2f ptional initial/
2d00: 6c 65 66 74 6d 6f 73 74 20 70 6f 72 74 69 6f 6e leftmost portion
2d10: 20 6f 66 20 74 68 65 20 63 6f 6e 73 74 72 75 63 of the construc
2d20: 74 65 64 20 73 74 72 69 6e 67 3b 0a 3b 3b 3b 20 ted string;.;;;
2d30: 20 20 69 74 20 64 65 66 61 75 6c 74 73 20 74 6f it defaults to
2d40: 20 74 68 65 20 65 6d 70 74 79 20 73 74 72 69 6e the empty strin
2d50: 67 20 22 22 2e 0a 3b 3b 3b 20 2d 20 4d 41 4b 45 g ""..;;; - MAKE
2d60: 2d 46 49 4e 41 4c 20 69 73 20 61 70 70 6c 69 65 -FINAL is applie
2d70: 64 20 74 6f 20 74 68 65 20 74 65 72 6d 69 6e 61 d to the termina
2d80: 6c 20 73 65 65 64 20 76 61 6c 75 65 20 28 6f 6e l seed value (on
2d90: 20 77 68 69 63 68 20 50 20 72 65 74 75 72 6e 73 which P returns
2da0: 0a 3b 3b 3b 20 20 20 74 72 75 65 29 20 74 6f 20 .;;; true) to
2db0: 70 72 6f 64 75 63 65 20 74 68 65 20 66 69 6e 61 produce the fina
2dc0: 6c 2f 72 69 67 68 74 6d 6f 73 74 20 70 6f 72 74 l/rightmost port
2dd0: 69 6f 6e 20 6f 66 20 74 68 65 20 63 6f 6e 73 74 ion of the const
2de0: 72 75 63 74 65 64 20 73 74 72 69 6e 67 2e 0a 3b ructed string..;
2df0: 3b 3b 20 20 20 49 74 20 64 65 66 61 75 6c 74 73 ;; It defaults
2e00: 20 74 6f 20 28 4c 41 4d 42 44 41 20 28 58 29 20 to (LAMBDA (X)
2e10: 22 22 29 2e 0a 3b 3b 3b 0a 3b 3b 3b 20 49 6e 20 "")..;;;.;;; In
2e20: 6f 74 68 65 72 20 77 6f 72 64 73 2c 20 74 68 65 other words, the
2e30: 20 66 6f 6c 6c 6f 77 69 6e 67 20 28 73 69 6d 70 following (simp
2e40: 6c 65 2c 20 69 6e 65 66 66 69 63 69 65 6e 74 29 le, inefficient)
2e50: 20 64 65 66 69 6e 69 74 69 6f 6e 20 68 6f 6c 64 definition hold
2e60: 73 3a 0a 3b 3b 3b 20 28 64 65 66 69 6e 65 20 28 s:.;;; (define (
2e70: 73 74 72 69 6e 67 2d 75 6e 66 6f 6c 64 20 70 20 string-unfold p
2e80: 66 20 67 20 73 65 65 64 20 62 61 73 65 20 6d 61 f g seed base ma
2e90: 6b 65 2d 66 69 6e 61 6c 29 0a 3b 3b 3b 20 20 20 ke-final).;;;
2ea0: 28 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 20 62 (string-append b
2eb0: 61 73 65 0a 3b 3b 3b 20 20 20 20 20 20 20 20 20 ase.;;;
2ec0: 20 20 20 20 20 20 20 20 20 28 6c 65 74 20 72 65 (let re
2ed0: 63 75 72 20 28 28 73 65 65 64 20 73 65 65 64 29 cur ((seed seed)
2ee0: 29 0a 3b 3b 3b 20 20 20 20 20 20 20 20 20 20 20 ).;;;
2ef0: 20 20 20 20 20 20 20 20 20 28 69 66 20 28 70 20 (if (p
2f00: 73 65 65 64 29 20 28 6d 61 6b 65 2d 66 69 6e 61 seed) (make-fina
2f10: 6c 20 73 65 65 64 29 0a 3b 3b 3b 20 20 20 20 20 l seed).;;;
2f20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2f30: 20 20 20 28 73 74 72 69 6e 67 2d 61 70 70 65 6e (string-appen
2f40: 64 20 28 73 74 72 69 6e 67 20 28 66 20 73 65 65 d (string (f see
2f50: 64 29 29 0a 3b 3b 3b 20 20 20 20 20 20 20 20 20 d)).;;;
2f60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2f70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 72 (r
2f80: 65 63 75 72 20 28 67 20 73 65 65 64 29 29 29 29 ecur (g seed))))
2f90: 29 29 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 53 54 52 ))).;;; .;;; STR
2fa0: 49 4e 47 2d 55 4e 46 4f 4c 44 20 69 73 20 61 20 ING-UNFOLD is a
2fb0: 66 61 69 72 6c 79 20 70 6f 77 65 72 66 75 6c 20 fairly powerful
2fc0: 63 6f 6e 73 74 72 75 63 74 6f 72 20 2d 2d 20 79 constructor -- y
2fd0: 6f 75 20 63 61 6e 20 75 73 65 20 69 74 20 74 6f ou can use it to
2fe0: 0a 3b 3b 3b 20 72 65 76 65 72 73 65 20 61 20 73 .;;; reverse a s
2ff0: 74 72 69 6e 67 2c 20 63 6f 70 79 20 61 20 73 74 tring, copy a st
3000: 72 69 6e 67 2c 20 63 6f 6e 76 65 72 74 20 61 20 ring, convert a
3010: 6c 69 73 74 20 74 6f 20 61 20 73 74 72 69 6e 67 list to a string
3020: 2c 20 72 65 61 64 0a 3b 3b 3b 20 61 20 70 6f 72 , read.;;; a por
3030: 74 20 69 6e 74 6f 20 61 20 73 74 72 69 6e 67 2c t into a string,
3040: 20 61 6e 64 20 73 6f 20 66 6f 72 74 68 2e 20 45 and so forth. E
3050: 78 61 6d 70 6c 65 73 3a 0a 3b 3b 3b 20 28 70 6f xamples:.;;; (po
3060: 72 74 2d 3e 73 74 72 69 6e 67 20 70 6f 72 74 29 rt->string port)
3070: 20 3d 0a 3b 3b 3b 20 20 20 28 73 74 72 69 6e 67 =.;;; (string
3080: 2d 75 6e 66 6f 6c 64 20 28 63 6f 6d 70 6f 73 65 -unfold (compose
3090: 20 65 6f 66 2d 6f 62 6a 65 63 74 3f 20 70 65 65 eof-object? pee
30a0: 6b 2d 63 68 61 72 29 0a 3b 3b 3b 20 20 20 20 20 k-char).;;;
30b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 72 65 61 rea
30c0: 64 2d 63 68 61 72 20 76 61 6c 75 65 73 20 70 6f d-char values po
30d0: 72 74 29 0a 3b 3b 3b 0a 3b 3b 3b 20 28 6c 69 73 rt).;;;.;;; (lis
30e0: 74 2d 3e 73 74 72 69 6e 67 20 6c 69 73 29 20 3d t->string lis) =
30f0: 20 28 73 74 72 69 6e 67 2d 75 6e 66 6f 6c 64 20 (string-unfold
3100: 6e 75 6c 6c 3f 20 63 61 72 20 63 64 72 20 6c 69 null? car cdr li
3110: 73 29 0a 3b 3b 3b 20 0a 3b 3b 3b 20 28 74 61 62 s).;;; .;;; (tab
3120: 75 6c 61 74 65 2d 73 74 72 69 6e 67 20 66 20 73 ulate-string f s
3130: 69 7a 65 29 20 3d 20 28 73 74 72 69 6e 67 2d 75 ize) = (string-u
3140: 6e 66 6f 6c 64 20 28 6c 61 6d 62 64 61 20 28 69 nfold (lambda (i
3150: 29 20 28 3d 20 69 20 73 69 7a 65 29 29 20 66 20 ) (= i size)) f
3160: 61 64 64 31 20 30 29 0a 0a 3b 3b 3b 20 41 20 70 add1 0)..;;; A p
3170: 72 6f 62 6c 65 6d 20 77 69 74 68 20 74 68 65 20 roblem with the
3180: 66 6f 6c 6c 6f 77 69 6e 67 20 73 69 6d 70 6c 65 following simple
3190: 20 66 6f 72 6d 75 6c 61 74 69 6f 6e 20 69 73 20 formulation is
31a0: 74 68 61 74 20 69 74 20 70 75 73 68 65 73 20 6f that it pushes o
31b0: 6e 65 0a 3b 3b 3b 20 73 74 61 63 6b 20 66 72 61 ne.;;; stack fra
31c0: 6d 65 20 66 6f 72 20 65 76 65 72 79 20 63 68 61 me for every cha
31d0: 72 20 69 6e 20 74 68 65 20 72 65 73 75 6c 74 20 r in the result
31e0: 73 74 72 69 6e 67 20 2d 2d 20 61 6e 20 69 73 73 string -- an iss
31f0: 75 65 20 69 66 20 79 6f 75 20 61 72 65 0a 3b 3b ue if you are.;;
3200: 3b 20 75 73 69 6e 67 20 69 74 20 74 6f 20 72 65 ; using it to re
3210: 61 64 20 61 20 31 30 30 6b 63 68 61 72 20 73 74 ad a 100kchar st
3220: 72 69 6e 67 2e 20 53 6f 20 77 65 20 64 6f 6e 27 ring. So we don'
3230: 74 20 75 73 65 20 69 74 20 2d 2d 20 62 75 74 20 t use it -- but
3240: 49 20 69 6e 63 6c 75 64 65 0a 3b 3b 3b 20 69 74 I include.;;; it
3250: 20 74 6f 20 67 69 76 65 20 61 20 63 6c 65 61 72 to give a clear
3260: 2c 20 73 74 72 61 69 67 68 74 66 6f 72 77 61 72 , straightforwar
3270: 64 20 64 65 73 63 72 69 70 74 69 6f 6e 20 6f 66 d description of
3280: 20 77 68 61 74 20 74 68 65 20 66 75 6e 63 74 69 what the functi
3290: 6f 6e 0a 3b 3b 3b 20 64 6f 65 73 2e 0a 0a 3b 28 on.;;; does...;(
32a0: 64 65 66 69 6e 65 20 28 73 74 72 69 6e 67 2d 75 define (string-u
32b0: 6e 66 6f 6c 64 20 70 20 66 20 67 20 73 65 65 64 nfold p f g seed
32c0: 20 62 61 73 65 20 6d 61 6b 65 2d 66 69 6e 61 6c base make-final
32d0: 29 0a 3b 20 20 28 6c 65 74 20 28 28 61 6e 73 20 ).; (let ((ans
32e0: 28 6c 65 74 20 72 65 63 75 72 20 28 28 73 65 65 (let recur ((see
32f0: 64 20 73 65 65 64 29 20 28 69 20 28 73 74 72 69 d seed) (i (stri
3300: 6e 67 2d 6c 65 6e 67 74 68 20 62 61 73 65 29 29 ng-length base))
3310: 29 0a 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 ).;
3320: 20 20 28 69 66 20 28 70 20 73 65 65 64 29 0a 3b (if (p seed).;
3330: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3340: 20 20 20 28 6c 65 74 2a 20 28 28 66 69 6e 61 6c (let* ((final
3350: 20 28 6d 61 6b 65 2d 66 69 6e 61 6c 20 73 65 65 (make-final see
3360: 64 29 29 0a 3b 20 20 20 20 20 20 20 20 20 20 20 d)).;
3370: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
3380: 61 6e 73 20 28 6d 61 6b 65 2d 73 74 72 69 6e 67 ans (make-string
3390: 20 28 2b 20 69 20 28 73 74 72 69 6e 67 2d 6c 65 (+ i (string-le
33a0: 6e 67 74 68 20 66 69 6e 61 6c 29 29 29 29 29 0a ngth final))))).
33b0: 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ;
33c0: 20 20 20 20 20 20 28 73 74 72 69 6e 67 2d 63 6f (string-co
33d0: 70 79 21 20 61 6e 73 20 69 20 66 69 6e 61 6c 29 py! ans i final)
33e0: 0a 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .;
33f0: 20 20 20 20 20 20 20 61 6e 73 29 0a 3b 0a 3b 20 ans).;.;
3400: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3410: 20 20 28 6c 65 74 2a 20 28 28 63 20 28 66 20 73 (let* ((c (f s
3420: 65 65 64 29 29 0a 3b 20 20 20 20 20 20 20 20 20 eed)).;
3430: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3440: 20 28 73 20 28 72 65 63 75 72 20 28 67 20 73 65 (s (recur (g se
3450: 65 64 29 20 28 2b 20 69 20 31 29 29 29 29 0a 3b ed) (+ i 1)))).;
3460: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3470: 20 20 20 20 20 28 73 74 72 69 6e 67 2d 73 65 74 (string-set
3480: 21 20 73 20 69 20 63 29 0a 3b 20 20 20 20 20 20 ! s i c).;
3490: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 73 s
34a0: 29 29 29 29 29 0a 3b 20 20 20 20 28 73 74 72 69 ))))).; (stri
34b0: 6e 67 2d 63 6f 70 79 21 20 61 6e 73 20 30 20 62 ng-copy! ans 0 b
34c0: 61 73 65 29 0a 3b 20 20 20 20 61 6e 73 29 29 0a ase).; ans)).
34d0: 0a 3b 3b 3b 20 54 68 65 20 73 74 72 61 74 65 67 .;;; The strateg
34e0: 79 20 69 73 20 74 6f 20 61 6c 6c 6f 63 61 74 65 y is to allocate
34f0: 20 61 20 73 65 72 69 65 73 20 6f 66 20 63 68 75 a series of chu
3500: 6e 6b 73 20 69 6e 74 6f 20 77 68 69 63 68 20 77 nks into which w
3510: 65 20 73 74 61 73 68 20 74 68 65 0a 3b 3b 3b 20 e stash the.;;;
3520: 63 68 61 72 73 20 61 73 20 77 65 20 67 65 6e 65 chars as we gene
3530: 72 61 74 65 20 74 68 65 6d 2e 20 43 68 75 6e 6b rate them. Chunk
3540: 20 73 69 7a 65 20 67 6f 65 73 20 75 70 20 69 6e size goes up in
3550: 20 70 6f 77 65 72 73 20 6f 66 20 74 77 6f 20 73 powers of two s
3560: 74 61 72 74 69 6e 67 0a 3b 3b 3b 20 77 69 74 68 tarting.;;; with
3570: 20 34 30 20 61 6e 64 20 6c 65 76 65 6c 6c 69 6e 40 and levellin
3580: 67 20 6f 75 74 20 61 74 20 34 6b 2c 20 69 2e 65 g out at 4k, i.e
3590: 2e 0a 3b 3b 3b 20 20 20 20 20 34 30 20 34 30 20 ..;;; 40 40
35a0: 38 30 20 31 36 30 20 33 32 30 20 36 34 30 20 31 80 160 320 640 1
35b0: 32 38 30 20 32 35 36 30 20 34 30 39 36 20 34 30 280 2560 4096 40
35c0: 39 36 20 34 30 39 36 20 34 30 39 36 20 34 30 39 96 4096 4096 409
35d0: 36 2e 2e 2e 0a 3b 3b 3b 20 54 68 69 73 20 73 68 6....;;; This sh
35e0: 6f 75 6c 64 20 77 6f 72 6b 20 70 72 65 74 74 79 ould work pretty
35f0: 20 77 65 6c 6c 20 66 6f 72 20 73 68 6f 72 74 20 well for short
3600: 73 74 72 69 6e 67 73 2c 20 31 2d 6c 69 6e 65 20 strings, 1-line
3610: 28 38 30 20 63 68 61 72 29 20 73 74 72 69 6e 67 (80 char) string
3620: 73 2c 0a 3b 3b 3b 20 61 6e 64 20 6c 6f 6e 67 65 s,.;;; and longe
3630: 72 20 6f 6e 65 73 2e 20 57 68 65 6e 20 64 6f 6e r ones. When don
3640: 65 2c 20 77 65 20 61 6c 6c 6f 63 61 74 65 20 61 e, we allocate a
3650: 6e 20 61 6e 73 77 65 72 20 73 74 72 69 6e 67 20 n answer string
3660: 61 6e 64 20 63 6f 70 79 20 74 68 65 0a 3b 3b 3b and copy the.;;;
3670: 20 63 68 61 72 73 20 6f 76 65 72 20 66 72 6f 6d chars over from
3680: 20 74 68 65 20 63 68 75 6e 6b 20 62 75 66 66 65 the chunk buffe
3690: 72 73 2e 0a 0a 28 64 65 66 69 6e 65 20 28 73 74 rs...(define (st
36a0: 72 69 6e 67 2d 75 6e 66 6f 6c 64 20 70 20 66 20 ring-unfold p f
36b0: 67 20 73 65 65 64 20 2e 20 62 61 73 65 2b 6d 61 g seed . base+ma
36c0: 6b 65 2d 66 69 6e 61 6c 29 0a 20 20 28 63 68 65 ke-final). (che
36d0: 63 6b 2d 61 72 67 20 70 72 6f 63 65 64 75 72 65 ck-arg procedure
36e0: 3f 20 70 20 73 74 72 69 6e 67 2d 75 6e 66 6f 6c ? p string-unfol
36f0: 64 29 0a 20 20 28 63 68 65 63 6b 2d 61 72 67 20 d). (check-arg
3700: 70 72 6f 63 65 64 75 72 65 3f 20 66 20 73 74 72 procedure? f str
3710: 69 6e 67 2d 75 6e 66 6f 6c 64 29 0a 20 20 28 63 ing-unfold). (c
3720: 68 65 63 6b 2d 61 72 67 20 70 72 6f 63 65 64 75 heck-arg procedu
3730: 72 65 3f 20 67 20 73 74 72 69 6e 67 2d 75 6e 66 re? g string-unf
3740: 6f 6c 64 29 0a 20 20 28 6c 65 74 2d 6f 70 74 69 old). (let-opti
3750: 6f 6e 61 6c 73 2a 20 62 61 73 65 2b 6d 61 6b 65 onals* base+make
3760: 2d 66 69 6e 61 6c 0a 20 20 20 20 20 20 20 20 20 -final.
3770: 20 20 20 20 20 20 20 20 20 28 28 62 61 73 65 20 ((base
3780: 20 20 20 20 20 20 22 22 20 20 20 20 20 20 20 20 ""
3790: 20 20 20 20 20 20 28 73 74 72 69 6e 67 3f 20 62 (string? b
37a0: 61 73 65 29 29 0a 09 09 20 20 20 28 6d 61 6b 65 ase))... (make
37b0: 2d 66 69 6e 61 6c 20 28 6c 61 6d 62 64 61 20 28 -final (lambda (
37c0: 78 29 20 22 22 29 20 28 70 72 6f 63 65 64 75 72 x) "") (procedur
37d0: 65 3f 20 6d 61 6b 65 2d 66 69 6e 61 6c 29 29 29 e? make-final)))
37e0: 0a 20 20 20 20 28 6c 65 74 20 6c 70 20 28 28 63 . (let lp ((c
37f0: 68 75 6e 6b 73 20 27 28 29 29 09 09 3b 20 50 72 hunks '())..; Pr
3800: 65 76 69 6f 75 73 6c 79 20 66 69 6c 6c 65 64 20 eviously filled
3810: 63 68 75 6e 6b 73 0a 09 20 20 20 20 20 28 6e 63 chunks.. (nc
3820: 68 61 72 73 20 30 29 09 09 09 3b 20 4e 75 6d 62 hars 0)...; Numb
3830: 65 72 20 6f 66 20 63 68 61 72 73 20 69 6e 20 43 er of chars in C
3840: 48 55 4e 4b 53 0a 09 20 20 20 20 20 28 63 68 75 HUNKS.. (chu
3850: 6e 6b 20 28 6d 61 6b 65 2d 73 74 72 69 6e 67 20 nk (make-string
3860: 34 30 29 29 09 3b 20 43 75 72 72 65 6e 74 20 63 40)).; Current c
3870: 68 75 6e 6b 20 69 6e 74 6f 20 77 68 69 63 68 20 hunk into which
3880: 77 65 20 77 72 69 74 65 0a 09 20 20 20 20 20 28 we write.. (
3890: 63 68 75 6e 6b 2d 6c 65 6e 20 34 30 29 0a 09 20 chunk-len 40)..
38a0: 20 20 20 20 28 69 20 30 29 09 09 09 3b 20 4e 75 (i 0)...; Nu
38b0: 6d 62 65 72 20 6f 66 20 63 68 61 72 73 20 77 72 mber of chars wr
38c0: 69 74 74 65 6e 20 69 6e 74 6f 20 43 48 55 4e 4b itten into CHUNK
38d0: 0a 09 20 20 20 20 20 28 73 65 65 64 20 73 65 65 .. (seed see
38e0: 64 29 29 0a 20 20 20 20 20 20 28 6c 65 74 20 6c d)). (let l
38f0: 70 32 20 28 28 69 20 69 29 20 28 73 65 65 64 20 p2 ((i i) (seed
3900: 73 65 65 64 29 29 0a 09 28 69 66 20 28 6e 6f 74 seed))..(if (not
3910: 20 28 70 20 73 65 65 64 29 29 0a 09 20 20 20 20 (p seed))..
3920: 28 6c 65 74 20 28 28 63 20 28 66 20 73 65 65 64 (let ((c (f seed
3930: 29 29 0a 09 09 20 20 28 73 65 65 64 20 28 67 20 ))... (seed (g
3940: 73 65 65 64 29 29 29 0a 09 20 20 20 20 20 20 28 seed))).. (
3950: 69 66 20 28 3c 20 69 20 63 68 75 6e 6b 2d 6c 65 if (< i chunk-le
3960: 6e 29 0a 09 09 20 20 28 62 65 67 69 6e 20 28 73 n)... (begin (s
3970: 74 72 69 6e 67 2d 73 65 74 21 20 63 68 75 6e 6b tring-set! chunk
3980: 20 69 20 63 29 0a 09 09 09 20 28 6c 70 32 20 28 i c).... (lp2 (
3990: 2b 20 69 20 31 29 20 73 65 65 64 29 29 0a 0a 09 + i 1) seed))...
39a0: 09 20 20 28 6c 65 74 2a 20 28 28 6e 63 68 61 72 . (let* ((nchar
39b0: 73 32 20 28 2b 20 63 68 75 6e 6b 2d 6c 65 6e 20 s2 (+ chunk-len
39c0: 6e 63 68 61 72 73 29 29 0a 09 09 09 20 28 63 68 nchars)).... (ch
39d0: 75 6e 6b 2d 6c 65 6e 32 20 28 6d 69 6e 20 34 30 unk-len2 (min 40
39e0: 39 36 20 6e 63 68 61 72 73 32 29 29 0a 09 09 09 96 nchars2))....
39f0: 20 28 6e 65 77 2d 63 68 75 6e 6b 20 28 6d 61 6b (new-chunk (mak
3a00: 65 2d 73 74 72 69 6e 67 20 63 68 75 6e 6b 2d 6c e-string chunk-l
3a10: 65 6e 32 29 29 29 0a 09 09 20 20 20 20 28 73 74 en2)))... (st
3a20: 72 69 6e 67 2d 73 65 74 21 20 6e 65 77 2d 63 68 ring-set! new-ch
3a30: 75 6e 6b 20 30 20 63 29 0a 09 09 20 20 20 20 28 unk 0 c)... (
3a40: 6c 70 20 28 63 6f 6e 73 20 63 68 75 6e 6b 20 63 lp (cons chunk c
3a50: 68 75 6e 6b 73 29 20 28 2b 20 6e 63 68 61 72 73 hunks) (+ nchars
3a60: 20 63 68 75 6e 6b 2d 6c 65 6e 29 0a 09 09 09 6e chunk-len)....n
3a70: 65 77 2d 63 68 75 6e 6b 20 63 68 75 6e 6b 2d 6c ew-chunk chunk-l
3a80: 65 6e 32 20 31 20 73 65 65 64 29 29 29 29 0a 0a en2 1 seed))))..
3a90: 09 20 20 20 20 3b 3b 20 57 65 27 72 65 20 64 6f . ;; We're do
3aa0: 6e 65 2e 20 4d 61 6b 65 20 74 68 65 20 61 6e 73 ne. Make the ans
3ab0: 77 65 72 20 73 74 72 69 6e 67 20 26 20 69 6e 73 wer string & ins
3ac0: 74 61 6c 6c 20 74 68 65 20 62 69 74 73 2e 0a 09 tall the bits...
3ad0: 20 20 20 20 28 6c 65 74 2a 20 28 28 66 69 6e 61 (let* ((fina
3ae0: 6c 20 28 6d 61 6b 65 2d 66 69 6e 61 6c 20 73 65 l (make-final se
3af0: 65 64 29 29 0a 09 09 20 20 20 28 66 6c 65 6e 20 ed))... (flen
3b00: 28 73 74 72 69 6e 67 2d 6c 65 6e 67 74 68 20 66 (string-length f
3b10: 69 6e 61 6c 29 29 0a 09 09 20 20 20 28 62 61 73 inal))... (bas
3b20: 65 2d 6c 65 6e 20 28 73 74 72 69 6e 67 2d 6c 65 e-len (string-le
3b30: 6e 67 74 68 20 62 61 73 65 29 29 0a 09 09 20 20 ngth base))...
3b40: 20 28 6a 20 28 2b 20 62 61 73 65 2d 6c 65 6e 20 (j (+ base-len
3b50: 6e 63 68 61 72 73 20 69 29 29 0a 09 09 20 20 20 nchars i))...
3b60: 28 61 6e 73 20 28 6d 61 6b 65 2d 73 74 72 69 6e (ans (make-strin
3b70: 67 20 28 2b 20 6a 20 66 6c 65 6e 29 29 29 29 0a g (+ j flen)))).
3b80: 09 20 20 20 20 20 20 28 25 73 74 72 69 6e 67 2d . (%string-
3b90: 63 6f 70 79 21 20 61 6e 73 20 6a 20 66 69 6e 61 copy! ans j fina
3ba0: 6c 20 30 20 66 6c 65 6e 29 09 3b 20 49 6e 73 74 l 0 flen).; Inst
3bb0: 61 6c 6c 20 46 49 4e 41 4c 2e 0a 09 20 20 20 20 all FINAL...
3bc0: 20 20 28 6c 65 74 20 28 28 6a 20 28 2d 20 6a 20 (let ((j (- j
3bd0: 69 29 29 29 0a 09 09 28 25 73 74 72 69 6e 67 2d i)))...(%string-
3be0: 63 6f 70 79 21 20 61 6e 73 20 6a 20 63 68 75 6e copy! ans j chun
3bf0: 6b 20 30 20 69 29 09 09 3b 20 49 6e 73 74 61 6c k 0 i)..; Instal
3c00: 6c 20 43 48 55 4e 4b 5b 30 2c 49 29 2e 0a 09 09 l CHUNK[0,I)....
3c10: 28 6c 65 74 20 6c 70 20 28 28 6a 20 6a 29 20 28 (let lp ((j j) (
3c20: 63 68 75 6e 6b 73 20 63 68 75 6e 6b 73 29 29 09 chunks chunks)).
3c30: 09 3b 20 49 6e 73 74 61 6c 6c 20 43 48 55 4e 4b .; Install CHUNK
3c40: 53 2e 0a 09 09 20 20 28 69 66 20 28 70 61 69 72 S.... (if (pair
3c50: 3f 20 63 68 75 6e 6b 73 29 0a 09 09 20 20 20 20 ? chunks)...
3c60: 20 20 28 6c 65 74 2a 20 28 28 63 68 75 6e 6b 20 (let* ((chunk
3c70: 20 28 63 61 72 20 63 68 75 6e 6b 73 29 29 0a 09 (car chunks))..
3c80: 09 09 20 20 20 20 20 28 63 68 75 6e 6b 73 20 28 .. (chunks (
3c90: 63 64 72 20 63 68 75 6e 6b 73 29 29 0a 09 09 09 cdr chunks))....
3ca0: 20 20 20 20 20 28 63 68 75 6e 6b 2d 6c 65 6e 20 (chunk-len
3cb0: 28 73 74 72 69 6e 67 2d 6c 65 6e 67 74 68 20 63 (string-length c
3cc0: 68 75 6e 6b 29 29 0a 09 09 09 20 20 20 20 20 28 hunk)).... (
3cd0: 6a 20 28 2d 20 6a 20 63 68 75 6e 6b 2d 6c 65 6e j (- j chunk-len
3ce0: 29 29 29 0a 09 09 09 28 25 73 74 72 69 6e 67 2d )))....(%string-
3cf0: 63 6f 70 79 21 20 61 6e 73 20 6a 20 63 68 75 6e copy! ans j chun
3d00: 6b 20 30 20 63 68 75 6e 6b 2d 6c 65 6e 29 0a 09 k 0 chunk-len)..
3d10: 09 09 28 6c 70 20 6a 20 63 68 75 6e 6b 73 29 29 ..(lp j chunks))
3d20: 29 29 29 0a 09 20 20 20 20 20 20 28 25 73 74 72 ))).. (%str
3d30: 69 6e 67 2d 63 6f 70 79 21 20 61 6e 73 20 30 20 ing-copy! ans 0
3d40: 62 61 73 65 20 30 20 62 61 73 65 2d 6c 65 6e 29 base 0 base-len)
3d50: 09 3b 20 49 6e 73 74 61 6c 6c 20 42 41 53 45 2e .; Install BASE.
3d60: 0a 09 20 20 20 20 20 20 61 6e 73 29 29 29 29 29 .. ans)))))
3d70: 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 74 72 69 )..(define (stri
3d80: 6e 67 2d 75 6e 66 6f 6c 64 2d 72 69 67 68 74 20 ng-unfold-right
3d90: 70 20 66 20 67 20 73 65 65 64 20 2e 20 62 61 73 p f g seed . bas
3da0: 65 2b 6d 61 6b 65 2d 66 69 6e 61 6c 29 0a 20 20 e+make-final).
3db0: 28 6c 65 74 2d 6f 70 74 69 6f 6e 61 6c 73 2a 20 (let-optionals*
3dc0: 62 61 73 65 2b 6d 61 6b 65 2d 66 69 6e 61 6c 0a base+make-final.
3dd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3de0: 20 20 28 28 62 61 73 65 20 20 20 20 20 20 20 22 ((base "
3df0: 22 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 " (
3e00: 73 74 72 69 6e 67 3f 20 62 61 73 65 29 29 0a 09 string? base))..
3e10: 09 20 20 20 28 6d 61 6b 65 2d 66 69 6e 61 6c 20 . (make-final
3e20: 28 6c 61 6d 62 64 61 20 28 78 29 20 22 22 29 20 (lambda (x) "")
3e30: 28 70 72 6f 63 65 64 75 72 65 3f 20 6d 61 6b 65 (procedure? make
3e40: 2d 66 69 6e 61 6c 29 29 29 0a 20 20 20 20 28 6c -final))). (l
3e50: 65 74 20 6c 70 20 28 28 63 68 75 6e 6b 73 20 27 et lp ((chunks '
3e60: 28 29 29 09 09 3b 20 50 72 65 76 69 6f 75 73 6c ())..; Previousl
3e70: 79 20 66 69 6c 6c 65 64 20 63 68 75 6e 6b 73 0a y filled chunks.
3e80: 09 20 20 20 20 20 28 6e 63 68 61 72 73 20 30 29 . (nchars 0)
3e90: 09 09 09 3b 20 4e 75 6d 62 65 72 20 6f 66 20 63 ...; Number of c
3ea0: 68 61 72 73 20 69 6e 20 43 48 55 4e 4b 53 0a 09 hars in CHUNKS..
3eb0: 20 20 20 20 20 28 63 68 75 6e 6b 20 28 6d 61 6b (chunk (mak
3ec0: 65 2d 73 74 72 69 6e 67 20 34 30 29 29 09 3b 20 e-string 40)).;
3ed0: 43 75 72 72 65 6e 74 20 63 68 75 6e 6b 20 69 6e Current chunk in
3ee0: 74 6f 20 77 68 69 63 68 20 77 65 20 77 72 69 74 to which we writ
3ef0: 65 0a 09 20 20 20 20 20 28 63 68 75 6e 6b 2d 6c e.. (chunk-l
3f00: 65 6e 20 34 30 29 0a 09 20 20 20 20 20 28 69 20 en 40).. (i
3f10: 34 30 29 09 09 09 3b 20 4e 75 6d 62 65 72 20 6f 40)...; Number o
3f20: 66 20 63 68 61 72 73 20 61 76 61 69 6c 61 62 6c f chars availabl
3f30: 65 20 69 6e 20 43 48 55 4e 4b 0a 09 20 20 20 20 e in CHUNK..
3f40: 20 28 73 65 65 64 20 73 65 65 64 29 29 0a 20 20 (seed seed)).
3f50: 20 20 20 20 28 6c 65 74 20 6c 70 32 20 28 28 69 (let lp2 ((i
3f60: 20 69 29 20 28 73 65 65 64 20 73 65 65 64 29 29 i) (seed seed))
3f70: 09 3b 20 46 69 6c 6c 20 75 70 20 43 48 55 4e 4b .; Fill up CHUNK
3f80: 20 66 72 6f 6d 20 72 69 67 68 74 0a 09 28 69 66 from right..(if
3f90: 20 28 6e 6f 74 20 28 70 20 73 65 65 64 29 29 09 (not (p seed)).
3fa0: 09 3b 20 74 6f 20 6c 65 66 74 2e 0a 09 20 20 20 .; to left...
3fb0: 20 28 6c 65 74 20 28 28 63 20 28 66 20 73 65 65 (let ((c (f see
3fc0: 64 29 29 0a 09 09 20 20 28 73 65 65 64 20 28 67 d))... (seed (g
3fd0: 20 73 65 65 64 29 29 29 0a 09 20 20 20 20 20 20 seed)))..
3fe0: 28 69 66 20 28 3e 20 69 20 30 29 0a 09 09 20 20 (if (> i 0)...
3ff0: 28 6c 65 74 20 28 28 69 20 28 2d 20 69 20 31 29 (let ((i (- i 1)
4000: 29 29 0a 09 09 20 20 20 20 28 73 74 72 69 6e 67 ))... (string
4010: 2d 73 65 74 21 20 63 68 75 6e 6b 20 69 20 63 29 -set! chunk i c)
4020: 0a 09 09 20 20 20 20 28 6c 70 32 20 69 20 73 65 ... (lp2 i se
4030: 65 64 29 29 0a 0a 09 09 20 20 28 6c 65 74 2a 20 ed)).... (let*
4040: 28 28 6e 63 68 61 72 73 32 20 28 2b 20 63 68 75 ((nchars2 (+ chu
4050: 6e 6b 2d 6c 65 6e 20 6e 63 68 61 72 73 29 29 0a nk-len nchars)).
4060: 09 09 09 20 28 63 68 75 6e 6b 2d 6c 65 6e 32 20 ... (chunk-len2
4070: 28 6d 69 6e 20 34 30 39 36 20 6e 63 68 61 72 73 (min 4096 nchars
4080: 32 29 29 0a 09 09 09 20 28 6e 65 77 2d 63 68 75 2)).... (new-chu
4090: 6e 6b 20 28 6d 61 6b 65 2d 73 74 72 69 6e 67 20 nk (make-string
40a0: 63 68 75 6e 6b 2d 6c 65 6e 32 29 29 0a 09 09 09 chunk-len2))....
40b0: 20 28 69 20 28 2d 20 63 68 75 6e 6b 2d 6c 65 6e (i (- chunk-len
40c0: 32 20 31 29 29 29 0a 09 09 20 20 20 20 28 73 74 2 1)))... (st
40d0: 72 69 6e 67 2d 73 65 74 21 20 6e 65 77 2d 63 68 ring-set! new-ch
40e0: 75 6e 6b 20 69 20 63 29 0a 09 09 20 20 20 20 28 unk i c)... (
40f0: 6c 70 20 28 63 6f 6e 73 20 63 68 75 6e 6b 20 63 lp (cons chunk c
4100: 68 75 6e 6b 73 29 20 28 2b 20 6e 63 68 61 72 73 hunks) (+ nchars
4110: 20 63 68 75 6e 6b 2d 6c 65 6e 29 0a 09 09 09 6e chunk-len)....n
4120: 65 77 2d 63 68 75 6e 6b 20 63 68 75 6e 6b 2d 6c ew-chunk chunk-l
4130: 65 6e 32 20 69 20 73 65 65 64 29 29 29 29 0a 0a en2 i seed))))..
4140: 09 20 20 20 20 3b 3b 20 57 65 27 72 65 20 64 6f . ;; We're do
4150: 6e 65 2e 20 4d 61 6b 65 20 74 68 65 20 61 6e 73 ne. Make the ans
4160: 77 65 72 20 73 74 72 69 6e 67 20 26 20 69 6e 73 wer string & ins
4170: 74 61 6c 6c 20 74 68 65 20 62 69 74 73 2e 0a 09 tall the bits...
4180: 20 20 20 20 28 6c 65 74 2a 20 28 28 66 69 6e 61 (let* ((fina
4190: 6c 20 28 6d 61 6b 65 2d 66 69 6e 61 6c 20 73 65 l (make-final se
41a0: 65 64 29 29 0a 09 09 20 20 20 28 66 6c 65 6e 20 ed))... (flen
41b0: 28 73 74 72 69 6e 67 2d 6c 65 6e 67 74 68 20 66 (string-length f
41c0: 69 6e 61 6c 29 29 0a 09 09 20 20 20 28 62 61 73 inal))... (bas
41d0: 65 2d 6c 65 6e 20 28 73 74 72 69 6e 67 2d 6c 65 e-len (string-le
41e0: 6e 67 74 68 20 62 61 73 65 29 29 0a 09 09 20 20 ngth base))...
41f0: 20 28 63 68 75 6e 6b 2d 75 73 65 64 20 28 2d 20 (chunk-used (-
4200: 63 68 75 6e 6b 2d 6c 65 6e 20 69 29 29 0a 09 09 chunk-len i))...
4210: 20 20 20 28 6a 20 28 2b 20 62 61 73 65 2d 6c 65 (j (+ base-le
4220: 6e 20 6e 63 68 61 72 73 20 63 68 75 6e 6b 2d 75 n nchars chunk-u
4230: 73 65 64 29 29 0a 09 09 20 20 20 28 61 6e 73 20 sed))... (ans
4240: 28 6d 61 6b 65 2d 73 74 72 69 6e 67 20 28 2b 20 (make-string (+
4250: 6a 20 66 6c 65 6e 29 29 29 29 0a 09 20 20 20 20 j flen))))..
4260: 20 20 28 25 73 74 72 69 6e 67 2d 63 6f 70 79 21 (%string-copy!
4270: 20 61 6e 73 20 30 20 66 69 6e 61 6c 20 30 20 66 ans 0 final 0 f
4280: 6c 65 6e 29 09 3b 20 49 6e 73 74 61 6c 6c 20 46 len).; Install F
4290: 49 4e 41 4c 2e 0a 09 20 20 20 20 20 20 28 25 73 INAL... (%s
42a0: 74 72 69 6e 67 2d 63 6f 70 79 21 20 61 6e 73 20 tring-copy! ans
42b0: 66 6c 65 6e 20 63 68 75 6e 6b 20 69 20 63 68 75 flen chunk i chu
42c0: 6e 6b 2d 6c 65 6e 29 3b 20 49 6e 73 74 61 6c 6c nk-len); Install
42d0: 20 43 48 55 4e 4b 5b 49 2c 29 2e 0a 09 20 20 20 CHUNK[I,)...
42e0: 20 20 20 28 6c 65 74 20 6c 70 20 28 28 6a 20 28 (let lp ((j (
42f0: 2b 20 66 6c 65 6e 20 63 68 75 6e 6b 2d 75 73 65 + flen chunk-use
4300: 64 29 29 09 09 3b 20 49 6e 73 74 61 6c 6c 20 43 d))..; Install C
4310: 48 55 4e 4b 53 2e 0a 09 09 20 20 20 20 20 20 20 HUNKS....
4320: 28 63 68 75 6e 6b 73 20 63 68 75 6e 6b 73 29 29 (chunks chunks))
4330: 09 09 0a 09 09 20 20 28 69 66 20 28 70 61 69 72 ..... (if (pair
4340: 3f 20 63 68 75 6e 6b 73 29 0a 09 09 20 20 20 20 ? chunks)...
4350: 20 20 28 6c 65 74 2a 20 28 28 63 68 75 6e 6b 20 (let* ((chunk
4360: 20 28 63 61 72 20 63 68 75 6e 6b 73 29 29 0a 09 (car chunks))..
4370: 09 09 20 20 20 20 20 28 63 68 75 6e 6b 73 20 28 .. (chunks (
4380: 63 64 72 20 63 68 75 6e 6b 73 29 29 0a 09 09 09 cdr chunks))....
4390: 20 20 20 20 20 28 63 68 75 6e 6b 2d 6c 65 6e 20 (chunk-len
43a0: 28 73 74 72 69 6e 67 2d 6c 65 6e 67 74 68 20 63 (string-length c
43b0: 68 75 6e 6b 29 29 29 0a 09 09 09 28 25 73 74 72 hunk)))....(%str
43c0: 69 6e 67 2d 63 6f 70 79 21 20 61 6e 73 20 6a 20 ing-copy! ans j
43d0: 63 68 75 6e 6b 20 30 20 63 68 75 6e 6b 2d 6c 65 chunk 0 chunk-le
43e0: 6e 29 0a 09 09 09 28 6c 70 20 28 2b 20 6a 20 63 n)....(lp (+ j c
43f0: 68 75 6e 6b 2d 6c 65 6e 29 20 63 68 75 6e 6b 73 hunk-len) chunks
4400: 29 29 0a 09 09 20 20 20 20 20 20 28 25 73 74 72 ))... (%str
4410: 69 6e 67 2d 63 6f 70 79 21 20 61 6e 73 20 6a 20 ing-copy! ans j
4420: 62 61 73 65 20 30 20 62 61 73 65 2d 6c 65 6e 29 base 0 base-len)
4430: 29 29 3b 20 49 6e 73 74 61 6c 6c 20 42 41 53 45 )); Install BASE
4440: 2e 0a 09 20 20 20 20 20 20 61 6e 73 29 29 29 29 ... ans))))
4450: 29 29 0a 0a 0a 28 64 65 66 69 6e 65 20 28 73 74 ))...(define (st
4460: 72 69 6e 67 2d 66 6f 72 2d 65 61 63 68 20 70 72 ring-for-each pr
4470: 6f 63 20 73 20 2e 20 6d 61 79 62 65 2d 73 74 61 oc s . maybe-sta
4480: 72 74 2b 65 6e 64 29 0a 20 20 28 63 68 65 63 6b rt+end). (check
4490: 2d 61 72 67 20 70 72 6f 63 65 64 75 72 65 3f 20 -arg procedure?
44a0: 70 72 6f 63 20 73 74 72 69 6e 67 2d 66 6f 72 2d proc string-for-
44b0: 65 61 63 68 29 0a 20 20 28 6c 65 74 2d 73 74 72 each). (let-str
44c0: 69 6e 67 2d 73 74 61 72 74 2b 65 6e 64 20 28 73 ing-start+end (s
44d0: 74 61 72 74 20 65 6e 64 29 20 73 74 72 69 6e 67 tart end) string
44e0: 2d 66 6f 72 2d 65 61 63 68 20 73 20 6d 61 79 62 -for-each s mayb
44f0: 65 2d 73 74 61 72 74 2b 65 6e 64 0a 20 20 20 20 e-start+end.
4500: 28 6c 65 74 20 6c 70 20 28 28 69 20 73 74 61 72 (let lp ((i star
4510: 74 29 29 0a 20 20 20 20 20 20 28 69 66 20 28 3c t)). (if (<
4520: 20 69 20 65 6e 64 29 0a 09 20 20 28 62 65 67 69 i end).. (begi
4530: 6e 20 28 70 72 6f 63 20 28 73 74 72 69 6e 67 2d n (proc (string-
4540: 72 65 66 20 73 20 69 29 29 20 0a 09 09 20 28 6c ref s i)) ... (l
4550: 70 20 28 2b 20 69 20 31 29 29 29 29 29 29 29 0a p (+ i 1))))))).
4560: 0a 28 64 65 66 69 6e 65 20 28 73 74 72 69 6e 67 .(define (string
4570: 2d 66 6f 72 2d 65 61 63 68 2d 69 6e 64 65 78 20 -for-each-index
4580: 70 72 6f 63 20 73 20 2e 20 6d 61 79 62 65 2d 73 proc s . maybe-s
4590: 74 61 72 74 2b 65 6e 64 29 0a 20 20 28 63 68 65 tart+end). (che
45a0: 63 6b 2d 61 72 67 20 70 72 6f 63 65 64 75 72 65 ck-arg procedure
45b0: 3f 20 70 72 6f 63 20 73 74 72 69 6e 67 2d 66 6f ? proc string-fo
45c0: 72 2d 65 61 63 68 2d 69 6e 64 65 78 29 0a 20 20 r-each-index).
45d0: 28 6c 65 74 2d 73 74 72 69 6e 67 2d 73 74 61 72 (let-string-star
45e0: 74 2b 65 6e 64 20 28 73 74 61 72 74 20 65 6e 64 t+end (start end
45f0: 29 20 73 74 72 69 6e 67 2d 66 6f 72 2d 65 61 63 ) string-for-eac
4600: 68 2d 69 6e 64 65 78 20 73 20 6d 61 79 62 65 2d h-index s maybe-
4610: 73 74 61 72 74 2b 65 6e 64 0a 20 20 20 20 28 6c start+end. (l
4620: 65 74 20 6c 70 20 28 28 69 20 73 74 61 72 74 29 et lp ((i start)
4630: 29 0a 20 20 20 20 20 20 28 69 66 20 28 3c 20 69 ). (if (< i
4640: 20 65 6e 64 29 20 28 62 65 67 69 6e 20 28 70 72 end) (begin (pr
4650: 6f 63 20 69 29 20 28 6c 70 20 28 2b 20 69 20 31 oc i) (lp (+ i 1
4660: 29 29 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 )))))))..(define
4670: 20 28 73 74 72 69 6e 67 2d 65 76 65 72 79 20 63 (string-every c
4680: 72 69 74 65 72 69 6f 6e 20 73 20 2e 20 6d 61 79 riterion s . may
4690: 62 65 2d 73 74 61 72 74 2b 65 6e 64 29 0a 20 20 be-start+end).
46a0: 28 6c 65 74 2d 73 74 72 69 6e 67 2d 73 74 61 72 (let-string-star
46b0: 74 2b 65 6e 64 20 28 73 74 61 72 74 20 65 6e 64 t+end (start end
46c0: 29 20 73 74 72 69 6e 67 2d 65 76 65 72 79 20 73 ) string-every s
46d0: 20 6d 61 79 62 65 2d 73 74 61 72 74 2b 65 6e 64 maybe-start+end
46e0: 0a 20 20 20 20 28 63 6f 6e 64 20 28 28 63 68 61 . (cond ((cha
46f0: 72 3f 20 63 72 69 74 65 72 69 6f 6e 29 0a 09 20 r? criterion)..
4700: 20 20 28 6c 65 74 20 6c 70 20 28 28 69 20 73 74 (let lp ((i st
4710: 61 72 74 29 29 0a 09 20 20 20 20 20 28 6f 72 20 art)).. (or
4720: 28 3e 3d 20 69 20 65 6e 64 29 0a 09 09 20 28 61 (>= i end)... (a
4730: 6e 64 20 28 63 68 61 72 3d 3f 20 63 72 69 74 65 nd (char=? crite
4740: 72 69 6f 6e 20 28 73 74 72 69 6e 67 2d 72 65 66 rion (string-ref
4750: 20 73 20 69 29 29 0a 09 09 20 20 20 20 20 20 28 s i))... (
4760: 6c 70 20 28 2b 20 69 20 31 29 29 29 29 29 29 0a lp (+ i 1)))))).
4770: 0a 09 20 20 28 28 63 68 61 72 2d 73 65 74 3f 20 .. ((char-set?
4780: 63 72 69 74 65 72 69 6f 6e 29 0a 09 20 20 20 28 criterion).. (
4790: 6c 65 74 20 6c 70 20 28 28 69 20 73 74 61 72 74 let lp ((i start
47a0: 29 29 0a 09 20 20 20 20 20 28 6f 72 20 28 3e 3d )).. (or (>=
47b0: 20 69 20 65 6e 64 29 0a 09 09 20 28 61 6e 64 20 i end)... (and
47c0: 28 63 68 61 72 2d 73 65 74 2d 63 6f 6e 74 61 69 (char-set-contai
47d0: 6e 73 3f 20 63 72 69 74 65 72 69 6f 6e 20 28 73 ns? criterion (s
47e0: 74 72 69 6e 67 2d 72 65 66 20 73 20 69 29 29 0a tring-ref s i)).
47f0: 09 09 20 20 20 20 20 20 28 6c 70 20 28 2b 20 69 .. (lp (+ i
4800: 20 31 29 29 29 29 29 29 0a 0a 09 20 20 28 28 70 1))))))... ((p
4810: 72 6f 63 65 64 75 72 65 3f 20 63 72 69 74 65 72 rocedure? criter
4820: 69 6f 6e 29 09 09 3b 20 53 6c 69 67 68 74 6c 79 ion)..; Slightly
4830: 20 66 75 6e 6b 79 20 6c 6f 6f 70 20 73 6f 20 74 funky loop so t
4840: 68 61 74 0a 09 20 20 20 28 6f 72 20 28 3d 20 73 hat.. (or (= s
4850: 74 61 72 74 20 65 6e 64 29 09 09 09 3b 20 66 69 tart end)...; fi
4860: 6e 61 6c 20 28 50 52 45 44 20 53 5b 45 4e 44 2d nal (PRED S[END-
4870: 31 5d 29 20 63 61 6c 6c 0a 09 20 20 20 20 20 20 1]) call..
4880: 20 28 6c 65 74 20 6c 70 20 28 28 69 20 73 74 61 (let lp ((i sta
4890: 72 74 29 29 09 09 3b 20 69 73 20 61 20 74 61 69 rt))..; is a tai
48a0: 6c 20 63 61 6c 6c 2e 0a 09 09 20 28 6c 65 74 20 l call.... (let
48b0: 28 28 63 20 28 73 74 72 69 6e 67 2d 72 65 66 20 ((c (string-ref
48c0: 73 20 69 29 29 0a 09 09 20 20 20 20 20 20 20 28 s i))... (
48d0: 69 31 20 28 2b 20 69 20 31 29 29 29 0a 09 09 20 i1 (+ i 1)))...
48e0: 20 20 28 69 66 20 28 3d 20 69 31 20 65 6e 64 29 (if (= i1 end)
48f0: 20 28 63 72 69 74 65 72 69 6f 6e 20 63 29 09 3b (criterion c).;
4900: 20 54 61 69 6c 20 63 61 6c 6c 2e 0a 09 09 20 20 Tail call....
4910: 20 20 20 20 20 28 61 6e 64 20 28 63 72 69 74 65 (and (crite
4920: 72 69 6f 6e 20 63 29 20 28 6c 70 20 69 31 29 29 rion c) (lp i1))
4930: 29 29 29 29 29 0a 0a 09 20 20 28 65 6c 73 65 20 )))))... (else
4940: 28 65 72 72 6f 72 20 22 53 65 63 6f 6e 64 20 70 (error "Second p
4950: 61 72 61 6d 20 69 73 20 6e 65 69 74 68 65 72 20 aram is neither
4960: 63 68 61 72 2d 73 65 74 2c 20 63 68 61 72 2c 20 char-set, char,
4970: 6f 72 20 70 72 65 64 69 63 61 74 65 20 70 72 6f or predicate pro
4980: 63 65 64 75 72 65 2e 22 0a 09 09 20 20 20 20 20 cedure."...
4990: 20 20 73 74 72 69 6e 67 2d 65 76 65 72 79 20 63 string-every c
49a0: 72 69 74 65 72 69 6f 6e 29 29 29 29 29 0a 0a 0a riterion)))))...
49b0: 28 64 65 66 69 6e 65 20 28 73 74 72 69 6e 67 2d (define (string-
49c0: 61 6e 79 20 63 72 69 74 65 72 69 6f 6e 20 73 20 any criterion s
49d0: 2e 20 6d 61 79 62 65 2d 73 74 61 72 74 2b 65 6e . maybe-start+en
49e0: 64 29 0a 20 20 28 6c 65 74 2d 73 74 72 69 6e 67 d). (let-string
49f0: 2d 73 74 61 72 74 2b 65 6e 64 20 28 73 74 61 72 -start+end (star
4a00: 74 20 65 6e 64 29 20 73 74 72 69 6e 67 2d 61 6e t end) string-an
4a10: 79 20 73 20 6d 61 79 62 65 2d 73 74 61 72 74 2b y s maybe-start+
4a20: 65 6e 64 0a 20 20 20 20 28 63 6f 6e 64 20 28 28 end. (cond ((
4a30: 63 68 61 72 3f 20 63 72 69 74 65 72 69 6f 6e 29 char? criterion)
4a40: 0a 09 20 20 20 28 6c 65 74 20 6c 70 20 28 28 69 .. (let lp ((i
4a50: 20 73 74 61 72 74 29 29 0a 09 20 20 20 20 20 28 start)).. (
4a60: 61 6e 64 20 28 3c 20 69 20 65 6e 64 29 0a 09 09 and (< i end)...
4a70: 20 20 28 6f 72 20 28 63 68 61 72 3d 3f 20 63 72 (or (char=? cr
4a80: 69 74 65 72 69 6f 6e 20 28 73 74 72 69 6e 67 2d iterion (string-
4a90: 72 65 66 20 73 20 69 29 29 0a 09 09 20 20 20 20 ref s i))...
4aa0: 20 20 28 6c 70 20 28 2b 20 69 20 31 29 29 29 29 (lp (+ i 1))))
4ab0: 29 29 0a 0a 09 20 20 28 28 63 68 61 72 2d 73 65 ))... ((char-se
4ac0: 74 3f 20 63 72 69 74 65 72 69 6f 6e 29 0a 09 20 t? criterion)..
4ad0: 20 20 28 6c 65 74 20 6c 70 20 28 28 69 20 73 74 (let lp ((i st
4ae0: 61 72 74 29 29 0a 09 20 20 20 20 20 28 61 6e 64 art)).. (and
4af0: 20 28 3c 20 69 20 65 6e 64 29 0a 09 09 20 20 28 (< i end)... (
4b00: 6f 72 20 28 63 68 61 72 2d 73 65 74 2d 63 6f 6e or (char-set-con
4b10: 74 61 69 6e 73 3f 20 63 72 69 74 65 72 69 6f 6e tains? criterion
4b20: 20 28 73 74 72 69 6e 67 2d 72 65 66 20 73 20 69 (string-ref s i
4b30: 29 29 0a 09 09 20 20 20 20 20 20 28 6c 70 20 28 ))... (lp (
4b40: 2b 20 69 20 31 29 29 29 29 29 29 0a 0a 09 20 20 + i 1))))))...
4b50: 28 28 70 72 6f 63 65 64 75 72 65 3f 20 63 72 69 ((procedure? cri
4b60: 74 65 72 69 6f 6e 29 09 09 3b 20 53 6c 69 67 68 terion)..; Sligh
4b70: 74 6c 79 20 66 75 6e 6b 79 20 6c 6f 6f 70 20 73 tly funky loop s
4b80: 6f 20 74 68 61 74 0a 09 20 20 20 28 61 6e 64 20 o that.. (and
4b90: 28 3c 20 73 74 61 72 74 20 65 6e 64 29 09 09 09 (< start end)...
4ba0: 3b 20 66 69 6e 61 6c 20 28 50 52 45 44 20 53 5b ; final (PRED S[
4bb0: 45 4e 44 2d 31 5d 29 20 63 61 6c 6c 0a 09 09 28 END-1]) call...(
4bc0: 6c 65 74 20 6c 70 20 28 28 69 20 73 74 61 72 74 let lp ((i start
4bd0: 29 29 09 09 3b 20 69 73 20 61 20 74 61 69 6c 20 ))..; is a tail
4be0: 63 61 6c 6c 2e 0a 09 09 20 20 28 6c 65 74 20 28 call.... (let (
4bf0: 28 63 20 28 73 74 72 69 6e 67 2d 72 65 66 20 73 (c (string-ref s
4c00: 20 69 29 29 0a 09 09 09 28 69 31 20 28 2b 20 69 i))....(i1 (+ i
4c10: 20 31 29 29 29 0a 09 09 20 20 20 20 28 69 66 20 1)))... (if
4c20: 28 3d 20 69 31 20 65 6e 64 29 20 28 63 72 69 74 (= i1 end) (crit
4c30: 65 72 69 6f 6e 20 63 29 09 3b 20 54 61 69 6c 20 erion c).; Tail
4c40: 63 61 6c 6c 0a 09 09 09 28 6f 72 20 28 63 72 69 call....(or (cri
4c50: 74 65 72 69 6f 6e 20 63 29 20 28 6c 70 20 69 31 terion c) (lp i1
4c60: 29 29 29 29 29 29 29 0a 0a 09 20 20 28 65 6c 73 )))))))... (els
4c70: 65 20 28 65 72 72 6f 72 20 22 53 65 63 6f 6e 64 e (error "Second
4c80: 20 70 61 72 61 6d 20 69 73 20 6e 65 69 74 68 65 param is neithe
4c90: 72 20 63 68 61 72 2d 73 65 74 2c 20 63 68 61 72 r char-set, char
4ca0: 2c 20 6f 72 20 70 72 65 64 69 63 61 74 65 20 70 , or predicate p
4cb0: 72 6f 63 65 64 75 72 65 2e 22 0a 09 09 20 20 20 rocedure."...
4cc0: 20 20 20 20 73 74 72 69 6e 67 2d 61 6e 79 20 63 string-any c
4cd0: 72 69 74 65 72 69 6f 6e 29 29 29 29 29 0a 0a 0a riterion)))))...
4ce0: 28 64 65 66 69 6e 65 20 28 73 74 72 69 6e 67 2d (define (string-
4cf0: 74 61 62 75 6c 61 74 65 20 70 72 6f 63 20 6c 65 tabulate proc le
4d00: 6e 29 0a 20 20 28 63 68 65 63 6b 2d 61 72 67 20 n). (check-arg
4d10: 70 72 6f 63 65 64 75 72 65 3f 20 70 72 6f 63 20 procedure? proc
4d20: 73 74 72 69 6e 67 2d 74 61 62 75 6c 61 74 65 29 string-tabulate)
4d30: 0a 20 20 28 63 68 65 63 6b 2d 61 72 67 20 28 6c . (check-arg (l
4d40: 61 6d 62 64 61 20 28 76 61 6c 29 20 28 61 6e 64 ambda (val) (and
4d50: 20 28 69 6e 74 65 67 65 72 3f 20 76 61 6c 29 20 (integer? val)
4d60: 28 65 78 61 63 74 3f 20 76 61 6c 29 20 28 3c 3d (exact? val) (<=
4d70: 20 30 20 76 61 6c 29 29 29 0a 09 20 20 20 20 20 0 val)))..
4d80: 6c 65 6e 20 73 74 72 69 6e 67 2d 74 61 62 75 6c len string-tabul
4d90: 61 74 65 29 0a 20 20 28 6c 65 74 20 28 28 73 20 ate). (let ((s
4da0: 28 6d 61 6b 65 2d 73 74 72 69 6e 67 20 6c 65 6e (make-string len
4db0: 29 29 29 0a 20 20 20 20 28 64 6f 20 28 28 69 20 ))). (do ((i
4dc0: 28 2d 20 6c 65 6e 20 31 29 20 28 2d 20 69 20 31 (- len 1) (- i 1
4dd0: 29 29 29 0a 09 28 28 3c 20 69 20 30 29 29 0a 20 )))..((< i 0)).
4de0: 20 20 20 20 20 28 73 74 72 69 6e 67 2d 73 65 74 (string-set
4df0: 21 20 73 20 69 20 28 70 72 6f 63 20 69 29 29 29 ! s i (proc i)))
4e00: 0a 20 20 20 20 73 29 29 0a 0a 0a 0c 0a 3b 3b 3b . s)).....;;;
4e10: 20 73 74 72 69 6e 67 2d 70 72 65 66 69 78 2d 6c string-prefix-l
4e20: 65 6e 67 74 68 5b 2d 63 69 5d 20 73 31 20 73 32 ength[-ci] s1 s2
4e30: 20 5b 73 74 61 72 74 31 20 65 6e 64 31 20 73 74 [start1 end1 st
4e40: 61 72 74 32 20 65 6e 64 32 5d 0a 3b 3b 3b 20 73 art2 end2].;;; s
4e50: 74 72 69 6e 67 2d 73 75 66 66 69 78 2d 6c 65 6e tring-suffix-len
4e60: 67 74 68 5b 2d 63 69 5d 20 73 31 20 73 32 20 5b gth[-ci] s1 s2 [
4e70: 73 74 61 72 74 31 20 65 6e 64 31 20 73 74 61 72 start1 end1 star
4e80: 74 32 20 65 6e 64 32 5d 0a 3b 3b 3b 3b 3b 3b 3b t2 end2].;;;;;;;
4e90: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
4ea0: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
4eb0: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
4ec0: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
4ed0: 3b 3b 3b 3b 3b 3b 3b 3b 0a 3b 3b 3b 20 46 69 6e ;;;;;;;;.;;; Fin
4ee0: 64 20 74 68 65 20 6c 65 6e 67 74 68 20 6f 66 20 d the length of
4ef0: 74 68 65 20 63 6f 6d 6d 6f 6e 20 70 72 65 66 69 the common prefi
4f00: 78 2f 73 75 66 66 69 78 2e 0a 3b 3b 3b 20 49 74 x/suffix..;;; It
4f10: 20 69 73 20 6e 6f 74 20 72 65 71 75 69 72 65 64 is not required
4f20: 20 74 68 61 74 20 74 68 65 20 74 77 6f 20 73 75 that the two su
4f30: 62 73 74 72 69 6e 67 73 20 70 61 73 73 65 64 20 bstrings passed
4f40: 62 65 20 6f 66 20 65 71 75 61 6c 20 6c 65 6e 67 be of equal leng
4f50: 74 68 2e 0a 3b 3b 3b 20 54 68 69 73 20 77 61 73 th..;;; This was
4f60: 20 6d 69 63 72 6f 63 6f 64 65 20 69 6e 20 4d 49 microcode in MI
4f70: 54 20 53 63 68 65 6d 65 20 2d 2d 20 61 20 76 65 T Scheme -- a ve
4f80: 72 79 20 74 69 67 68 74 6c 79 20 62 75 6d 6d 65 ry tightly bumme
4f90: 64 20 70 72 69 6d 69 74 69 76 65 2e 0a 3b 3b 3b d primitive..;;;
4fa0: 20 25 53 54 52 49 4e 47 2d 50 52 45 46 49 58 2d %STRING-PREFIX-
4fb0: 4c 45 4e 47 54 48 20 69 73 20 74 68 65 20 63 6f LENGTH is the co
4fc0: 72 65 20 72 6f 75 74 69 6e 65 20 6f 66 20 61 6c re routine of al
4fd0: 6c 20 73 74 72 69 6e 67 2d 63 6f 6d 70 61 72 69 l string-compari
4fe0: 73 6f 6e 73 2c 0a 3b 3b 3b 20 73 6f 20 73 68 6f sons,.;;; so sho
4ff0: 75 6c 64 20 62 65 20 61 73 20 74 65 6e 73 65 20 uld be as tense
5000: 61 73 20 70 6f 73 73 69 62 6c 65 2e 0a 0a 28 64 as possible...(d
5010: 65 66 69 6e 65 20 28 25 73 74 72 69 6e 67 2d 70 efine (%string-p
5020: 72 65 66 69 78 2d 6c 65 6e 67 74 68 20 73 31 20 refix-length s1
5030: 73 74 61 72 74 31 20 65 6e 64 31 20 73 32 20 73 start1 end1 s2 s
5040: 74 61 72 74 32 20 65 6e 64 32 29 0a 20 20 28 6c tart2 end2). (l
5050: 65 74 2a 20 28 28 64 65 6c 74 61 20 28 6d 69 6e et* ((delta (min
5060: 20 28 2d 20 65 6e 64 31 20 73 74 61 72 74 31 29 (- end1 start1)
5070: 20 28 2d 20 65 6e 64 32 20 73 74 61 72 74 32 29 (- end2 start2)
5080: 29 29 0a 09 20 28 65 6e 64 31 20 28 2b 20 73 74 )).. (end1 (+ st
5090: 61 72 74 31 20 64 65 6c 74 61 29 29 29 0a 0a 20 art1 delta)))..
50a0: 20 20 20 28 69 66 20 28 61 6e 64 20 28 65 71 3f (if (and (eq?
50b0: 20 73 31 20 73 32 29 20 28 3d 20 73 74 61 72 74 s1 s2) (= start
50c0: 31 20 73 74 61 72 74 32 29 29 09 3b 20 45 51 20 1 start2)).; EQ
50d0: 66 61 73 74 20 70 61 74 68 0a 09 64 65 6c 74 61 fast path..delta
50e0: 0a 0a 09 28 6c 65 74 20 6c 70 20 28 28 69 20 73 ...(let lp ((i s
50f0: 74 61 72 74 31 29 20 28 6a 20 73 74 61 72 74 32 tart1) (j start2
5100: 29 29 09 09 3b 20 52 65 67 75 6c 61 72 20 70 61 ))..; Regular pa
5110: 74 68 0a 09 20 20 28 69 66 20 28 6f 72 20 28 3e th.. (if (or (>
5120: 3d 20 69 20 65 6e 64 31 29 0a 09 09 20 20 28 6e = i end1)... (n
5130: 6f 74 20 28 63 68 61 72 3d 3f 20 28 73 74 72 69 ot (char=? (stri
5140: 6e 67 2d 72 65 66 20 73 31 20 69 29 0a 09 09 09 ng-ref s1 i)....
5150: 20 20 20 20 20 20 20 28 73 74 72 69 6e 67 2d 72 (string-r
5160: 65 66 20 73 32 20 6a 29 29 29 29 0a 09 20 20 20 ef s2 j))))..
5170: 20 20 20 28 2d 20 69 20 73 74 61 72 74 31 29 0a (- i start1).
5180: 09 20 20 20 20 20 20 28 6c 70 20 28 2b 20 69 20 . (lp (+ i
5190: 31 29 20 28 2b 20 6a 20 31 29 29 29 29 29 29 29 1) (+ j 1)))))))
51a0: 0a 0a 28 64 65 66 69 6e 65 20 28 25 73 74 72 69 ..(define (%stri
51b0: 6e 67 2d 73 75 66 66 69 78 2d 6c 65 6e 67 74 68 ng-suffix-length
51c0: 20 73 31 20 73 74 61 72 74 31 20 65 6e 64 31 20 s1 start1 end1
51d0: 73 32 20 73 74 61 72 74 32 20 65 6e 64 32 29 0a s2 start2 end2).
51e0: 20 20 28 6c 65 74 2a 20 28 28 64 65 6c 74 61 20 (let* ((delta
51f0: 28 6d 69 6e 20 28 2d 20 65 6e 64 31 20 73 74 61 (min (- end1 sta
5200: 72 74 31 29 20 28 2d 20 65 6e 64 32 20 73 74 61 rt1) (- end2 sta
5210: 72 74 32 29 29 29 0a 09 20 28 73 74 61 72 74 31 rt2))).. (start1
5220: 20 28 2d 20 65 6e 64 31 20 64 65 6c 74 61 29 29 (- end1 delta))
5230: 29 0a 0a 20 20 20 20 28 69 66 20 28 61 6e 64 20 ).. (if (and
5240: 28 65 71 3f 20 73 31 20 73 32 29 20 28 3d 20 65 (eq? s1 s2) (= e
5250: 6e 64 31 20 65 6e 64 32 29 29 09 09 3b 20 45 51 nd1 end2))..; EQ
5260: 20 66 61 73 74 20 70 61 74 68 0a 09 64 65 6c 74 fast path..delt
5270: 61 0a 0a 09 28 6c 65 74 20 6c 70 20 28 28 69 20 a...(let lp ((i
5280: 28 2d 20 65 6e 64 31 20 31 29 29 20 28 6a 20 28 (- end1 1)) (j (
5290: 2d 20 65 6e 64 32 20 31 29 29 29 09 3b 20 52 65 - end2 1))).; Re
52a0: 67 75 6c 61 72 20 70 61 74 68 0a 09 20 20 28 69 gular path.. (i
52b0: 66 20 28 6f 72 20 28 3c 20 69 20 73 74 61 72 74 f (or (< i start
52c0: 31 29 0a 09 09 20 20 28 6e 6f 74 20 28 63 68 61 1)... (not (cha
52d0: 72 3d 3f 20 28 73 74 72 69 6e 67 2d 72 65 66 20 r=? (string-ref
52e0: 73 31 20 69 29 0a 09 09 09 20 20 20 20 20 20 20 s1 i)....
52f0: 28 73 74 72 69 6e 67 2d 72 65 66 20 73 32 20 6a (string-ref s2 j
5300: 29 29 29 29 0a 09 20 20 20 20 20 20 28 2d 20 28 )))).. (- (
5310: 2d 20 65 6e 64 31 20 69 29 20 31 29 0a 09 20 20 - end1 i) 1)..
5320: 20 20 20 20 28 6c 70 20 28 2d 20 69 20 31 29 20 (lp (- i 1)
5330: 28 2d 20 6a 20 31 29 29 29 29 29 29 29 0a 0a 28 (- j 1)))))))..(
5340: 64 65 66 69 6e 65 20 28 25 73 74 72 69 6e 67 2d define (%string-
5350: 70 72 65 66 69 78 2d 6c 65 6e 67 74 68 2d 63 69 prefix-length-ci
5360: 20 73 31 20 73 74 61 72 74 31 20 65 6e 64 31 20 s1 start1 end1
5370: 73 32 20 73 74 61 72 74 32 20 65 6e 64 32 29 0a s2 start2 end2).
5380: 20 20 28 6c 65 74 2a 20 28 28 64 65 6c 74 61 20 (let* ((delta
5390: 28 6d 69 6e 20 28 2d 20 65 6e 64 31 20 73 74 61 (min (- end1 sta
53a0: 72 74 31 29 20 28 2d 20 65 6e 64 32 20 73 74 61 rt1) (- end2 sta
53b0: 72 74 32 29 29 29 0a 09 20 28 65 6e 64 31 20 28 rt2))).. (end1 (
53c0: 2b 20 73 74 61 72 74 31 20 64 65 6c 74 61 29 29 + start1 delta))
53d0: 29 0a 0a 20 20 20 20 28 69 66 20 28 61 6e 64 20 ).. (if (and
53e0: 28 65 71 3f 20 73 31 20 73 32 29 20 28 3d 20 73 (eq? s1 s2) (= s
53f0: 74 61 72 74 31 20 73 74 61 72 74 32 29 29 09 3b tart1 start2)).;
5400: 20 45 51 20 66 61 73 74 20 70 61 74 68 0a 09 64 EQ fast path..d
5410: 65 6c 74 61 0a 0a 09 28 6c 65 74 20 6c 70 20 28 elta...(let lp (
5420: 28 69 20 73 74 61 72 74 31 29 20 28 6a 20 73 74 (i start1) (j st
5430: 61 72 74 32 29 29 09 09 3b 20 52 65 67 75 6c 61 art2))..; Regula
5440: 72 20 70 61 74 68 0a 09 20 20 28 69 66 20 28 6f r path.. (if (o
5450: 72 20 28 3e 3d 20 69 20 65 6e 64 31 29 0a 09 09 r (>= i end1)...
5460: 20 20 28 6e 6f 74 20 28 63 68 61 72 2d 63 69 3d (not (char-ci=
5470: 3f 20 28 73 74 72 69 6e 67 2d 72 65 66 20 73 31 ? (string-ref s1
5480: 20 69 29 0a 09 09 09 09 20 20 28 73 74 72 69 6e i)..... (strin
5490: 67 2d 72 65 66 20 73 32 20 6a 29 29 29 29 0a 09 g-ref s2 j))))..
54a0: 20 20 20 20 20 20 28 2d 20 69 20 73 74 61 72 74 (- i start
54b0: 31 29 0a 09 20 20 20 20 20 20 28 6c 70 20 28 2b 1).. (lp (+
54c0: 20 69 20 31 29 20 28 2b 20 6a 20 31 29 29 29 29 i 1) (+ j 1))))
54d0: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 25 73 )))..(define (%s
54e0: 74 72 69 6e 67 2d 73 75 66 66 69 78 2d 6c 65 6e tring-suffix-len
54f0: 67 74 68 2d 63 69 20 73 31 20 73 74 61 72 74 31 gth-ci s1 start1
5500: 20 65 6e 64 31 20 73 32 20 73 74 61 72 74 32 20 end1 s2 start2
5510: 65 6e 64 32 29 0a 20 20 28 6c 65 74 2a 20 28 28 end2). (let* ((
5520: 64 65 6c 74 61 20 28 6d 69 6e 20 28 2d 20 65 6e delta (min (- en
5530: 64 31 20 73 74 61 72 74 31 29 20 28 2d 20 65 6e d1 start1) (- en
5540: 64 32 20 73 74 61 72 74 32 29 29 29 0a 09 20 28 d2 start2))).. (
5550: 73 74 61 72 74 31 20 28 2d 20 65 6e 64 31 20 64 start1 (- end1 d
5560: 65 6c 74 61 29 29 29 0a 0a 20 20 20 20 28 69 66 elta))).. (if
5570: 20 28 61 6e 64 20 28 65 71 3f 20 73 31 20 73 32 (and (eq? s1 s2
5580: 29 20 28 3d 20 65 6e 64 31 20 65 6e 64 32 29 29 ) (= end1 end2))
5590: 09 09 3b 20 45 51 20 66 61 73 74 20 70 61 74 68 ..; EQ fast path
55a0: 0a 09 64 65 6c 74 61 0a 0a 09 28 6c 65 74 20 6c ..delta...(let l
55b0: 70 20 28 28 69 20 28 2d 20 65 6e 64 31 20 31 29 p ((i (- end1 1)
55c0: 29 20 28 6a 20 28 2d 20 65 6e 64 32 20 31 29 29 ) (j (- end2 1))
55d0: 29 09 3b 20 52 65 67 75 6c 61 72 20 70 61 74 68 ).; Regular path
55e0: 0a 09 20 20 28 69 66 20 28 6f 72 20 28 3c 20 69 .. (if (or (< i
55f0: 20 73 74 61 72 74 31 29 0a 09 09 20 20 28 6e 6f start1)... (no
5600: 74 20 28 63 68 61 72 2d 63 69 3d 3f 20 28 73 74 t (char-ci=? (st
5610: 72 69 6e 67 2d 72 65 66 20 73 31 20 69 29 0a 09 ring-ref s1 i)..
5620: 09 09 09 20 20 28 73 74 72 69 6e 67 2d 72 65 66 ... (string-ref
5630: 20 73 32 20 6a 29 29 29 29 0a 09 20 20 20 20 20 s2 j))))..
5640: 20 28 2d 20 28 2d 20 65 6e 64 31 20 69 29 20 31 (- (- end1 i) 1
5650: 29 0a 09 20 20 20 20 20 20 28 6c 70 20 28 2d 20 ).. (lp (-
5660: 69 20 31 29 20 28 2d 20 6a 20 31 29 29 29 29 29 i 1) (- j 1)))))
5670: 29 29 0a 0a 0a 28 64 65 66 69 6e 65 20 28 73 74 ))...(define (st
5680: 72 69 6e 67 2d 70 72 65 66 69 78 2d 6c 65 6e 67 ring-prefix-leng
5690: 74 68 20 73 31 20 73 32 20 2e 20 6d 61 79 62 65 th s1 s2 . maybe
56a0: 2d 73 74 61 72 74 73 2b 65 6e 64 73 29 0a 20 20 -starts+ends).
56b0: 28 6c 65 74 2d 73 74 72 69 6e 67 2d 73 74 61 72 (let-string-star
56c0: 74 2b 65 6e 64 32 20 28 73 74 61 72 74 31 20 65 t+end2 (start1 e
56d0: 6e 64 31 20 73 74 61 72 74 32 20 65 6e 64 32 29 nd1 start2 end2)
56e0: 20 0a 09 09 09 20 73 74 72 69 6e 67 2d 70 72 65 .... string-pre
56f0: 66 69 78 2d 6c 65 6e 67 74 68 20 73 31 20 73 32 fix-length s1 s2
5700: 20 6d 61 79 62 65 2d 73 74 61 72 74 73 2b 65 6e maybe-starts+en
5710: 64 73 0a 20 20 20 20 28 25 73 74 72 69 6e 67 2d ds. (%string-
5720: 70 72 65 66 69 78 2d 6c 65 6e 67 74 68 20 73 31 prefix-length s1
5730: 20 73 74 61 72 74 31 20 65 6e 64 31 20 73 32 20 start1 end1 s2
5740: 73 74 61 72 74 32 20 65 6e 64 32 29 29 29 0a 0a start2 end2)))..
5750: 28 64 65 66 69 6e 65 20 28 73 74 72 69 6e 67 2d (define (string-
5760: 73 75 66 66 69 78 2d 6c 65 6e 67 74 68 20 73 31 suffix-length s1
5770: 20 73 32 20 2e 20 6d 61 79 62 65 2d 73 74 61 72 s2 . maybe-star
5780: 74 73 2b 65 6e 64 73 29 0a 20 20 28 6c 65 74 2d ts+ends). (let-
5790: 73 74 72 69 6e 67 2d 73 74 61 72 74 2b 65 6e 64 string-start+end
57a0: 32 20 28 73 74 61 72 74 31 20 65 6e 64 31 20 73 2 (start1 end1 s
57b0: 74 61 72 74 32 20 65 6e 64 32 29 20 0a 09 09 09 tart2 end2) ....
57c0: 20 73 74 72 69 6e 67 2d 73 75 66 66 69 78 2d 6c string-suffix-l
57d0: 65 6e 67 74 68 20 73 31 20 73 32 20 6d 61 79 62 ength s1 s2 mayb
57e0: 65 2d 73 74 61 72 74 73 2b 65 6e 64 73 0a 20 20 e-starts+ends.
57f0: 20 20 28 25 73 74 72 69 6e 67 2d 73 75 66 66 69 (%string-suffi
5800: 78 2d 6c 65 6e 67 74 68 20 73 31 20 73 74 61 72 x-length s1 star
5810: 74 31 20 65 6e 64 31 20 73 32 20 73 74 61 72 74 t1 end1 s2 start
5820: 32 20 65 6e 64 32 29 29 29 0a 0a 28 64 65 66 69 2 end2)))..(defi
5830: 6e 65 20 28 73 74 72 69 6e 67 2d 70 72 65 66 69 ne (string-prefi
5840: 78 2d 6c 65 6e 67 74 68 2d 63 69 20 73 31 20 73 x-length-ci s1 s
5850: 32 20 2e 20 6d 61 79 62 65 2d 73 74 61 72 74 73 2 . maybe-starts
5860: 2b 65 6e 64 73 29 0a 20 20 28 6c 65 74 2d 73 74 +ends). (let-st
5870: 72 69 6e 67 2d 73 74 61 72 74 2b 65 6e 64 32 20 ring-start+end2
5880: 28 73 74 61 72 74 31 20 65 6e 64 31 20 73 74 61 (start1 end1 sta
5890: 72 74 32 20 65 6e 64 32 29 20 0a 09 09 09 20 73 rt2 end2) .... s
58a0: 74 72 69 6e 67 2d 70 72 65 66 69 78 2d 6c 65 6e tring-prefix-len
58b0: 67 74 68 2d 63 69 20 73 31 20 73 32 20 6d 61 79 gth-ci s1 s2 may
58c0: 62 65 2d 73 74 61 72 74 73 2b 65 6e 64 73 0a 20 be-starts+ends.
58d0: 20 20 20 28 25 73 74 72 69 6e 67 2d 70 72 65 66 (%string-pref
58e0: 69 78 2d 6c 65 6e 67 74 68 2d 63 69 20 73 31 20 ix-length-ci s1
58f0: 73 74 61 72 74 31 20 65 6e 64 31 20 73 32 20 73 start1 end1 s2 s
5900: 74 61 72 74 32 20 65 6e 64 32 29 29 29 0a 0a 28 tart2 end2)))..(
5910: 64 65 66 69 6e 65 20 28 73 74 72 69 6e 67 2d 73 define (string-s
5920: 75 66 66 69 78 2d 6c 65 6e 67 74 68 2d 63 69 20 uffix-length-ci
5930: 73 31 20 73 32 20 2e 20 6d 61 79 62 65 2d 73 74 s1 s2 . maybe-st
5940: 61 72 74 73 2b 65 6e 64 73 29 0a 20 20 28 6c 65 arts+ends). (le
5950: 74 2d 73 74 72 69 6e 67 2d 73 74 61 72 74 2b 65 t-string-start+e
5960: 6e 64 32 20 28 73 74 61 72 74 31 20 65 6e 64 31 nd2 (start1 end1
5970: 20 73 74 61 72 74 32 20 65 6e 64 32 29 20 0a 09 start2 end2) ..
5980: 09 09 20 73 74 72 69 6e 67 2d 73 75 66 66 69 78 .. string-suffix
5990: 2d 6c 65 6e 67 74 68 2d 63 69 20 73 31 20 73 32 -length-ci s1 s2
59a0: 20 6d 61 79 62 65 2d 73 74 61 72 74 73 2b 65 6e maybe-starts+en
59b0: 64 73 0a 20 20 20 20 28 25 73 74 72 69 6e 67 2d ds. (%string-
59c0: 73 75 66 66 69 78 2d 6c 65 6e 67 74 68 2d 63 69 suffix-length-ci
59d0: 20 73 31 20 73 74 61 72 74 31 20 65 6e 64 31 20 s1 start1 end1
59e0: 73 32 20 73 74 61 72 74 32 20 65 6e 64 32 29 29 s2 start2 end2))
59f0: 29 0a 0a 0a 3b 3b 3b 20 73 74 72 69 6e 67 2d 70 )...;;; string-p
5a00: 72 65 66 69 78 3f 20 20 20 20 73 31 20 73 32 20 refix? s1 s2
5a10: 5b 73 74 61 72 74 31 20 65 6e 64 31 20 73 74 61 [start1 end1 sta
5a20: 72 74 32 20 65 6e 64 32 5d 0a 3b 3b 3b 20 73 74 rt2 end2].;;; st
5a30: 72 69 6e 67 2d 73 75 66 66 69 78 3f 20 20 20 20 ring-suffix?
5a40: 73 31 20 73 32 20 5b 73 74 61 72 74 31 20 65 6e s1 s2 [start1 en
5a50: 64 31 20 73 74 61 72 74 32 20 65 6e 64 32 5d 0a d1 start2 end2].
5a60: 3b 3b 3b 20 73 74 72 69 6e 67 2d 70 72 65 66 69 ;;; string-prefi
5a70: 78 2d 63 69 3f 20 73 31 20 73 32 20 5b 73 74 61 x-ci? s1 s2 [sta
5a80: 72 74 31 20 65 6e 64 31 20 73 74 61 72 74 32 20 rt1 end1 start2
5a90: 65 6e 64 32 5d 0a 3b 3b 3b 20 73 74 72 69 6e 67 end2].;;; string
5aa0: 2d 73 75 66 66 69 78 2d 63 69 3f 20 73 31 20 73 -suffix-ci? s1 s
5ab0: 32 20 5b 73 74 61 72 74 31 20 65 6e 64 31 20 73 2 [start1 end1 s
5ac0: 74 61 72 74 32 20 65 6e 64 32 5d 0a 3b 3b 3b 3b tart2 end2].;;;;
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 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
5b00: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
5b10: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 0a 3b 3b 3b 20 ;;;;;;;;;;;.;;;
5b20: 54 68 65 73 65 20 61 72 65 20 61 6c 6c 20 73 69 These are all si
5b30: 6d 70 6c 65 20 64 65 72 69 76 61 74 69 76 65 73 mple derivatives
5b40: 20 6f 66 20 74 68 65 20 70 72 65 76 69 6f 75 73 of the previous
5b50: 20 63 6f 75 6e 74 69 6e 67 20 66 75 6e 73 2e 0a counting funs..
5b60: 0a 28 64 65 66 69 6e 65 20 28 73 74 72 69 6e 67 .(define (string
5b70: 2d 70 72 65 66 69 78 3f 20 73 31 20 73 32 20 2e -prefix? s1 s2 .
5b80: 20 6d 61 79 62 65 2d 73 74 61 72 74 73 2b 65 6e maybe-starts+en
5b90: 64 73 29 0a 20 20 28 6c 65 74 2d 73 74 72 69 6e ds). (let-strin
5ba0: 67 2d 73 74 61 72 74 2b 65 6e 64 32 20 28 73 74 g-start+end2 (st
5bb0: 61 72 74 31 20 65 6e 64 31 20 73 74 61 72 74 32 art1 end1 start2
5bc0: 20 65 6e 64 32 29 20 0a 09 09 09 20 73 74 72 69 end2) .... stri
5bd0: 6e 67 2d 70 72 65 66 69 78 3f 20 73 31 20 73 32 ng-prefix? s1 s2
5be0: 20 6d 61 79 62 65 2d 73 74 61 72 74 73 2b 65 6e maybe-starts+en
5bf0: 64 73 0a 20 20 20 20 28 25 73 74 72 69 6e 67 2d ds. (%string-
5c00: 70 72 65 66 69 78 3f 20 73 31 20 73 74 61 72 74 prefix? s1 start
5c10: 31 20 65 6e 64 31 20 73 32 20 73 74 61 72 74 32 1 end1 s2 start2
5c20: 20 65 6e 64 32 29 29 29 0a 0a 28 64 65 66 69 6e end2)))..(defin
5c30: 65 20 28 73 74 72 69 6e 67 2d 73 75 66 66 69 78 e (string-suffix
5c40: 3f 20 73 31 20 73 32 20 2e 20 6d 61 79 62 65 2d ? s1 s2 . maybe-
5c50: 73 74 61 72 74 73 2b 65 6e 64 73 29 0a 20 20 28 starts+ends). (
5c60: 6c 65 74 2d 73 74 72 69 6e 67 2d 73 74 61 72 74 let-string-start
5c70: 2b 65 6e 64 32 20 28 73 74 61 72 74 31 20 65 6e +end2 (start1 en
5c80: 64 31 20 73 74 61 72 74 32 20 65 6e 64 32 29 20 d1 start2 end2)
5c90: 0a 09 09 09 20 73 74 72 69 6e 67 2d 73 75 66 66 .... string-suff
5ca0: 69 78 3f 20 73 31 20 73 32 20 6d 61 79 62 65 2d ix? s1 s2 maybe-
5cb0: 73 74 61 72 74 73 2b 65 6e 64 73 0a 20 20 20 20 starts+ends.
5cc0: 28 25 73 74 72 69 6e 67 2d 73 75 66 66 69 78 3f (%string-suffix?
5cd0: 20 73 31 20 73 74 61 72 74 31 20 65 6e 64 31 20 s1 start1 end1
5ce0: 73 32 20 73 74 61 72 74 32 20 65 6e 64 32 29 29 s2 start2 end2))
5cf0: 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 74 72 69 )..(define (stri
5d00: 6e 67 2d 70 72 65 66 69 78 2d 63 69 3f 20 73 31 ng-prefix-ci? s1
5d10: 20 73 32 20 2e 20 6d 61 79 62 65 2d 73 74 61 72 s2 . maybe-star
5d20: 74 73 2b 65 6e 64 73 29 0a 20 20 28 6c 65 74 2d ts+ends). (let-
5d30: 73 74 72 69 6e 67 2d 73 74 61 72 74 2b 65 6e 64 string-start+end
5d40: 32 20 28 73 74 61 72 74 31 20 65 6e 64 31 20 73 2 (start1 end1 s
5d50: 74 61 72 74 32 20 65 6e 64 32 29 20 0a 09 09 09 tart2 end2) ....
5d60: 20 73 74 72 69 6e 67 2d 70 72 65 66 69 78 2d 63 string-prefix-c
5d70: 69 3f 20 73 31 20 73 32 20 6d 61 79 62 65 2d 73 i? s1 s2 maybe-s
5d80: 74 61 72 74 73 2b 65 6e 64 73 0a 20 20 20 20 28 tarts+ends. (
5d90: 25 73 74 72 69 6e 67 2d 70 72 65 66 69 78 2d 63 %string-prefix-c
5da0: 69 3f 20 73 31 20 73 74 61 72 74 31 20 65 6e 64 i? s1 start1 end
5db0: 31 20 73 32 20 73 74 61 72 74 32 20 65 6e 64 32 1 s2 start2 end2
5dc0: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 74 )))..(define (st
5dd0: 72 69 6e 67 2d 73 75 66 66 69 78 2d 63 69 3f 20 ring-suffix-ci?
5de0: 73 31 20 73 32 20 2e 20 6d 61 79 62 65 2d 73 74 s1 s2 . maybe-st
5df0: 61 72 74 73 2b 65 6e 64 73 29 0a 20 20 28 6c 65 arts+ends). (le
5e00: 74 2d 73 74 72 69 6e 67 2d 73 74 61 72 74 2b 65 t-string-start+e
5e10: 6e 64 32 20 28 73 74 61 72 74 31 20 65 6e 64 31 nd2 (start1 end1
5e20: 20 73 74 61 72 74 32 20 65 6e 64 32 29 20 0a 09 start2 end2) ..
5e30: 09 09 20 73 74 72 69 6e 67 2d 73 75 66 66 69 78 .. string-suffix
5e40: 2d 63 69 3f 20 73 31 20 73 32 20 6d 61 79 62 65 -ci? s1 s2 maybe
5e50: 2d 73 74 61 72 74 73 2b 65 6e 64 73 0a 20 20 20 -starts+ends.
5e60: 20 28 25 73 74 72 69 6e 67 2d 73 75 66 66 69 78 (%string-suffix
5e70: 2d 63 69 3f 20 73 31 20 73 74 61 72 74 31 20 65 -ci? s1 start1 e
5e80: 6e 64 31 20 73 32 20 73 74 61 72 74 32 20 65 6e nd1 s2 start2 en
5e90: 64 32 29 29 29 0a 0a 0a 3b 3b 3b 20 48 65 72 65 d2)))...;;; Here
5ea0: 20 61 72 65 20 74 68 65 20 69 6e 74 65 72 6e 61 are the interna
5eb0: 6c 20 72 6f 75 74 69 6e 65 73 20 74 68 61 74 20 l routines that
5ec0: 64 6f 20 74 68 65 20 72 65 61 6c 20 77 6f 72 6b do the real work
5ed0: 2e 0a 0a 28 64 65 66 69 6e 65 20 28 25 73 74 72 ...(define (%str
5ee0: 69 6e 67 2d 70 72 65 66 69 78 3f 20 73 31 20 73 ing-prefix? s1 s
5ef0: 74 61 72 74 31 20 65 6e 64 31 20 73 32 20 73 74 tart1 end1 s2 st
5f00: 61 72 74 32 20 65 6e 64 32 29 0a 20 20 28 6c 65 art2 end2). (le
5f10: 74 20 28 28 6c 65 6e 31 20 28 2d 20 65 6e 64 31 t ((len1 (- end1
5f20: 20 73 74 61 72 74 31 29 29 29 0a 20 20 20 20 28 start1))). (
5f30: 61 6e 64 20 28 3c 3d 20 6c 65 6e 31 20 28 2d 20 and (<= len1 (-
5f40: 65 6e 64 32 20 73 74 61 72 74 32 29 29 09 3b 20 end2 start2)).;
5f50: 51 75 69 63 6b 20 63 68 65 63 6b 0a 09 20 28 3d Quick check.. (=
5f60: 20 28 25 73 74 72 69 6e 67 2d 70 72 65 66 69 78 (%string-prefix
5f70: 2d 6c 65 6e 67 74 68 20 73 31 20 73 74 61 72 74 -length s1 start
5f80: 31 20 65 6e 64 31 0a 09 09 09 09 20 20 20 73 32 1 end1..... s2
5f90: 20 73 74 61 72 74 32 20 65 6e 64 32 29 0a 09 20 start2 end2)..
5fa0: 20 20 20 6c 65 6e 31 29 29 29 29 0a 0a 28 64 65 len1))))..(de
5fb0: 66 69 6e 65 20 28 25 73 74 72 69 6e 67 2d 73 75 fine (%string-su
5fc0: 66 66 69 78 3f 20 73 31 20 73 74 61 72 74 31 20 ffix? s1 start1
5fd0: 65 6e 64 31 20 73 32 20 73 74 61 72 74 32 20 65 end1 s2 start2 e
5fe0: 6e 64 32 29 0a 20 20 28 6c 65 74 20 28 28 6c 65 nd2). (let ((le
5ff0: 6e 31 20 28 2d 20 65 6e 64 31 20 73 74 61 72 74 n1 (- end1 start
6000: 31 29 29 29 0a 20 20 20 20 28 61 6e 64 20 28 3c 1))). (and (<
6010: 3d 20 6c 65 6e 31 20 28 2d 20 65 6e 64 32 20 73 = len1 (- end2 s
6020: 74 61 72 74 32 29 29 09 3b 20 51 75 69 63 6b 20 tart2)).; Quick
6030: 63 68 65 63 6b 0a 09 20 28 3d 20 6c 65 6e 31 20 check.. (= len1
6040: 28 25 73 74 72 69 6e 67 2d 73 75 66 66 69 78 2d (%string-suffix-
6050: 6c 65 6e 67 74 68 20 73 31 20 73 74 61 72 74 31 length s1 start1
6060: 20 65 6e 64 31 0a 09 09 09 09 09 73 32 20 73 74 end1......s2 st
6070: 61 72 74 32 20 65 6e 64 32 29 29 29 29 29 0a 0a art2 end2)))))..
6080: 28 64 65 66 69 6e 65 20 28 25 73 74 72 69 6e 67 (define (%string
6090: 2d 70 72 65 66 69 78 2d 63 69 3f 20 73 31 20 73 -prefix-ci? s1 s
60a0: 74 61 72 74 31 20 65 6e 64 31 20 73 32 20 73 74 tart1 end1 s2 st
60b0: 61 72 74 32 20 65 6e 64 32 29 0a 20 20 28 6c 65 art2 end2). (le
60c0: 74 20 28 28 6c 65 6e 31 20 28 2d 20 65 6e 64 31 t ((len1 (- end1
60d0: 20 73 74 61 72 74 31 29 29 29 0a 20 20 20 20 28 start1))). (
60e0: 61 6e 64 20 28 3c 3d 20 6c 65 6e 31 20 28 2d 20 and (<= len1 (-
60f0: 65 6e 64 32 20 73 74 61 72 74 32 29 29 09 3b 20 end2 start2)).;
6100: 51 75 69 63 6b 20 63 68 65 63 6b 0a 09 20 28 3d Quick check.. (=
6110: 20 6c 65 6e 31 20 28 25 73 74 72 69 6e 67 2d 70 len1 (%string-p
6120: 72 65 66 69 78 2d 6c 65 6e 67 74 68 2d 63 69 20 refix-length-ci
6130: 73 31 20 73 74 61 72 74 31 20 65 6e 64 31 0a 09 s1 start1 end1..
6140: 09 09 09 09 20 20 20 73 32 20 73 74 61 72 74 32 .... s2 start2
6150: 20 65 6e 64 32 29 29 29 29 29 0a 0a 28 64 65 66 end2)))))..(def
6160: 69 6e 65 20 28 25 73 74 72 69 6e 67 2d 73 75 66 ine (%string-suf
6170: 66 69 78 2d 63 69 3f 20 73 31 20 73 74 61 72 74 fix-ci? s1 start
6180: 31 20 65 6e 64 31 20 73 32 20 73 74 61 72 74 32 1 end1 s2 start2
6190: 20 65 6e 64 32 29 0a 20 20 28 6c 65 74 20 28 28 end2). (let ((
61a0: 6c 65 6e 31 20 28 2d 20 65 6e 64 31 20 73 74 61 len1 (- end1 sta
61b0: 72 74 31 29 29 29 0a 20 20 20 20 28 61 6e 64 20 rt1))). (and
61c0: 28 3c 3d 20 6c 65 6e 31 20 28 2d 20 65 6e 64 32 (<= len1 (- end2
61d0: 20 73 74 61 72 74 32 29 29 09 3b 20 51 75 69 63 start2)).; Quic
61e0: 6b 20 63 68 65 63 6b 0a 09 20 28 3d 20 6c 65 6e k check.. (= len
61f0: 31 20 28 25 73 74 72 69 6e 67 2d 73 75 66 66 69 1 (%string-suffi
6200: 78 2d 6c 65 6e 67 74 68 2d 63 69 20 73 31 20 73 x-length-ci s1 s
6210: 74 61 72 74 31 20 65 6e 64 31 0a 09 09 09 09 09 tart1 end1......
6220: 20 20 20 73 32 20 73 74 61 72 74 32 20 65 6e 64 s2 start2 end
6230: 32 29 29 29 29 29 0a 0a 0c 0a 3b 3b 3b 20 73 74 2)))))....;;; st
6240: 72 69 6e 67 2d 63 6f 6d 70 61 72 65 20 20 20 20 ring-compare
6250: 73 31 20 73 32 20 70 72 6f 63 3c 20 70 72 6f 63 s1 s2 proc< proc
6260: 3d 20 70 72 6f 63 3e 20 5b 73 74 61 72 74 31 20 = proc> [start1
6270: 65 6e 64 31 20 73 74 61 72 74 32 20 65 6e 64 32 end1 start2 end2
6280: 5d 0a 3b 3b 3b 20 73 74 72 69 6e 67 2d 63 6f 6d ].;;; string-com
6290: 70 61 72 65 2d 63 69 20 73 31 20 73 32 20 70 72 pare-ci s1 s2 pr
62a0: 6f 63 3c 20 70 72 6f 63 3d 20 70 72 6f 63 3e 20 oc< proc= proc>
62b0: 5b 73 74 61 72 74 31 20 65 6e 64 31 20 73 74 61 [start1 end1 sta
62c0: 72 74 32 20 65 6e 64 32 5d 0a 3b 3b 3b 3b 3b 3b rt2 end2].;;;;;;
62d0: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
62e0: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
62f0: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
6300: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
6310: 3b 3b 3b 3b 3b 3b 3b 3b 3b 0a 3b 3b 3b 20 50 72 ;;;;;;;;;.;;; Pr
6320: 69 6d 69 74 69 76 65 20 73 74 72 69 6e 67 2d 63 imitive string-c
6330: 6f 6d 70 61 72 69 73 6f 6e 20 66 75 6e 63 74 69 omparison functi
6340: 6f 6e 73 2e 0a 3b 3b 3b 20 43 6f 6e 74 69 6e 75 ons..;;; Continu
6350: 61 74 69 6f 6e 20 6f 72 64 65 72 20 69 73 20 64 ation order is d
6360: 69 66 66 65 72 65 6e 74 20 66 72 6f 6d 20 4d 49 ifferent from MI
6370: 54 20 53 63 68 65 6d 65 2e 0a 3b 3b 3b 20 43 6f T Scheme..;;; Co
6380: 6e 74 69 6e 75 61 74 69 6f 6e 73 20 61 72 65 20 ntinuations are
6390: 61 70 70 6c 69 65 64 20 74 6f 20 73 31 27 73 20 applied to s1's
63a0: 6d 69 73 6d 61 74 63 68 20 69 6e 64 65 78 3b 0a mismatch index;.
63b0: 3b 3b 3b 20 69 6e 20 74 68 65 20 63 61 73 65 20 ;;; in the case
63c0: 6f 66 20 65 71 75 61 6c 69 74 79 2c 20 74 68 69 of equality, thi
63d0: 73 20 69 73 20 45 4e 44 31 2e 0a 0a 28 64 65 66 s is END1...(def
63e0: 69 6e 65 20 28 25 73 74 72 69 6e 67 2d 63 6f 6d ine (%string-com
63f0: 70 61 72 65 20 73 31 20 73 74 61 72 74 31 20 65 pare s1 start1 e
6400: 6e 64 31 20 73 32 20 73 74 61 72 74 32 20 65 6e nd1 s2 start2 en
6410: 64 32 0a 09 09 09 20 20 20 70 72 6f 63 3c 20 70 d2.... proc< p
6420: 72 6f 63 3d 20 70 72 6f 63 3e 29 0a 20 20 28 6c roc= proc>). (l
6430: 65 74 20 28 28 73 69 7a 65 31 20 28 2d 20 65 6e et ((size1 (- en
6440: 64 31 20 73 74 61 72 74 31 29 29 0a 09 28 73 69 d1 start1))..(si
6450: 7a 65 32 20 28 2d 20 65 6e 64 32 20 73 74 61 72 ze2 (- end2 star
6460: 74 32 29 29 29 0a 20 20 20 20 28 6c 65 74 20 28 t2))). (let (
6470: 28 6d 61 74 63 68 20 28 25 73 74 72 69 6e 67 2d (match (%string-
6480: 70 72 65 66 69 78 2d 6c 65 6e 67 74 68 20 73 31 prefix-length s1
6490: 20 73 74 61 72 74 31 20 65 6e 64 31 20 73 32 20 start1 end1 s2
64a0: 73 74 61 72 74 32 20 65 6e 64 32 29 29 29 0a 20 start2 end2))).
64b0: 20 20 20 20 20 28 69 66 20 28 3d 20 6d 61 74 63 (if (= matc
64c0: 68 20 73 69 7a 65 31 29 0a 09 20 20 28 28 69 66 h size1).. ((if
64d0: 20 28 3d 20 6d 61 74 63 68 20 73 69 7a 65 32 29 (= match size2)
64e0: 20 70 72 6f 63 3d 20 70 72 6f 63 3c 29 20 65 6e proc= proc<) en
64f0: 64 31 29 0a 09 20 20 28 28 69 66 20 28 3d 20 6d d1).. ((if (= m
6500: 61 74 63 68 20 73 69 7a 65 32 29 0a 09 20 20 20 atch size2)..
6510: 20 20 20 20 70 72 6f 63 3e 0a 09 20 20 20 20 20 proc>..
6520: 20 20 28 69 66 20 28 63 68 61 72 3c 3f 20 28 73 (if (char<? (s
6530: 74 72 69 6e 67 2d 72 65 66 20 73 31 20 28 2b 20 tring-ref s1 (+
6540: 73 74 61 72 74 31 20 6d 61 74 63 68 29 29 0a 09 start1 match))..
6550: 09 09 20 20 20 28 73 74 72 69 6e 67 2d 72 65 66 .. (string-ref
6560: 20 73 32 20 28 2b 20 73 74 61 72 74 32 20 6d 61 s2 (+ start2 ma
6570: 74 63 68 29 29 29 0a 09 09 20 20 20 70 72 6f 63 tch)))... proc
6580: 3c 20 70 72 6f 63 3e 29 29 0a 09 20 20 20 28 2b < proc>)).. (+
6590: 20 6d 61 74 63 68 20 73 74 61 72 74 31 29 29 29 match start1)))
65a0: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 25 73 )))..(define (%s
65b0: 74 72 69 6e 67 2d 63 6f 6d 70 61 72 65 2d 63 69 tring-compare-ci
65c0: 20 73 31 20 73 74 61 72 74 31 20 65 6e 64 31 20 s1 start1 end1
65d0: 73 32 20 73 74 61 72 74 32 20 65 6e 64 32 0a 09 s2 start2 end2..
65e0: 09 09 20 20 20 20 20 20 70 72 6f 63 3c 20 70 72 .. proc< pr
65f0: 6f 63 3d 20 70 72 6f 63 3e 29 0a 20 20 28 6c 65 oc= proc>). (le
6600: 74 20 28 28 73 69 7a 65 31 20 28 2d 20 65 6e 64 t ((size1 (- end
6610: 31 20 73 74 61 72 74 31 29 29 0a 09 28 73 69 7a 1 start1))..(siz
6620: 65 32 20 28 2d 20 65 6e 64 32 20 73 74 61 72 74 e2 (- end2 start
6630: 32 29 29 29 0a 20 20 20 20 28 6c 65 74 20 28 28 2))). (let ((
6640: 6d 61 74 63 68 20 28 25 73 74 72 69 6e 67 2d 70 match (%string-p
6650: 72 65 66 69 78 2d 6c 65 6e 67 74 68 2d 63 69 20 refix-length-ci
6660: 73 31 20 73 74 61 72 74 31 20 65 6e 64 31 20 73 s1 start1 end1 s
6670: 32 20 73 74 61 72 74 32 20 65 6e 64 32 29 29 29 2 start2 end2)))
6680: 0a 20 20 20 20 20 20 28 69 66 20 28 3d 20 6d 61 . (if (= ma
6690: 74 63 68 20 73 69 7a 65 31 29 0a 09 20 20 28 28 tch size1).. ((
66a0: 69 66 20 28 3d 20 6d 61 74 63 68 20 73 69 7a 65 if (= match size
66b0: 32 29 20 70 72 6f 63 3d 20 70 72 6f 63 3c 29 20 2) proc= proc<)
66c0: 65 6e 64 31 29 0a 09 20 20 28 28 69 66 20 28 3d end1).. ((if (=
66d0: 20 6d 61 74 63 68 20 73 69 7a 65 32 29 20 70 72 match size2) pr
66e0: 6f 63 3e 0a 09 20 20 20 20 20 20 20 28 69 66 20 oc>.. (if
66f0: 28 63 68 61 72 2d 63 69 3c 3f 20 28 73 74 72 69 (char-ci<? (stri
6700: 6e 67 2d 72 65 66 20 73 31 20 28 2b 20 73 74 61 ng-ref s1 (+ sta
6710: 72 74 31 20 6d 61 74 63 68 29 29 0a 09 09 09 20 rt1 match))....
6720: 20 20 20 20 20 28 73 74 72 69 6e 67 2d 72 65 66 (string-ref
6730: 20 73 32 20 28 2b 20 73 74 61 72 74 32 20 6d 61 s2 (+ start2 ma
6740: 74 63 68 29 29 29 0a 09 09 20 20 20 70 72 6f 63 tch)))... proc
6750: 3c 20 70 72 6f 63 3e 29 29 0a 09 20 20 20 28 2b < proc>)).. (+
6760: 20 73 74 61 72 74 31 20 6d 61 74 63 68 29 29 29 start1 match)))
6770: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 74 )))..(define (st
6780: 72 69 6e 67 2d 63 6f 6d 70 61 72 65 20 73 31 20 ring-compare s1
6790: 73 32 20 70 72 6f 63 3c 20 70 72 6f 63 3d 20 70 s2 proc< proc= p
67a0: 72 6f 63 3e 20 2e 20 6d 61 79 62 65 2d 73 74 61 roc> . maybe-sta
67b0: 72 74 73 2b 65 6e 64 73 29 0a 20 20 28 63 68 65 rts+ends). (che
67c0: 63 6b 2d 61 72 67 20 70 72 6f 63 65 64 75 72 65 ck-arg procedure
67d0: 3f 20 70 72 6f 63 3c 20 73 74 72 69 6e 67 2d 63 ? proc< string-c
67e0: 6f 6d 70 61 72 65 29 0a 20 20 28 63 68 65 63 6b ompare). (check
67f0: 2d 61 72 67 20 70 72 6f 63 65 64 75 72 65 3f 20 -arg procedure?
6800: 70 72 6f 63 3d 20 73 74 72 69 6e 67 2d 63 6f 6d proc= string-com
6810: 70 61 72 65 29 0a 20 20 28 63 68 65 63 6b 2d 61 pare). (check-a
6820: 72 67 20 70 72 6f 63 65 64 75 72 65 3f 20 70 72 rg procedure? pr
6830: 6f 63 3e 20 73 74 72 69 6e 67 2d 63 6f 6d 70 61 oc> string-compa
6840: 72 65 29 0a 20 20 28 6c 65 74 2d 73 74 72 69 6e re). (let-strin
6850: 67 2d 73 74 61 72 74 2b 65 6e 64 32 20 28 73 74 g-start+end2 (st
6860: 61 72 74 31 20 65 6e 64 31 20 73 74 61 72 74 32 art1 end1 start2
6870: 20 65 6e 64 32 29 20 0a 09 09 09 20 73 74 72 69 end2) .... stri
6880: 6e 67 2d 63 6f 6d 70 61 72 65 20 73 31 20 73 32 ng-compare s1 s2
6890: 20 6d 61 79 62 65 2d 73 74 61 72 74 73 2b 65 6e maybe-starts+en
68a0: 64 73 0a 20 20 20 20 28 25 73 74 72 69 6e 67 2d ds. (%string-
68b0: 63 6f 6d 70 61 72 65 20 73 31 20 73 74 61 72 74 compare s1 start
68c0: 31 20 65 6e 64 31 20 73 32 20 73 74 61 72 74 32 1 end1 s2 start2
68d0: 20 65 6e 64 32 20 70 72 6f 63 3c 20 70 72 6f 63 end2 proc< proc
68e0: 3d 20 70 72 6f 63 3e 29 29 29 0a 0a 28 64 65 66 = proc>)))..(def
68f0: 69 6e 65 20 28 73 74 72 69 6e 67 2d 63 6f 6d 70 ine (string-comp
6900: 61 72 65 2d 63 69 20 73 31 20 73 32 20 70 72 6f are-ci s1 s2 pro
6910: 63 3c 20 70 72 6f 63 3d 20 70 72 6f 63 3e 20 2e c< proc= proc> .
6920: 20 6d 61 79 62 65 2d 73 74 61 72 74 73 2b 65 6e maybe-starts+en
6930: 64 73 29 0a 20 20 28 63 68 65 63 6b 2d 61 72 67 ds). (check-arg
6940: 20 70 72 6f 63 65 64 75 72 65 3f 20 70 72 6f 63 procedure? proc
6950: 3c 20 73 74 72 69 6e 67 2d 63 6f 6d 70 61 72 65 < string-compare
6960: 2d 63 69 29 0a 20 20 28 63 68 65 63 6b 2d 61 72 -ci). (check-ar
6970: 67 20 70 72 6f 63 65 64 75 72 65 3f 20 70 72 6f g procedure? pro
6980: 63 3d 20 73 74 72 69 6e 67 2d 63 6f 6d 70 61 72 c= string-compar
6990: 65 2d 63 69 29 0a 20 20 28 63 68 65 63 6b 2d 61 e-ci). (check-a
69a0: 72 67 20 70 72 6f 63 65 64 75 72 65 3f 20 70 72 rg procedure? pr
69b0: 6f 63 3e 20 73 74 72 69 6e 67 2d 63 6f 6d 70 61 oc> string-compa
69c0: 72 65 2d 63 69 29 0a 20 20 28 6c 65 74 2d 73 74 re-ci). (let-st
69d0: 72 69 6e 67 2d 73 74 61 72 74 2b 65 6e 64 32 20 ring-start+end2
69e0: 28 73 74 61 72 74 31 20 65 6e 64 31 20 73 74 61 (start1 end1 sta
69f0: 72 74 32 20 65 6e 64 32 29 20 0a 09 09 09 20 73 rt2 end2) .... s
6a00: 74 72 69 6e 67 2d 63 6f 6d 70 61 72 65 2d 63 69 tring-compare-ci
6a10: 20 73 31 20 73 32 20 6d 61 79 62 65 2d 73 74 61 s1 s2 maybe-sta
6a20: 72 74 73 2b 65 6e 64 73 0a 20 20 20 20 28 25 73 rts+ends. (%s
6a30: 74 72 69 6e 67 2d 63 6f 6d 70 61 72 65 2d 63 69 tring-compare-ci
6a40: 20 73 31 20 73 74 61 72 74 31 20 65 6e 64 31 20 s1 start1 end1
6a50: 73 32 20 73 74 61 72 74 32 20 65 6e 64 32 20 70 s2 start2 end2 p
6a60: 72 6f 63 3c 20 70 72 6f 63 3d 20 70 72 6f 63 3e roc< proc= proc>
6a70: 29 29 29 0a 0a 0a 0a 3b 3b 3b 20 73 74 72 69 6e )))....;;; strin
6a80: 67 3d 20 20 20 20 20 20 20 20 20 20 73 74 72 69 g= stri
6a90: 6e 67 3c 3e 09 09 73 74 72 69 6e 67 2d 63 69 3d ng<>..string-ci=
6aa0: 20 20 20 20 20 20 20 20 20 20 73 74 72 69 6e 67 string
6ab0: 2d 63 69 3c 3e 0a 3b 3b 3b 20 73 74 72 69 6e 67 -ci<>.;;; string
6ac0: 3c 20 20 20 20 20 20 20 20 20 20 73 74 72 69 6e < strin
6ad0: 67 3e 09 09 73 74 72 69 6e 67 2d 63 69 3c 20 20 g>..string-ci<
6ae0: 20 20 20 20 20 20 20 20 73 74 72 69 6e 67 2d 63 string-c
6af0: 69 3e 0a 3b 3b 3b 20 73 74 72 69 6e 67 3c 3d 20 i>.;;; string<=
6b00: 20 20 20 20 20 20 20 20 73 74 72 69 6e 67 3e 3d string>=
6b10: 09 09 73 74 72 69 6e 67 2d 63 69 3c 3d 20 20 20 ..string-ci<=
6b20: 20 20 20 20 20 20 73 74 72 69 6e 67 2d 63 69 3e string-ci>
6b30: 3d 0a 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b =.;;;;;;;;;;;;;;
6b40: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
6b50: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
6b60: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
6b70: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
6b80: 3b 0a 3b 3b 3b 20 53 69 6d 70 6c 65 20 64 65 66 ;.;;; Simple def
6b90: 69 6e 69 74 69 6f 6e 73 20 69 6e 20 74 65 72 6d initions in term
6ba0: 73 20 6f 66 20 74 68 65 20 70 72 65 76 69 6f 75 s of the previou
6bb0: 73 20 63 6f 6d 70 61 72 69 73 6f 6e 20 66 75 6e s comparison fun
6bc0: 73 2e 0a 3b 3b 3b 20 49 20 73 75 72 65 20 68 6f s..;;; I sure ho
6bd0: 70 65 20 74 68 65 20 25 53 54 52 49 4e 47 2d 43 pe the %STRING-C
6be0: 4f 4d 50 41 52 45 20 63 61 6c 6c 73 20 67 65 74 OMPARE calls get
6bf0: 20 69 6e 74 65 67 72 61 74 65 64 2e 0a 0a 28 64 integrated...(d
6c00: 65 66 69 6e 65 20 28 73 74 72 69 6e 67 3d 20 73 efine (string= s
6c10: 31 20 73 32 20 2e 20 6d 61 79 62 65 2d 73 74 61 1 s2 . maybe-sta
6c20: 72 74 73 2b 65 6e 64 73 29 0a 20 20 28 6c 65 74 rts+ends). (let
6c30: 2d 73 74 72 69 6e 67 2d 73 74 61 72 74 2b 65 6e -string-start+en
6c40: 64 32 20 28 73 74 61 72 74 31 20 65 6e 64 31 20 d2 (start1 end1
6c50: 73 74 61 72 74 32 20 65 6e 64 32 29 20 0a 09 09 start2 end2) ...
6c60: 09 20 73 74 72 69 6e 67 3d 20 73 31 20 73 32 20 . string= s1 s2
6c70: 6d 61 79 62 65 2d 73 74 61 72 74 73 2b 65 6e 64 maybe-starts+end
6c80: 73 0a 20 20 20 20 28 61 6e 64 20 28 3d 20 28 2d s. (and (= (-
6c90: 20 65 6e 64 31 20 73 74 61 72 74 31 29 20 28 2d end1 start1) (-
6ca0: 20 65 6e 64 32 20 73 74 61 72 74 32 29 29 09 09 end2 start2))..
6cb0: 09 3b 20 51 75 69 63 6b 20 66 69 6c 74 65 72 0a .; Quick filter.
6cc0: 09 20 28 6f 72 20 28 61 6e 64 20 28 65 71 3f 20 . (or (and (eq?
6cd0: 73 31 20 73 32 29 20 28 3d 20 73 74 61 72 74 31 s1 s2) (= start1
6ce0: 20 73 74 61 72 74 32 29 29 09 09 3b 20 46 61 73 start2))..; Fas
6cf0: 74 20 70 61 74 68 0a 09 20 20 20 20 20 28 25 73 t path.. (%s
6d00: 74 72 69 6e 67 2d 63 6f 6d 70 61 72 65 20 73 31 tring-compare s1
6d10: 20 73 74 61 72 74 31 20 65 6e 64 31 20 73 32 20 start1 end1 s2
6d20: 73 74 61 72 74 32 20 65 6e 64 32 09 3b 20 52 65 start2 end2.; Re
6d30: 61 6c 20 74 65 73 74 0a 09 09 09 20 20 20 20 20 al test....
6d40: 20 28 6c 61 6d 62 64 61 20 28 69 29 20 23 66 29 (lambda (i) #f)
6d50: 0a 09 09 09 20 20 20 20 20 20 76 61 6c 75 65 73 .... values
6d60: 0a 09 09 09 20 20 20 20 20 20 28 6c 61 6d 62 64 .... (lambd
6d70: 61 20 28 69 29 20 23 66 29 29 29 29 29 29 0a 0a a (i) #f))))))..
6d80: 28 64 65 66 69 6e 65 20 28 73 74 72 69 6e 67 3c (define (string<
6d90: 3e 20 73 31 20 73 32 20 2e 20 6d 61 79 62 65 2d > s1 s2 . maybe-
6da0: 73 74 61 72 74 73 2b 65 6e 64 73 29 0a 20 20 28 starts+ends). (
6db0: 6c 65 74 2d 73 74 72 69 6e 67 2d 73 74 61 72 74 let-string-start
6dc0: 2b 65 6e 64 32 20 28 73 74 61 72 74 31 20 65 6e +end2 (start1 en
6dd0: 64 31 20 73 74 61 72 74 32 20 65 6e 64 32 29 20 d1 start2 end2)
6de0: 0a 09 09 09 20 73 74 72 69 6e 67 3c 3e 20 73 31 .... string<> s1
6df0: 20 73 32 20 6d 61 79 62 65 2d 73 74 61 72 74 73 s2 maybe-starts
6e00: 2b 65 6e 64 73 0a 20 20 20 20 28 6f 72 20 28 6e +ends. (or (n
6e10: 6f 74 20 28 3d 20 28 2d 20 65 6e 64 31 20 73 74 ot (= (- end1 st
6e20: 61 72 74 31 29 20 28 2d 20 65 6e 64 32 20 73 74 art1) (- end2 st
6e30: 61 72 74 32 29 29 29 09 09 3b 20 46 61 73 74 20 art2)))..; Fast
6e40: 70 61 74 68 0a 09 28 61 6e 64 20 28 6e 6f 74 20 path..(and (not
6e50: 28 61 6e 64 20 28 65 71 3f 20 73 31 20 73 32 29 (and (eq? s1 s2)
6e60: 20 28 3d 20 73 74 61 72 74 31 20 73 74 61 72 74 (= start1 start
6e70: 32 29 29 29 09 09 3b 20 51 75 69 63 6b 20 66 69 2)))..; Quick fi
6e80: 6c 74 65 72 0a 09 20 20 20 20 20 28 25 73 74 72 lter.. (%str
6e90: 69 6e 67 2d 63 6f 6d 70 61 72 65 20 73 31 20 73 ing-compare s1 s
6ea0: 74 61 72 74 31 20 65 6e 64 31 20 73 32 20 73 74 tart1 end1 s2 st
6eb0: 61 72 74 32 20 65 6e 64 32 09 3b 20 52 65 61 6c art2 end2.; Real
6ec0: 20 74 65 73 74 0a 09 09 09 20 20 20 20 20 20 76 test.... v
6ed0: 61 6c 75 65 73 0a 09 09 09 20 20 20 20 20 20 28 alues.... (
6ee0: 6c 61 6d 62 64 61 20 28 69 29 20 23 66 29 0a 09 lambda (i) #f)..
6ef0: 09 09 20 20 20 20 20 20 76 61 6c 75 65 73 29 29 .. values))
6f00: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 74 )))..(define (st
6f10: 72 69 6e 67 3c 20 73 31 20 73 32 20 2e 20 6d 61 ring< s1 s2 . ma
6f20: 79 62 65 2d 73 74 61 72 74 73 2b 65 6e 64 73 29 ybe-starts+ends)
6f30: 0a 20 20 28 6c 65 74 2d 73 74 72 69 6e 67 2d 73 . (let-string-s
6f40: 74 61 72 74 2b 65 6e 64 32 20 28 73 74 61 72 74 tart+end2 (start
6f50: 31 20 65 6e 64 31 20 73 74 61 72 74 32 20 65 6e 1 end1 start2 en
6f60: 64 32 29 20 0a 09 09 09 20 73 74 72 69 6e 67 3c d2) .... string<
6f70: 20 73 31 20 73 32 20 6d 61 79 62 65 2d 73 74 61 s1 s2 maybe-sta
6f80: 72 74 73 2b 65 6e 64 73 0a 20 20 20 20 28 69 66 rts+ends. (if
6f90: 20 28 61 6e 64 20 28 65 71 3f 20 73 31 20 73 32 (and (eq? s1 s2
6fa0: 29 20 28 3d 20 73 74 61 72 74 31 20 73 74 61 72 ) (= start1 star
6fb0: 74 32 29 29 09 09 09 3b 20 46 61 73 74 20 70 61 t2))...; Fast pa
6fc0: 74 68 0a 09 28 3c 20 65 6e 64 31 20 65 6e 64 32 th..(< end1 end2
6fd0: 29 0a 0a 09 28 25 73 74 72 69 6e 67 2d 63 6f 6d )...(%string-com
6fe0: 70 61 72 65 20 73 31 20 73 74 61 72 74 31 20 65 pare s1 start1 e
6ff0: 6e 64 31 20 73 32 20 73 74 61 72 74 32 20 65 6e nd1 s2 start2 en
7000: 64 32 20 09 09 3b 20 52 65 61 6c 20 74 65 73 74 d2 ..; Real test
7010: 0a 09 09 09 20 76 61 6c 75 65 73 0a 09 09 09 20 .... values....
7020: 28 6c 61 6d 62 64 61 20 28 69 29 20 23 66 29 0a (lambda (i) #f).
7030: 09 09 09 20 28 6c 61 6d 62 64 61 20 28 69 29 20 ... (lambda (i)
7040: 23 66 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 #f)))))..(define
7050: 20 28 73 74 72 69 6e 67 3e 20 73 31 20 73 32 20 (string> s1 s2
7060: 2e 20 6d 61 79 62 65 2d 73 74 61 72 74 73 2b 65 . maybe-starts+e
7070: 6e 64 73 29 0a 20 20 28 6c 65 74 2d 73 74 72 69 nds). (let-stri
7080: 6e 67 2d 73 74 61 72 74 2b 65 6e 64 32 20 28 73 ng-start+end2 (s
7090: 74 61 72 74 31 20 65 6e 64 31 20 73 74 61 72 74 tart1 end1 start
70a0: 32 20 65 6e 64 32 29 20 0a 09 09 09 20 73 74 72 2 end2) .... str
70b0: 69 6e 67 3e 20 73 31 20 73 32 20 6d 61 79 62 65 ing> s1 s2 maybe
70c0: 2d 73 74 61 72 74 73 2b 65 6e 64 73 0a 20 20 20 -starts+ends.
70d0: 20 28 69 66 20 28 61 6e 64 20 28 65 71 3f 20 73 (if (and (eq? s
70e0: 31 20 73 32 29 20 28 3d 20 73 74 61 72 74 31 20 1 s2) (= start1
70f0: 73 74 61 72 74 32 29 29 09 09 09 3b 20 46 61 73 start2))...; Fas
7100: 74 20 70 61 74 68 0a 09 28 3e 20 65 6e 64 31 20 t path..(> end1
7110: 65 6e 64 32 29 0a 0a 09 28 25 73 74 72 69 6e 67 end2)...(%string
7120: 2d 63 6f 6d 70 61 72 65 20 73 31 20 73 74 61 72 -compare s1 star
7130: 74 31 20 65 6e 64 31 20 73 32 20 73 74 61 72 74 t1 end1 s2 start
7140: 32 20 65 6e 64 32 20 09 09 3b 20 52 65 61 6c 20 2 end2 ..; Real
7150: 74 65 73 74 0a 09 09 09 20 28 6c 61 6d 62 64 61 test.... (lambda
7160: 20 28 69 29 20 23 66 29 0a 09 09 09 20 28 6c 61 (i) #f).... (la
7170: 6d 62 64 61 20 28 69 29 20 23 66 29 0a 09 09 09 mbda (i) #f)....
7180: 20 76 61 6c 75 65 73 29 29 29 29 0a 0a 28 64 65 values))))..(de
7190: 66 69 6e 65 20 28 73 74 72 69 6e 67 3c 3d 20 73 fine (string<= s
71a0: 31 20 73 32 20 2e 20 6d 61 79 62 65 2d 73 74 61 1 s2 . maybe-sta
71b0: 72 74 73 2b 65 6e 64 73 29 0a 20 20 28 6c 65 74 rts+ends). (let
71c0: 2d 73 74 72 69 6e 67 2d 73 74 61 72 74 2b 65 6e -string-start+en
71d0: 64 32 20 28 73 74 61 72 74 31 20 65 6e 64 31 20 d2 (start1 end1
71e0: 73 74 61 72 74 32 20 65 6e 64 32 29 20 0a 09 09 start2 end2) ...
71f0: 09 20 73 74 72 69 6e 67 3c 3d 20 73 31 20 73 32 . string<= s1 s2
7200: 20 6d 61 79 62 65 2d 73 74 61 72 74 73 2b 65 6e maybe-starts+en
7210: 64 73 0a 20 20 20 20 28 69 66 20 28 61 6e 64 20 ds. (if (and
7220: 28 65 71 3f 20 73 31 20 73 32 29 20 28 3d 20 73 (eq? s1 s2) (= s
7230: 74 61 72 74 31 20 73 74 61 72 74 32 29 29 09 09 tart1 start2))..
7240: 09 3b 20 46 61 73 74 20 70 61 74 68 0a 09 28 3c .; Fast path..(<
7250: 3d 20 65 6e 64 31 20 65 6e 64 32 29 0a 0a 09 28 = end1 end2)...(
7260: 25 73 74 72 69 6e 67 2d 63 6f 6d 70 61 72 65 20 %string-compare
7270: 73 31 20 73 74 61 72 74 31 20 65 6e 64 31 20 73 s1 start1 end1 s
7280: 32 20 73 74 61 72 74 32 20 65 6e 64 32 20 09 09 2 start2 end2 ..
7290: 3b 20 52 65 61 6c 20 74 65 73 74 0a 09 09 09 20 ; Real test....
72a0: 76 61 6c 75 65 73 0a 09 09 09 20 76 61 6c 75 65 values.... value
72b0: 73 0a 09 09 09 20 28 6c 61 6d 62 64 61 20 28 69 s.... (lambda (i
72c0: 29 20 23 66 29 29 29 29 29 0a 0a 28 64 65 66 69 ) #f)))))..(defi
72d0: 6e 65 20 28 73 74 72 69 6e 67 3e 3d 20 73 31 20 ne (string>= s1
72e0: 73 32 20 2e 20 6d 61 79 62 65 2d 73 74 61 72 74 s2 . maybe-start
72f0: 73 2b 65 6e 64 73 29 0a 20 20 28 6c 65 74 2d 73 s+ends). (let-s
7300: 74 72 69 6e 67 2d 73 74 61 72 74 2b 65 6e 64 32 tring-start+end2
7310: 20 28 73 74 61 72 74 31 20 65 6e 64 31 20 73 74 (start1 end1 st
7320: 61 72 74 32 20 65 6e 64 32 29 20 0a 09 09 09 20 art2 end2) ....
7330: 73 74 72 69 6e 67 3e 3d 20 73 31 20 73 32 20 6d string>= s1 s2 m
7340: 61 79 62 65 2d 73 74 61 72 74 73 2b 65 6e 64 73 aybe-starts+ends
7350: 0a 20 20 20 20 28 69 66 20 28 61 6e 64 20 28 65 . (if (and (e
7360: 71 3f 20 73 31 20 73 32 29 20 28 3d 20 73 74 61 q? s1 s2) (= sta
7370: 72 74 31 20 73 74 61 72 74 32 29 29 09 09 09 3b rt1 start2))...;
7380: 20 46 61 73 74 20 70 61 74 68 0a 09 28 3e 3d 20 Fast path..(>=
7390: 65 6e 64 31 20 65 6e 64 32 29 0a 0a 09 28 25 73 end1 end2)...(%s
73a0: 74 72 69 6e 67 2d 63 6f 6d 70 61 72 65 20 73 31 tring-compare s1
73b0: 20 73 74 61 72 74 31 20 65 6e 64 31 20 73 32 20 start1 end1 s2
73c0: 73 74 61 72 74 32 20 65 6e 64 32 20 09 09 3b 20 start2 end2 ..;
73d0: 52 65 61 6c 20 74 65 73 74 0a 09 09 09 20 28 6c Real test.... (l
73e0: 61 6d 62 64 61 20 28 69 29 20 23 66 29 0a 09 09 ambda (i) #f)...
73f0: 09 20 76 61 6c 75 65 73 0a 09 09 09 20 76 61 6c . values.... val
7400: 75 65 73 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 ues))))..(define
7410: 20 28 73 74 72 69 6e 67 2d 63 69 3d 20 73 31 20 (string-ci= s1
7420: 73 32 20 2e 20 6d 61 79 62 65 2d 73 74 61 72 74 s2 . maybe-start
7430: 73 2b 65 6e 64 73 29 0a 20 20 28 6c 65 74 2d 73 s+ends). (let-s
7440: 74 72 69 6e 67 2d 73 74 61 72 74 2b 65 6e 64 32 tring-start+end2
7450: 20 28 73 74 61 72 74 31 20 65 6e 64 31 20 73 74 (start1 end1 st
7460: 61 72 74 32 20 65 6e 64 32 29 20 0a 09 09 09 20 art2 end2) ....
7470: 73 74 72 69 6e 67 2d 63 69 3d 20 73 31 20 73 32 string-ci= s1 s2
7480: 20 6d 61 79 62 65 2d 73 74 61 72 74 73 2b 65 6e maybe-starts+en
7490: 64 73 0a 20 20 20 20 28 61 6e 64 20 28 3d 20 28 ds. (and (= (
74a0: 2d 20 65 6e 64 31 20 73 74 61 72 74 31 29 20 28 - end1 start1) (
74b0: 2d 20 65 6e 64 32 20 73 74 61 72 74 32 29 29 09 - end2 start2)).
74c0: 09 09 3b 20 51 75 69 63 6b 20 66 69 6c 74 65 72 ..; Quick filter
74d0: 0a 09 20 28 6f 72 20 28 61 6e 64 20 28 65 71 3f .. (or (and (eq?
74e0: 20 73 31 20 73 32 29 20 28 3d 20 73 74 61 72 74 s1 s2) (= start
74f0: 31 20 73 74 61 72 74 32 29 29 09 09 3b 20 46 61 1 start2))..; Fa
7500: 73 74 20 70 61 74 68 0a 09 20 20 20 20 20 28 25 st path.. (%
7510: 73 74 72 69 6e 67 2d 63 6f 6d 70 61 72 65 2d 63 string-compare-c
7520: 69 20 73 31 20 73 74 61 72 74 31 20 65 6e 64 31 i s1 start1 end1
7530: 20 73 32 20 73 74 61 72 74 32 20 65 6e 64 32 09 s2 start2 end2.
7540: 3b 20 52 65 61 6c 20 74 65 73 74 0a 09 09 09 09 ; Real test.....
7550: 20 28 6c 61 6d 62 64 61 20 28 69 29 20 23 66 29 (lambda (i) #f)
7560: 0a 09 09 09 09 20 76 61 6c 75 65 73 0a 09 09 09 ..... values....
7570: 09 20 28 6c 61 6d 62 64 61 20 28 69 29 20 23 66 . (lambda (i) #f
7580: 29 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 ))))))..(define
7590: 28 73 74 72 69 6e 67 2d 63 69 3c 3e 20 73 31 20 (string-ci<> s1
75a0: 73 32 20 2e 20 6d 61 79 62 65 2d 73 74 61 72 74 s2 . maybe-start
75b0: 73 2b 65 6e 64 73 29 0a 20 20 28 6c 65 74 2d 73 s+ends). (let-s
75c0: 74 72 69 6e 67 2d 73 74 61 72 74 2b 65 6e 64 32 tring-start+end2
75d0: 20 28 73 74 61 72 74 31 20 65 6e 64 31 20 73 74 (start1 end1 st
75e0: 61 72 74 32 20 65 6e 64 32 29 20 0a 09 09 09 20 art2 end2) ....
75f0: 73 74 72 69 6e 67 2d 63 69 3c 3e 20 73 31 20 73 string-ci<> s1 s
7600: 32 20 6d 61 79 62 65 2d 73 74 61 72 74 73 2b 65 2 maybe-starts+e
7610: 6e 64 73 0a 20 20 20 20 28 6f 72 20 28 6e 6f 74 nds. (or (not
7620: 20 28 3d 20 28 2d 20 65 6e 64 31 20 73 74 61 72 (= (- end1 star
7630: 74 31 29 20 28 2d 20 65 6e 64 32 20 73 74 61 72 t1) (- end2 star
7640: 74 32 29 29 29 09 09 3b 20 46 61 73 74 20 70 61 t2)))..; Fast pa
7650: 74 68 0a 09 28 61 6e 64 20 28 6e 6f 74 20 28 61 th..(and (not (a
7660: 6e 64 20 28 65 71 3f 20 73 31 20 73 32 29 20 28 nd (eq? s1 s2) (
7670: 3d 20 73 74 61 72 74 31 20 73 74 61 72 74 32 29 = start1 start2)
7680: 29 29 09 09 3b 20 51 75 69 63 6b 20 66 69 6c 74 ))..; Quick filt
7690: 65 72 0a 09 20 20 20 20 20 28 25 73 74 72 69 6e er.. (%strin
76a0: 67 2d 63 6f 6d 70 61 72 65 2d 63 69 20 73 31 20 g-compare-ci s1
76b0: 73 74 61 72 74 31 20 65 6e 64 31 20 73 32 20 73 start1 end1 s2 s
76c0: 74 61 72 74 32 20 65 6e 64 32 09 3b 20 52 65 61 tart2 end2.; Rea
76d0: 6c 20 74 65 73 74 0a 09 09 09 09 20 76 61 6c 75 l test..... valu
76e0: 65 73 0a 09 09 09 09 20 28 6c 61 6d 62 64 61 20 es..... (lambda
76f0: 28 69 29 20 23 66 29 0a 09 09 09 09 20 76 61 6c (i) #f)..... val
7700: 75 65 73 29 29 29 29 29 0a 0a 28 64 65 66 69 6e ues)))))..(defin
7710: 65 20 28 73 74 72 69 6e 67 2d 63 69 3c 20 73 31 e (string-ci< s1
7720: 20 73 32 20 2e 20 6d 61 79 62 65 2d 73 74 61 72 s2 . maybe-star
7730: 74 73 2b 65 6e 64 73 29 0a 20 20 28 6c 65 74 2d ts+ends). (let-
7740: 73 74 72 69 6e 67 2d 73 74 61 72 74 2b 65 6e 64 string-start+end
7750: 32 20 28 73 74 61 72 74 31 20 65 6e 64 31 20 73 2 (start1 end1 s
7760: 74 61 72 74 32 20 65 6e 64 32 29 20 0a 09 09 09 tart2 end2) ....
7770: 20 73 74 72 69 6e 67 2d 63 69 3c 20 73 31 20 73 string-ci< s1 s
7780: 32 20 6d 61 79 62 65 2d 73 74 61 72 74 73 2b 65 2 maybe-starts+e
7790: 6e 64 73 0a 20 20 20 20 28 69 66 20 28 61 6e 64 nds. (if (and
77a0: 20 28 65 71 3f 20 73 31 20 73 32 29 20 28 3d 20 (eq? s1 s2) (=
77b0: 73 74 61 72 74 31 20 73 74 61 72 74 32 29 29 09 start1 start2)).
77c0: 09 09 3b 20 46 61 73 74 20 70 61 74 68 0a 09 28 ..; Fast path..(
77d0: 3c 20 65 6e 64 31 20 65 6e 64 32 29 0a 0a 09 28 < end1 end2)...(
77e0: 25 73 74 72 69 6e 67 2d 63 6f 6d 70 61 72 65 2d %string-compare-
77f0: 63 69 20 73 31 20 73 74 61 72 74 31 20 65 6e 64 ci s1 start1 end
7800: 31 20 73 32 20 73 74 61 72 74 32 20 65 6e 64 32 1 s2 start2 end2
7810: 09 3b 20 52 65 61 6c 20 74 65 73 74 0a 09 09 09 .; Real test....
7820: 20 20 20 20 76 61 6c 75 65 73 0a 09 09 09 20 20 values....
7830: 20 20 28 6c 61 6d 62 64 61 20 28 69 29 20 23 66 (lambda (i) #f
7840: 29 0a 09 09 09 20 20 20 20 28 6c 61 6d 62 64 61 ).... (lambda
7850: 20 28 69 29 20 23 66 29 29 29 29 29 0a 0a 28 64 (i) #f)))))..(d
7860: 65 66 69 6e 65 20 28 73 74 72 69 6e 67 2d 63 69 efine (string-ci
7870: 3e 20 73 31 20 73 32 20 2e 20 6d 61 79 62 65 2d > s1 s2 . maybe-
7880: 73 74 61 72 74 73 2b 65 6e 64 73 29 0a 20 20 28 starts+ends). (
7890: 6c 65 74 2d 73 74 72 69 6e 67 2d 73 74 61 72 74 let-string-start
78a0: 2b 65 6e 64 32 20 28 73 74 61 72 74 31 20 65 6e +end2 (start1 en
78b0: 64 31 20 73 74 61 72 74 32 20 65 6e 64 32 29 20 d1 start2 end2)
78c0: 0a 09 09 09 20 73 74 72 69 6e 67 2d 63 69 3e 20 .... string-ci>
78d0: 73 31 20 73 32 20 6d 61 79 62 65 2d 73 74 61 72 s1 s2 maybe-star
78e0: 74 73 2b 65 6e 64 73 0a 20 20 20 20 28 69 66 20 ts+ends. (if
78f0: 28 61 6e 64 20 28 65 71 3f 20 73 31 20 73 32 29 (and (eq? s1 s2)
7900: 20 28 3d 20 73 74 61 72 74 31 20 73 74 61 72 74 (= start1 start
7910: 32 29 29 09 09 09 3b 20 46 61 73 74 20 70 61 74 2))...; Fast pat
7920: 68 0a 09 28 3e 20 65 6e 64 31 20 65 6e 64 32 29 h..(> end1 end2)
7930: 0a 0a 09 28 25 73 74 72 69 6e 67 2d 63 6f 6d 70 ...(%string-comp
7940: 61 72 65 2d 63 69 20 73 31 20 73 74 61 72 74 31 are-ci s1 start1
7950: 20 65 6e 64 31 20 73 32 20 73 74 61 72 74 32 20 end1 s2 start2
7960: 65 6e 64 32 09 3b 20 52 65 61 6c 20 74 65 73 74 end2.; Real test
7970: 0a 09 09 09 20 20 20 20 28 6c 61 6d 62 64 61 20 .... (lambda
7980: 28 69 29 20 23 66 29 0a 09 09 09 20 20 20 20 28 (i) #f).... (
7990: 6c 61 6d 62 64 61 20 28 69 29 20 23 66 29 0a 09 lambda (i) #f)..
79a0: 09 09 20 20 20 20 76 61 6c 75 65 73 29 29 29 29 .. values))))
79b0: 0a 0a 28 64 65 66 69 6e 65 20 28 73 74 72 69 6e ..(define (strin
79c0: 67 2d 63 69 3c 3d 20 73 31 20 73 32 20 2e 20 6d g-ci<= s1 s2 . m
79d0: 61 79 62 65 2d 73 74 61 72 74 73 2b 65 6e 64 73 aybe-starts+ends
79e0: 29 0a 20 20 28 6c 65 74 2d 73 74 72 69 6e 67 2d ). (let-string-
79f0: 73 74 61 72 74 2b 65 6e 64 32 20 28 73 74 61 72 start+end2 (star
7a00: 74 31 20 65 6e 64 31 20 73 74 61 72 74 32 20 65 t1 end1 start2 e
7a10: 6e 64 32 29 20 0a 09 09 09 20 73 74 72 69 6e 67 nd2) .... string
7a20: 2d 63 69 3c 3d 20 73 31 20 73 32 20 6d 61 79 62 -ci<= s1 s2 mayb
7a30: 65 2d 73 74 61 72 74 73 2b 65 6e 64 73 0a 20 20 e-starts+ends.
7a40: 20 20 28 69 66 20 28 61 6e 64 20 28 65 71 3f 20 (if (and (eq?
7a50: 73 31 20 73 32 29 20 28 3d 20 73 74 61 72 74 31 s1 s2) (= start1
7a60: 20 73 74 61 72 74 32 29 29 09 09 09 3b 20 46 61 start2))...; Fa
7a70: 73 74 20 70 61 74 68 0a 09 28 3c 3d 20 65 6e 64 st path..(<= end
7a80: 31 20 65 6e 64 32 29 0a 0a 09 28 25 73 74 72 69 1 end2)...(%stri
7a90: 6e 67 2d 63 6f 6d 70 61 72 65 2d 63 69 20 73 31 ng-compare-ci s1
7aa0: 20 73 74 61 72 74 31 20 65 6e 64 31 20 73 32 20 start1 end1 s2
7ab0: 73 74 61 72 74 32 20 65 6e 64 32 09 3b 20 52 65 start2 end2.; Re
7ac0: 61 6c 20 74 65 73 74 0a 09 09 09 20 20 20 20 76 al test.... v
7ad0: 61 6c 75 65 73 0a 09 09 09 20 20 20 20 76 61 6c alues.... val
7ae0: 75 65 73 0a 09 09 09 20 20 20 20 28 6c 61 6d 62 ues.... (lamb
7af0: 64 61 20 28 69 29 20 23 66 29 29 29 29 29 0a 0a da (i) #f)))))..
7b00: 28 64 65 66 69 6e 65 20 28 73 74 72 69 6e 67 2d (define (string-
7b10: 63 69 3e 3d 20 73 31 20 73 32 20 2e 20 6d 61 79 ci>= s1 s2 . may
7b20: 62 65 2d 73 74 61 72 74 73 2b 65 6e 64 73 29 0a be-starts+ends).
7b30: 20 20 28 6c 65 74 2d 73 74 72 69 6e 67 2d 73 74 (let-string-st
7b40: 61 72 74 2b 65 6e 64 32 20 28 73 74 61 72 74 31 art+end2 (start1
7b50: 20 65 6e 64 31 20 73 74 61 72 74 32 20 65 6e 64 end1 start2 end
7b60: 32 29 20 0a 09 09 09 20 73 74 72 69 6e 67 2d 63 2) .... string-c
7b70: 69 3e 3d 20 73 31 20 73 32 20 6d 61 79 62 65 2d i>= s1 s2 maybe-
7b80: 73 74 61 72 74 73 2b 65 6e 64 73 0a 20 20 20 20 starts+ends.
7b90: 28 69 66 20 28 61 6e 64 20 28 65 71 3f 20 73 31 (if (and (eq? s1
7ba0: 20 73 32 29 20 28 3d 20 73 74 61 72 74 31 20 73 s2) (= start1 s
7bb0: 74 61 72 74 32 29 29 09 09 09 3b 20 46 61 73 74 tart2))...; Fast
7bc0: 20 70 61 74 68 0a 09 28 3e 3d 20 65 6e 64 31 20 path..(>= end1
7bd0: 65 6e 64 32 29 0a 0a 09 28 25 73 74 72 69 6e 67 end2)...(%string
7be0: 2d 63 6f 6d 70 61 72 65 2d 63 69 20 73 31 20 73 -compare-ci s1 s
7bf0: 74 61 72 74 31 20 65 6e 64 31 20 73 32 20 73 74 tart1 end1 s2 st
7c00: 61 72 74 32 20 65 6e 64 32 09 3b 20 52 65 61 6c art2 end2.; Real
7c10: 20 74 65 73 74 0a 09 09 09 20 20 20 20 28 6c 61 test.... (la
7c20: 6d 62 64 61 20 28 69 29 20 23 66 29 0a 09 09 09 mbda (i) #f)....
7c30: 20 20 20 20 76 61 6c 75 65 73 0a 09 09 09 20 20 values....
7c40: 20 20 76 61 6c 75 65 73 29 29 29 29 0a 0a 0c 0a values))))....
7c50: 3b 3b 3b 20 48 61 73 68 0a 3b 3b 3b 3b 3b 3b 3b ;;; Hash.;;;;;;;
7c60: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
7c70: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
7c80: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
7c90: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
7ca0: 3b 3b 3b 3b 3b 3b 3b 3b 0a 3b 3b 3b 20 43 6f 6d ;;;;;;;;.;;; Com
7cb0: 70 75 74 65 20 28 63 20 2b 20 33 37 20 63 20 2b pute (c + 37 c +
7cc0: 20 33 37 5e 32 20 63 20 2b 20 2e 2e 2e 29 20 6d 37^2 c + ...) m
7cd0: 6f 64 75 6c 6f 20 42 4f 55 4e 44 2c 20 77 69 74 odulo BOUND, wit
7ce0: 68 20 73 6c 65 61 7a 65 20 74 68 72 6f 77 6e 20 h sleaze thrown
7cf0: 69 6e 0a 3b 3b 3b 20 74 6f 20 6b 65 65 70 20 74 in.;;; to keep t
7d00: 68 65 20 69 6e 74 65 72 6d 65 64 69 61 74 65 20 he intermediate
7d10: 76 61 6c 75 65 73 20 73 6d 61 6c 6c 2e 20 28 57 values small. (W
7d20: 65 20 64 6f 20 74 68 65 20 63 61 6c 63 75 6c 61 e do the calcula
7d30: 74 69 6f 6e 20 77 69 74 68 20 6a 75 73 74 0a 3b tion with just.;
7d40: 3b 3b 20 65 6e 6f 75 67 68 20 62 69 74 73 20 74 ;; enough bits t
7d50: 6f 20 72 65 70 72 65 73 65 6e 74 20 42 4f 55 4e o represent BOUN
7d60: 44 2c 20 6d 61 73 6b 69 6e 67 20 6f 66 66 20 68 D, masking off h
7d70: 69 67 68 20 62 69 74 73 20 61 74 20 65 61 63 68 igh bits at each
7d80: 20 73 74 65 70 20 69 6e 0a 3b 3b 3b 20 63 61 6c step in.;;; cal
7d90: 63 75 6c 61 74 69 6f 6e 2e 20 49 66 20 74 68 69 culation. If thi
7da0: 73 20 73 63 72 65 77 73 20 75 70 20 61 6e 79 20 s screws up any
7db0: 69 6d 70 6f 72 74 61 6e 74 20 70 72 6f 70 65 72 important proper
7dc0: 74 69 65 73 20 6f 66 20 74 68 65 20 68 61 73 68 ties of the hash
7dd0: 0a 3b 3b 3b 20 66 75 6e 63 74 69 6f 6e 20 49 27 .;;; function I'
7de0: 64 20 6c 69 6b 65 20 74 6f 20 68 65 61 72 20 61 d like to hear a
7df0: 62 6f 75 74 20 69 74 2e 20 2d 4f 6c 69 6e 29 0a bout it. -Olin).
7e00: 3b 3b 3b 0a 3b 3b 3b 20 49 66 20 79 6f 75 20 6b ;;;.;;; If you k
7e10: 65 65 70 20 42 4f 55 4e 44 20 73 6d 61 6c 6c 20 eep BOUND small
7e20: 65 6e 6f 75 67 68 2c 20 74 68 65 20 69 6e 74 65 enough, the inte
7e30: 72 6d 65 64 69 61 74 65 20 63 61 6c 63 75 6c 61 rmediate calcula
7e40: 74 69 6f 6e 73 20 77 69 6c 6c 20 0a 3b 3b 3b 20 tions will .;;;
7e50: 61 6c 77 61 79 73 20 62 65 20 66 69 78 6e 75 6d always be fixnum
7e60: 73 2e 20 48 6f 77 20 73 6d 61 6c 6c 20 69 73 20 s. How small is
7e70: 64 65 70 65 6e 64 65 6e 74 20 6f 6e 20 74 68 65 dependent on the
7e80: 20 75 6e 64 65 72 6c 79 69 6e 67 20 53 63 68 65 underlying Sche
7e90: 6d 65 20 73 79 73 74 65 6d 3b 20 0a 3b 3b 3b 20 me system; .;;;
7ea0: 77 65 20 75 73 65 20 61 20 64 65 66 61 75 6c 74 we use a default
7eb0: 20 42 4f 55 4e 44 20 6f 66 20 32 5e 32 32 20 3d BOUND of 2^22 =
7ec0: 20 34 31 39 34 33 30 34 2c 20 77 68 69 63 68 20 4194304, which
7ed0: 73 68 6f 75 6c 64 20 68 61 63 6b 20 69 74 20 69 should hack it i
7ee0: 6e 0a 3b 3b 3b 20 53 63 68 65 6d 65 73 20 74 68 n.;;; Schemes th
7ef0: 61 74 20 67 69 76 65 20 79 6f 75 20 61 74 20 6c at give you at l
7f00: 65 61 73 74 20 32 39 20 73 69 67 6e 65 64 20 62 east 29 signed b
7f10: 69 74 73 20 66 6f 72 20 66 69 78 6e 75 6d 73 2e its for fixnums.
7f20: 20 54 68 65 20 63 6f 72 65 20 0a 3b 3b 3b 20 63 The core .;;; c
7f30: 61 6c 63 75 6c 61 74 69 6f 6e 20 74 68 61 74 20 alculation that
7f40: 79 6f 75 20 64 6f 6e 27 74 20 77 61 6e 74 20 74 you don't want t
7f50: 6f 20 6f 76 65 72 66 6c 6f 77 20 69 73 2c 20 77 o overflow is, w
7f60: 6f 72 73 74 20 63 61 73 65 2c 0a 3b 3b 3b 20 20 orst case,.;;;
7f70: 20 20 20 28 2b 20 36 35 35 33 35 20 28 2a 20 33 (+ 65535 (* 3
7f80: 37 20 28 2d 20 62 6f 75 6e 64 20 31 29 29 29 0a 7 (- bound 1))).
7f90: 3b 3b 3b 20 77 68 65 72 65 20 36 35 35 33 35 20 ;;; where 65535
7fa0: 69 73 20 74 68 65 20 6d 61 78 20 63 68 61 72 61 is the max chara
7fb0: 63 74 65 72 20 63 6f 64 65 2e 20 43 68 6f 6f 73 cter code. Choos
7fc0: 65 20 74 68 65 20 64 65 66 61 75 6c 74 20 42 4f e the default BO
7fd0: 55 4e 44 20 74 6f 20 62 65 20 74 68 65 0a 3b 3b UND to be the.;;
7fe0: 3b 20 62 69 67 67 65 73 74 20 70 6f 77 65 72 20 ; biggest power
7ff0: 6f 66 20 74 77 6f 20 74 68 61 74 20 77 6f 6e 27 of two that won'
8000: 74 20 63 61 75 73 65 20 74 68 69 73 20 65 78 70 t cause this exp
8010: 72 65 73 73 69 6f 6e 20 74 6f 20 66 69 78 6e 75 ression to fixnu
8020: 6d 20 6f 76 65 72 66 6c 6f 77 2c 20 0a 3b 3b 3b m overflow, .;;;
8030: 20 61 6e 64 20 65 76 65 72 79 74 68 69 6e 67 20 and everything
8040: 77 69 6c 6c 20 62 65 20 63 6f 70 61 63 65 74 69 will be copaceti
8050: 63 2e 0a 0a 28 64 65 66 69 6e 65 20 28 25 73 74 c...(define (%st
8060: 72 69 6e 67 2d 68 61 73 68 20 73 20 63 68 61 72 ring-hash s char
8070: 2d 3e 69 6e 74 20 62 6f 75 6e 64 20 73 74 61 72 ->int bound star
8080: 74 20 65 6e 64 29 0a 20 20 28 6c 65 74 20 28 28 t end). (let ((
8090: 69 72 65 66 20 28 6c 61 6d 62 64 61 20 28 73 20 iref (lambda (s
80a0: 69 29 20 28 63 68 61 72 2d 3e 69 6e 74 20 28 73 i) (char->int (s
80b0: 74 72 69 6e 67 2d 72 65 66 20 73 20 69 29 29 29 tring-ref s i)))
80c0: 29 0a 09 3b 3b 20 43 6f 6d 70 75 74 65 20 61 20 )..;; Compute a
80d0: 31 31 31 2e 2e 2e 31 20 6d 61 73 6b 20 74 68 61 111...1 mask tha
80e0: 74 20 77 69 6c 6c 20 63 6f 76 65 72 20 42 4f 55 t will cover BOU
80f0: 4e 44 2d 31 3a 0a 09 28 6d 61 73 6b 20 28 6c 65 ND-1:..(mask (le
8100: 74 20 6c 70 20 28 28 69 20 23 78 31 30 30 30 30 t lp ((i #x10000
8110: 29 29 20 3b 20 4c 65 74 27 73 20 73 6b 69 70 20 )) ; Let's skip
8120: 66 69 72 73 74 20 31 36 20 69 74 65 72 61 74 69 first 16 iterati
8130: 6f 6e 73 2c 20 65 68 3f 0a 09 09 28 69 66 20 28 ons, eh?...(if (
8140: 3e 3d 20 69 20 62 6f 75 6e 64 29 20 28 2d 20 69 >= i bound) (- i
8150: 20 31 29 20 28 6c 70 20 28 2b 20 69 20 69 29 29 1) (lp (+ i i))
8160: 29 29 29 29 0a 20 20 20 20 28 6c 65 74 20 6c 70 )))). (let lp
8170: 20 28 28 69 20 73 74 61 72 74 29 20 28 61 6e 73 ((i start) (ans
8180: 20 30 29 29 0a 20 20 20 20 20 20 28 69 66 20 28 0)). (if (
8190: 3e 3d 20 69 20 65 6e 64 29 20 28 6d 6f 64 75 6c >= i end) (modul
81a0: 6f 20 61 6e 73 20 62 6f 75 6e 64 29 0a 09 20 20 o ans bound)..
81b0: 28 6c 70 20 28 2b 20 69 20 31 29 20 28 62 69 74 (lp (+ i 1) (bit
81c0: 77 69 73 65 2d 61 6e 64 20 6d 61 73 6b 20 28 2b wise-and mask (+
81d0: 20 28 2a 20 33 37 20 61 6e 73 29 20 28 69 72 65 (* 37 ans) (ire
81e0: 66 20 73 20 69 29 29 29 29 29 29 29 29 0a 0a 28 f s i))))))))..(
81f0: 64 65 66 69 6e 65 20 28 73 74 72 69 6e 67 2d 68 define (string-h
8200: 61 73 68 20 73 20 2e 20 6d 61 79 62 65 2d 62 6f ash s . maybe-bo
8210: 75 6e 64 2b 73 74 61 72 74 2b 65 6e 64 29 0a 20 und+start+end).
8220: 20 28 6c 65 74 2d 6f 70 74 69 6f 6e 61 6c 73 2a (let-optionals*
8230: 20 6d 61 79 62 65 2d 62 6f 75 6e 64 2b 73 74 61 maybe-bound+sta
8240: 72 74 2b 65 6e 64 20 28 28 62 6f 75 6e 64 20 34 rt+end ((bound 4
8250: 31 39 34 33 30 34 20 28 61 6e 64 20 28 69 6e 74 194304 (and (int
8260: 65 67 65 72 3f 20 62 6f 75 6e 64 29 0a 09 09 09 eger? bound)....
8270: 09 09 09 09 20 20 20 20 20 28 65 78 61 63 74 3f .... (exact?
8280: 20 62 6f 75 6e 64 29 0a 09 09 09 09 09 09 09 20 bound)........
8290: 20 20 20 20 28 3c 3d 20 30 20 62 6f 75 6e 64 29 (<= 0 bound)
82a0: 29 29 0a 09 09 09 09 09 20 72 65 73 74 29 0a 20 ))...... rest).
82b0: 20 20 20 28 6c 65 74 20 28 28 62 6f 75 6e 64 20 (let ((bound
82c0: 28 69 66 20 28 7a 65 72 6f 3f 20 62 6f 75 6e 64 (if (zero? bound
82d0: 29 20 34 31 39 34 33 30 34 20 62 6f 75 6e 64 29 ) 4194304 bound)
82e0: 29 29 09 3b 20 30 20 6d 65 61 6e 73 20 64 65 66 )).; 0 means def
82f0: 61 75 6c 74 2e 0a 20 20 20 20 20 20 28 6c 65 74 ault.. (let
8300: 2d 73 74 72 69 6e 67 2d 73 74 61 72 74 2b 65 6e -string-start+en
8310: 64 20 28 73 74 61 72 74 20 65 6e 64 29 20 73 74 d (start end) st
8320: 72 69 6e 67 2d 68 61 73 68 20 73 20 72 65 73 74 ring-hash s rest
8330: 0a 20 20 20 20 20 20 20 20 28 25 73 74 72 69 6e . (%strin
8340: 67 2d 68 61 73 68 20 73 20 63 68 61 72 2d 3e 69 g-hash s char->i
8350: 6e 74 65 67 65 72 20 62 6f 75 6e 64 20 73 74 61 nteger bound sta
8360: 72 74 20 65 6e 64 29 29 29 29 29 0a 0a 28 64 65 rt end)))))..(de
8370: 66 69 6e 65 20 28 73 74 72 69 6e 67 2d 68 61 73 fine (string-has
8380: 68 2d 63 69 20 73 20 2e 20 6d 61 79 62 65 2d 62 h-ci s . maybe-b
8390: 6f 75 6e 64 2b 73 74 61 72 74 2b 65 6e 64 29 0a ound+start+end).
83a0: 20 20 28 6c 65 74 2d 6f 70 74 69 6f 6e 61 6c 73 (let-optionals
83b0: 2a 20 6d 61 79 62 65 2d 62 6f 75 6e 64 2b 73 74 * maybe-bound+st
83c0: 61 72 74 2b 65 6e 64 20 28 28 62 6f 75 6e 64 20 art+end ((bound
83d0: 34 31 39 34 33 30 34 20 28 61 6e 64 20 28 69 6e 4194304 (and (in
83e0: 74 65 67 65 72 3f 20 62 6f 75 6e 64 29 0a 09 09 teger? bound)...
83f0: 09 09 09 09 09 20 20 20 20 20 28 65 78 61 63 74 ..... (exact
8400: 3f 20 62 6f 75 6e 64 29 0a 09 09 09 09 09 09 09 ? bound)........
8410: 20 20 20 20 20 28 3c 3d 20 30 20 62 6f 75 6e 64 (<= 0 bound
8420: 29 29 29 0a 09 09 09 09 09 20 72 65 73 74 29 0a )))...... rest).
8430: 20 20 20 20 28 6c 65 74 20 28 28 62 6f 75 6e 64 (let ((bound
8440: 20 28 69 66 20 28 7a 65 72 6f 3f 20 62 6f 75 6e (if (zero? boun
8450: 64 29 20 34 31 39 34 33 30 34 20 62 6f 75 6e 64 d) 4194304 bound
8460: 29 29 29 09 3b 20 30 20 6d 65 61 6e 73 20 64 65 ))).; 0 means de
8470: 66 61 75 6c 74 2e 0a 20 20 20 20 20 20 28 6c 65 fault.. (le
8480: 74 2d 73 74 72 69 6e 67 2d 73 74 61 72 74 2b 65 t-string-start+e
8490: 6e 64 20 28 73 74 61 72 74 20 65 6e 64 29 20 73 nd (start end) s
84a0: 74 72 69 6e 67 2d 68 61 73 68 2d 63 69 20 73 20 tring-hash-ci s
84b0: 72 65 73 74 0a 20 20 20 20 20 20 20 20 28 25 73 rest. (%s
84c0: 74 72 69 6e 67 2d 68 61 73 68 20 73 20 28 6c 61 tring-hash s (la
84d0: 6d 62 64 61 20 28 63 29 20 28 63 68 61 72 2d 3e mbda (c) (char->
84e0: 69 6e 74 65 67 65 72 20 28 63 68 61 72 2d 64 6f integer (char-do
84f0: 77 6e 63 61 73 65 20 63 29 29 29 0a 09 09 20 20 wncase c)))...
8500: 20 20 20 20 62 6f 75 6e 64 20 73 74 61 72 74 20 bound start
8510: 65 6e 64 29 29 29 29 29 0a 0a 3b 3b 3b 20 43 61 end)))))..;;; Ca
8520: 73 65 20 68 61 63 6b 69 6e 67 0a 3b 3b 3b 3b 3b se hacking.;;;;;
8530: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
8540: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
8550: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
8560: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
8570: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 0a 3b 3b 3b 20 73 ;;;;;;;;;;.;;; s
8580: 74 72 69 6e 67 2d 75 70 63 61 73 65 20 20 73 20 tring-upcase s
8590: 5b 73 74 61 72 74 20 65 6e 64 5d 0a 3b 3b 3b 20 [start end].;;;
85a0: 73 74 72 69 6e 67 2d 75 70 63 61 73 65 21 20 73 string-upcase! s
85b0: 20 5b 73 74 61 72 74 20 65 6e 64 5d 0a 3b 3b 3b [start end].;;;
85c0: 20 73 74 72 69 6e 67 2d 64 6f 77 6e 63 61 73 65 string-downcase
85d0: 20 20 73 20 5b 73 74 61 72 74 20 65 6e 64 5d 0a s [start end].
85e0: 3b 3b 3b 20 73 74 72 69 6e 67 2d 64 6f 77 6e 63 ;;; string-downc
85f0: 61 73 65 21 20 73 20 5b 73 74 61 72 74 20 65 6e ase! s [start en
8600: 64 5d 0a 3b 3b 3b 0a 3b 3b 3b 20 73 74 72 69 6e d].;;;.;;; strin
8610: 67 2d 74 69 74 6c 65 63 61 73 65 20 20 73 20 5b g-titlecase s [
8620: 73 74 61 72 74 20 65 6e 64 5d 0a 3b 3b 3b 20 73 start end].;;; s
8630: 74 72 69 6e 67 2d 74 69 74 6c 65 63 61 73 65 21 tring-titlecase!
8640: 20 73 20 5b 73 74 61 72 74 20 65 6e 64 5d 0a 3b s [start end].;
8650: 3b 3b 20 20 20 43 61 70 69 74 61 6c 69 7a 65 20 ;; Capitalize
8660: 65 76 65 72 79 20 63 6f 6e 74 69 67 75 6f 75 73 every contiguous
8670: 20 61 6c 70 68 61 20 73 65 71 75 65 6e 63 65 3a alpha sequence:
8680: 20 63 61 70 69 74 61 6c 69 73 65 0a 3b 3b 3b 20 capitalise.;;;
8690: 20 20 66 69 72 73 74 20 63 68 61 72 2c 20 6c 6f first char, lo
86a0: 77 65 72 63 61 73 65 20 72 65 73 74 2e 0a 0a 28 wercase rest...(
86b0: 64 65 66 69 6e 65 20 28 73 74 72 69 6e 67 2d 75 define (string-u
86c0: 70 63 61 73 65 20 20 73 20 2e 20 6d 61 79 62 65 pcase s . maybe
86d0: 2d 73 74 61 72 74 2b 65 6e 64 29 0a 20 20 28 6c -start+end). (l
86e0: 65 74 2d 73 74 72 69 6e 67 2d 73 74 61 72 74 2b et-string-start+
86f0: 65 6e 64 20 28 73 74 61 72 74 20 65 6e 64 29 20 end (start end)
8700: 73 74 72 69 6e 67 2d 75 70 63 61 73 65 20 73 20 string-upcase s
8710: 6d 61 79 62 65 2d 73 74 61 72 74 2b 65 6e 64 0a maybe-start+end.
8720: 20 20 20 20 28 25 73 74 72 69 6e 67 2d 6d 61 70 (%string-map
8730: 20 63 68 61 72 2d 75 70 63 61 73 65 20 73 20 73 char-upcase s s
8740: 74 61 72 74 20 65 6e 64 29 29 29 0a 0a 28 64 65 tart end)))..(de
8750: 66 69 6e 65 20 28 73 74 72 69 6e 67 2d 75 70 63 fine (string-upc
8760: 61 73 65 21 20 73 20 2e 20 6d 61 79 62 65 2d 73 ase! s . maybe-s
8770: 74 61 72 74 2b 65 6e 64 29 0a 20 20 28 6c 65 74 tart+end). (let
8780: 2d 73 74 72 69 6e 67 2d 73 74 61 72 74 2b 65 6e -string-start+en
8790: 64 20 28 73 74 61 72 74 20 65 6e 64 29 20 73 74 d (start end) st
87a0: 72 69 6e 67 2d 75 70 63 61 73 65 21 20 73 20 6d ring-upcase! s m
87b0: 61 79 62 65 2d 73 74 61 72 74 2b 65 6e 64 0a 20 aybe-start+end.
87c0: 20 20 20 28 25 73 74 72 69 6e 67 2d 6d 61 70 21 (%string-map!
87d0: 20 63 68 61 72 2d 75 70 63 61 73 65 20 73 20 73 char-upcase s s
87e0: 74 61 72 74 20 65 6e 64 29 29 29 0a 0a 28 64 65 tart end)))..(de
87f0: 66 69 6e 65 20 28 73 74 72 69 6e 67 2d 64 6f 77 fine (string-dow
8800: 6e 63 61 73 65 20 20 73 20 2e 20 6d 61 79 62 65 ncase s . maybe
8810: 2d 73 74 61 72 74 2b 65 6e 64 29 0a 20 20 28 6c -start+end). (l
8820: 65 74 2d 73 74 72 69 6e 67 2d 73 74 61 72 74 2b et-string-start+
8830: 65 6e 64 20 28 73 74 61 72 74 20 65 6e 64 29 20 end (start end)
8840: 73 74 72 69 6e 67 2d 64 6f 77 6e 63 61 73 65 20 string-downcase
8850: 73 20 6d 61 79 62 65 2d 73 74 61 72 74 2b 65 6e s maybe-start+en
8860: 64 0a 20 20 20 20 28 25 73 74 72 69 6e 67 2d 6d d. (%string-m
8870: 61 70 20 63 68 61 72 2d 64 6f 77 6e 63 61 73 65 ap char-downcase
8880: 20 73 20 73 74 61 72 74 20 65 6e 64 29 29 29 0a s start end))).
8890: 0a 28 64 65 66 69 6e 65 20 28 73 74 72 69 6e 67 .(define (string
88a0: 2d 64 6f 77 6e 63 61 73 65 21 20 73 20 2e 20 6d -downcase! s . m
88b0: 61 79 62 65 2d 73 74 61 72 74 2b 65 6e 64 29 0a aybe-start+end).
88c0: 20 20 28 6c 65 74 2d 73 74 72 69 6e 67 2d 73 74 (let-string-st
88d0: 61 72 74 2b 65 6e 64 20 28 73 74 61 72 74 20 65 art+end (start e
88e0: 6e 64 29 20 73 74 72 69 6e 67 2d 64 6f 77 6e 63 nd) string-downc
88f0: 61 73 65 21 20 73 20 6d 61 79 62 65 2d 73 74 61 ase! s maybe-sta
8900: 72 74 2b 65 6e 64 0a 20 20 20 20 28 25 73 74 72 rt+end. (%str
8910: 69 6e 67 2d 6d 61 70 21 20 63 68 61 72 2d 64 6f ing-map! char-do
8920: 77 6e 63 61 73 65 20 73 20 73 74 61 72 74 20 65 wncase s start e
8930: 6e 64 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 nd)))..(define (
8940: 25 73 74 72 69 6e 67 2d 74 69 74 6c 65 63 61 73 %string-titlecas
8950: 65 21 20 73 20 73 74 61 72 74 20 65 6e 64 29 0a e! s start end).
8960: 20 20 28 6c 65 74 20 6c 70 20 28 28 69 20 73 74 (let lp ((i st
8970: 61 72 74 29 29 0a 20 20 20 20 28 63 6f 6e 64 20 art)). (cond
8980: 28 28 73 74 72 69 6e 67 2d 69 6e 64 65 78 20 73 ((string-index s
8990: 20 63 68 61 72 2d 63 61 73 65 64 3f 20 69 20 65 char-cased? i e
89a0: 6e 64 29 20 3d 3e 0a 20 20 20 20 20 20 20 20 20 nd) =>.
89b0: 20 20 28 6c 61 6d 62 64 61 20 28 69 29 0a 09 20 (lambda (i)..
89c0: 20 20 20 20 28 73 74 72 69 6e 67 2d 73 65 74 21 (string-set!
89d0: 20 73 20 69 20 28 63 68 61 72 2d 74 69 74 6c 65 s i (char-title
89e0: 63 61 73 65 20 28 73 74 72 69 6e 67 2d 72 65 66 case (string-ref
89f0: 20 73 20 69 29 29 29 0a 09 20 20 20 20 20 28 6c s i))).. (l
8a00: 65 74 20 28 28 69 31 20 28 2b 20 69 20 31 29 29 et ((i1 (+ i 1))
8a10: 29 0a 09 20 20 20 20 20 20 20 28 63 6f 6e 64 20 ).. (cond
8a20: 28 28 73 74 72 69 6e 67 2d 73 6b 69 70 20 73 20 ((string-skip s
8a30: 63 68 61 72 2d 63 61 73 65 64 3f 20 69 31 20 65 char-cased? i1 e
8a40: 6e 64 29 20 3d 3e 0a 09 09 20 20 20 20 20 20 28 nd) =>... (
8a50: 6c 61 6d 62 64 61 20 28 6a 29 0a 09 09 09 28 73 lambda (j)....(s
8a60: 74 72 69 6e 67 2d 64 6f 77 6e 63 61 73 65 21 20 tring-downcase!
8a70: 73 20 69 31 20 6a 29 0a 09 09 09 28 6c 70 20 28 s i1 j)....(lp (
8a80: 2b 20 6a 20 31 29 29 29 29 0a 09 09 20 20 20 20 + j 1))))...
8a90: 20 28 65 6c 73 65 20 28 73 74 72 69 6e 67 2d 64 (else (string-d
8aa0: 6f 77 6e 63 61 73 65 21 20 73 20 69 31 20 65 6e owncase! s i1 en
8ab0: 64 29 29 29 29 29 29 29 29 29 0a 0a 28 64 65 66 d)))))))))..(def
8ac0: 69 6e 65 20 28 73 74 72 69 6e 67 2d 74 69 74 6c ine (string-titl
8ad0: 65 63 61 73 65 21 20 73 20 2e 20 6d 61 79 62 65 ecase! s . maybe
8ae0: 2d 73 74 61 72 74 2b 65 6e 64 29 0a 20 20 28 6c -start+end). (l
8af0: 65 74 2d 73 74 72 69 6e 67 2d 73 74 61 72 74 2b et-string-start+
8b00: 65 6e 64 20 28 73 74 61 72 74 20 65 6e 64 29 20 end (start end)
8b10: 73 74 72 69 6e 67 2d 74 69 74 6c 65 63 61 73 65 string-titlecase
8b20: 21 20 73 20 6d 61 79 62 65 2d 73 74 61 72 74 2b ! s maybe-start+
8b30: 65 6e 64 0a 20 20 20 20 28 25 73 74 72 69 6e 67 end. (%string
8b40: 2d 74 69 74 6c 65 63 61 73 65 21 20 73 20 73 74 -titlecase! s st
8b50: 61 72 74 20 65 6e 64 29 29 29 0a 0a 28 64 65 66 art end)))..(def
8b60: 69 6e 65 20 28 73 74 72 69 6e 67 2d 74 69 74 6c ine (string-titl
8b70: 65 63 61 73 65 20 73 20 2e 20 6d 61 79 62 65 2d ecase s . maybe-
8b80: 73 74 61 72 74 2b 65 6e 64 29 0a 20 20 28 6c 65 start+end). (le
8b90: 74 2d 73 74 72 69 6e 67 2d 73 74 61 72 74 2b 65 t-string-start+e
8ba0: 6e 64 20 28 73 74 61 72 74 20 65 6e 64 29 20 73 nd (start end) s
8bb0: 74 72 69 6e 67 2d 74 69 74 6c 65 63 61 73 65 21 tring-titlecase!
8bc0: 20 73 20 6d 61 79 62 65 2d 73 74 61 72 74 2b 65 s maybe-start+e
8bd0: 6e 64 0a 20 20 20 20 28 6c 65 74 20 28 28 61 6e nd. (let ((an
8be0: 73 20 28 73 75 62 73 74 72 69 6e 67 20 73 20 73 s (substring s s
8bf0: 74 61 72 74 20 65 6e 64 29 29 29 0a 20 20 20 20 tart end))).
8c00: 20 20 28 25 73 74 72 69 6e 67 2d 74 69 74 6c 65 (%string-title
8c10: 63 61 73 65 21 20 61 6e 73 20 30 20 28 2d 20 65 case! ans 0 (- e
8c20: 6e 64 20 73 74 61 72 74 29 29 0a 20 20 20 20 20 nd start)).
8c30: 20 61 6e 73 29 29 29 0a 0a 0c 0a 3b 3b 3b 20 43 ans)))....;;; C
8c40: 75 74 74 69 6e 67 20 26 20 70 61 73 74 69 6e 67 utting & pasting
8c50: 20 73 74 72 69 6e 67 73 0a 3b 3b 3b 3b 3b 3b 3b strings.;;;;;;;
8c60: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
8c70: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
8c80: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
8c90: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
8ca0: 3b 3b 3b 3b 3b 3b 3b 3b 0a 3b 3b 3b 20 73 74 72 ;;;;;;;;.;;; str
8cb0: 69 6e 67 2d 74 61 6b 65 20 73 74 72 69 6e 67 20 ing-take string
8cc0: 6e 63 68 61 72 73 0a 3b 3b 3b 20 73 74 72 69 6e nchars.;;; strin
8cd0: 67 2d 64 72 6f 70 20 73 74 72 69 6e 67 20 6e 63 g-drop string nc
8ce0: 68 61 72 73 0a 3b 3b 3b 0a 3b 3b 3b 20 73 74 72 hars.;;;.;;; str
8cf0: 69 6e 67 2d 74 61 6b 65 2d 72 69 67 68 74 20 73 ing-take-right s
8d00: 74 72 69 6e 67 20 6e 63 68 61 72 73 0a 3b 3b 3b tring nchars.;;;
8d10: 20 73 74 72 69 6e 67 2d 64 72 6f 70 2d 72 69 67 string-drop-rig
8d20: 68 74 20 73 74 72 69 6e 67 20 6e 63 68 61 72 73 ht string nchars
8d30: 0a 3b 3b 3b 0a 3b 3b 3b 20 73 74 72 69 6e 67 2d .;;;.;;; string-
8d40: 70 61 64 20 73 74 72 69 6e 67 20 6b 20 5b 63 68 pad string k [ch
8d50: 61 72 20 73 74 61 72 74 20 65 6e 64 5d 20 0a 3b ar start end] .;
8d60: 3b 3b 20 73 74 72 69 6e 67 2d 70 61 64 2d 72 69 ;; string-pad-ri
8d70: 67 68 74 20 73 74 72 69 6e 67 20 6b 20 5b 63 68 ght string k [ch
8d80: 61 72 20 73 74 61 72 74 20 65 6e 64 5d 20 0a 3b ar start end] .;
8d90: 3b 3b 20 0a 3b 3b 3b 20 73 74 72 69 6e 67 2d 74 ;; .;;; string-t
8da0: 72 69 6d 20 20 20 20 20 20 20 73 74 72 69 6e 67 rim string
8db0: 20 5b 63 68 61 72 2f 63 68 61 72 2d 73 65 74 2f [char/char-set/
8dc0: 70 72 65 64 20 73 74 61 72 74 20 65 6e 64 5d 20 pred start end]
8dd0: 0a 3b 3b 3b 20 73 74 72 69 6e 67 2d 74 72 69 6d .;;; string-trim
8de0: 2d 72 69 67 68 74 20 73 74 72 69 6e 67 20 5b 63 -right string [c
8df0: 68 61 72 2f 63 68 61 72 2d 73 65 74 2f 70 72 65 har/char-set/pre
8e00: 64 20 73 74 61 72 74 20 65 6e 64 5d 20 0a 3b 3b d start end] .;;
8e10: 3b 20 73 74 72 69 6e 67 2d 74 72 69 6d 2d 62 6f ; string-trim-bo
8e20: 74 68 20 20 73 74 72 69 6e 67 20 5b 63 68 61 72 th string [char
8e30: 2f 63 68 61 72 2d 73 65 74 2f 70 72 65 64 20 73 /char-set/pred s
8e40: 74 61 72 74 20 65 6e 64 5d 20 0a 3b 3b 3b 0a 3b tart end] .;;;.;
8e50: 3b 3b 20 54 68 65 73 65 20 74 72 69 6d 6d 65 72 ;; These trimmer
8e60: 73 20 69 6e 76 65 72 74 20 74 68 65 20 63 68 61 s invert the cha
8e70: 72 2d 73 65 74 20 6d 65 61 6e 69 6e 67 20 66 72 r-set meaning fr
8e80: 6f 6d 20 4d 49 54 20 53 63 68 65 6d 65 20 2d 2d om MIT Scheme --
8e90: 20 79 6f 75 0a 3b 3b 3b 20 73 61 79 20 77 68 61 you.;;; say wha
8ea0: 74 20 79 6f 75 20 77 61 6e 74 20 74 6f 20 74 72 t you want to tr
8eb0: 69 6d 2e 0a 0a 28 64 65 66 69 6e 65 20 28 73 74 im...(define (st
8ec0: 72 69 6e 67 2d 74 61 6b 65 20 73 20 6e 29 0a 20 ring-take s n).
8ed0: 20 28 63 68 65 63 6b 2d 61 72 67 20 73 74 72 69 (check-arg stri
8ee0: 6e 67 3f 20 73 20 73 74 72 69 6e 67 2d 74 61 6b ng? s string-tak
8ef0: 65 29 0a 20 20 28 63 68 65 63 6b 2d 61 72 67 20 e). (check-arg
8f00: 28 6c 61 6d 62 64 61 20 28 76 61 6c 29 20 28 61 (lambda (val) (a
8f10: 6e 64 20 28 69 6e 74 65 67 65 72 3f 20 6e 29 20 nd (integer? n)
8f20: 28 65 78 61 63 74 3f 20 6e 29 0a 09 09 09 09 28 (exact? n).....(
8f30: 3c 3d 20 30 20 6e 20 28 73 74 72 69 6e 67 2d 6c <= 0 n (string-l
8f40: 65 6e 67 74 68 20 73 29 29 29 29 0a 09 20 20 20 ength s))))..
8f50: 20 20 6e 20 73 74 72 69 6e 67 2d 74 61 6b 65 29 n string-take)
8f60: 0a 20 20 28 25 73 75 62 73 74 72 69 6e 67 2f 73 . (%substring/s
8f70: 68 61 72 65 64 20 73 20 30 20 6e 29 29 0a 0a 28 hared s 0 n))..(
8f80: 64 65 66 69 6e 65 20 28 73 74 72 69 6e 67 2d 74 define (string-t
8f90: 61 6b 65 2d 72 69 67 68 74 20 73 20 6e 29 0a 20 ake-right s n).
8fa0: 20 28 63 68 65 63 6b 2d 61 72 67 20 73 74 72 69 (check-arg stri
8fb0: 6e 67 3f 20 73 20 73 74 72 69 6e 67 2d 74 61 6b ng? s string-tak
8fc0: 65 2d 72 69 67 68 74 29 0a 20 20 28 6c 65 74 20 e-right). (let
8fd0: 28 28 6c 65 6e 20 28 73 74 72 69 6e 67 2d 6c 65 ((len (string-le
8fe0: 6e 67 74 68 20 73 29 29 29 0a 20 20 20 20 28 63 ngth s))). (c
8ff0: 68 65 63 6b 2d 61 72 67 20 28 6c 61 6d 62 64 61 heck-arg (lambda
9000: 20 28 76 61 6c 29 20 28 61 6e 64 20 28 69 6e 74 (val) (and (int
9010: 65 67 65 72 3f 20 6e 29 20 28 65 78 61 63 74 3f eger? n) (exact?
9020: 20 6e 29 20 28 3c 3d 20 30 20 6e 20 6c 65 6e 29 n) (<= 0 n len)
9030: 29 29 0a 09 20 20 20 20 20 20 20 6e 20 73 74 72 )).. n str
9040: 69 6e 67 2d 74 61 6b 65 2d 72 69 67 68 74 29 0a ing-take-right).
9050: 20 20 20 20 28 25 73 75 62 73 74 72 69 6e 67 2f (%substring/
9060: 73 68 61 72 65 64 20 73 20 28 2d 20 6c 65 6e 20 shared s (- len
9070: 6e 29 20 6c 65 6e 29 29 29 0a 0a 28 64 65 66 69 n) len)))..(defi
9080: 6e 65 20 28 73 74 72 69 6e 67 2d 64 72 6f 70 20 ne (string-drop
9090: 73 20 6e 29 0a 20 20 28 63 68 65 63 6b 2d 61 72 s n). (check-ar
90a0: 67 20 73 74 72 69 6e 67 3f 20 73 20 73 74 72 69 g string? s stri
90b0: 6e 67 2d 64 72 6f 70 29 0a 20 20 28 6c 65 74 20 ng-drop). (let
90c0: 28 28 6c 65 6e 20 28 73 74 72 69 6e 67 2d 6c 65 ((len (string-le
90d0: 6e 67 74 68 20 73 29 29 29 0a 20 20 20 20 28 63 ngth s))). (c
90e0: 68 65 63 6b 2d 61 72 67 20 28 6c 61 6d 62 64 61 heck-arg (lambda
90f0: 20 28 76 61 6c 29 20 28 61 6e 64 20 28 69 6e 74 (val) (and (int
9100: 65 67 65 72 3f 20 6e 29 20 28 65 78 61 63 74 3f eger? n) (exact?
9110: 20 6e 29 20 28 3c 3d 20 30 20 6e 20 6c 65 6e 29 n) (<= 0 n len)
9120: 29 29 0a 09 20 20 20 20 20 20 20 6e 20 73 74 72 )).. n str
9130: 69 6e 67 2d 64 72 6f 70 29 0a 20 20 28 25 73 75 ing-drop). (%su
9140: 62 73 74 72 69 6e 67 2f 73 68 61 72 65 64 20 73 bstring/shared s
9150: 20 6e 20 6c 65 6e 29 29 29 0a 0a 28 64 65 66 69 n len)))..(defi
9160: 6e 65 20 28 73 74 72 69 6e 67 2d 64 72 6f 70 2d ne (string-drop-
9170: 72 69 67 68 74 20 73 20 6e 29 0a 20 20 28 63 68 right s n). (ch
9180: 65 63 6b 2d 61 72 67 20 73 74 72 69 6e 67 3f 20 eck-arg string?
9190: 73 20 73 74 72 69 6e 67 2d 64 72 6f 70 2d 72 69 s string-drop-ri
91a0: 67 68 74 29 0a 20 20 28 6c 65 74 20 28 28 6c 65 ght). (let ((le
91b0: 6e 20 28 73 74 72 69 6e 67 2d 6c 65 6e 67 74 68 n (string-length
91c0: 20 73 29 29 29 0a 20 20 20 20 28 63 68 65 63 6b s))). (check
91d0: 2d 61 72 67 20 28 6c 61 6d 62 64 61 20 28 76 61 -arg (lambda (va
91e0: 6c 29 20 28 61 6e 64 20 28 69 6e 74 65 67 65 72 l) (and (integer
91f0: 3f 20 6e 29 20 28 65 78 61 63 74 3f 20 6e 29 20 ? n) (exact? n)
9200: 28 3c 3d 20 30 20 6e 20 6c 65 6e 29 29 29 0a 09 (<= 0 n len)))..
9210: 20 20 20 20 20 20 20 6e 20 73 74 72 69 6e 67 2d n string-
9220: 64 72 6f 70 2d 72 69 67 68 74 29 0a 20 20 20 20 drop-right).
9230: 28 25 73 75 62 73 74 72 69 6e 67 2f 73 68 61 72 (%substring/shar
9240: 65 64 20 73 20 30 20 28 2d 20 6c 65 6e 20 6e 29 ed s 0 (- len n)
9250: 29 29 29 0a 0a 0a 28 64 65 66 69 6e 65 20 28 73 )))...(define (s
9260: 74 72 69 6e 67 2d 74 72 69 6d 20 73 20 2e 20 63 tring-trim s . c
9270: 72 69 74 65 72 69 6f 6e 2b 73 74 61 72 74 2b 65 riterion+start+e
9280: 6e 64 29 0a 20 20 28 6c 65 74 2d 6f 70 74 69 6f nd). (let-optio
9290: 6e 61 6c 73 2a 20 63 72 69 74 65 72 69 6f 6e 2b nals* criterion+
92a0: 73 74 61 72 74 2b 65 6e 64 20 28 28 63 72 69 74 start+end ((crit
92b0: 65 72 69 6f 6e 20 63 68 61 72 2d 73 65 74 3a 77 erion char-set:w
92c0: 68 69 74 65 73 70 61 63 65 29 20 72 65 73 74 29 hitespace) rest)
92d0: 0a 20 20 20 20 28 6c 65 74 2d 73 74 72 69 6e 67 . (let-string
92e0: 2d 73 74 61 72 74 2b 65 6e 64 20 28 73 74 61 72 -start+end (star
92f0: 74 20 65 6e 64 29 20 73 74 72 69 6e 67 2d 74 72 t end) string-tr
9300: 69 6d 20 73 20 72 65 73 74 0a 20 20 20 20 20 20 im s rest.
9310: 28 63 6f 6e 64 20 28 28 73 74 72 69 6e 67 2d 73 (cond ((string-s
9320: 6b 69 70 20 73 20 63 72 69 74 65 72 69 6f 6e 20 kip s criterion
9330: 73 74 61 72 74 20 65 6e 64 29 20 3d 3e 0a 09 20 start end) =>..
9340: 20 20 20 20 28 6c 61 6d 62 64 61 20 28 69 29 20 (lambda (i)
9350: 28 25 73 75 62 73 74 72 69 6e 67 2f 73 68 61 72 (%substring/shar
9360: 65 64 20 73 20 69 20 65 6e 64 29 29 29 0a 09 20 ed s i end)))..
9370: 20 20 20 28 65 6c 73 65 20 22 22 29 29 29 29 29 (else "")))))
9380: 0a 0a 28 64 65 66 69 6e 65 20 28 73 74 72 69 6e ..(define (strin
9390: 67 2d 74 72 69 6d 2d 72 69 67 68 74 20 73 20 2e g-trim-right s .
93a0: 20 63 72 69 74 65 72 69 6f 6e 2b 73 74 61 72 74 criterion+start
93b0: 2b 65 6e 64 29 0a 20 20 28 6c 65 74 2d 6f 70 74 +end). (let-opt
93c0: 69 6f 6e 61 6c 73 2a 20 63 72 69 74 65 72 69 6f ionals* criterio
93d0: 6e 2b 73 74 61 72 74 2b 65 6e 64 20 28 28 63 72 n+start+end ((cr
93e0: 69 74 65 72 69 6f 6e 20 63 68 61 72 2d 73 65 74 iterion char-set
93f0: 3a 77 68 69 74 65 73 70 61 63 65 29 20 72 65 73 :whitespace) res
9400: 74 29 0a 20 20 20 20 28 6c 65 74 2d 73 74 72 69 t). (let-stri
9410: 6e 67 2d 73 74 61 72 74 2b 65 6e 64 20 28 73 74 ng-start+end (st
9420: 61 72 74 20 65 6e 64 29 20 73 74 72 69 6e 67 2d art end) string-
9430: 74 72 69 6d 2d 72 69 67 68 74 20 73 20 72 65 73 trim-right s res
9440: 74 0a 20 20 20 20 20 20 28 63 6f 6e 64 20 28 28 t. (cond ((
9450: 73 74 72 69 6e 67 2d 73 6b 69 70 2d 72 69 67 68 string-skip-righ
9460: 74 20 73 20 63 72 69 74 65 72 69 6f 6e 20 73 74 t s criterion st
9470: 61 72 74 20 65 6e 64 29 20 3d 3e 0a 09 20 20 20 art end) =>..
9480: 20 20 28 6c 61 6d 62 64 61 20 28 69 29 20 28 25 (lambda (i) (%
9490: 73 75 62 73 74 72 69 6e 67 2f 73 68 61 72 65 64 substring/shared
94a0: 20 73 20 30 20 28 2b 20 31 20 69 29 29 29 29 0a s 0 (+ 1 i)))).
94b0: 09 20 20 20 20 28 65 6c 73 65 20 22 22 29 29 29 . (else "")))
94c0: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 74 72 ))..(define (str
94d0: 69 6e 67 2d 74 72 69 6d 2d 62 6f 74 68 20 73 20 ing-trim-both s
94e0: 2e 20 63 72 69 74 65 72 69 6f 6e 2b 73 74 61 72 . criterion+star
94f0: 74 2b 65 6e 64 29 0a 20 20 28 6c 65 74 2d 6f 70 t+end). (let-op
9500: 74 69 6f 6e 61 6c 73 2a 20 63 72 69 74 65 72 69 tionals* criteri
9510: 6f 6e 2b 73 74 61 72 74 2b 65 6e 64 20 28 28 63 on+start+end ((c
9520: 72 69 74 65 72 69 6f 6e 20 63 68 61 72 2d 73 65 riterion char-se
9530: 74 3a 77 68 69 74 65 73 70 61 63 65 29 20 72 65 t:whitespace) re
9540: 73 74 29 0a 20 20 20 20 28 6c 65 74 2d 73 74 72 st). (let-str
9550: 69 6e 67 2d 73 74 61 72 74 2b 65 6e 64 20 28 73 ing-start+end (s
9560: 74 61 72 74 20 65 6e 64 29 20 73 74 72 69 6e 67 tart end) string
9570: 2d 74 72 69 6d 2d 62 6f 74 68 20 73 20 72 65 73 -trim-both s res
9580: 74 0a 20 20 20 20 20 20 28 63 6f 6e 64 20 28 28 t. (cond ((
9590: 73 74 72 69 6e 67 2d 73 6b 69 70 20 73 20 63 72 string-skip s cr
95a0: 69 74 65 72 69 6f 6e 20 73 74 61 72 74 20 65 6e iterion start en
95b0: 64 29 20 3d 3e 0a 09 20 20 20 20 20 28 6c 61 6d d) =>.. (lam
95c0: 62 64 61 20 28 69 29 0a 09 20 20 20 20 20 20 20 bda (i)..
95d0: 28 25 73 75 62 73 74 72 69 6e 67 2f 73 68 61 72 (%substring/shar
95e0: 65 64 20 73 20 69 20 28 2b 20 31 20 28 73 74 72 ed s i (+ 1 (str
95f0: 69 6e 67 2d 73 6b 69 70 2d 72 69 67 68 74 20 73 ing-skip-right s
9600: 20 63 72 69 74 65 72 69 6f 6e 20 69 20 65 6e 64 criterion i end
9610: 29 29 29 29 29 0a 09 20 20 20 20 28 65 6c 73 65 ))))).. (else
9620: 20 22 22 29 29 29 29 29 0a 0a 0a 28 64 65 66 69 "")))))...(defi
9630: 6e 65 20 28 73 74 72 69 6e 67 2d 70 61 64 2d 72 ne (string-pad-r
9640: 69 67 68 74 20 73 20 6e 20 2e 20 63 68 61 72 2b ight s n . char+
9650: 73 74 61 72 74 2b 65 6e 64 29 0a 20 20 28 6c 65 start+end). (le
9660: 74 2d 6f 70 74 69 6f 6e 61 6c 73 2a 20 63 68 61 t-optionals* cha
9670: 72 2b 73 74 61 72 74 2b 65 6e 64 20 28 28 63 68 r+start+end ((ch
9680: 61 72 20 23 5c 73 70 61 63 65 20 28 63 68 61 72 ar #\space (char
9690: 3f 20 63 68 61 72 29 29 20 72 65 73 74 29 0a 20 ? char)) rest).
96a0: 20 20 20 28 6c 65 74 2d 73 74 72 69 6e 67 2d 73 (let-string-s
96b0: 74 61 72 74 2b 65 6e 64 20 28 73 74 61 72 74 20 tart+end (start
96c0: 65 6e 64 29 20 73 74 72 69 6e 67 2d 70 61 64 2d end) string-pad-
96d0: 72 69 67 68 74 20 73 20 72 65 73 74 0a 20 20 20 right s rest.
96e0: 20 20 20 28 63 68 65 63 6b 2d 61 72 67 20 28 6c (check-arg (l
96f0: 61 6d 62 64 61 20 28 6e 29 20 28 61 6e 64 20 28 ambda (n) (and (
9700: 69 6e 74 65 67 65 72 3f 20 6e 29 20 28 65 78 61 integer? n) (exa
9710: 63 74 3f 20 6e 29 20 28 3c 3d 20 30 20 6e 29 29 ct? n) (<= 0 n))
9720: 29 0a 09 09 20 6e 20 73 74 72 69 6e 67 2d 70 61 )... n string-pa
9730: 64 2d 72 69 67 68 74 29 0a 20 20 20 20 20 20 28 d-right). (
9740: 6c 65 74 20 28 28 6c 65 6e 20 28 2d 20 65 6e 64 let ((len (- end
9750: 20 73 74 61 72 74 29 29 29 0a 09 28 69 66 20 28 start)))..(if (
9760: 3c 3d 20 6e 20 6c 65 6e 29 0a 09 20 20 20 20 28 <= n len).. (
9770: 25 73 75 62 73 74 72 69 6e 67 2f 73 68 61 72 65 %substring/share
9780: 64 20 73 20 73 74 61 72 74 20 28 2b 20 73 74 61 d s start (+ sta
9790: 72 74 20 6e 29 29 0a 09 20 20 20 20 28 6c 65 74 rt n)).. (let
97a0: 20 28 28 61 6e 73 20 28 6d 61 6b 65 2d 73 74 72 ((ans (make-str
97b0: 69 6e 67 20 6e 20 63 68 61 72 29 29 29 0a 09 20 ing n char)))..
97c0: 20 20 20 20 20 28 25 73 74 72 69 6e 67 2d 63 6f (%string-co
97d0: 70 79 21 20 61 6e 73 20 30 20 73 20 73 74 61 72 py! ans 0 s star
97e0: 74 20 65 6e 64 29 0a 09 20 20 20 20 20 20 61 6e t end).. an
97f0: 73 29 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 s))))))..(define
9800: 20 28 73 74 72 69 6e 67 2d 70 61 64 20 73 20 6e (string-pad s n
9810: 20 2e 20 63 68 61 72 2b 73 74 61 72 74 2b 65 6e . char+start+en
9820: 64 29 0a 20 20 28 6c 65 74 2d 6f 70 74 69 6f 6e d). (let-option
9830: 61 6c 73 2a 20 63 68 61 72 2b 73 74 61 72 74 2b als* char+start+
9840: 65 6e 64 20 28 28 63 68 61 72 20 23 5c 73 70 61 end ((char #\spa
9850: 63 65 20 28 63 68 61 72 3f 20 63 68 61 72 29 29 ce (char? char))
9860: 20 72 65 73 74 29 0a 20 20 20 20 28 6c 65 74 2d rest). (let-
9870: 73 74 72 69 6e 67 2d 73 74 61 72 74 2b 65 6e 64 string-start+end
9880: 20 28 73 74 61 72 74 20 65 6e 64 29 20 73 74 72 (start end) str
9890: 69 6e 67 2d 70 61 64 20 73 20 72 65 73 74 0a 20 ing-pad s rest.
98a0: 20 20 20 20 20 28 63 68 65 63 6b 2d 61 72 67 20 (check-arg
98b0: 28 6c 61 6d 62 64 61 20 28 6e 29 20 28 61 6e 64 (lambda (n) (and
98c0: 20 28 69 6e 74 65 67 65 72 3f 20 6e 29 20 28 65 (integer? n) (e
98d0: 78 61 63 74 3f 20 6e 29 20 28 3c 3d 20 30 20 6e xact? n) (<= 0 n
98e0: 29 29 29 0a 09 09 20 6e 20 73 74 72 69 6e 67 2d )))... n string-
98f0: 70 61 64 29 0a 20 20 20 20 20 20 28 6c 65 74 20 pad). (let
9900: 28 28 6c 65 6e 20 28 2d 20 65 6e 64 20 73 74 61 ((len (- end sta
9910: 72 74 29 29 29 0a 09 28 69 66 20 28 3c 3d 20 6e rt)))..(if (<= n
9920: 20 6c 65 6e 29 0a 09 20 20 20 20 28 25 73 75 62 len).. (%sub
9930: 73 74 72 69 6e 67 2f 73 68 61 72 65 64 20 73 20 string/shared s
9940: 28 2d 20 65 6e 64 20 6e 29 20 65 6e 64 29 0a 09 (- end n) end)..
9950: 20 20 20 20 28 6c 65 74 20 28 28 61 6e 73 20 28 (let ((ans (
9960: 6d 61 6b 65 2d 73 74 72 69 6e 67 20 6e 20 63 68 make-string n ch
9970: 61 72 29 29 29 0a 09 20 20 20 20 20 20 28 25 73 ar))).. (%s
9980: 74 72 69 6e 67 2d 63 6f 70 79 21 20 61 6e 73 20 tring-copy! ans
9990: 28 2d 20 6e 20 6c 65 6e 29 20 73 20 73 74 61 72 (- n len) s star
99a0: 74 20 65 6e 64 29 0a 09 20 20 20 20 20 20 61 6e t end).. an
99b0: 73 29 29 29 29 29 29 0a 0a 0a 0c 0a 3b 3b 3b 20 s)))))).....;;;
99c0: 46 69 6c 74 65 72 69 6e 67 20 73 74 72 69 6e 67 Filtering string
99d0: 73 0a 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b s.;;;;;;;;;;;;;;
99e0: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
99f0: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
9a00: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
9a10: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
9a20: 3b 0a 3b 3b 3b 20 73 74 72 69 6e 67 2d 64 65 6c ;.;;; string-del
9a30: 65 74 65 20 63 68 61 72 2f 63 68 61 72 2d 73 65 ete char/char-se
9a40: 74 2f 70 72 65 64 20 73 74 72 69 6e 67 20 5b 73 t/pred string [s
9a50: 74 61 72 74 20 65 6e 64 5d 0a 3b 3b 3b 20 73 74 tart end].;;; st
9a60: 72 69 6e 67 2d 66 69 6c 74 65 72 20 63 68 61 72 ring-filter char
9a70: 2f 63 68 61 72 2d 73 65 74 2f 70 72 65 64 20 73 /char-set/pred s
9a80: 74 72 69 6e 67 20 5b 73 74 61 72 74 20 65 6e 64 tring [start end
9a90: 5d 0a 3b 3b 3b 0a 3b 3b 3b 20 49 66 20 74 68 65 ].;;;.;;; If the
9aa0: 20 63 72 69 74 65 72 69 6f 6e 20 69 73 20 61 20 criterion is a
9ab0: 63 68 61 72 20 6f 72 20 63 68 61 72 2d 73 65 74 char or char-set
9ac0: 2c 20 77 65 20 73 63 61 6e 20 74 68 65 20 73 74 , we scan the st
9ad0: 72 69 6e 67 20 74 77 69 63 65 20 77 69 74 68 0a ring twice with.
9ae0: 3b 3b 3b 20 20 20 73 74 72 69 6e 67 2d 66 6f 6c ;;; string-fol
9af0: 64 20 2d 2d 20 6f 6e 63 65 20 74 6f 20 64 65 74 d -- once to det
9b00: 65 72 6d 69 6e 65 20 74 68 65 20 6c 65 6e 67 74 ermine the lengt
9b10: 68 20 6f 66 20 74 68 65 20 72 65 73 75 6c 74 20 h of the result
9b20: 73 74 72 69 6e 67 2c 20 0a 3b 3b 3b 20 20 20 61 string, .;;; a
9b30: 6e 64 20 6f 6e 63 65 20 74 6f 20 64 6f 20 74 68 nd once to do th
9b40: 65 20 66 69 6c 74 65 72 65 64 20 63 6f 70 79 2e e filtered copy.
9b50: 0a 3b 3b 3b 20 49 66 20 74 68 65 20 63 72 69 74 .;;; If the crit
9b60: 65 72 69 6f 6e 20 69 73 20 61 20 70 72 65 64 69 erion is a predi
9b70: 63 61 74 65 2c 20 77 65 20 64 6f 6e 27 74 20 64 cate, we don't d
9b80: 6f 20 74 68 69 73 20 64 6f 75 62 6c 65 2d 73 63 o this double-sc
9b90: 61 6e 20 73 74 72 61 74 65 67 79 2c 20 0a 3b 3b an strategy, .;;
9ba0: 3b 20 20 20 62 65 63 61 75 73 65 20 74 68 65 20 ; because the
9bb0: 70 72 65 64 69 63 61 74 65 20 6d 69 67 68 74 20 predicate might
9bc0: 68 61 76 65 20 73 69 64 65 2d 65 66 66 65 63 74 have side-effect
9bd0: 73 20 6f 72 20 62 65 20 76 65 72 79 20 65 78 70 s or be very exp
9be0: 65 6e 73 69 76 65 20 74 6f 0a 3b 3b 3b 20 20 20 ensive to.;;;
9bf0: 63 6f 6d 70 75 74 65 2e 20 53 6f 20 77 65 20 70 compute. So we p
9c00: 72 65 61 6c 6c 6f 63 61 74 65 20 61 20 74 65 6d reallocate a tem
9c10: 70 20 62 75 66 66 65 72 20 70 65 73 73 69 6d 69 p buffer pessimi
9c20: 73 74 69 63 61 6c 6c 79 2c 20 61 6e 64 20 6f 6e stically, and on
9c30: 6c 79 20 64 6f 0a 3b 3b 3b 20 20 20 6f 6e 65 20 ly do.;;; one
9c40: 73 63 61 6e 20 6f 76 65 72 20 53 2e 20 54 68 69 scan over S. Thi
9c50: 73 20 69 73 20 6c 69 6b 65 6c 79 20 74 6f 20 62 s is likely to b
9c60: 65 20 66 61 73 74 65 72 20 61 6e 64 20 6d 6f 72 e faster and mor
9c70: 65 20 73 70 61 63 65 2d 65 66 66 69 63 69 65 6e e space-efficien
9c80: 74 0a 3b 3b 3b 20 20 20 74 68 61 6e 20 63 6f 6e t.;;; than con
9c90: 73 69 6e 67 20 61 20 6c 69 73 74 2e 0a 0a 28 64 sing a list...(d
9ca0: 65 66 69 6e 65 20 28 73 74 72 69 6e 67 2d 64 65 efine (string-de
9cb0: 6c 65 74 65 20 63 72 69 74 65 72 69 6f 6e 20 73 lete criterion s
9cc0: 20 2e 20 6d 61 79 62 65 2d 73 74 61 72 74 2b 65 . maybe-start+e
9cd0: 6e 64 29 0a 20 20 28 6c 65 74 2d 73 74 72 69 6e nd). (let-strin
9ce0: 67 2d 73 74 61 72 74 2b 65 6e 64 20 28 73 74 61 g-start+end (sta
9cf0: 72 74 20 65 6e 64 29 20 73 74 72 69 6e 67 2d 64 rt end) string-d
9d00: 65 6c 65 74 65 20 73 20 6d 61 79 62 65 2d 73 74 elete s maybe-st
9d10: 61 72 74 2b 65 6e 64 0a 20 20 20 20 28 69 66 20 art+end. (if
9d20: 28 70 72 6f 63 65 64 75 72 65 3f 20 63 72 69 74 (procedure? crit
9d30: 65 72 69 6f 6e 29 0a 09 28 6c 65 74 2a 20 28 28 erion)..(let* ((
9d40: 73 6c 65 6e 20 28 2d 20 65 6e 64 20 73 74 61 72 slen (- end star
9d50: 74 29 29 0a 09 20 20 20 20 20 20 20 28 74 65 6d t)).. (tem
9d60: 70 20 28 6d 61 6b 65 2d 73 74 72 69 6e 67 20 73 p (make-string s
9d70: 6c 65 6e 29 29 0a 09 20 20 20 20 20 20 20 28 61 len)).. (a
9d80: 6e 73 2d 6c 65 6e 20 28 73 74 72 69 6e 67 2d 66 ns-len (string-f
9d90: 6f 6c 64 20 28 6c 61 6d 62 64 61 20 28 63 20 69 old (lambda (c i
9da0: 29 0a 09 09 09 09 20 20 20 20 20 20 20 28 69 66 )..... (if
9db0: 20 28 63 72 69 74 65 72 69 6f 6e 20 63 29 20 69 (criterion c) i
9dc0: 0a 09 09 09 09 09 20 20 20 28 62 65 67 69 6e 20 ...... (begin
9dd0: 28 73 74 72 69 6e 67 2d 73 65 74 21 20 74 65 6d (string-set! tem
9de0: 70 20 69 20 63 29 0a 09 09 09 09 09 09 20 20 28 p i c)....... (
9df0: 2b 20 69 20 31 29 29 29 29 0a 09 09 09 09 20 20 + i 1)))).....
9e00: 20 20 20 30 20 73 20 73 74 61 72 74 20 65 6e 64 0 s start end
9e10: 29 29 29 0a 09 20 20 28 69 66 20 28 3d 20 61 6e ))).. (if (= an
9e20: 73 2d 6c 65 6e 20 73 6c 65 6e 29 20 74 65 6d 70 s-len slen) temp
9e30: 20 28 73 75 62 73 74 72 69 6e 67 20 74 65 6d 70 (substring temp
9e40: 20 30 20 61 6e 73 2d 6c 65 6e 29 29 29 0a 0a 09 0 ans-len)))...
9e50: 28 6c 65 74 2a 20 28 28 63 73 65 74 20 28 63 6f (let* ((cset (co
9e60: 6e 64 20 28 28 63 68 61 72 2d 73 65 74 3f 20 63 nd ((char-set? c
9e70: 72 69 74 65 72 69 6f 6e 29 20 63 72 69 74 65 72 riterion) criter
9e80: 69 6f 6e 29 0a 09 09 09 20 20 20 28 28 63 68 61 ion).... ((cha
9e90: 72 3f 20 63 72 69 74 65 72 69 6f 6e 29 20 28 63 r? criterion) (c
9ea0: 68 61 72 2d 73 65 74 20 63 72 69 74 65 72 69 6f har-set criterio
9eb0: 6e 29 29 0a 09 09 09 20 20 20 28 65 6c 73 65 20 n)).... (else
9ec0: 28 65 72 72 6f 72 20 22 73 74 72 69 6e 67 2d 64 (error "string-d
9ed0: 65 6c 65 74 65 20 63 72 69 74 65 72 69 6f 6e 20 elete criterion
9ee0: 6e 6f 74 20 70 72 65 64 69 63 61 74 65 2c 20 63 not predicate, c
9ef0: 68 61 72 20 6f 72 20 63 68 61 72 2d 73 65 74 22 har or char-set"
9f00: 20 63 72 69 74 65 72 69 6f 6e 29 29 29 29 0a 09 criterion))))..
9f10: 20 20 20 20 20 20 20 28 6c 65 6e 20 28 73 74 72 (len (str
9f20: 69 6e 67 2d 66 6f 6c 64 20 28 6c 61 6d 62 64 61 ing-fold (lambda
9f30: 20 28 63 20 69 29 20 28 69 66 20 28 63 68 61 72 (c i) (if (char
9f40: 2d 73 65 74 2d 63 6f 6e 74 61 69 6e 73 3f 20 63 -set-contains? c
9f50: 73 65 74 20 63 29 0a 09 09 09 09 09 09 20 20 20 set c).......
9f60: 69 0a 09 09 09 09 09 09 20 20 20 28 2b 20 69 20 i....... (+ i
9f70: 31 29 29 29 0a 09 09 09 09 20 30 20 73 20 73 74 1)))..... 0 s st
9f80: 61 72 74 20 65 6e 64 29 29 0a 09 20 20 20 20 20 art end))..
9f90: 20 20 28 61 6e 73 20 28 6d 61 6b 65 2d 73 74 72 (ans (make-str
9fa0: 69 6e 67 20 6c 65 6e 29 29 29 0a 09 20 20 28 73 ing len))).. (s
9fb0: 74 72 69 6e 67 2d 66 6f 6c 64 20 28 6c 61 6d 62 tring-fold (lamb
9fc0: 64 61 20 28 63 20 69 29 20 28 69 66 20 28 63 68 da (c i) (if (ch
9fd0: 61 72 2d 73 65 74 2d 63 6f 6e 74 61 69 6e 73 3f ar-set-contains?
9fe0: 20 63 73 65 74 20 63 29 0a 09 09 09 09 09 20 69 cset c)...... i
9ff0: 0a 09 09 09 09 09 20 28 62 65 67 69 6e 20 28 73 ...... (begin (s
a000: 74 72 69 6e 67 2d 73 65 74 21 20 61 6e 73 20 69 tring-set! ans i
a010: 20 63 29 0a 09 09 09 09 09 09 28 2b 20 69 20 31 c).......(+ i 1
a020: 29 29 29 29 0a 09 09 20 20 20 20 20 20 20 30 20 ))))... 0
a030: 73 20 73 74 61 72 74 20 65 6e 64 29 0a 09 20 20 s start end)..
a040: 61 6e 73 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 ans))))..(define
a050: 20 28 73 74 72 69 6e 67 2d 66 69 6c 74 65 72 20 (string-filter
a060: 63 72 69 74 65 72 69 6f 6e 20 73 20 2e 20 6d 61 criterion s . ma
a070: 79 62 65 2d 73 74 61 72 74 2b 65 6e 64 29 0a 20 ybe-start+end).
a080: 20 28 6c 65 74 2d 73 74 72 69 6e 67 2d 73 74 61 (let-string-sta
a090: 72 74 2b 65 6e 64 20 28 73 74 61 72 74 20 65 6e rt+end (start en
a0a0: 64 29 20 73 74 72 69 6e 67 2d 66 69 6c 74 65 72 d) string-filter
a0b0: 20 73 20 6d 61 79 62 65 2d 73 74 61 72 74 2b 65 s maybe-start+e
a0c0: 6e 64 0a 20 20 20 20 28 69 66 20 28 70 72 6f 63 nd. (if (proc
a0d0: 65 64 75 72 65 3f 20 63 72 69 74 65 72 69 6f 6e edure? criterion
a0e0: 29 0a 09 28 6c 65 74 2a 20 28 28 73 6c 65 6e 20 )..(let* ((slen
a0f0: 28 2d 20 65 6e 64 20 73 74 61 72 74 29 29 0a 09 (- end start))..
a100: 20 20 20 20 20 20 20 28 74 65 6d 70 20 28 6d 61 (temp (ma
a110: 6b 65 2d 73 74 72 69 6e 67 20 73 6c 65 6e 29 29 ke-string slen))
a120: 0a 09 20 20 20 20 20 20 20 28 61 6e 73 2d 6c 65 .. (ans-le
a130: 6e 20 28 73 74 72 69 6e 67 2d 66 6f 6c 64 20 28 n (string-fold (
a140: 6c 61 6d 62 64 61 20 28 63 20 69 29 0a 09 09 09 lambda (c i)....
a150: 09 20 20 20 20 20 20 20 28 69 66 20 28 63 72 69 . (if (cri
a160: 74 65 72 69 6f 6e 20 63 29 0a 09 09 09 09 09 20 terion c)......
a170: 20 20 28 62 65 67 69 6e 20 28 73 74 72 69 6e 67 (begin (string
a180: 2d 73 65 74 21 20 74 65 6d 70 20 69 20 63 29 0a -set! temp i c).
a190: 09 09 09 09 09 09 20 20 28 2b 20 69 20 31 29 29 ...... (+ i 1))
a1a0: 0a 09 09 09 09 09 20 20 20 69 29 29 0a 09 09 09 ...... i))....
a1b0: 09 20 20 20 20 20 30 20 73 20 73 74 61 72 74 20 . 0 s start
a1c0: 65 6e 64 29 29 29 0a 09 20 20 28 69 66 20 28 3d end))).. (if (=
a1d0: 20 61 6e 73 2d 6c 65 6e 20 73 6c 65 6e 29 20 74 ans-len slen) t
a1e0: 65 6d 70 20 28 73 75 62 73 74 72 69 6e 67 20 74 emp (substring t
a1f0: 65 6d 70 20 30 20 61 6e 73 2d 6c 65 6e 29 29 29 emp 0 ans-len)))
a200: 0a 0a 09 28 6c 65 74 2a 20 28 28 63 73 65 74 20 ...(let* ((cset
a210: 28 63 6f 6e 64 20 28 28 63 68 61 72 2d 73 65 74 (cond ((char-set
a220: 3f 20 63 72 69 74 65 72 69 6f 6e 29 20 63 72 69 ? criterion) cri
a230: 74 65 72 69 6f 6e 29 0a 09 09 09 20 20 20 28 28 terion).... ((
a240: 63 68 61 72 3f 20 63 72 69 74 65 72 69 6f 6e 29 char? criterion)
a250: 20 28 63 68 61 72 2d 73 65 74 20 63 72 69 74 65 (char-set crite
a260: 72 69 6f 6e 29 29 0a 09 09 09 20 20 20 28 65 6c rion)).... (el
a270: 73 65 20 28 65 72 72 6f 72 20 22 73 74 72 69 6e se (error "strin
a280: 67 2d 64 65 6c 65 74 65 20 63 72 69 74 65 72 69 g-delete criteri
a290: 6f 6e 20 6e 6f 74 20 70 72 65 64 69 63 61 74 65 on not predicate
a2a0: 2c 20 63 68 61 72 20 6f 72 20 63 68 61 72 2d 73 , char or char-s
a2b0: 65 74 22 20 63 72 69 74 65 72 69 6f 6e 29 29 29 et" criterion)))
a2c0: 29 0a 0a 09 20 20 20 20 20 20 20 28 6c 65 6e 20 )... (len
a2d0: 28 73 74 72 69 6e 67 2d 66 6f 6c 64 20 28 6c 61 (string-fold (la
a2e0: 6d 62 64 61 20 28 63 20 69 29 20 28 69 66 20 28 mbda (c i) (if (
a2f0: 63 68 61 72 2d 73 65 74 2d 63 6f 6e 74 61 69 6e char-set-contain
a300: 73 3f 20 63 73 65 74 20 63 29 0a 09 09 09 09 09 s? cset c)......
a310: 09 20 20 20 28 2b 20 69 20 31 29 0a 09 09 09 09 . (+ i 1).....
a320: 09 09 20 20 20 69 29 29 0a 09 09 09 09 20 30 20 .. i))..... 0
a330: 73 20 73 74 61 72 74 20 65 6e 64 29 29 0a 09 20 s start end))..
a340: 20 20 20 20 20 20 28 61 6e 73 20 28 6d 61 6b 65 (ans (make
a350: 2d 73 74 72 69 6e 67 20 6c 65 6e 29 29 29 0a 09 -string len)))..
a360: 20 20 28 73 74 72 69 6e 67 2d 66 6f 6c 64 20 28 (string-fold (
a370: 6c 61 6d 62 64 61 20 28 63 20 69 29 20 28 69 66 lambda (c i) (if
a380: 20 28 63 68 61 72 2d 73 65 74 2d 63 6f 6e 74 61 (char-set-conta
a390: 69 6e 73 3f 20 63 73 65 74 20 63 29 0a 09 09 09 ins? cset c)....
a3a0: 09 09 20 28 62 65 67 69 6e 20 28 73 74 72 69 6e .. (begin (strin
a3b0: 67 2d 73 65 74 21 20 61 6e 73 20 69 20 63 29 0a g-set! ans i c).
a3c0: 09 09 09 09 09 09 28 2b 20 69 20 31 29 29 0a 09 ......(+ i 1))..
a3d0: 09 09 09 09 20 69 29 29 0a 09 09 20 20 20 20 20 .... i))...
a3e0: 20 20 30 20 73 20 73 74 61 72 74 20 65 6e 64 29 0 s start end)
a3f0: 0a 09 20 20 61 6e 73 29 29 29 29 0a 0a 0c 0a 3b .. ans))))....;
a400: 3b 3b 20 53 74 72 69 6e 67 20 73 65 61 72 63 68 ;; String search
a410: 0a 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b .;;;;;;;;;;;;;;;
a420: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
a430: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
a440: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
a450: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
a460: 0a 3b 3b 3b 20 73 74 72 69 6e 67 2d 69 6e 64 65 .;;; string-inde
a470: 78 20 20 20 20 20 20 20 73 74 72 69 6e 67 20 63 x string c
a480: 68 61 72 2f 63 68 61 72 2d 73 65 74 2f 70 72 65 har/char-set/pre
a490: 64 20 5b 73 74 61 72 74 20 65 6e 64 5d 0a 3b 3b d [start end].;;
a4a0: 3b 20 73 74 72 69 6e 67 2d 69 6e 64 65 78 2d 72 ; string-index-r
a4b0: 69 67 68 74 20 73 74 72 69 6e 67 20 63 68 61 72 ight string char
a4c0: 2f 63 68 61 72 2d 73 65 74 2f 70 72 65 64 20 5b /char-set/pred [
a4d0: 73 74 61 72 74 20 65 6e 64 5d 0a 3b 3b 3b 20 73 start end].;;; s
a4e0: 74 72 69 6e 67 2d 73 6b 69 70 20 20 20 20 20 20 tring-skip
a4f0: 20 20 73 74 72 69 6e 67 20 63 68 61 72 2f 63 68 string char/ch
a500: 61 72 2d 73 65 74 2f 70 72 65 64 20 5b 73 74 61 ar-set/pred [sta
a510: 72 74 20 65 6e 64 5d 0a 3b 3b 3b 20 73 74 72 69 rt end].;;; stri
a520: 6e 67 2d 73 6b 69 70 2d 72 69 67 68 74 20 20 73 ng-skip-right s
a530: 74 72 69 6e 67 20 63 68 61 72 2f 63 68 61 72 2d tring char/char-
a540: 73 65 74 2f 70 72 65 64 20 5b 73 74 61 72 74 20 set/pred [start
a550: 65 6e 64 5d 0a 3b 3b 3b 20 73 74 72 69 6e 67 2d end].;;; string-
a560: 63 6f 75 6e 74 20 20 20 20 20 20 20 73 74 72 69 count stri
a570: 6e 67 20 63 68 61 72 2f 63 68 61 72 2d 73 65 74 ng char/char-set
a580: 2f 70 72 65 64 20 5b 73 74 61 72 74 20 65 6e 64 /pred [start end
a590: 5d 0a 3b 3b 3b 20 20 20 20 20 54 68 65 72 65 27 ].;;; There'
a5a0: 73 20 61 20 6c 6f 74 20 6f 66 20 72 65 70 6c 69 s a lot of repli
a5b0: 63 61 74 65 64 20 63 6f 64 65 20 68 65 72 65 20 cated code here
a5c0: 66 6f 72 20 65 66 66 69 63 69 65 6e 63 79 2e 0a for efficiency..
a5d0: 3b 3b 3b 20 20 20 20 20 46 6f 72 20 65 78 61 6d ;;; For exam
a5e0: 70 6c 65 2c 20 74 68 65 20 63 68 61 72 2f 63 68 ple, the char/ch
a5f0: 61 72 2d 73 65 74 2f 70 72 65 64 20 64 69 73 63 ar-set/pred disc
a600: 72 69 6d 69 6e 61 74 69 6f 6e 20 68 61 73 0a 3b rimination has.;
a610: 3b 3b 20 20 20 20 20 62 65 65 6e 20 6c 69 66 74 ;; been lift
a620: 65 64 20 61 62 6f 76 65 20 74 68 65 20 69 6e 6e ed above the inn
a630: 65 72 20 6c 6f 6f 70 20 6f 66 20 65 61 63 68 20 er loop of each
a640: 70 72 6f 63 2e 0a 0a 28 64 65 66 69 6e 65 20 28 proc...(define (
a650: 73 74 72 69 6e 67 2d 69 6e 64 65 78 20 73 74 72 string-index str
a660: 20 63 72 69 74 65 72 69 6f 6e 20 2e 20 6d 61 79 criterion . may
a670: 62 65 2d 73 74 61 72 74 2b 65 6e 64 29 0a 20 20 be-start+end).
a680: 28 6c 65 74 2d 73 74 72 69 6e 67 2d 73 74 61 72 (let-string-star
a690: 74 2b 65 6e 64 20 28 73 74 61 72 74 20 65 6e 64 t+end (start end
a6a0: 29 20 73 74 72 69 6e 67 2d 69 6e 64 65 78 20 73 ) string-index s
a6b0: 74 72 20 6d 61 79 62 65 2d 73 74 61 72 74 2b 65 tr maybe-start+e
a6c0: 6e 64 0a 20 20 20 20 28 63 6f 6e 64 20 28 28 63 nd. (cond ((c
a6d0: 68 61 72 3f 20 63 72 69 74 65 72 69 6f 6e 29 0a har? criterion).
a6e0: 09 20 20 20 28 6c 65 74 20 6c 70 20 28 28 69 20 . (let lp ((i
a6f0: 73 74 61 72 74 29 29 0a 09 20 20 20 20 20 28 61 start)).. (a
a700: 6e 64 20 28 3c 20 69 20 65 6e 64 29 0a 09 09 20 nd (< i end)...
a710: 20 28 69 66 20 28 63 68 61 72 3d 3f 20 63 72 69 (if (char=? cri
a720: 74 65 72 69 6f 6e 20 28 73 74 72 69 6e 67 2d 72 terion (string-r
a730: 65 66 20 73 74 72 20 69 29 29 20 69 0a 09 09 20 ef str i)) i...
a740: 20 20 20 20 20 28 6c 70 20 28 2b 20 69 20 31 29 (lp (+ i 1)
a750: 29 29 29 29 29 0a 09 20 20 28 28 63 68 61 72 2d ))))).. ((char-
a760: 73 65 74 3f 20 63 72 69 74 65 72 69 6f 6e 29 0a set? criterion).
a770: 09 20 20 20 28 6c 65 74 20 6c 70 20 28 28 69 20 . (let lp ((i
a780: 73 74 61 72 74 29 29 0a 09 20 20 20 20 20 28 61 start)).. (a
a790: 6e 64 20 28 3c 20 69 20 65 6e 64 29 0a 09 09 20 nd (< i end)...
a7a0: 20 28 69 66 20 28 63 68 61 72 2d 73 65 74 2d 63 (if (char-set-c
a7b0: 6f 6e 74 61 69 6e 73 3f 20 63 72 69 74 65 72 69 ontains? criteri
a7c0: 6f 6e 20 28 73 74 72 69 6e 67 2d 72 65 66 20 73 on (string-ref s
a7d0: 74 72 20 69 29 29 20 69 0a 09 09 20 20 20 20 20 tr i)) i...
a7e0: 20 28 6c 70 20 28 2b 20 69 20 31 29 29 29 29 29 (lp (+ i 1)))))
a7f0: 29 0a 09 20 20 28 28 70 72 6f 63 65 64 75 72 65 ).. ((procedure
a800: 3f 20 63 72 69 74 65 72 69 6f 6e 29 0a 09 20 20 ? criterion)..
a810: 20 28 6c 65 74 20 6c 70 20 28 28 69 20 73 74 61 (let lp ((i sta
a820: 72 74 29 29 0a 09 20 20 20 20 20 28 61 6e 64 20 rt)).. (and
a830: 28 3c 20 69 20 65 6e 64 29 0a 09 09 20 20 28 69 (< i end)... (i
a840: 66 20 28 63 72 69 74 65 72 69 6f 6e 20 28 73 74 f (criterion (st
a850: 72 69 6e 67 2d 72 65 66 20 73 74 72 20 69 29 29 ring-ref str i))
a860: 20 69 0a 09 09 20 20 20 20 20 20 28 6c 70 20 28 i... (lp (
a870: 2b 20 69 20 31 29 29 29 29 29 29 0a 09 20 20 28 + i 1)))))).. (
a880: 65 6c 73 65 20 28 65 72 72 6f 72 20 22 53 65 63 else (error "Sec
a890: 6f 6e 64 20 70 61 72 61 6d 20 69 73 20 6e 65 69 ond param is nei
a8a0: 74 68 65 72 20 63 68 61 72 2d 73 65 74 2c 20 63 ther char-set, c
a8b0: 68 61 72 2c 20 6f 72 20 70 72 65 64 69 63 61 74 har, or predicat
a8c0: 65 20 70 72 6f 63 65 64 75 72 65 2e 22 0a 09 09 e procedure."...
a8d0: 20 20 20 20 20 20 20 73 74 72 69 6e 67 2d 69 6e string-in
a8e0: 64 65 78 20 63 72 69 74 65 72 69 6f 6e 29 29 29 dex criterion)))
a8f0: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 74 72 ))..(define (str
a900: 69 6e 67 2d 69 6e 64 65 78 2d 72 69 67 68 74 20 ing-index-right
a910: 73 74 72 20 63 72 69 74 65 72 69 6f 6e 20 2e 20 str criterion .
a920: 6d 61 79 62 65 2d 73 74 61 72 74 2b 65 6e 64 29 maybe-start+end)
a930: 0a 20 20 28 6c 65 74 2d 73 74 72 69 6e 67 2d 73 . (let-string-s
a940: 74 61 72 74 2b 65 6e 64 20 28 73 74 61 72 74 20 tart+end (start
a950: 65 6e 64 29 20 73 74 72 69 6e 67 2d 69 6e 64 65 end) string-inde
a960: 78 2d 72 69 67 68 74 20 73 74 72 20 6d 61 79 62 x-right str mayb
a970: 65 2d 73 74 61 72 74 2b 65 6e 64 0a 20 20 20 20 e-start+end.
a980: 28 63 6f 6e 64 20 28 28 63 68 61 72 3f 20 63 72 (cond ((char? cr
a990: 69 74 65 72 69 6f 6e 29 0a 09 20 20 20 28 6c 65 iterion).. (le
a9a0: 74 20 6c 70 20 28 28 69 20 28 2d 20 65 6e 64 20 t lp ((i (- end
a9b0: 31 29 29 29 0a 09 20 20 20 20 20 28 61 6e 64 20 1))).. (and
a9c0: 28 3e 3d 20 69 20 73 74 61 72 74 29 0a 09 09 20 (>= i start)...
a9d0: 20 28 69 66 20 28 63 68 61 72 3d 3f 20 63 72 69 (if (char=? cri
a9e0: 74 65 72 69 6f 6e 20 28 73 74 72 69 6e 67 2d 72 terion (string-r
a9f0: 65 66 20 73 74 72 20 69 29 29 20 69 0a 09 09 20 ef str i)) i...
aa00: 20 20 20 20 20 28 6c 70 20 28 2d 20 69 20 31 29 (lp (- i 1)
aa10: 29 29 29 29 29 0a 09 20 20 28 28 63 68 61 72 2d ))))).. ((char-
aa20: 73 65 74 3f 20 63 72 69 74 65 72 69 6f 6e 29 0a set? criterion).
aa30: 09 20 20 20 28 6c 65 74 20 6c 70 20 28 28 69 20 . (let lp ((i
aa40: 28 2d 20 65 6e 64 20 31 29 29 29 0a 09 20 20 20 (- end 1)))..
aa50: 20 20 28 61 6e 64 20 28 3e 3d 20 69 20 73 74 61 (and (>= i sta
aa60: 72 74 29 0a 09 09 20 20 28 69 66 20 28 63 68 61 rt)... (if (cha
aa70: 72 2d 73 65 74 2d 63 6f 6e 74 61 69 6e 73 3f 20 r-set-contains?
aa80: 63 72 69 74 65 72 69 6f 6e 20 28 73 74 72 69 6e criterion (strin
aa90: 67 2d 72 65 66 20 73 74 72 20 69 29 29 20 69 0a g-ref str i)) i.
aaa0: 09 09 20 20 20 20 20 20 28 6c 70 20 28 2d 20 69 .. (lp (- i
aab0: 20 31 29 29 29 29 29 29 0a 09 20 20 28 28 70 72 1)))))).. ((pr
aac0: 6f 63 65 64 75 72 65 3f 20 63 72 69 74 65 72 69 ocedure? criteri
aad0: 6f 6e 29 0a 09 20 20 20 28 6c 65 74 20 6c 70 20 on).. (let lp
aae0: 28 28 69 20 28 2d 20 65 6e 64 20 31 29 29 29 0a ((i (- end 1))).
aaf0: 09 20 20 20 20 20 28 61 6e 64 20 28 3e 3d 20 69 . (and (>= i
ab00: 20 73 74 61 72 74 29 0a 09 09 20 20 28 69 66 20 start)... (if
ab10: 28 63 72 69 74 65 72 69 6f 6e 20 28 73 74 72 69 (criterion (stri
ab20: 6e 67 2d 72 65 66 20 73 74 72 20 69 29 29 20 69 ng-ref str i)) i
ab30: 0a 09 09 20 20 20 20 20 20 28 6c 70 20 28 2d 20 ... (lp (-
ab40: 69 20 31 29 29 29 29 29 29 0a 09 20 20 28 65 6c i 1)))))).. (el
ab50: 73 65 20 28 65 72 72 6f 72 20 22 53 65 63 6f 6e se (error "Secon
ab60: 64 20 70 61 72 61 6d 20 69 73 20 6e 65 69 74 68 d param is neith
ab70: 65 72 20 63 68 61 72 2d 73 65 74 2c 20 63 68 61 er char-set, cha
ab80: 72 2c 20 6f 72 20 70 72 65 64 69 63 61 74 65 20 r, or predicate
ab90: 70 72 6f 63 65 64 75 72 65 2e 22 0a 09 09 20 20 procedure."...
aba0: 20 20 20 20 20 73 74 72 69 6e 67 2d 69 6e 64 65 string-inde
abb0: 78 2d 72 69 67 68 74 20 63 72 69 74 65 72 69 6f x-right criterio
abc0: 6e 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 n)))))..(define
abd0: 28 73 74 72 69 6e 67 2d 73 6b 69 70 20 73 74 72 (string-skip str
abe0: 20 63 72 69 74 65 72 69 6f 6e 20 2e 20 6d 61 79 criterion . may
abf0: 62 65 2d 73 74 61 72 74 2b 65 6e 64 29 0a 20 20 be-start+end).
ac00: 28 6c 65 74 2d 73 74 72 69 6e 67 2d 73 74 61 72 (let-string-star
ac10: 74 2b 65 6e 64 20 28 73 74 61 72 74 20 65 6e 64 t+end (start end
ac20: 29 20 73 74 72 69 6e 67 2d 73 6b 69 70 20 73 74 ) string-skip st
ac30: 72 20 6d 61 79 62 65 2d 73 74 61 72 74 2b 65 6e r maybe-start+en
ac40: 64 0a 20 20 20 20 28 63 6f 6e 64 20 28 28 63 68 d. (cond ((ch
ac50: 61 72 3f 20 63 72 69 74 65 72 69 6f 6e 29 0a 09 ar? criterion)..
ac60: 20 20 20 28 6c 65 74 20 6c 70 20 28 28 69 20 73 (let lp ((i s
ac70: 74 61 72 74 29 29 0a 09 20 20 20 20 20 28 61 6e tart)).. (an
ac80: 64 20 28 3c 20 69 20 65 6e 64 29 0a 09 09 20 20 d (< i end)...
ac90: 28 69 66 20 28 63 68 61 72 3d 3f 20 63 72 69 74 (if (char=? crit
aca0: 65 72 69 6f 6e 20 28 73 74 72 69 6e 67 2d 72 65 erion (string-re
acb0: 66 20 73 74 72 20 69 29 29 0a 09 09 20 20 20 20 f str i))...
acc0: 20 20 28 6c 70 20 28 2b 20 69 20 31 29 29 0a 09 (lp (+ i 1))..
acd0: 09 20 20 20 20 20 20 69 29 29 29 29 0a 09 20 20 . i))))..
ace0: 28 28 63 68 61 72 2d 73 65 74 3f 20 63 72 69 74 ((char-set? crit
acf0: 65 72 69 6f 6e 29 0a 09 20 20 20 28 6c 65 74 20 erion).. (let
ad00: 6c 70 20 28 28 69 20 73 74 61 72 74 29 29 0a 09 lp ((i start))..
ad10: 20 20 20 20 20 28 61 6e 64 20 28 3c 20 69 20 65 (and (< i e
ad20: 6e 64 29 0a 09 09 20 20 28 69 66 20 28 63 68 61 nd)... (if (cha
ad30: 72 2d 73 65 74 2d 63 6f 6e 74 61 69 6e 73 3f 20 r-set-contains?
ad40: 63 72 69 74 65 72 69 6f 6e 20 28 73 74 72 69 6e criterion (strin
ad50: 67 2d 72 65 66 20 73 74 72 20 69 29 29 0a 09 09 g-ref str i))...
ad60: 20 20 20 20 20 20 28 6c 70 20 28 2b 20 69 20 31 (lp (+ i 1
ad70: 29 29 0a 09 09 20 20 20 20 20 20 69 29 29 29 29 ))... i))))
ad80: 0a 09 20 20 28 28 70 72 6f 63 65 64 75 72 65 3f .. ((procedure?
ad90: 20 63 72 69 74 65 72 69 6f 6e 29 0a 09 20 20 20 criterion)..
ada0: 28 6c 65 74 20 6c 70 20 28 28 69 20 73 74 61 72 (let lp ((i star
adb0: 74 29 29 0a 09 20 20 20 20 20 28 61 6e 64 20 28 t)).. (and (
adc0: 3c 20 69 20 65 6e 64 29 0a 09 09 20 20 28 69 66 < i end)... (if
add0: 20 28 63 72 69 74 65 72 69 6f 6e 20 28 73 74 72 (criterion (str
ade0: 69 6e 67 2d 72 65 66 20 73 74 72 20 69 29 29 20 ing-ref str i))
adf0: 28 6c 70 20 28 2b 20 69 20 31 29 29 0a 09 09 20 (lp (+ i 1))...
ae00: 20 20 20 20 20 69 29 29 29 29 0a 09 20 20 28 65 i)))).. (e
ae10: 6c 73 65 20 28 65 72 72 6f 72 20 22 53 65 63 6f lse (error "Seco
ae20: 6e 64 20 70 61 72 61 6d 20 69 73 20 6e 65 69 74 nd param is neit
ae30: 68 65 72 20 63 68 61 72 2d 73 65 74 2c 20 63 68 her char-set, ch
ae40: 61 72 2c 20 6f 72 20 70 72 65 64 69 63 61 74 65 ar, or predicate
ae50: 20 70 72 6f 63 65 64 75 72 65 2e 22 0a 09 09 20 procedure."...
ae60: 20 20 20 20 20 20 73 74 72 69 6e 67 2d 73 6b 69 string-ski
ae70: 70 20 63 72 69 74 65 72 69 6f 6e 29 29 29 29 29 p criterion)))))
ae80: 0a 0a 28 64 65 66 69 6e 65 20 28 73 74 72 69 6e ..(define (strin
ae90: 67 2d 73 6b 69 70 2d 72 69 67 68 74 20 73 74 72 g-skip-right str
aea0: 20 63 72 69 74 65 72 69 6f 6e 20 2e 20 6d 61 79 criterion . may
aeb0: 62 65 2d 73 74 61 72 74 2b 65 6e 64 29 0a 20 20 be-start+end).
aec0: 28 6c 65 74 2d 73 74 72 69 6e 67 2d 73 74 61 72 (let-string-star
aed0: 74 2b 65 6e 64 20 28 73 74 61 72 74 20 65 6e 64 t+end (start end
aee0: 29 20 73 74 72 69 6e 67 2d 73 6b 69 70 2d 72 69 ) string-skip-ri
aef0: 67 68 74 20 73 74 72 20 6d 61 79 62 65 2d 73 74 ght str maybe-st
af00: 61 72 74 2b 65 6e 64 0a 20 20 20 20 28 63 6f 6e art+end. (con
af10: 64 20 28 28 63 68 61 72 3f 20 63 72 69 74 65 72 d ((char? criter
af20: 69 6f 6e 29 0a 09 20 20 20 28 6c 65 74 20 6c 70 ion).. (let lp
af30: 20 28 28 69 20 28 2d 20 65 6e 64 20 31 29 29 29 ((i (- end 1)))
af40: 0a 09 20 20 20 20 20 28 61 6e 64 20 28 3e 3d 20 .. (and (>=
af50: 69 20 73 74 61 72 74 29 0a 09 09 20 20 28 69 66 i start)... (if
af60: 20 28 63 68 61 72 3d 3f 20 63 72 69 74 65 72 69 (char=? criteri
af70: 6f 6e 20 28 73 74 72 69 6e 67 2d 72 65 66 20 73 on (string-ref s
af80: 74 72 20 69 29 29 0a 09 09 20 20 20 20 20 20 28 tr i))... (
af90: 6c 70 20 28 2d 20 69 20 31 29 29 0a 09 09 20 20 lp (- i 1))...
afa0: 20 20 20 20 69 29 29 29 29 0a 09 20 20 28 28 63 i)))).. ((c
afb0: 68 61 72 2d 73 65 74 3f 20 63 72 69 74 65 72 69 har-set? criteri
afc0: 6f 6e 29 0a 09 20 20 20 28 6c 65 74 20 6c 70 20 on).. (let lp
afd0: 28 28 69 20 28 2d 20 65 6e 64 20 31 29 29 29 0a ((i (- end 1))).
afe0: 09 20 20 20 20 20 28 61 6e 64 20 28 3e 3d 20 69 . (and (>= i
aff0: 20 73 74 61 72 74 29 0a 09 09 20 20 28 69 66 20 start)... (if
b000: 28 63 68 61 72 2d 73 65 74 2d 63 6f 6e 74 61 69 (char-set-contai
b010: 6e 73 3f 20 63 72 69 74 65 72 69 6f 6e 20 28 73 ns? criterion (s
b020: 74 72 69 6e 67 2d 72 65 66 20 73 74 72 20 69 29 tring-ref str i)
b030: 29 0a 09 09 20 20 20 20 20 20 28 6c 70 20 28 2d )... (lp (-
b040: 20 69 20 31 29 29 0a 09 09 20 20 20 20 20 20 69 i 1))... i
b050: 29 29 29 29 0a 09 20 20 28 28 70 72 6f 63 65 64 )))).. ((proced
b060: 75 72 65 3f 20 63 72 69 74 65 72 69 6f 6e 29 0a ure? criterion).
b070: 09 20 20 20 28 6c 65 74 20 6c 70 20 28 28 69 20 . (let lp ((i
b080: 28 2d 20 65 6e 64 20 31 29 29 29 0a 09 20 20 20 (- end 1)))..
b090: 20 20 28 61 6e 64 20 28 3e 3d 20 69 20 73 74 61 (and (>= i sta
b0a0: 72 74 29 0a 09 09 20 20 28 69 66 20 28 63 72 69 rt)... (if (cri
b0b0: 74 65 72 69 6f 6e 20 28 73 74 72 69 6e 67 2d 72 terion (string-r
b0c0: 65 66 20 73 74 72 20 69 29 29 20 28 6c 70 20 28 ef str i)) (lp (
b0d0: 2d 20 69 20 31 29 29 0a 09 09 20 20 20 20 20 20 - i 1))...
b0e0: 69 29 29 29 29 0a 09 20 20 28 65 6c 73 65 20 28 i)))).. (else (
b0f0: 65 72 72 6f 72 20 22 43 52 49 54 45 52 49 4f 4e error "CRITERION
b100: 20 70 61 72 61 6d 20 69 73 20 6e 65 69 74 68 65 param is neithe
b110: 72 20 63 68 61 72 2d 73 65 74 20 6f 72 20 63 68 r char-set or ch
b120: 61 72 2e 22 0a 09 09 20 20 20 20 20 20 20 73 74 ar."... st
b130: 72 69 6e 67 2d 73 6b 69 70 2d 72 69 67 68 74 20 ring-skip-right
b140: 63 72 69 74 65 72 69 6f 6e 29 29 29 29 29 0a 0a criterion)))))..
b150: 0a 28 64 65 66 69 6e 65 20 28 73 74 72 69 6e 67 .(define (string
b160: 2d 63 6f 75 6e 74 20 73 20 63 72 69 74 65 72 69 -count s criteri
b170: 6f 6e 20 2e 20 6d 61 79 62 65 2d 73 74 61 72 74 on . maybe-start
b180: 2b 65 6e 64 29 0a 20 20 28 6c 65 74 2d 73 74 72 +end). (let-str
b190: 69 6e 67 2d 73 74 61 72 74 2b 65 6e 64 20 28 73 ing-start+end (s
b1a0: 74 61 72 74 20 65 6e 64 29 20 73 74 72 69 6e 67 tart end) string
b1b0: 2d 63 6f 75 6e 74 20 73 20 6d 61 79 62 65 2d 73 -count s maybe-s
b1c0: 74 61 72 74 2b 65 6e 64 0a 20 20 20 20 28 63 6f tart+end. (co
b1d0: 6e 64 20 28 28 63 68 61 72 3f 20 63 72 69 74 65 nd ((char? crite
b1e0: 72 69 6f 6e 29 0a 09 20 20 20 28 64 6f 20 28 28 rion).. (do ((
b1f0: 69 20 73 74 61 72 74 20 28 2b 20 69 20 31 29 29 i start (+ i 1))
b200: 0a 09 09 28 63 6f 75 6e 74 20 30 20 28 69 66 20 ...(count 0 (if
b210: 28 63 68 61 72 3d 3f 20 63 72 69 74 65 72 69 6f (char=? criterio
b220: 6e 20 28 73 74 72 69 6e 67 2d 72 65 66 20 73 20 n (string-ref s
b230: 69 29 29 0a 09 09 09 20 20 20 20 20 28 2b 20 63 i)).... (+ c
b240: 6f 75 6e 74 20 31 29 0a 09 09 09 20 20 20 20 20 ount 1)....
b250: 63 6f 75 6e 74 29 29 29 0a 09 20 20 20 20 20 20 count)))..
b260: 20 28 28 3e 3d 20 69 20 65 6e 64 29 20 63 6f 75 ((>= i end) cou
b270: 6e 74 29 29 29 0a 0a 09 20 20 28 28 63 68 61 72 nt)))... ((char
b280: 2d 73 65 74 3f 20 63 72 69 74 65 72 69 6f 6e 29 -set? criterion)
b290: 0a 09 20 20 20 28 64 6f 20 28 28 69 20 73 74 61 .. (do ((i sta
b2a0: 72 74 20 28 2b 20 69 20 31 29 29 0a 09 09 28 63 rt (+ i 1))...(c
b2b0: 6f 75 6e 74 20 30 20 28 69 66 20 28 63 68 61 72 ount 0 (if (char
b2c0: 2d 73 65 74 2d 63 6f 6e 74 61 69 6e 73 3f 20 63 -set-contains? c
b2d0: 72 69 74 65 72 69 6f 6e 20 28 73 74 72 69 6e 67 riterion (string
b2e0: 2d 72 65 66 20 73 20 69 29 29 0a 09 09 09 20 20 -ref s i))....
b2f0: 20 20 20 28 2b 20 63 6f 75 6e 74 20 31 29 0a 09 (+ count 1)..
b300: 09 09 20 20 20 20 20 63 6f 75 6e 74 29 29 29 0a .. count))).
b310: 09 20 20 20 20 20 20 20 28 28 3e 3d 20 69 20 65 . ((>= i e
b320: 6e 64 29 20 63 6f 75 6e 74 29 29 29 0a 0a 09 20 nd) count)))...
b330: 20 28 28 70 72 6f 63 65 64 75 72 65 3f 20 63 72 ((procedure? cr
b340: 69 74 65 72 69 6f 6e 29 0a 09 20 20 20 28 64 6f iterion).. (do
b350: 20 28 28 69 20 73 74 61 72 74 20 28 2b 20 69 20 ((i start (+ i
b360: 31 29 29 0a 09 09 28 63 6f 75 6e 74 20 30 20 28 1))...(count 0 (
b370: 69 66 20 28 63 72 69 74 65 72 69 6f 6e 20 28 73 if (criterion (s
b380: 74 72 69 6e 67 2d 72 65 66 20 73 20 69 29 29 20 tring-ref s i))
b390: 28 2b 20 63 6f 75 6e 74 20 31 29 20 63 6f 75 6e (+ count 1) coun
b3a0: 74 29 29 29 0a 09 20 20 20 20 20 20 20 28 28 3e t))).. ((>
b3b0: 3d 20 69 20 65 6e 64 29 20 63 6f 75 6e 74 29 29 = i end) count))
b3c0: 29 0a 0a 09 20 20 28 65 6c 73 65 20 28 65 72 72 )... (else (err
b3d0: 6f 72 20 22 43 52 49 54 45 52 49 4f 4e 20 70 61 or "CRITERION pa
b3e0: 72 61 6d 20 69 73 20 6e 65 69 74 68 65 72 20 63 ram is neither c
b3f0: 68 61 72 2d 73 65 74 20 6f 72 20 63 68 61 72 2e har-set or char.
b400: 22 0a 09 09 20 20 20 20 20 20 20 73 74 72 69 6e "... strin
b410: 67 2d 63 6f 75 6e 74 20 63 72 69 74 65 72 69 6f g-count criterio
b420: 6e 29 29 29 29 29 0a 0a 0a 0c 0a 3b 3b 3b 3b 3b n))))).....;;;;;
b430: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
b440: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
b450: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
b460: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
b470: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 0a 3b 3b 3b 20 73 ;;;;;;;;;;.;;; s
b480: 74 72 69 6e 67 2d 66 69 6c 6c 21 20 73 74 72 69 tring-fill! stri
b490: 6e 67 20 63 68 61 72 20 5b 73 74 61 72 74 20 65 ng char [start e
b4a0: 6e 64 5d 0a 3b 3b 3b 20 0a 3b 3b 3b 20 73 74 72 nd].;;; .;;; str
b4b0: 69 6e 67 2d 63 6f 70 79 21 20 74 6f 20 74 73 74 ing-copy! to tst
b4c0: 61 72 74 20 66 72 6f 6d 20 5b 66 73 74 61 72 74 art from [fstart
b4d0: 20 66 65 6e 64 5d 0a 3b 3b 3b 20 09 47 75 61 72 fend].;;; .Guar
b4e0: 61 6e 74 65 65 64 20 74 6f 20 77 6f 72 6b 2c 20 anteed to work,
b4f0: 65 76 65 6e 20 69 66 20 73 31 20 65 71 20 73 32 even if s1 eq s2
b500: 2e 0a 0a 28 64 65 66 69 6e 65 20 28 73 74 72 69 ...(define (stri
b510: 6e 67 2d 66 69 6c 6c 21 20 73 20 63 68 61 72 20 ng-fill! s char
b520: 2e 20 6d 61 79 62 65 2d 73 74 61 72 74 2b 65 6e . maybe-start+en
b530: 64 29 0a 20 20 28 63 68 65 63 6b 2d 61 72 67 20 d). (check-arg
b540: 63 68 61 72 3f 20 63 68 61 72 20 73 74 72 69 6e char? char strin
b550: 67 2d 66 69 6c 6c 21 29 0a 20 20 28 6c 65 74 2d g-fill!). (let-
b560: 73 74 72 69 6e 67 2d 73 74 61 72 74 2b 65 6e 64 string-start+end
b570: 20 28 73 74 61 72 74 20 65 6e 64 29 20 73 74 72 (start end) str
b580: 69 6e 67 2d 66 69 6c 6c 21 20 73 20 6d 61 79 62 ing-fill! s mayb
b590: 65 2d 73 74 61 72 74 2b 65 6e 64 0a 20 20 20 20 e-start+end.
b5a0: 28 64 6f 20 28 28 69 20 28 2d 20 65 6e 64 20 31 (do ((i (- end 1
b5b0: 29 20 28 2d 20 69 20 31 29 29 29 0a 09 28 28 3c ) (- i 1)))..((<
b5c0: 20 69 20 73 74 61 72 74 29 29 0a 20 20 20 20 20 i start)).
b5d0: 20 28 73 74 72 69 6e 67 2d 73 65 74 21 20 73 20 (string-set! s
b5e0: 69 20 63 68 61 72 29 29 29 29 0a 0a 28 64 65 66 i char))))..(def
b5f0: 69 6e 65 20 28 73 74 72 69 6e 67 2d 63 6f 70 79 ine (string-copy
b600: 21 20 74 6f 20 74 73 74 61 72 74 20 66 72 6f 6d ! to tstart from
b610: 20 2e 20 6d 61 79 62 65 2d 66 73 74 61 72 74 2b . maybe-fstart+
b620: 66 65 6e 64 29 0a 20 20 28 6c 65 74 2d 73 74 72 fend). (let-str
b630: 69 6e 67 2d 73 74 61 72 74 2b 65 6e 64 20 28 66 ing-start+end (f
b640: 73 74 61 72 74 20 66 65 6e 64 29 20 73 74 72 69 start fend) stri
b650: 6e 67 2d 63 6f 70 79 21 20 66 72 6f 6d 20 6d 61 ng-copy! from ma
b660: 79 62 65 2d 66 73 74 61 72 74 2b 66 65 6e 64 0a ybe-fstart+fend.
b670: 20 20 20 20 28 63 68 65 63 6b 2d 61 72 67 20 69 (check-arg i
b680: 6e 74 65 67 65 72 3f 20 74 73 74 61 72 74 20 73 nteger? tstart s
b690: 74 72 69 6e 67 2d 63 6f 70 79 21 29 0a 20 20 20 tring-copy!).
b6a0: 20 28 63 68 65 63 6b 2d 73 75 62 73 74 72 69 6e (check-substrin
b6b0: 67 2d 73 70 65 63 20 73 74 72 69 6e 67 2d 63 6f g-spec string-co
b6c0: 70 79 21 20 74 6f 20 74 73 74 61 72 74 20 28 2b py! to tstart (+
b6d0: 20 74 73 74 61 72 74 20 28 2d 20 66 65 6e 64 20 tstart (- fend
b6e0: 66 73 74 61 72 74 29 29 29 0a 20 20 20 20 28 25 fstart))). (%
b6f0: 73 74 72 69 6e 67 2d 63 6f 70 79 21 20 74 6f 20 string-copy! to
b700: 74 73 74 61 72 74 20 66 72 6f 6d 20 66 73 74 61 tstart from fsta
b710: 72 74 20 66 65 6e 64 29 29 29 0a 0a 3b 3b 3b 20 rt fend)))..;;;
b720: 4c 69 62 72 61 72 79 2d 69 6e 74 65 72 6e 61 6c Library-internal
b730: 20 72 6f 75 74 69 6e 65 0a 28 64 65 66 69 6e 65 routine.(define
b740: 20 28 25 73 74 72 69 6e 67 2d 63 6f 70 79 21 20 (%string-copy!
b750: 74 6f 20 74 73 74 61 72 74 20 66 72 6f 6d 20 66 to tstart from f
b760: 73 74 61 72 74 20 66 65 6e 64 29 0a 20 20 28 69 start fend). (i
b770: 66 20 28 3e 20 66 73 74 61 72 74 20 74 73 74 61 f (> fstart tsta
b780: 72 74 29 0a 20 20 20 20 20 20 28 64 6f 20 28 28 rt). (do ((
b790: 69 20 66 73 74 61 72 74 20 28 2b 20 69 20 31 29 i fstart (+ i 1)
b7a0: 29 0a 09 20 20 20 28 6a 20 74 73 74 61 72 74 20 ).. (j tstart
b7b0: 28 2b 20 6a 20 31 29 29 29 0a 09 20 20 28 28 3e (+ j 1))).. ((>
b7c0: 3d 20 69 20 66 65 6e 64 29 29 0a 09 28 73 74 72 = i fend))..(str
b7d0: 69 6e 67 2d 73 65 74 21 20 74 6f 20 6a 20 28 73 ing-set! to j (s
b7e0: 74 72 69 6e 67 2d 72 65 66 20 66 72 6f 6d 20 69 tring-ref from i
b7f0: 29 29 29 0a 0a 20 20 20 20 20 20 28 64 6f 20 28 ))).. (do (
b800: 28 69 20 28 2d 20 66 65 6e 64 20 31 29 20 20 20 (i (- fend 1)
b810: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b820: 20 28 2d 20 69 20 31 29 29 0a 09 20 20 20 28 6a (- i 1)).. (j
b830: 20 28 2b 20 2d 31 20 74 73 74 61 72 74 20 28 2d (+ -1 tstart (-
b840: 20 66 65 6e 64 20 66 73 74 61 72 74 29 29 20 28 fend fstart)) (
b850: 2d 20 6a 20 31 29 29 29 0a 09 20 20 28 28 3c 20 - j 1))).. ((<
b860: 69 20 66 73 74 61 72 74 29 29 0a 09 28 73 74 72 i fstart))..(str
b870: 69 6e 67 2d 73 65 74 21 20 74 6f 20 6a 20 28 73 ing-set! to j (s
b880: 74 72 69 6e 67 2d 72 65 66 20 66 72 6f 6d 20 69 tring-ref from i
b890: 29 29 29 29 29 0a 0a 0a 0c 0a 3b 3b 3b 20 52 65 ))))).....;;; Re
b8a0: 74 75 72 6e 73 20 73 74 61 72 74 69 6e 67 2d 70 turns starting-p
b8b0: 6f 73 69 74 69 6f 6e 20 69 6e 20 53 54 52 49 4e osition in STRIN
b8c0: 47 20 6f 72 20 23 66 20 69 66 20 6e 6f 74 20 74 G or #f if not t
b8d0: 72 75 65 2e 0a 3b 3b 3b 20 54 68 69 73 20 69 6d rue..;;; This im
b8e0: 70 6c 65 6d 65 6e 74 61 74 69 6f 6e 20 69 73 20 plementation is
b8f0: 73 6c 6f 77 20 26 20 73 69 6d 70 6c 65 2e 20 49 slow & simple. I
b900: 74 20 69 73 20 75 73 65 66 75 6c 20 61 73 20 61 t is useful as a
b910: 20 22 73 70 65 63 22 20 6f 72 20 66 6f 72 0a 3b "spec" or for.;
b920: 3b 3b 20 63 6f 6d 70 61 72 69 73 6f 6e 20 74 65 ;; comparison te
b930: 73 74 69 6e 67 20 77 69 74 68 20 66 61 6e 63 69 sting with fanci
b940: 65 72 20 69 6d 70 6c 65 6d 65 6e 74 61 74 69 6f er implementatio
b950: 6e 73 2e 0a 3b 3b 3b 20 53 65 65 20 62 65 6c 6f ns..;;; See belo
b960: 77 20 66 6f 72 20 66 61 73 74 20 4b 4d 50 20 76 w for fast KMP v
b970: 65 72 73 69 6f 6e 2e 0a 0a 3b 28 64 65 66 69 6e ersion...;(defin
b980: 65 20 28 73 74 72 69 6e 67 2d 63 6f 6e 74 61 69 e (string-contai
b990: 6e 73 20 73 74 72 69 6e 67 20 73 75 62 73 74 72 ns string substr
b9a0: 69 6e 67 20 2e 20 6d 61 79 62 65 2d 73 74 61 72 ing . maybe-star
b9b0: 74 73 2b 65 6e 64 73 29 0a 3b 20 20 28 6c 65 74 ts+ends).; (let
b9c0: 2d 73 74 72 69 6e 67 2d 73 74 61 72 74 2b 65 6e -string-start+en
b9d0: 64 32 20 28 73 74 61 72 74 31 20 65 6e 64 31 20 d2 (start1 end1
b9e0: 73 74 61 72 74 32 20 65 6e 64 32 29 20 0a 3b 20 start2 end2) .;
b9f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ba00: 20 20 20 20 20 20 20 20 73 74 72 69 6e 67 2d 63 string-c
ba10: 6f 6e 74 61 69 6e 73 20 73 74 72 69 6e 67 20 73 ontains string s
ba20: 75 62 73 74 72 69 6e 67 20 6d 61 79 62 65 2d 73 ubstring maybe-s
ba30: 74 61 72 74 73 2b 65 6e 64 73 0a 3b 20 20 20 20 tarts+ends.;
ba40: 28 6c 65 74 2a 20 28 28 6c 65 6e 20 28 2d 20 65 (let* ((len (- e
ba50: 6e 64 32 20 73 74 61 72 74 32 29 29 0a 3b 09 20 nd2 start2)).;.
ba60: 20 20 28 69 2d 62 6f 75 6e 64 20 28 2d 20 65 6e (i-bound (- en
ba70: 64 31 20 6c 65 6e 29 29 29 0a 3b 20 20 20 20 20 d1 len))).;
ba80: 20 28 6c 65 74 20 6c 70 20 28 28 69 20 73 74 61 (let lp ((i sta
ba90: 72 74 31 29 29 0a 3b 09 28 61 6e 64 20 28 3c 20 rt1)).;.(and (<
baa0: 69 20 69 2d 62 6f 75 6e 64 29 0a 3b 09 20 20 20 i i-bound).;.
bab0: 20 20 28 69 66 20 28 73 74 72 69 6e 67 3d 20 73 (if (string= s
bac0: 74 72 69 6e 67 20 73 75 62 73 74 72 69 6e 67 20 tring substring
bad0: 69 20 28 2b 20 69 20 6c 65 6e 29 20 73 74 61 72 i (+ i len) star
bae0: 74 32 20 65 6e 64 32 29 0a 3b 09 09 20 69 0a 3b t2 end2).;.. i.;
baf0: 09 09 20 28 6c 70 20 28 2b 20 69 20 31 29 29 29 .. (lp (+ i 1)))
bb00: 29 29 29 29 29 0a 0a 0a 3b 3b 3b 20 53 65 61 72 )))))...;;; Sear
bb10: 63 68 69 6e 67 20 66 6f 72 20 61 6e 20 6f 63 63 ching for an occ
bb20: 75 72 72 65 6e 63 65 20 6f 66 20 61 20 73 75 62 urrence of a sub
bb30: 73 74 72 69 6e 67 0a 3b 3b 3b 3b 3b 3b 3b 3b 3b string.;;;;;;;;;
bb40: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
bb50: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
bb60: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
bb70: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
bb80: 3b 3b 3b 3b 3b 3b 0a 0a 28 64 65 66 69 6e 65 20 ;;;;;;..(define
bb90: 28 73 74 72 69 6e 67 2d 63 6f 6e 74 61 69 6e 73 (string-contains
bba0: 20 74 65 78 74 20 70 61 74 74 65 72 6e 20 2e 20 text pattern .
bbb0: 6d 61 79 62 65 2d 73 74 61 72 74 73 2b 65 6e 64 maybe-starts+end
bbc0: 73 29 0a 20 20 28 6c 65 74 2d 73 74 72 69 6e 67 s). (let-string
bbd0: 2d 73 74 61 72 74 2b 65 6e 64 32 20 28 74 2d 73 -start+end2 (t-s
bbe0: 74 61 72 74 20 74 2d 65 6e 64 20 70 2d 73 74 61 tart t-end p-sta
bbf0: 72 74 20 70 2d 65 6e 64 29 0a 20 20 20 20 20 20 rt p-end).
bc00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
bc10: 20 20 20 73 74 72 69 6e 67 2d 63 6f 6e 74 61 69 string-contai
bc20: 6e 73 20 74 65 78 74 20 70 61 74 74 65 72 6e 20 ns text pattern
bc30: 6d 61 79 62 65 2d 73 74 61 72 74 73 2b 65 6e 64 maybe-starts+end
bc40: 73 0a 20 20 20 20 28 25 6b 6d 70 2d 73 65 61 72 s. (%kmp-sear
bc50: 63 68 20 70 61 74 74 65 72 6e 20 74 65 78 74 20 ch pattern text
bc60: 63 68 61 72 3d 3f 20 70 2d 73 74 61 72 74 20 70 char=? p-start p
bc70: 2d 65 6e 64 20 74 2d 73 74 61 72 74 20 74 2d 65 -end t-start t-e
bc80: 6e 64 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 nd)))..(define (
bc90: 73 74 72 69 6e 67 2d 63 6f 6e 74 61 69 6e 73 2d string-contains-
bca0: 63 69 20 74 65 78 74 20 70 61 74 74 65 72 6e 20 ci text pattern
bcb0: 2e 20 6d 61 79 62 65 2d 73 74 61 72 74 73 2b 65 . maybe-starts+e
bcc0: 6e 64 73 29 0a 20 20 28 6c 65 74 2d 73 74 72 69 nds). (let-stri
bcd0: 6e 67 2d 73 74 61 72 74 2b 65 6e 64 32 20 28 74 ng-start+end2 (t
bce0: 2d 73 74 61 72 74 20 74 2d 65 6e 64 20 70 2d 73 -start t-end p-s
bcf0: 74 61 72 74 20 70 2d 65 6e 64 29 0a 20 20 20 20 tart p-end).
bd00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
bd10: 20 20 20 20 20 73 74 72 69 6e 67 2d 63 6f 6e 74 string-cont
bd20: 61 69 6e 73 2d 63 69 20 74 65 78 74 20 70 61 74 ains-ci text pat
bd30: 74 65 72 6e 20 6d 61 79 62 65 2d 73 74 61 72 74 tern maybe-start
bd40: 73 2b 65 6e 64 73 0a 20 20 20 20 28 25 6b 6d 70 s+ends. (%kmp
bd50: 2d 73 65 61 72 63 68 20 70 61 74 74 65 72 6e 20 -search pattern
bd60: 74 65 78 74 20 63 68 61 72 2d 63 69 3d 3f 20 70 text char-ci=? p
bd70: 2d 73 74 61 72 74 20 70 2d 65 6e 64 20 74 2d 73 -start p-end t-s
bd80: 74 61 72 74 20 74 2d 65 6e 64 29 29 29 0a 0a 0a tart t-end)))...
bd90: 3b 3b 3b 20 4b 6e 75 74 68 2d 4d 6f 72 72 69 73 ;;; Knuth-Morris
bda0: 2d 50 72 61 74 74 20 73 74 72 69 6e 67 20 73 65 -Pratt string se
bdb0: 61 72 63 68 69 6e 67 0a 3b 3b 3b 3b 3b 3b 3b 3b arching.;;;;;;;;
bdc0: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
bdd0: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
bde0: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
bdf0: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
be00: 3b 3b 3b 3b 3b 3b 3b 0a 3b 3b 3b 20 53 65 65 0a ;;;;;;;.;;; See.
be10: 3b 3b 3b 20 20 20 20 20 22 46 61 73 74 20 70 61 ;;; "Fast pa
be20: 74 74 65 72 6e 20 6d 61 74 63 68 69 6e 67 20 69 ttern matching i
be30: 6e 20 73 74 72 69 6e 67 73 22 0a 3b 3b 3b 20 20 n strings".;;;
be40: 20 20 20 53 49 41 4d 20 4a 2e 20 43 6f 6d 70 75 SIAM J. Compu
be50: 74 69 6e 67 20 36 28 32 29 3a 33 32 33 2d 33 35 ting 6(2):323-35
be60: 30 20 31 39 37 37 0a 3b 3b 3b 20 20 20 20 20 44 0 1977.;;; D
be70: 2e 20 45 2e 20 4b 6e 75 74 68 2c 20 4a 2e 20 48 . E. Knuth, J. H
be80: 2e 20 4d 6f 72 72 69 73 20 61 6e 64 20 56 2e 20 . Morris and V.
be90: 52 2e 20 50 72 61 74 74 0a 3b 3b 3b 20 61 6c 73 R. Pratt.;;; als
bea0: 6f 20 64 65 73 63 72 69 62 65 64 20 69 6e 0a 3b o described in.;
beb0: 3b 3b 20 20 20 20 20 22 50 61 74 74 65 72 6e 20 ;; "Pattern
bec0: 6d 61 74 63 68 69 6e 67 20 69 6e 20 73 74 72 69 matching in stri
bed0: 6e 67 73 22 0a 3b 3b 3b 20 20 20 20 20 41 6c 66 ngs".;;; Alf
bee0: 72 65 64 20 56 2e 20 41 68 6f 0a 3b 3b 3b 20 20 red V. Aho.;;;
bef0: 20 20 20 46 6f 72 6d 61 6c 20 4c 61 6e 67 75 61 Formal Langua
bf00: 67 65 20 54 68 65 6f 72 79 20 2d 20 50 65 72 73 ge Theory - Pers
bf10: 70 65 63 74 69 76 65 73 20 61 6e 64 20 4f 70 65 pectives and Ope
bf20: 6e 20 50 72 6f 62 6c 65 6d 73 0a 3b 3b 3b 20 20 n Problems.;;;
bf30: 20 20 20 52 6f 6e 61 6c 64 20 56 2e 20 42 72 6f Ronald V. Bro
bf40: 6f 6b 20 28 65 64 69 74 6f 72 29 0a 3b 3b 3b 20 ok (editor).;;;
bf50: 54 68 69 73 20 61 6c 67 6f 72 69 74 68 6d 20 69 This algorithm i
bf60: 73 20 4f 28 6d 20 2b 20 6e 29 20 77 68 65 72 65 s O(m + n) where
bf70: 20 6d 20 61 6e 64 20 6e 20 61 72 65 20 74 68 65 m and n are the
bf80: 20 0a 3b 3b 3b 20 6c 65 6e 67 74 68 73 20 6f 66 .;;; lengths of
bf90: 20 74 68 65 20 70 61 74 74 65 72 6e 20 61 6e 64 the pattern and
bfa0: 20 73 74 72 69 6e 67 20 72 65 73 70 65 63 74 69 string respecti
bfb0: 76 65 6c 79 0a 0a 3b 3b 3b 20 4b 4d 50 20 73 65 vely..;;; KMP se
bfc0: 61 72 63 68 20 73 6f 75 72 63 65 5b 73 74 61 72 arch source[star
bfd0: 74 2c 65 6e 64 29 20 66 6f 72 20 50 41 54 54 45 t,end) for PATTE
bfe0: 52 4e 2e 20 52 65 74 75 72 6e 20 73 74 61 72 74 RN. Return start
bff0: 69 6e 67 20 69 6e 64 65 78 20 6f 66 0a 3b 3b 3b ing index of.;;;
c000: 20 6c 65 66 74 6d 6f 73 74 20 6d 61 74 63 68 20 leftmost match
c010: 6f 72 20 23 66 2e 0a 0a 28 64 65 66 69 6e 65 20 or #f...(define
c020: 28 25 6b 6d 70 2d 73 65 61 72 63 68 20 70 61 74 (%kmp-search pat
c030: 74 65 72 6e 20 74 65 78 74 20 63 3d 20 70 2d 73 tern text c= p-s
c040: 74 61 72 74 20 70 2d 65 6e 64 20 74 2d 73 74 61 tart p-end t-sta
c050: 72 74 20 74 2d 65 6e 64 29 0a 20 20 28 6c 65 74 rt t-end). (let
c060: 20 28 28 70 6c 65 6e 20 28 2d 20 70 2d 65 6e 64 ((plen (- p-end
c070: 20 70 2d 73 74 61 72 74 29 29 0a 09 28 72 76 20 p-start))..(rv
c080: 28 6d 61 6b 65 2d 6b 6d 70 2d 72 65 73 74 61 72 (make-kmp-restar
c090: 74 2d 76 65 63 74 6f 72 20 70 61 74 74 65 72 6e t-vector pattern
c0a0: 20 63 3d 20 70 2d 73 74 61 72 74 20 70 2d 65 6e c= p-start p-en
c0b0: 64 29 29 29 0a 0a 20 20 20 20 3b 3b 20 54 68 65 d))).. ;; The
c0c0: 20 73 65 61 72 63 68 20 6c 6f 6f 70 2e 20 54 4a search loop. TJ
c0d0: 20 26 20 50 4a 20 61 72 65 20 72 65 64 75 6e 64 & PJ are redund
c0e0: 61 6e 74 20 73 74 61 74 65 2e 0a 20 20 20 20 28 ant state.. (
c0f0: 6c 65 74 20 6c 70 20 28 28 74 69 20 74 2d 73 74 let lp ((ti t-st
c100: 61 72 74 29 20 28 70 69 20 30 29 0a 09 20 20 20 art) (pi 0)..
c110: 20 20 28 74 6a 20 28 2d 20 74 2d 65 6e 64 20 74 (tj (- t-end t
c120: 2d 73 74 61 72 74 29 29 20 3b 20 28 2d 20 74 6c -start)) ; (- tl
c130: 65 6e 20 74 69 29 20 2d 2d 20 68 6f 77 20 6d 61 en ti) -- how ma
c140: 6e 79 20 63 68 61 72 73 20 6c 65 66 74 2e 0a 09 ny chars left...
c150: 20 20 20 20 20 28 70 6a 20 70 6c 65 6e 29 29 09 (pj plen)).
c160: 09 20 3b 20 28 2d 20 70 6c 65 6e 20 70 69 29 20 . ; (- plen pi)
c170: 2d 2d 20 68 6f 77 20 6d 61 6e 79 20 63 68 61 72 -- how many char
c180: 73 20 6c 65 66 74 2e 0a 0a 20 20 20 20 20 20 28 s left... (
c190: 69 66 20 28 3d 20 70 69 20 70 6c 65 6e 29 0a 09 if (= pi plen)..
c1a0: 20 20 28 2d 20 74 69 20 70 6c 65 6e 29 09 09 09 (- ti plen)...
c1b0: 3b 20 57 69 6e 2e 0a 09 20 20 28 61 6e 64 20 28 ; Win... (and (
c1c0: 3c 3d 20 70 6a 20 74 6a 29 09 09 3b 20 4c 6f 73 <= pj tj)..; Los
c1d0: 65 2e 0a 09 20 20 20 20 20 20 20 28 69 66 20 28 e... (if (
c1e0: 63 3d 20 28 73 74 72 69 6e 67 2d 72 65 66 20 74 c= (string-ref t
c1f0: 65 78 74 20 74 69 29 20 3b 20 53 65 61 72 63 68 ext ti) ; Search
c200: 2e 0a 09 09 20 20 20 20 20 20 20 28 73 74 72 69 .... (stri
c210: 6e 67 2d 72 65 66 20 70 61 74 74 65 72 6e 20 28 ng-ref pattern (
c220: 2b 20 70 2d 73 74 61 72 74 20 70 69 29 29 29 0a + p-start pi))).
c230: 09 09 20 20 20 28 6c 70 20 28 2b 20 31 20 74 69 .. (lp (+ 1 ti
c240: 29 20 28 2b 20 31 20 70 69 29 20 28 2d 20 74 6a ) (+ 1 pi) (- tj
c250: 20 31 29 20 28 2d 20 70 6a 20 31 29 29 20 3b 20 1) (- pj 1)) ;
c260: 41 64 76 61 6e 63 65 2e 0a 09 09 20 20 20 0a 09 Advance.... ..
c270: 09 20 20 20 28 6c 65 74 20 28 28 70 69 20 28 76 . (let ((pi (v
c280: 65 63 74 6f 72 2d 72 65 66 20 72 76 20 70 69 29 ector-ref rv pi)
c290: 29 29 20 3b 20 52 65 74 72 65 61 74 2e 0a 09 09 )) ; Retreat....
c2a0: 20 20 20 20 20 28 69 66 20 28 3d 20 70 69 20 2d (if (= pi -
c2b0: 31 29 0a 09 09 09 20 28 6c 70 20 28 2b 20 74 69 1).... (lp (+ ti
c2c0: 20 31 29 20 30 20 20 28 2d 20 74 6a 20 31 29 20 1) 0 (- tj 1)
c2d0: 70 6c 65 6e 29 20 3b 20 50 75 6e 74 2e 0a 09 09 plen) ; Punt....
c2e0: 09 20 28 6c 70 20 74 69 20 20 20 20 20 20 20 70 . (lp ti p
c2f0: 69 20 74 6a 20 20 20 20 20 20 20 28 2d 20 70 6c i tj (- pl
c300: 65 6e 20 70 69 29 29 29 29 29 29 29 29 29 29 0a en pi)))))))))).
c310: 0a 3b 3b 3b 20 28 6d 61 6b 65 2d 6b 6d 70 2d 72 .;;; (make-kmp-r
c320: 65 73 74 61 72 74 2d 76 65 63 74 6f 72 20 70 61 estart-vector pa
c330: 74 74 65 72 6e 20 5b 63 3d 20 73 74 61 72 74 20 ttern [c= start
c340: 65 6e 64 5d 29 20 2d 3e 20 69 6e 74 65 67 65 72 end]) -> integer
c350: 2d 76 65 63 74 6f 72 0a 3b 3b 3b 3b 3b 3b 3b 3b -vector.;;;;;;;;
c360: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
c370: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
c380: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
c390: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
c3a0: 3b 3b 3b 3b 3b 3b 3b 0a 3b 3b 3b 20 43 6f 6d 70 ;;;;;;;.;;; Comp
c3b0: 75 74 65 20 74 68 65 20 4b 4d 50 20 72 65 73 74 ute the KMP rest
c3c0: 61 72 74 20 76 65 63 74 6f 72 20 52 56 20 66 6f art vector RV fo
c3d0: 72 20 73 74 72 69 6e 67 20 50 41 54 54 45 52 4e r string PATTERN
c3e0: 2e 20 20 49 66 0a 3b 3b 3b 20 77 65 20 68 61 76 . If.;;; we hav
c3f0: 65 20 6d 61 74 63 68 65 64 20 63 68 61 72 73 20 e matched chars
c400: 30 2e 2e 69 2d 31 20 6f 66 20 50 41 54 54 45 52 0..i-1 of PATTER
c410: 4e 20 61 67 61 69 6e 73 74 20 61 20 73 65 61 72 N against a sear
c420: 63 68 20 73 74 72 69 6e 67 20 53 2c 20 61 6e 64 ch string S, and
c430: 0a 3b 3b 3b 20 50 41 54 54 45 52 4e 5b 69 5d 20 .;;; PATTERN[i]
c440: 64 6f 65 73 6e 27 74 20 6d 61 74 63 68 20 53 5b doesn't match S[
c450: 6b 5d 2c 20 74 68 65 6e 20 72 65 73 65 74 20 69 k], then reset i
c460: 20 3a 3d 20 52 56 5b 69 5d 2c 20 61 6e 64 20 74 := RV[i], and t
c470: 72 79 20 61 67 61 69 6e 20 74 6f 0a 3b 3b 3b 20 ry again to.;;;
c480: 6d 61 74 63 68 20 53 5b 6b 5d 2e 20 20 49 66 20 match S[k]. If
c490: 52 56 5b 69 5d 20 3d 20 2d 31 2c 20 74 68 65 6e RV[i] = -1, then
c4a0: 20 70 75 6e 74 20 53 5b 6b 5d 20 63 6f 6d 70 6c punt S[k] compl
c4b0: 65 74 65 6c 79 2c 20 61 6e 64 20 6d 6f 76 65 20 etely, and move
c4c0: 6f 6e 20 74 6f 0a 3b 3b 3b 20 53 5b 6b 2b 31 5d on to.;;; S[k+1]
c4d0: 20 61 6e 64 20 50 41 54 54 45 52 4e 5b 30 5d 20 and PATTERN[0]
c4e0: 2d 2d 20 6e 6f 20 70 6f 73 73 69 62 6c 65 20 6d -- no possible m
c4f0: 61 74 63 68 20 6f 66 20 50 41 54 5b 30 2e 2e 69 atch of PAT[0..i
c500: 5d 20 63 6f 6e 74 61 69 6e 73 20 53 5b 6b 5d 2e ] contains S[k].
c510: 0a 3b 3b 3b 0a 3b 3b 3b 20 49 6e 20 6f 74 68 65 .;;;.;;; In othe
c520: 72 20 77 6f 72 64 73 2c 20 69 66 20 79 6f 75 20 r words, if you
c530: 68 61 76 65 20 6d 61 74 63 68 65 64 20 74 68 65 have matched the
c540: 20 66 69 72 73 74 20 69 20 63 68 61 72 73 20 6f first i chars o
c550: 66 20 50 41 54 54 45 52 4e 2c 20 62 75 74 0a 3b f PATTERN, but.;
c560: 3b 3b 20 74 68 65 20 69 2b 31 27 74 68 20 63 68 ;; the i+1'th ch
c570: 61 72 20 64 6f 65 73 6e 27 74 20 6d 61 74 63 68 ar doesn't match
c580: 2c 20 52 56 5b 69 5d 20 74 65 6c 6c 73 20 79 6f , RV[i] tells yo
c590: 75 20 77 68 61 74 20 74 68 65 20 6e 65 78 74 2d u what the next-
c5a0: 6c 6f 6e 67 65 73 74 0a 3b 3b 3b 20 70 72 65 66 longest.;;; pref
c5b0: 69 78 20 6f 66 20 50 41 54 54 45 52 4e 20 69 73 ix of PATTERN is
c5c0: 20 74 68 61 74 20 79 6f 75 20 68 61 76 65 20 6d that you have m
c5d0: 61 74 63 68 65 64 2e 0a 3b 3b 3b 0a 3b 3b 3b 20 atched..;;;.;;;
c5e0: 2d 20 43 3d 20 28 64 65 66 61 75 6c 74 20 43 48 - C= (default CH
c5f0: 41 52 3d 3f 29 20 69 73 20 75 73 65 64 20 74 6f AR=?) is used to
c600: 20 63 6f 6d 70 61 72 65 20 63 68 61 72 61 63 74 compare charact
c610: 65 72 73 20 66 6f 72 20 65 71 75 61 6c 69 74 79 ers for equality
c620: 2e 0a 3b 3b 3b 20 20 20 50 61 73 73 20 69 6e 20 ..;;; Pass in
c630: 43 48 41 52 2d 43 49 3d 3f 20 66 6f 72 20 63 61 CHAR-CI=? for ca
c640: 73 65 2d 66 6f 6c 64 65 64 20 73 74 72 69 6e 67 se-folded string
c650: 20 73 65 61 72 63 68 2e 0a 3b 3b 3b 0a 3b 3b 3b search..;;;.;;;
c660: 20 2d 20 53 54 41 52 54 20 26 20 45 4e 44 20 72 - START & END r
c670: 65 73 74 72 69 63 74 20 74 68 65 20 70 61 74 74 estrict the patt
c680: 65 72 6e 20 74 6f 20 74 68 65 20 69 6e 64 69 63 ern to the indic
c690: 61 74 65 64 20 73 75 62 73 74 72 69 6e 67 3b 20 ated substring;
c6a0: 74 68 65 0a 3b 3b 3b 20 20 20 72 65 74 75 72 6e the.;;; return
c6b0: 65 64 20 76 65 63 74 6f 72 20 77 69 6c 6c 20 62 ed vector will b
c6c0: 65 20 6f 66 20 6c 65 6e 67 74 68 20 45 4e 44 20 e of length END
c6d0: 2d 20 53 54 41 52 54 2e 20 54 68 65 20 6e 75 6d - START. The num
c6e0: 62 65 72 73 20 73 74 6f 72 65 64 0a 3b 3b 3b 20 bers stored.;;;
c6f0: 20 20 69 6e 20 74 68 65 20 76 65 63 74 6f 72 20 in the vector
c700: 77 69 6c 6c 20 62 65 20 76 61 6c 75 65 73 20 69 will be values i
c710: 6e 20 74 68 65 20 72 61 6e 67 65 20 5b 30 2c 45 n the range [0,E
c720: 4e 44 2d 53 54 41 52 54 29 20 2d 2d 20 74 68 61 ND-START) -- tha
c730: 74 20 69 73 2c 0a 3b 3b 3b 20 20 20 74 68 65 79 t is,.;;; they
c740: 20 61 72 65 20 76 61 6c 69 64 20 69 6e 64 69 63 are valid indic
c750: 65 73 20 69 6e 74 6f 20 74 68 65 20 72 65 73 74 es into the rest
c760: 61 72 74 20 76 65 63 74 6f 72 3b 20 79 6f 75 20 art vector; you
c770: 68 61 76 65 20 74 6f 20 61 64 64 20 53 54 41 52 have to add STAR
c780: 54 0a 3b 3b 3b 20 20 20 74 6f 20 74 68 65 6d 20 T.;;; to them
c790: 74 6f 20 75 73 65 20 74 68 65 6d 20 61 73 20 69 to use them as i
c7a0: 6e 64 69 63 65 73 20 69 6e 74 6f 20 50 41 54 54 ndices into PATT
c7b0: 45 52 4e 2e 0a 3b 3b 3b 0a 3b 3b 3b 20 49 27 76 ERN..;;;.;;; I'v
c7c0: 65 20 73 70 6c 69 74 20 74 68 69 73 20 6f 75 74 e split this out
c7d0: 20 61 73 20 61 20 73 65 70 61 72 61 74 65 20 66 as a separate f
c7e0: 75 6e 63 74 69 6f 6e 20 69 6e 20 63 61 73 65 20 unction in case
c7f0: 6f 74 68 65 72 20 63 6f 6e 73 74 61 6e 74 2d 73 other constant-s
c800: 74 72 69 6e 67 0a 3b 3b 3b 20 73 65 61 72 63 68 tring.;;; search
c810: 65 72 73 20 6d 69 67 68 74 20 77 61 6e 74 20 74 ers might want t
c820: 6f 20 75 73 65 20 69 74 2e 0a 3b 3b 3b 0a 3b 3b o use it..;;;.;;
c830: 3b 20 45 2e 67 2e 3a 0a 3b 3b 3b 20 20 20 20 61 ; E.g.:.;;; a
c840: 20 62 20 64 20 20 61 20 62 20 78 0a 3b 3b 3b 20 b d a b x.;;;
c850: 23 28 2d 31 20 30 20 30 20 2d 31 20 31 20 32 29 #(-1 0 0 -1 1 2)
c860: 0a 0a 28 64 65 66 69 6e 65 20 28 6d 61 6b 65 2d ..(define (make-
c870: 6b 6d 70 2d 72 65 73 74 61 72 74 2d 76 65 63 74 kmp-restart-vect
c880: 6f 72 20 70 61 74 74 65 72 6e 20 2e 20 6d 61 79 or pattern . may
c890: 62 65 2d 63 3d 2b 73 74 61 72 74 2b 65 6e 64 29 be-c=+start+end)
c8a0: 0a 20 20 28 6c 65 74 2d 6f 70 74 69 6f 6e 61 6c . (let-optional
c8b0: 73 2a 20 6d 61 79 62 65 2d 63 3d 2b 73 74 61 72 s* maybe-c=+star
c8c0: 74 2b 65 6e 64 0a 20 20 20 20 20 20 20 20 20 20 t+end.
c8d0: 20 20 20 20 20 20 20 20 28 28 63 3d 20 63 68 61 ((c= cha
c8e0: 72 3d 3f 20 28 70 72 6f 63 65 64 75 72 65 3f 20 r=? (procedure?
c8f0: 63 3d 29 29 0a 09 09 20 20 20 28 28 73 74 61 72 c=))... ((star
c900: 74 20 65 6e 64 29 20 28 6c 61 6d 62 64 61 20 28 t end) (lambda (
c910: 61 72 67 73 29 0a 09 09 09 09 20 20 28 73 74 72 args)..... (str
c920: 69 6e 67 2d 70 61 72 73 65 2d 73 74 61 72 74 2b ing-parse-start+
c930: 65 6e 64 20 6d 61 6b 65 2d 6b 6d 70 2d 72 65 73 end make-kmp-res
c940: 74 61 72 74 2d 76 65 63 74 6f 72 0a 09 09 09 09 tart-vector.....
c950: 09 09 09 20 20 70 61 74 74 65 72 6e 20 61 72 67 ... pattern arg
c960: 73 29 29 29 29 0a 20 20 20 20 28 6c 65 74 2a 20 s)))). (let*
c970: 28 28 72 76 6c 65 6e 20 28 2d 20 65 6e 64 20 73 ((rvlen (- end s
c980: 74 61 72 74 29 29 0a 09 20 20 20 28 72 76 20 28 tart)).. (rv (
c990: 6d 61 6b 65 2d 76 65 63 74 6f 72 20 72 76 6c 65 make-vector rvle
c9a0: 6e 20 2d 31 29 29 29 0a 20 20 20 20 20 20 28 69 n -1))). (i
c9b0: 66 20 28 3e 20 72 76 6c 65 6e 20 30 29 0a 09 20 f (> rvlen 0)..
c9c0: 20 28 6c 65 74 20 28 28 72 76 6c 65 6e 2d 31 20 (let ((rvlen-1
c9d0: 28 2d 20 72 76 6c 65 6e 20 31 29 29 0a 09 09 28 (- rvlen 1))...(
c9e0: 63 30 20 28 73 74 72 69 6e 67 2d 72 65 66 20 70 c0 (string-ref p
c9f0: 61 74 74 65 72 6e 20 73 74 61 72 74 29 29 29 0a attern start))).
ca00: 0a 09 20 20 20 20 3b 3b 20 48 65 72 65 27 73 20 .. ;; Here's
ca10: 74 68 65 20 6d 61 69 6e 20 6c 6f 6f 70 2e 20 57 the main loop. W
ca20: 65 20 68 61 76 65 20 73 65 74 20 72 76 5b 30 5d e have set rv[0]
ca30: 20 2e 2e 2e 20 72 76 5b 69 5d 2e 0a 09 20 20 20 ... rv[i]...
ca40: 20 3b 3b 20 4b 20 3d 20 49 20 2b 20 53 54 41 52 ;; K = I + STAR
ca50: 54 20 2d 2d 20 69 74 20 69 73 20 74 68 65 20 63 T -- it is the c
ca60: 6f 72 72 65 73 70 6f 6e 64 69 6e 67 20 69 6e 64 orresponding ind
ca70: 65 78 20 69 6e 74 6f 20 50 41 54 54 45 52 4e 2e ex into PATTERN.
ca80: 0a 09 20 20 20 20 28 6c 65 74 20 6c 70 31 20 28 .. (let lp1 (
ca90: 28 69 20 30 29 20 28 6a 20 2d 31 29 20 28 6b 20 (i 0) (j -1) (k
caa0: 73 74 61 72 74 29 29 09 0a 09 20 20 20 20 20 20 start))...
cab0: 28 69 66 20 28 3c 20 69 20 72 76 6c 65 6e 2d 31 (if (< i rvlen-1
cac0: 29 0a 09 09 20 20 3b 3b 20 6c 70 32 20 69 6e 76 )... ;; lp2 inv
cad0: 61 72 69 61 6e 74 3a 0a 09 09 20 20 3b 3b 20 20 ariant:... ;;
cae0: 20 70 61 74 5b 28 6b 2d 6a 29 20 2e 2e 20 6b 2d pat[(k-j) .. k-
caf0: 31 5d 20 6d 61 74 63 68 65 73 20 70 61 74 5b 73 1] matches pat[s
cb00: 74 61 72 74 20 2e 2e 20 73 74 61 72 74 2b 6a 2d tart .. start+j-
cb10: 31 5d 0a 09 09 20 20 3b 3b 20 20 20 6f 72 20 6a 1]... ;; or j
cb20: 20 3d 20 2d 31 2e 0a 09 09 20 20 28 6c 65 74 20 = -1.... (let
cb30: 6c 70 32 20 28 28 6a 20 6a 29 29 0a 09 09 20 20 lp2 ((j j))...
cb40: 20 20 28 63 6f 6e 64 20 28 28 3d 20 6a 20 2d 31 (cond ((= j -1
cb50: 29 0a 09 09 09 20 20 20 28 6c 65 74 20 28 28 69 ).... (let ((i
cb60: 31 20 28 2b 20 31 20 69 29 29 29 0a 09 09 09 20 1 (+ 1 i)))....
cb70: 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 63 3d (if (not (c=
cb80: 20 28 73 74 72 69 6e 67 2d 72 65 66 20 70 61 74 (string-ref pat
cb90: 74 65 72 6e 20 28 2b 20 6b 20 31 29 29 20 63 30 tern (+ k 1)) c0
cba0: 29 29 0a 09 09 09 09 20 28 76 65 63 74 6f 72 2d ))..... (vector-
cbb0: 73 65 74 21 20 72 76 20 69 31 20 30 29 29 0a 09 set! rv i1 0))..
cbc0: 09 09 20 20 20 20 20 28 6c 70 31 20 69 31 20 30 .. (lp1 i1 0
cbd0: 20 28 2b 20 6b 20 31 29 29 29 29 0a 09 09 09 20 (+ k 1))))....
cbe0: 20 3b 3b 20 70 61 74 5b 28 6b 2d 6a 29 20 2e 2e ;; pat[(k-j) ..
cbf0: 20 6b 5d 20 6d 61 74 63 68 65 73 20 70 61 74 5b k] matches pat[
cc00: 73 74 61 72 74 2e 2e 73 74 61 72 74 2b 6a 5d 2e start..start+j].
cc10: 0a 09 09 09 20 20 28 28 63 3d 20 28 73 74 72 69 .... ((c= (stri
cc20: 6e 67 2d 72 65 66 20 70 61 74 74 65 72 6e 20 6b ng-ref pattern k
cc30: 29 20 28 73 74 72 69 6e 67 2d 72 65 66 20 70 61 ) (string-ref pa
cc40: 74 74 65 72 6e 20 28 2b 20 6a 20 73 74 61 72 74 ttern (+ j start
cc50: 29 29 29 0a 09 09 09 20 20 20 28 6c 65 74 2a 20 ))).... (let*
cc60: 28 28 69 31 20 28 2b 20 31 20 69 29 29 0a 09 09 ((i1 (+ 1 i))...
cc70: 09 09 20 20 28 6a 31 20 28 2b 20 31 20 6a 29 29 .. (j1 (+ 1 j))
cc80: 29 0a 09 09 09 20 20 20 20 20 28 76 65 63 74 6f ).... (vecto
cc90: 72 2d 73 65 74 21 20 72 76 20 69 31 20 6a 31 29 r-set! rv i1 j1)
cca0: 0a 09 09 09 20 20 20 20 20 28 6c 70 31 20 69 31 .... (lp1 i1
ccb0: 20 6a 31 20 28 2b 20 6b 20 31 29 29 29 29 0a 0a j1 (+ k 1))))..
ccc0: 09 09 09 20 20 28 65 6c 73 65 20 28 6c 70 32 20 ... (else (lp2
ccd0: 28 76 65 63 74 6f 72 2d 72 65 66 20 72 76 20 6a (vector-ref rv j
cce0: 29 29 29 29 29 29 29 29 29 0a 20 20 20 20 20 20 ))))))))).
ccf0: 72 76 29 29 29 0a 0a 0a 3b 3b 3b 20 57 65 27 76 rv)))...;;; We'v
cd00: 65 20 6d 61 74 63 68 65 64 20 49 20 63 68 61 72 e matched I char
cd10: 73 20 66 72 6f 6d 20 50 41 54 2e 20 43 20 69 73 s from PAT. C is
cd20: 20 74 68 65 20 6e 65 78 74 20 63 68 61 72 20 66 the next char f
cd30: 72 6f 6d 20 74 68 65 20 73 65 61 72 63 68 20 73 rom the search s
cd40: 74 72 69 6e 67 2e 0a 3b 3b 3b 20 52 65 74 75 72 tring..;;; Retur
cd50: 6e 20 74 68 65 20 6e 65 77 20 49 20 61 66 74 65 n the new I afte
cd60: 72 20 68 61 6e 64 6c 69 6e 67 20 43 2e 20 0a 3b r handling C. .;
cd70: 3b 3b 0a 3b 3b 3b 20 54 68 65 20 70 61 74 74 65 ;;.;;; The patte
cd80: 72 6e 20 69 73 20 28 56 45 43 54 4f 52 2d 4c 45 rn is (VECTOR-LE
cd90: 4e 47 54 48 20 52 56 29 20 63 68 61 72 73 20 6c NGTH RV) chars l
cda0: 6f 6e 67 2c 20 62 65 67 69 6e 6e 69 6e 67 20 61 ong, beginning a
cdb0: 74 20 69 6e 64 65 78 20 50 41 54 2d 53 54 41 52 t index PAT-STAR
cdc0: 54 0a 3b 3b 3b 20 69 6e 20 50 41 54 20 28 50 41 T.;;; in PAT (PA
cdd0: 54 2d 53 54 41 52 54 20 69 73 20 75 73 75 61 6c T-START is usual
cde0: 6c 79 20 30 29 2e 20 54 68 65 20 49 20 63 68 61 ly 0). The I cha
cdf0: 72 73 20 6f 66 20 74 68 65 20 70 61 74 74 65 72 rs of the patter
ce00: 6e 20 77 65 27 76 65 20 6d 61 74 63 68 65 64 0a n we've matched.
ce10: 3b 3b 3b 20 61 72 65 20 0a 3b 3b 3b 20 20 20 20 ;;; are .;;;
ce20: 20 50 41 54 5b 50 41 54 2d 53 54 41 52 54 20 2e PAT[PAT-START .
ce30: 2e 20 50 41 54 2d 53 54 41 52 54 20 2b 20 49 5d . PAT-START + I]
ce40: 2e 0a 3b 3b 3b 0a 3b 3b 3b 20 49 74 27 73 20 2a ..;;;.;;; It's *
ce50: 6e 6f 74 2a 20 61 6e 20 6f 76 65 72 73 69 67 68 not* an oversigh
ce60: 74 20 74 68 61 74 20 74 68 65 72 65 20 69 73 20 t that there is
ce70: 6e 6f 20 66 72 69 65 6e 64 6c 79 20 65 72 72 6f no friendly erro
ce80: 72 20 63 68 65 63 6b 69 6e 67 20 6f 72 0a 3b 3b r checking or.;;
ce90: 3b 20 64 65 66 61 75 6c 74 69 6e 67 20 6f 66 20 ; defaulting of
cea0: 61 72 67 75 6d 65 6e 74 73 2e 20 54 68 69 73 20 arguments. This
ceb0: 69 73 20 61 20 6c 6f 77 2d 6c 65 76 65 6c 2c 20 is a low-level,
cec0: 69 6e 6e 65 72 2d 6c 6f 6f 70 20 70 72 6f 63 65 inner-loop proce
ced0: 64 75 72 65 0a 3b 3b 3b 20 74 68 61 74 20 77 65 dure.;;; that we
cee0: 20 77 61 6e 74 20 69 6e 74 65 67 72 61 74 65 64 want integrated
cef0: 2f 69 6e 6c 69 6e 65 64 20 69 6e 74 6f 20 74 68 /inlined into th
cf00: 65 20 70 6f 69 6e 74 20 6f 66 20 63 61 6c 6c 2e e point of call.
cf10: 0a 0a 28 64 65 66 69 6e 65 20 28 6b 6d 70 2d 73 ..(define (kmp-s
cf20: 74 65 70 20 70 61 74 20 72 76 20 63 20 69 20 63 tep pat rv c i c
cf30: 3d 20 70 2d 73 74 61 72 74 29 0a 20 20 28 6c 65 = p-start). (le
cf40: 74 20 6c 70 20 28 28 69 20 69 29 29 0a 20 20 20 t lp ((i i)).
cf50: 20 28 69 66 20 28 63 3d 20 63 20 28 73 74 72 69 (if (c= c (stri
cf60: 6e 67 2d 72 65 66 20 70 61 74 20 28 2b 20 69 20 ng-ref pat (+ i
cf70: 70 2d 73 74 61 72 74 29 29 29 09 3b 20 4d 61 74 p-start))).; Mat
cf80: 63 68 20 3d 3e 0a 09 28 2b 20 69 20 31 29 09 09 ch =>..(+ i 1)..
cf90: 09 09 09 3b 20 20 20 44 6f 6e 65 2e 0a 09 28 6c ...; Done...(l
cfa0: 65 74 20 28 28 69 20 28 76 65 63 74 6f 72 2d 72 et ((i (vector-r
cfb0: 65 66 20 72 76 20 69 29 29 29 09 09 3b 20 42 61 ef rv i)))..; Ba
cfc0: 63 6b 20 75 70 20 69 6e 20 50 41 54 2e 0a 09 20 ck up in PAT...
cfd0: 20 28 69 66 20 28 3d 20 69 20 2d 31 29 20 30 09 (if (= i -1) 0.
cfe0: 09 09 3b 20 43 61 6e 27 74 20 62 61 63 6b 20 75 ..; Can't back u
cff0: 70 20 66 75 72 74 68 65 72 2e 0a 09 20 20 20 20 p further...
d000: 20 20 28 6c 70 20 69 29 29 29 29 29 29 09 09 09 (lp i))))))...
d010: 3b 20 4b 65 65 70 20 74 72 79 69 6e 67 20 66 6f ; Keep trying fo
d020: 72 20 6d 61 74 63 68 2e 0a 0a 3b 3b 3b 20 5a 69 r match...;;; Zi
d030: 70 20 74 68 72 6f 75 67 68 20 53 5b 73 74 61 72 p through S[star
d040: 74 2c 65 6e 64 29 2c 20 6c 6f 6f 6b 69 6e 67 20 t,end), looking
d050: 66 6f 72 20 61 20 6d 61 74 63 68 20 6f 66 20 50 for a match of P
d060: 41 54 2e 20 41 73 73 75 6d 65 20 77 65 27 76 65 AT. Assume we've
d070: 0a 3b 3b 3b 20 61 6c 72 65 61 64 79 20 6d 61 74 .;;; already mat
d080: 63 68 65 64 20 74 68 65 20 66 69 72 73 74 20 49 ched the first I
d090: 20 63 68 61 72 73 20 6f 66 20 50 41 54 20 77 68 chars of PAT wh
d0a0: 65 6e 20 77 65 20 63 6f 6d 6d 65 6e 63 65 20 61 en we commence a
d0b0: 74 20 53 5b 73 74 61 72 74 5d 2e 0a 3b 3b 3b 20 t S[start]..;;;
d0c0: 2d 20 3c 30 3a 20 20 49 66 20 77 65 20 66 69 6e - <0: If we fin
d0d0: 64 20 61 20 6d 61 74 63 68 20 2a 65 6e 64 69 6e d a match *endin
d0e0: 67 2a 20 61 74 20 69 6e 64 65 78 20 4a 2c 20 72 g* at index J, r
d0f0: 65 74 75 72 6e 20 2d 4a 2e 0a 3b 3b 3b 20 2d 20 eturn -J..;;; -
d100: 3e 3d 30 3a 20 49 66 20 77 65 20 67 65 74 20 74 >=0: If we get t
d110: 6f 20 74 68 65 20 65 6e 64 20 6f 66 20 74 68 65 o the end of the
d120: 20 53 5b 73 74 61 72 74 2c 65 6e 64 29 20 73 70 S[start,end) sp
d130: 61 6e 20 77 69 74 68 6f 75 74 20 66 69 6e 64 69 an without findi
d140: 6e 67 0a 3b 3b 3b 20 20 20 61 20 63 6f 6d 70 6c ng.;;; a compl
d150: 65 74 65 20 6d 61 74 63 68 2c 20 72 65 74 75 72 ete match, retur
d160: 6e 20 74 68 65 20 6e 75 6d 62 65 72 20 6f 66 20 n the number of
d170: 63 68 61 72 73 20 66 72 6f 6d 20 50 41 54 20 77 chars from PAT w
d180: 65 27 64 20 6d 61 74 63 68 65 64 0a 3b 3b 3b 20 e'd matched.;;;
d190: 20 20 77 68 65 6e 20 77 65 20 72 61 6e 20 6f 66 when we ran of
d1a0: 66 20 74 68 65 20 65 6e 64 2e 0a 3b 3b 3b 0a 3b f the end..;;;.;
d1b0: 3b 3b 20 54 68 69 73 20 69 73 20 75 73 65 66 75 ;; This is usefu
d1c0: 6c 20 66 6f 72 20 73 65 61 72 63 68 69 6e 67 20 l for searching
d1d0: 2a 61 63 72 6f 73 73 2a 20 62 75 66 66 65 72 73 *across* buffers
d1e0: 20 2d 2d 20 74 68 61 74 20 69 73 2c 20 77 68 65 -- that is, whe
d1f0: 6e 20 79 6f 75 72 0a 3b 3b 3b 20 69 6e 70 75 74 n your.;;; input
d200: 20 63 6f 6d 65 73 20 69 6e 20 63 68 75 6e 6b 73 comes in chunks
d210: 20 6f 66 20 74 65 78 74 2e 20 57 65 20 68 61 6e of text. We han
d220: 64 2d 69 6e 74 65 67 72 61 74 65 20 74 68 65 20 d-integrate the
d230: 4b 4d 50 2d 53 54 45 50 20 6c 6f 6f 70 0a 3b 3b KMP-STEP loop.;;
d240: 3b 20 66 6f 72 20 73 70 65 65 64 2e 0a 0a 28 64 ; for speed...(d
d250: 65 66 69 6e 65 20 28 73 74 72 69 6e 67 2d 6b 6d efine (string-km
d260: 70 2d 70 61 72 74 69 61 6c 2d 73 65 61 72 63 68 p-partial-search
d270: 20 70 61 74 20 72 76 20 73 20 69 20 2e 20 63 3d pat rv s i . c=
d280: 2b 70 2d 73 74 61 72 74 2b 73 2d 73 74 61 72 74 +p-start+s-start
d290: 2b 73 2d 65 6e 64 29 0a 20 20 28 63 68 65 63 6b +s-end). (check
d2a0: 2d 61 72 67 20 76 65 63 74 6f 72 3f 20 72 76 20 -arg vector? rv
d2b0: 73 74 72 69 6e 67 2d 6b 6d 70 2d 70 61 72 74 69 string-kmp-parti
d2c0: 61 6c 2d 73 65 61 72 63 68 29 0a 20 20 28 6c 65 al-search). (le
d2d0: 74 2d 6f 70 74 69 6f 6e 61 6c 73 2a 20 63 3d 2b t-optionals* c=+
d2e0: 70 2d 73 74 61 72 74 2b 73 2d 73 74 61 72 74 2b p-start+s-start+
d2f0: 73 2d 65 6e 64 0a 09 09 20 20 28 28 63 3d 20 20 s-end... ((c=
d300: 20 20 20 20 63 68 61 72 3d 3f 20 28 70 72 6f 63 char=? (proc
d310: 65 64 75 72 65 3f 20 63 3d 29 29 0a 09 09 20 20 edure? c=))...
d320: 20 28 70 2d 73 74 61 72 74 20 30 20 28 61 6e 64 (p-start 0 (and
d330: 20 28 69 6e 74 65 67 65 72 3f 20 70 2d 73 74 61 (integer? p-sta
d340: 72 74 29 20 28 65 78 61 63 74 3f 20 70 2d 73 74 rt) (exact? p-st
d350: 61 72 74 29 20 28 3c 3d 20 30 20 70 2d 73 74 61 art) (<= 0 p-sta
d360: 72 74 29 29 29 0a 09 09 20 20 20 28 28 73 2d 73 rt)))... ((s-s
d370: 74 61 72 74 20 73 2d 65 6e 64 29 20 28 6c 61 6d tart s-end) (lam
d380: 62 64 61 20 28 61 72 67 73 29 0a 09 09 09 09 20 bda (args).....
d390: 20 20 20 20 20 28 73 74 72 69 6e 67 2d 70 61 72 (string-par
d3a0: 73 65 2d 73 74 61 72 74 2b 65 6e 64 20 73 74 72 se-start+end str
d3b0: 69 6e 67 2d 6b 6d 70 2d 70 61 72 74 69 61 6c 2d ing-kmp-partial-
d3c0: 73 65 61 72 63 68 0a 09 09 09 09 09 09 09 20 20 search........
d3d0: 20 20 20 20 73 20 61 72 67 73 29 29 29 29 0a 20 s args)))).
d3e0: 20 20 20 28 6c 65 74 20 28 28 70 61 74 6c 65 6e (let ((patlen
d3f0: 20 28 76 65 63 74 6f 72 2d 6c 65 6e 67 74 68 20 (vector-length
d400: 72 76 29 29 29 0a 20 20 20 20 20 20 28 63 68 65 rv))). (che
d410: 63 6b 2d 61 72 67 20 28 6c 61 6d 62 64 61 20 28 ck-arg (lambda (
d420: 69 29 20 28 61 6e 64 20 28 69 6e 74 65 67 65 72 i) (and (integer
d430: 3f 20 69 29 20 28 65 78 61 63 74 3f 20 69 29 20 ? i) (exact? i)
d440: 28 3c 3d 20 30 20 69 29 20 28 3c 20 69 20 70 61 (<= 0 i) (< i pa
d450: 74 6c 65 6e 29 29 29 0a 09 09 20 69 20 73 74 72 tlen)))... i str
d460: 69 6e 67 2d 6b 6d 70 2d 70 61 72 74 69 61 6c 2d ing-kmp-partial-
d470: 73 65 61 72 63 68 29 0a 0a 20 20 20 20 20 20 3b search).. ;
d480: 3b 20 45 6e 6f 75 67 68 20 70 72 65 6c 75 64 65 ; Enough prelude
d490: 2e 20 48 65 72 65 27 73 20 74 68 65 20 61 63 74 . Here's the act
d4a0: 75 61 6c 20 63 6f 64 65 2e 0a 20 20 20 20 20 20 ual code..
d4b0: 28 6c 65 74 20 6c 70 20 28 28 73 69 20 73 2d 73 (let lp ((si s-s
d4c0: 74 61 72 74 29 09 09 3b 20 41 6e 20 69 6e 64 65 tart)..; An inde
d4d0: 78 20 69 6e 74 6f 20 53 2e 0a 09 20 20 20 20 20 x into S...
d4e0: 20 20 28 76 69 20 69 29 29 09 09 09 3b 20 41 6e (vi i))...; An
d4f0: 20 69 6e 64 65 78 20 69 6e 74 6f 20 52 56 2e 0a index into RV..
d500: 09 28 63 6f 6e 64 20 28 28 3d 20 76 69 20 70 61 .(cond ((= vi pa
d510: 74 6c 65 6e 29 20 28 2d 20 73 69 29 29 09 3b 20 tlen) (- si)).;
d520: 57 69 6e 2e 0a 09 20 20 20 20 20 20 28 28 3d 20 Win... ((=
d530: 73 69 20 73 2d 65 6e 64 29 20 76 69 29 09 09 3b si s-end) vi)..;
d540: 20 52 61 6e 20 6f 66 66 20 74 68 65 20 65 6e 64 Ran off the end
d550: 2e 0a 09 20 20 20 20 20 20 28 65 6c 73 65 09 09 ... (else..
d560: 09 3b 20 4d 61 74 63 68 20 73 5b 73 69 5d 20 26 .; Match s[si] &
d570: 20 6c 6f 6f 70 2e 0a 09 20 20 20 20 20 20 20 28 loop... (
d580: 6c 65 74 20 28 28 63 20 28 73 74 72 69 6e 67 2d let ((c (string-
d590: 72 65 66 20 73 20 73 69 29 29 29 0a 09 09 20 28 ref s si)))... (
d5a0: 6c 70 20 28 2b 20 73 69 20 31 29 09 0a 09 09 20 lp (+ si 1)....
d5b0: 20 20 20 20 28 6c 65 74 20 6c 70 32 20 28 28 76 (let lp2 ((v
d5c0: 69 20 76 69 29 29 09 3b 20 54 68 69 73 20 69 73 i vi)).; This is
d5d0: 20 6a 75 73 74 20 4b 4d 50 2d 53 54 45 50 2e 0a just KMP-STEP..
d5e0: 09 09 20 20 20 20 20 20 20 28 69 66 20 28 63 3d .. (if (c=
d5f0: 20 63 20 28 73 74 72 69 6e 67 2d 72 65 66 20 70 c (string-ref p
d600: 61 74 20 28 2b 20 76 69 20 70 2d 73 74 61 72 74 at (+ vi p-start
d610: 29 29 29 0a 09 09 09 20 20 20 28 2b 20 76 69 20 ))).... (+ vi
d620: 31 29 0a 09 09 09 20 20 20 28 6c 65 74 20 28 28 1).... (let ((
d630: 76 69 20 28 76 65 63 74 6f 72 2d 72 65 66 20 72 vi (vector-ref r
d640: 76 20 76 69 29 29 29 0a 09 09 09 20 20 20 20 20 v vi)))....
d650: 28 69 66 20 28 3d 20 76 69 20 2d 31 29 20 30 0a (if (= vi -1) 0.
d660: 09 09 09 09 20 28 6c 70 32 20 76 69 29 29 29 29 .... (lp2 vi))))
d670: 29 29 29 29 29 29 29 29 29 0a 0a 0c 0a 3b 3b 3b )))))))))....;;;
d680: 20 4d 69 73 63 0a 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b Misc.;;;;;;;;;;
d690: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
d6a0: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
d6b0: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
d6c0: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
d6d0: 3b 3b 3b 3b 3b 0a 3b 3b 3b 20 28 73 74 72 69 6e ;;;;;.;;; (strin
d6e0: 67 2d 6e 75 6c 6c 3f 20 73 29 0a 3b 3b 3b 20 28 g-null? s).;;; (
d6f0: 73 74 72 69 6e 67 2d 72 65 76 65 72 73 65 20 20 string-reverse
d700: 73 20 5b 73 74 61 72 74 20 65 6e 64 5d 29 0a 3b s [start end]).;
d710: 3b 3b 20 28 73 74 72 69 6e 67 2d 72 65 76 65 72 ;; (string-rever
d720: 73 65 21 20 73 20 5b 73 74 61 72 74 20 65 6e 64 se! s [start end
d730: 5d 29 0a 3b 3b 3b 20 28 72 65 76 65 72 73 65 2d ]).;;; (reverse-
d740: 6c 69 73 74 2d 3e 73 74 72 69 6e 67 20 63 6c 69 list->string cli
d750: 73 74 29 0a 3b 3b 3b 20 28 73 74 72 69 6e 67 2d st).;;; (string-
d760: 3e 6c 69 73 74 20 73 20 5b 73 74 61 72 74 20 65 >list s [start e
d770: 6e 64 5d 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 nd])..(define (s
d780: 74 72 69 6e 67 2d 6e 75 6c 6c 3f 20 73 29 20 28 tring-null? s) (
d790: 7a 65 72 6f 3f 20 28 73 74 72 69 6e 67 2d 6c 65 zero? (string-le
d7a0: 6e 67 74 68 20 73 29 29 29 0a 0a 28 64 65 66 69 ngth s)))..(defi
d7b0: 6e 65 20 28 73 74 72 69 6e 67 2d 72 65 76 65 72 ne (string-rever
d7c0: 73 65 20 73 20 2e 20 6d 61 79 62 65 2d 73 74 61 se s . maybe-sta
d7d0: 72 74 2b 65 6e 64 29 0a 20 20 28 6c 65 74 2d 73 rt+end). (let-s
d7e0: 74 72 69 6e 67 2d 73 74 61 72 74 2b 65 6e 64 20 tring-start+end
d7f0: 28 73 74 61 72 74 20 65 6e 64 29 20 73 74 72 69 (start end) stri
d800: 6e 67 2d 72 65 76 65 72 73 65 20 73 20 6d 61 79 ng-reverse s may
d810: 62 65 2d 73 74 61 72 74 2b 65 6e 64 0a 20 20 20 be-start+end.
d820: 20 28 6c 65 74 2a 20 28 28 6c 65 6e 20 28 2d 20 (let* ((len (-
d830: 65 6e 64 20 73 74 61 72 74 29 29 0a 09 20 20 20 end start))..
d840: 28 61 6e 73 20 28 6d 61 6b 65 2d 73 74 72 69 6e (ans (make-strin
d850: 67 20 6c 65 6e 29 29 29 0a 20 20 20 20 20 20 28 g len))). (
d860: 64 6f 20 28 28 69 20 73 74 61 72 74 20 28 2b 20 do ((i start (+
d870: 69 20 31 29 29 0a 09 20 20 20 28 6a 20 28 2d 20 i 1)).. (j (-
d880: 6c 65 6e 20 31 29 20 28 2d 20 6a 20 31 29 29 29 len 1) (- j 1)))
d890: 0a 09 20 20 28 28 3c 20 6a 20 30 29 29 0a 09 28 .. ((< j 0))..(
d8a0: 73 74 72 69 6e 67 2d 73 65 74 21 20 61 6e 73 20 string-set! ans
d8b0: 6a 20 28 73 74 72 69 6e 67 2d 72 65 66 20 73 20 j (string-ref s
d8c0: 69 29 29 29 0a 20 20 20 20 20 20 61 6e 73 29 29 i))). ans))
d8d0: 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 74 72 69 )..(define (stri
d8e0: 6e 67 2d 72 65 76 65 72 73 65 21 20 73 20 2e 20 ng-reverse! s .
d8f0: 6d 61 79 62 65 2d 73 74 61 72 74 2b 65 6e 64 29 maybe-start+end)
d900: 0a 20 20 28 6c 65 74 2d 73 74 72 69 6e 67 2d 73 . (let-string-s
d910: 74 61 72 74 2b 65 6e 64 20 28 73 74 61 72 74 20 tart+end (start
d920: 65 6e 64 29 20 73 74 72 69 6e 67 2d 72 65 76 65 end) string-reve
d930: 72 73 65 21 20 73 20 6d 61 79 62 65 2d 73 74 61 rse! s maybe-sta
d940: 72 74 2b 65 6e 64 0a 20 20 20 20 28 64 6f 20 28 rt+end. (do (
d950: 28 69 20 28 2d 20 65 6e 64 20 31 29 20 28 2d 20 (i (- end 1) (-
d960: 69 20 31 29 29 0a 09 20 28 6a 20 73 74 61 72 74 i 1)).. (j start
d970: 20 28 2b 20 6a 20 31 29 29 29 0a 09 28 28 3c 3d (+ j 1)))..((<=
d980: 20 69 20 6a 29 29 0a 20 20 20 20 20 20 28 6c 65 i j)). (le
d990: 74 20 28 28 63 69 20 28 73 74 72 69 6e 67 2d 72 t ((ci (string-r
d9a0: 65 66 20 73 20 69 29 29 29 0a 09 28 73 74 72 69 ef s i)))..(stri
d9b0: 6e 67 2d 73 65 74 21 20 73 20 69 20 28 73 74 72 ng-set! s i (str
d9c0: 69 6e 67 2d 72 65 66 20 73 20 6a 29 29 0a 09 28 ing-ref s j))..(
d9d0: 73 74 72 69 6e 67 2d 73 65 74 21 20 73 20 6a 20 string-set! s j
d9e0: 63 69 29 29 29 29 29 0a 0a 0a 28 64 65 66 69 6e ci)))))...(defin
d9f0: 65 20 28 72 65 76 65 72 73 65 2d 6c 69 73 74 2d e (reverse-list-
da00: 3e 73 74 72 69 6e 67 20 63 6c 69 73 74 29 0a 20 >string clist).
da10: 20 28 6c 65 74 2a 20 28 28 6c 65 6e 20 28 6c 65 (let* ((len (le
da20: 6e 67 74 68 20 63 6c 69 73 74 29 29 0a 09 20 28 ngth clist)).. (
da30: 73 20 28 6d 61 6b 65 2d 73 74 72 69 6e 67 20 6c s (make-string l
da40: 65 6e 29 29 29 0a 20 20 20 20 28 64 6f 20 28 28 en))). (do ((
da50: 69 20 28 2d 20 6c 65 6e 20 31 29 20 28 2d 20 69 i (- len 1) (- i
da60: 20 31 29 29 20 20 20 28 63 6c 69 73 74 20 63 6c 1)) (clist cl
da70: 69 73 74 20 28 63 64 72 20 63 6c 69 73 74 29 29 ist (cdr clist))
da80: 29 0a 09 28 28 6e 6f 74 20 28 70 61 69 72 3f 20 )..((not (pair?
da90: 63 6c 69 73 74 29 29 29 0a 20 20 20 20 20 20 28 clist))). (
daa0: 73 74 72 69 6e 67 2d 73 65 74 21 20 73 20 69 20 string-set! s i
dab0: 28 63 61 72 20 63 6c 69 73 74 29 29 29 0a 20 20 (car clist))).
dac0: 20 20 73 29 29 0a 0a 0a 3b 28 64 65 66 69 6e 65 s))...;(define
dad0: 20 28 73 74 72 69 6e 67 2d 3e 6c 69 73 74 20 73 (string->list s
dae0: 20 2e 20 6d 61 79 62 65 2d 73 74 61 72 74 2b 65 . maybe-start+e
daf0: 6e 64 29 0a 3b 20 20 28 61 70 70 6c 79 20 73 74 nd).; (apply st
db00: 72 69 6e 67 2d 66 6f 6c 64 2d 72 69 67 68 74 20 ring-fold-right
db10: 63 6f 6e 73 20 27 28 29 20 73 20 6d 61 79 62 65 cons '() s maybe
db20: 2d 73 74 61 72 74 2b 65 6e 64 29 29 0a 0a 28 64 -start+end))..(d
db30: 65 66 69 6e 65 20 28 73 74 72 69 6e 67 2d 3e 6c efine (string->l
db40: 69 73 74 20 73 20 2e 20 6d 61 79 62 65 2d 73 74 ist s . maybe-st
db50: 61 72 74 2b 65 6e 64 29 0a 20 20 28 6c 65 74 2d art+end). (let-
db60: 73 74 72 69 6e 67 2d 73 74 61 72 74 2b 65 6e 64 string-start+end
db70: 20 28 73 74 61 72 74 20 65 6e 64 29 20 73 74 72 (start end) str
db80: 69 6e 67 2d 3e 6c 69 73 74 20 73 20 6d 61 79 62 ing->list s mayb
db90: 65 2d 73 74 61 72 74 2b 65 6e 64 0a 20 20 20 20 e-start+end.
dba0: 28 64 6f 20 28 28 69 20 28 2d 20 65 6e 64 20 31 (do ((i (- end 1
dbb0: 29 20 28 2d 20 69 20 31 29 29 0a 09 20 28 61 6e ) (- i 1)).. (an
dbc0: 73 20 27 28 29 20 28 63 6f 6e 73 20 28 73 74 72 s '() (cons (str
dbd0: 69 6e 67 2d 72 65 66 20 73 20 69 29 20 61 6e 73 ing-ref s i) ans
dbe0: 29 29 29 0a 09 28 28 3c 20 69 20 73 74 61 72 74 )))..((< i start
dbf0: 29 20 61 6e 73 29 29 29 29 0a 0a 3b 3b 3b 20 44 ) ans))))..;;; D
dc00: 65 66 69 6e 65 64 20 62 79 20 52 35 52 53 2c 20 efined by R5RS,
dc10: 73 6f 20 63 6f 6d 6d 65 6e 74 65 64 20 6f 75 74 so commented out
dc20: 20 68 65 72 65 2e 0a 3b 28 64 65 66 69 6e 65 20 here..;(define
dc30: 28 6c 69 73 74 2d 3e 73 74 72 69 6e 67 20 6c 69 (list->string li
dc40: 73 29 20 28 73 74 72 69 6e 67 2d 75 6e 66 6f 6c s) (string-unfol
dc50: 64 20 6e 75 6c 6c 3f 20 63 61 72 20 63 64 72 20 d null? car cdr
dc60: 6c 69 73 29 29 0a 0a 0a 3b 3b 3b 20 73 74 72 69 lis))...;;; stri
dc70: 6e 67 2d 63 6f 6e 63 61 74 65 6e 61 74 65 20 20 ng-concatenate
dc80: 20 20 20 20 20 20 73 74 72 69 6e 67 2d 6c 69 73 string-lis
dc90: 74 20 2d 3e 20 73 74 72 69 6e 67 0a 3b 3b 3b 20 t -> string.;;;
dca0: 73 74 72 69 6e 67 2d 63 6f 6e 63 61 74 65 6e 61 string-concatena
dcb0: 74 65 2f 73 68 61 72 65 64 20 73 74 72 69 6e 67 te/shared string
dcc0: 2d 6c 69 73 74 20 2d 3e 20 73 74 72 69 6e 67 0a -list -> string.
dcd0: 3b 3b 3b 20 73 74 72 69 6e 67 2d 61 70 70 65 6e ;;; string-appen
dce0: 64 2f 73 68 61 72 65 64 20 73 20 2e 2e 2e 20 2d d/shared s ... -
dcf0: 3e 20 73 74 72 69 6e 67 0a 3b 3b 3b 3b 3b 3b 3b > string.;;;;;;;
dd00: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
dd10: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
dd20: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
dd30: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
dd40: 3b 3b 3b 3b 3b 3b 3b 3b 0a 3b 3b 3b 20 53 54 52 ;;;;;;;;.;;; STR
dd50: 49 4e 47 2d 41 50 50 45 4e 44 2f 53 48 41 52 45 ING-APPEND/SHARE
dd60: 44 20 68 61 73 20 6c 69 63 65 6e 73 65 20 74 6f D has license to
dd70: 20 72 65 74 75 72 6e 20 61 20 73 74 72 69 6e 67 return a string
dd80: 20 74 68 61 74 20 73 68 61 72 65 73 20 73 74 6f that shares sto
dd90: 72 61 67 65 0a 3b 3b 3b 20 77 69 74 68 20 61 6e rage.;;; with an
dda0: 79 20 6f 66 20 69 74 73 20 61 72 67 75 6d 65 6e y of its argumen
ddb0: 74 73 2e 20 49 6e 20 70 61 72 74 69 63 75 6c 61 ts. In particula
ddc0: 72 2c 20 69 66 20 74 68 65 72 65 20 69 73 20 6f r, if there is o
ddd0: 6e 6c 79 20 6f 6e 65 20 6e 6f 6e 2d 65 6d 70 74 nly one non-empt
dde0: 79 0a 3b 3b 3b 20 73 74 72 69 6e 67 20 61 6d 6f y.;;; string amo
ddf0: 6e 67 73 74 20 69 74 73 20 70 61 72 61 6d 65 74 ngst its paramet
de00: 65 72 73 2c 20 69 74 20 69 73 20 70 65 72 6d 69 ers, it is permi
de10: 74 74 65 64 20 74 6f 20 72 65 74 75 72 6e 20 74 tted to return t
de20: 68 61 74 20 73 74 72 69 6e 67 20 61 73 0a 3b 3b hat string as.;;
de30: 3b 20 69 74 73 20 72 65 73 75 6c 74 2e 20 53 54 ; its result. ST
de40: 52 49 4e 47 2d 41 50 50 45 4e 44 2c 20 62 79 20 RING-APPEND, by
de50: 63 6f 6e 74 72 61 73 74 2c 20 61 6c 77 61 79 73 contrast, always
de60: 20 61 6c 6c 6f 63 61 74 65 73 20 6e 65 77 20 73 allocates new s
de70: 74 6f 72 61 67 65 2e 0a 3b 3b 3b 0a 3b 3b 3b 20 torage..;;;.;;;
de80: 53 54 52 49 4e 47 2d 43 4f 4e 43 41 54 45 4e 41 STRING-CONCATENA
de90: 54 45 20 26 20 53 54 52 49 4e 47 2d 43 4f 4e 43 TE & STRING-CONC
dea0: 41 54 45 4e 41 54 45 2f 53 48 41 52 45 44 20 61 ATENATE/SHARED a
deb0: 72 65 20 70 61 73 73 65 64 20 61 20 6c 69 73 74 re passed a list
dec0: 20 6f 66 0a 3b 3b 3b 20 73 74 72 69 6e 67 73 2c of.;;; strings,
ded0: 20 77 68 69 63 68 20 74 68 65 79 20 63 6f 6e 63 which they conc
dee0: 61 74 65 6e 61 74 65 20 69 6e 74 6f 20 61 20 72 atenate into a r
def0: 65 73 75 6c 74 20 73 74 72 69 6e 67 2e 20 53 54 esult string. ST
df00: 52 49 4e 47 2d 43 4f 4e 43 41 54 45 4e 41 54 45 RING-CONCATENATE
df10: 0a 3b 3b 3b 20 61 6c 77 61 79 73 20 61 6c 6c 6f .;;; always allo
df20: 63 61 74 65 73 20 61 20 66 72 65 73 68 20 73 74 cates a fresh st
df30: 72 69 6e 67 3b 20 53 54 52 49 4e 47 2d 43 4f 4e ring; STRING-CON
df40: 43 41 54 45 4e 41 54 45 2f 53 48 41 52 45 44 20 CATENATE/SHARED
df50: 6d 61 79 20 28 6f 72 20 6d 61 79 0a 3b 3b 3b 20 may (or may.;;;
df60: 6e 6f 74 29 20 72 65 74 75 72 6e 20 61 20 72 65 not) return a re
df70: 73 75 6c 74 20 74 68 61 74 20 73 68 61 72 65 73 sult that shares
df80: 20 73 74 6f 72 61 67 65 20 77 69 74 68 20 61 6e storage with an
df90: 79 20 6f 66 20 69 74 73 20 61 72 67 75 6d 65 6e y of its argumen
dfa0: 74 73 2e 20 49 6e 0a 3b 3b 3b 20 70 61 72 74 69 ts. In.;;; parti
dfb0: 63 75 6c 61 72 2c 20 69 66 20 69 74 20 69 73 20 cular, if it is
dfc0: 61 70 70 6c 69 65 64 20 74 6f 20 61 20 73 69 6e applied to a sin
dfd0: 67 6c 65 74 6f 6e 20 6c 69 73 74 2c 20 69 74 20 gleton list, it
dfe0: 69 73 20 70 65 72 6d 69 74 74 65 64 20 74 6f 0a is permitted to.
dff0: 3b 3b 3b 20 72 65 74 75 72 6e 20 74 68 65 20 63 ;;; return the c
e000: 61 72 20 6f 66 20 74 68 61 74 20 6c 69 73 74 20 ar of that list
e010: 61 73 20 69 74 73 20 76 61 6c 75 65 2e 0a 0a 28 as its value...(
e020: 64 65 66 69 6e 65 20 28 73 74 72 69 6e 67 2d 61 define (string-a
e030: 70 70 65 6e 64 2f 73 68 61 72 65 64 20 2e 20 73 ppend/shared . s
e040: 74 72 69 6e 67 73 29 20 28 73 74 72 69 6e 67 2d trings) (string-
e050: 63 6f 6e 63 61 74 65 6e 61 74 65 2f 73 68 61 72 concatenate/shar
e060: 65 64 20 73 74 72 69 6e 67 73 29 29 0a 0a 28 64 ed strings))..(d
e070: 65 66 69 6e 65 20 28 73 74 72 69 6e 67 2d 63 6f efine (string-co
e080: 6e 63 61 74 65 6e 61 74 65 2f 73 68 61 72 65 64 ncatenate/shared
e090: 20 73 74 72 69 6e 67 73 29 0a 20 20 28 6c 65 74 strings). (let
e0a0: 20 6c 70 20 28 28 73 74 72 69 6e 67 73 20 73 74 lp ((strings st
e0b0: 72 69 6e 67 73 29 20 28 6e 63 68 61 72 73 20 30 rings) (nchars 0
e0c0: 29 20 28 66 69 72 73 74 20 23 66 29 29 0a 20 20 ) (first #f)).
e0d0: 20 20 28 63 6f 6e 64 20 28 28 70 61 69 72 3f 20 (cond ((pair?
e0e0: 73 74 72 69 6e 67 73 29 09 09 09 3b 20 53 63 61 strings)...; Sca
e0f0: 6e 20 74 68 65 20 61 72 67 73 2c 20 61 64 64 20 n the args, add
e100: 75 70 20 74 6f 74 61 6c 0a 09 20 20 20 28 6c 65 up total.. (le
e110: 74 2a 20 28 28 73 74 72 69 6e 67 20 20 28 63 61 t* ((string (ca
e120: 72 20 73 74 72 69 6e 67 73 29 29 09 3b 20 6c 65 r strings)).; le
e130: 6e 67 74 68 2c 20 72 65 6d 65 6d 62 65 72 20 31 ngth, remember 1
e140: 73 74 20 0a 09 09 20 20 28 74 61 69 6c 20 28 63 st ... (tail (c
e150: 64 72 20 73 74 72 69 6e 67 73 29 29 09 09 3b 20 dr strings))..;
e160: 6e 6f 6e 2d 65 6d 70 74 79 20 73 74 72 69 6e 67 non-empty string
e170: 2e 0a 09 09 20 20 28 73 6c 65 6e 20 28 73 74 72 .... (slen (str
e180: 69 6e 67 2d 6c 65 6e 67 74 68 20 73 74 72 69 6e ing-length strin
e190: 67 29 29 29 0a 09 20 20 20 20 20 28 69 66 20 28 g))).. (if (
e1a0: 7a 65 72 6f 3f 20 73 6c 65 6e 29 0a 09 09 20 28 zero? slen)... (
e1b0: 6c 70 20 74 61 69 6c 20 6e 63 68 61 72 73 20 66 lp tail nchars f
e1c0: 69 72 73 74 29 0a 09 09 20 28 6c 70 20 74 61 69 irst)... (lp tai
e1d0: 6c 20 28 2b 20 6e 63 68 61 72 73 20 73 6c 65 6e l (+ nchars slen
e1e0: 29 20 28 6f 72 20 66 69 72 73 74 20 73 74 72 69 ) (or first stri
e1f0: 6e 67 73 29 29 29 29 29 0a 0a 09 20 20 28 28 7a ngs)))))... ((z
e200: 65 72 6f 3f 20 6e 63 68 61 72 73 29 20 22 22 29 ero? nchars) "")
e210: 0a 0a 09 20 20 3b 3b 20 4a 75 73 74 20 6f 6e 65 ... ;; Just one
e220: 20 6e 6f 6e 2d 65 6d 70 74 79 20 73 74 72 69 6e non-empty strin
e230: 67 21 20 52 65 74 75 72 6e 20 69 74 2e 0a 09 20 g! Return it...
e240: 20 28 28 3d 20 6e 63 68 61 72 73 20 28 73 74 72 ((= nchars (str
e250: 69 6e 67 2d 6c 65 6e 67 74 68 20 28 63 61 72 20 ing-length (car
e260: 66 69 72 73 74 29 29 29 20 28 63 61 72 20 66 69 first))) (car fi
e270: 72 73 74 29 29 0a 0a 09 20 20 28 65 6c 73 65 20 rst))... (else
e280: 28 6c 65 74 20 28 28 61 6e 73 20 28 6d 61 6b 65 (let ((ans (make
e290: 2d 73 74 72 69 6e 67 20 6e 63 68 61 72 73 29 29 -string nchars))
e2a0: 29 0a 09 09 20 20 28 6c 65 74 20 6c 70 20 28 28 )... (let lp ((
e2b0: 73 74 72 69 6e 67 73 20 66 69 72 73 74 29 20 28 strings first) (
e2c0: 69 20 30 29 29 0a 09 09 20 20 20 20 28 69 66 20 i 0))... (if
e2d0: 28 70 61 69 72 3f 20 73 74 72 69 6e 67 73 29 0a (pair? strings).
e2e0: 09 09 09 28 6c 65 74 2a 20 28 28 73 20 28 63 61 ...(let* ((s (ca
e2f0: 72 20 73 74 72 69 6e 67 73 29 29 0a 09 09 09 20 r strings))....
e300: 20 20 20 20 20 20 28 73 6c 65 6e 20 28 73 74 72 (slen (str
e310: 69 6e 67 2d 6c 65 6e 67 74 68 20 73 29 29 29 0a ing-length s))).
e320: 09 09 09 20 20 28 25 73 74 72 69 6e 67 2d 63 6f ... (%string-co
e330: 70 79 21 20 61 6e 73 20 69 20 73 20 30 20 73 6c py! ans i s 0 sl
e340: 65 6e 29 0a 09 09 09 20 20 28 6c 70 20 28 63 64 en).... (lp (cd
e350: 72 20 73 74 72 69 6e 67 73 29 20 28 2b 20 69 20 r strings) (+ i
e360: 73 6c 65 6e 29 29 29 29 29 0a 09 09 20 20 61 6e slen)))))... an
e370: 73 29 29 29 29 29 0a 09 09 09 0a 0a 3b 20 41 6c s)))))......; Al
e380: 61 73 2c 20 53 63 68 65 6d 65 20 34 38 27 73 20 as, Scheme 48's
e390: 41 50 50 4c 59 20 62 6c 6f 77 73 20 75 70 20 69 APPLY blows up i
e3a0: 66 20 79 6f 75 20 68 61 76 65 20 6d 61 6e 79 2c f you have many,
e3b0: 20 6d 61 6e 79 20 61 72 67 75 6d 65 6e 74 73 2e many arguments.
e3c0: 0a 3b 28 64 65 66 69 6e 65 20 28 73 74 72 69 6e .;(define (strin
e3d0: 67 2d 63 6f 6e 63 61 74 65 6e 61 74 65 20 73 74 g-concatenate st
e3e0: 72 69 6e 67 73 29 20 28 61 70 70 6c 79 20 73 74 rings) (apply st
e3f0: 72 69 6e 67 2d 61 70 70 65 6e 64 20 73 74 72 69 ring-append stri
e400: 6e 67 73 29 29 0a 0a 3b 3b 3b 20 48 65 72 65 20 ngs))..;;; Here
e410: 69 74 20 69 73 20 77 72 69 74 74 65 6e 20 6f 75 it is written ou
e420: 74 2e 20 49 20 61 76 6f 69 64 20 75 73 69 6e 67 t. I avoid using
e430: 20 52 45 44 55 43 45 20 74 6f 20 61 64 64 20 75 REDUCE to add u
e440: 70 20 73 74 72 69 6e 67 20 6c 65 6e 67 74 68 73 p string lengths
e450: 0a 3b 3b 3b 20 74 6f 20 61 76 6f 69 64 20 6e 6f .;;; to avoid no
e460: 6e 2d 52 35 52 53 20 64 65 70 65 6e 64 65 6e 63 n-R5RS dependenc
e470: 69 65 73 2e 0a 28 64 65 66 69 6e 65 20 28 73 74 ies..(define (st
e480: 72 69 6e 67 2d 63 6f 6e 63 61 74 65 6e 61 74 65 ring-concatenate
e490: 20 73 74 72 69 6e 67 73 29 0a 20 20 28 6c 65 74 strings). (let
e4a0: 2a 20 28 28 74 6f 74 61 6c 20 28 64 6f 20 28 28 * ((total (do ((
e4b0: 73 74 72 69 6e 67 73 20 73 74 72 69 6e 67 73 20 strings strings
e4c0: 28 63 64 72 20 73 74 72 69 6e 67 73 29 29 0a 09 (cdr strings))..
e4d0: 09 20 20 20 20 20 28 69 20 30 20 28 2b 20 69 20 . (i 0 (+ i
e4e0: 28 73 74 72 69 6e 67 2d 6c 65 6e 67 74 68 20 28 (string-length (
e4f0: 63 61 72 20 73 74 72 69 6e 67 73 29 29 29 29 29 car strings)))))
e500: 0a 09 09 20 20 20 20 28 28 6e 6f 74 20 28 70 61 ... ((not (pa
e510: 69 72 3f 20 73 74 72 69 6e 67 73 29 29 20 69 29 ir? strings)) i)
e520: 29 29 0a 09 20 28 61 6e 73 20 28 6d 61 6b 65 2d )).. (ans (make-
e530: 73 74 72 69 6e 67 20 74 6f 74 61 6c 29 29 29 0a string total))).
e540: 20 20 20 20 28 6c 65 74 20 6c 70 20 28 28 69 20 (let lp ((i
e550: 30 29 20 28 73 74 72 69 6e 67 73 20 73 74 72 69 0) (strings stri
e560: 6e 67 73 29 29 0a 20 20 20 20 20 20 28 69 66 20 ngs)). (if
e570: 28 70 61 69 72 3f 20 73 74 72 69 6e 67 73 29 0a (pair? strings).
e580: 09 20 20 28 6c 65 74 2a 20 28 28 73 20 28 63 61 . (let* ((s (ca
e590: 72 20 73 74 72 69 6e 67 73 29 29 0a 09 09 20 28 r strings))... (
e5a0: 73 6c 65 6e 20 28 73 74 72 69 6e 67 2d 6c 65 6e slen (string-len
e5b0: 67 74 68 20 73 29 29 29 0a 09 20 20 20 20 28 25 gth s))).. (%
e5c0: 73 74 72 69 6e 67 2d 63 6f 70 79 21 20 61 6e 73 string-copy! ans
e5d0: 20 69 20 73 20 30 20 73 6c 65 6e 29 0a 09 20 20 i s 0 slen)..
e5e0: 20 20 28 6c 70 20 28 2b 20 69 20 73 6c 65 6e 29 (lp (+ i slen)
e5f0: 20 28 63 64 72 20 73 74 72 69 6e 67 73 29 29 29 (cdr strings)))
e600: 29 29 0a 20 20 20 20 61 6e 73 29 29 0a 09 20 20 )). ans))..
e610: 0a 0a 3b 3b 3b 20 44 65 66 69 6e 65 64 20 62 79 ..;;; Defined by
e620: 20 52 35 52 53 2c 20 73 6f 20 63 6f 6d 6d 65 6e R5RS, so commen
e630: 74 65 64 20 6f 75 74 20 68 65 72 65 2e 0a 3b 28 ted out here..;(
e640: 64 65 66 69 6e 65 20 28 73 74 72 69 6e 67 2d 61 define (string-a
e650: 70 70 65 6e 64 20 2e 20 73 74 72 69 6e 67 73 29 ppend . strings)
e660: 20 28 73 74 72 69 6e 67 2d 63 6f 6e 63 61 74 65 (string-concate
e670: 6e 61 74 65 20 73 74 72 69 6e 67 73 29 29 0a 0a nate strings))..
e680: 3b 3b 3b 20 73 74 72 69 6e 67 2d 63 6f 6e 63 61 ;;; string-conca
e690: 74 65 6e 61 74 65 2d 72 65 76 65 72 73 65 20 20 tenate-reverse
e6a0: 20 20 20 20 20 20 73 74 72 69 6e 67 2d 6c 69 73 string-lis
e6b0: 74 20 5b 66 69 6e 61 6c 2d 73 74 72 69 6e 67 20 t [final-string
e6c0: 65 6e 64 5d 20 2d 3e 20 73 74 72 69 6e 67 0a 3b end] -> string.;
e6d0: 3b 3b 20 73 74 72 69 6e 67 2d 63 6f 6e 63 61 74 ;; string-concat
e6e0: 65 6e 61 74 65 2d 72 65 76 65 72 73 65 2f 73 68 enate-reverse/sh
e6f0: 61 72 65 64 20 73 74 72 69 6e 67 2d 6c 69 73 74 ared string-list
e700: 20 5b 66 69 6e 61 6c 2d 73 74 72 69 6e 67 20 65 [final-string e
e710: 6e 64 5d 20 2d 3e 20 73 74 72 69 6e 67 0a 3b 3b nd] -> string.;;
e720: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
e730: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
e740: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
e750: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
e760: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 0a 3b 3b ;;;;;;;;;;;;;.;;
e770: 3b 20 52 65 74 75 72 6e 0a 3b 3b 3b 20 20 20 28 ; Return.;;; (
e780: 73 74 72 69 6e 67 2d 63 6f 6e 63 61 74 65 6e 61 string-concatena
e790: 74 65 20 0a 3b 3b 3b 20 20 20 20 20 28 72 65 76 te .;;; (rev
e7a0: 65 72 73 65 0a 3b 3b 3b 20 20 20 20 20 20 20 28 erse.;;; (
e7b0: 63 6f 6e 73 20 28 73 75 62 73 74 72 69 6e 67 20 cons (substring
e7c0: 66 69 6e 61 6c 2d 73 74 72 69 6e 67 20 30 20 65 final-string 0 e
e7d0: 6e 64 29 20 73 74 72 69 6e 67 2d 6c 69 73 74 29 nd) string-list)
e7e0: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 74 72 ))..(define (str
e7f0: 69 6e 67 2d 63 6f 6e 63 61 74 65 6e 61 74 65 2d ing-concatenate-
e800: 72 65 76 65 72 73 65 20 73 74 72 69 6e 67 2d 6c reverse string-l
e810: 69 73 74 20 2e 20 6d 61 79 62 65 2d 66 69 6e 61 ist . maybe-fina
e820: 6c 2b 65 6e 64 29 0a 20 20 28 6c 65 74 2d 6f 70 l+end). (let-op
e830: 74 69 6f 6e 61 6c 73 2a 20 6d 61 79 62 65 2d 66 tionals* maybe-f
e840: 69 6e 61 6c 2b 65 6e 64 20 28 28 66 69 6e 61 6c inal+end ((final
e850: 20 22 22 20 28 73 74 72 69 6e 67 3f 20 66 69 6e "" (string? fin
e860: 61 6c 29 29 0a 09 09 09 09 20 20 20 28 65 6e 64 al))..... (end
e870: 20 28 73 74 72 69 6e 67 2d 6c 65 6e 67 74 68 20 (string-length
e880: 66 69 6e 61 6c 29 0a 09 09 09 09 09 28 61 6e 64 final)......(and
e890: 20 28 69 6e 74 65 67 65 72 3f 20 65 6e 64 29 0a (integer? end).
e8a0: 09 09 09 09 09 20 20 20 20 20 28 65 78 61 63 74 ..... (exact
e8b0: 3f 20 65 6e 64 29 0a 09 09 09 09 09 20 20 20 20 ? end)......
e8c0: 20 28 3c 3d 20 30 20 65 6e 64 20 28 73 74 72 69 (<= 0 end (stri
e8d0: 6e 67 2d 6c 65 6e 67 74 68 20 66 69 6e 61 6c 29 ng-length final)
e8e0: 29 29 29 29 0a 20 20 20 20 28 6c 65 74 20 28 28 )))). (let ((
e8f0: 6c 65 6e 20 28 6c 65 74 20 6c 70 20 28 28 73 75 len (let lp ((su
e900: 6d 20 30 29 20 28 6c 69 73 20 73 74 72 69 6e 67 m 0) (lis string
e910: 2d 6c 69 73 74 29 29 0a 09 09 20 28 69 66 20 28 -list))... (if (
e920: 70 61 69 72 3f 20 6c 69 73 29 0a 09 09 20 20 20 pair? lis)...
e930: 20 20 28 6c 70 20 28 2b 20 73 75 6d 20 28 73 74 (lp (+ sum (st
e940: 72 69 6e 67 2d 6c 65 6e 67 74 68 20 28 63 61 72 ring-length (car
e950: 20 6c 69 73 29 29 29 20 28 63 64 72 20 6c 69 73 lis))) (cdr lis
e960: 29 29 0a 09 09 20 20 20 20 20 73 75 6d 29 29 29 ))... sum)))
e970: 29 0a 0a 20 20 20 20 20 20 28 25 66 69 6e 69 73 ).. (%finis
e980: 68 2d 73 74 72 69 6e 67 2d 63 6f 6e 63 61 74 65 h-string-concate
e990: 6e 61 74 65 2d 72 65 76 65 72 73 65 20 6c 65 6e nate-reverse len
e9a0: 20 73 74 72 69 6e 67 2d 6c 69 73 74 20 66 69 6e string-list fin
e9b0: 61 6c 20 65 6e 64 29 29 29 29 0a 0a 28 64 65 66 al end))))..(def
e9c0: 69 6e 65 20 28 73 74 72 69 6e 67 2d 63 6f 6e 63 ine (string-conc
e9d0: 61 74 65 6e 61 74 65 2d 72 65 76 65 72 73 65 2f atenate-reverse/
e9e0: 73 68 61 72 65 64 20 73 74 72 69 6e 67 2d 6c 69 shared string-li
e9f0: 73 74 20 2e 20 6d 61 79 62 65 2d 66 69 6e 61 6c st . maybe-final
ea00: 2b 65 6e 64 29 0a 20 20 28 6c 65 74 2d 6f 70 74 +end). (let-opt
ea10: 69 6f 6e 61 6c 73 2a 20 6d 61 79 62 65 2d 66 69 ionals* maybe-fi
ea20: 6e 61 6c 2b 65 6e 64 20 28 28 66 69 6e 61 6c 20 nal+end ((final
ea30: 22 22 20 28 73 74 72 69 6e 67 3f 20 66 69 6e 61 "" (string? fina
ea40: 6c 29 29 0a 09 09 09 09 20 20 20 28 65 6e 64 20 l))..... (end
ea50: 28 73 74 72 69 6e 67 2d 6c 65 6e 67 74 68 20 66 (string-length f
ea60: 69 6e 61 6c 29 0a 09 09 09 09 09 28 61 6e 64 20 inal)......(and
ea70: 28 69 6e 74 65 67 65 72 3f 20 65 6e 64 29 0a 09 (integer? end)..
ea80: 09 09 09 09 20 20 20 20 20 28 65 78 61 63 74 3f .... (exact?
ea90: 20 65 6e 64 29 0a 09 09 09 09 09 20 20 20 20 20 end)......
eaa0: 28 3c 3d 20 30 20 65 6e 64 20 28 73 74 72 69 6e (<= 0 end (strin
eab0: 67 2d 6c 65 6e 67 74 68 20 66 69 6e 61 6c 29 29 g-length final))
eac0: 29 29 29 0a 20 20 20 20 3b 3b 20 41 64 64 20 75 ))). ;; Add u
ead0: 70 20 74 68 65 20 6c 65 6e 67 74 68 73 20 6f 66 p the lengths of
eae0: 20 61 6c 6c 20 74 68 65 20 73 74 72 69 6e 67 73 all the strings
eaf0: 20 69 6e 20 53 54 52 49 4e 47 2d 4c 49 53 54 3b in STRING-LIST;
eb00: 20 61 6c 73 6f 20 67 65 74 20 61 0a 20 20 20 20 also get a.
eb10: 3b 3b 20 70 6f 69 6e 74 65 72 20 4e 5a 4c 49 53 ;; pointer NZLIS
eb20: 54 20 69 6e 74 6f 20 53 54 52 49 4e 47 2d 4c 49 T into STRING-LI
eb30: 53 54 20 73 68 6f 77 69 6e 67 20 77 68 65 72 65 ST showing where
eb40: 20 74 68 65 20 66 69 72 73 74 20 6e 6f 6e 2d 7a the first non-z
eb50: 65 72 6f 2d 6c 65 6e 67 74 68 0a 20 20 20 20 3b ero-length. ;
eb60: 3b 20 73 74 72 69 6e 67 20 73 74 61 72 74 73 2e ; string starts.
eb70: 0a 20 20 20 20 28 6c 65 74 20 6c 70 20 28 28 6c . (let lp ((l
eb80: 65 6e 20 30 29 20 28 6e 7a 6c 69 73 74 20 23 66 en 0) (nzlist #f
eb90: 29 20 28 6c 69 73 20 73 74 72 69 6e 67 2d 6c 69 ) (lis string-li
eba0: 73 74 29 29 0a 20 20 20 20 20 20 28 69 66 20 28 st)). (if (
ebb0: 70 61 69 72 3f 20 6c 69 73 29 0a 09 20 20 28 6c pair? lis).. (l
ebc0: 65 74 20 28 28 73 6c 65 6e 20 28 73 74 72 69 6e et ((slen (strin
ebd0: 67 2d 6c 65 6e 67 74 68 20 28 63 61 72 20 6c 69 g-length (car li
ebe0: 73 29 29 29 29 0a 09 20 20 20 20 28 6c 70 20 28 s)))).. (lp (
ebf0: 2b 20 6c 65 6e 20 73 6c 65 6e 29 0a 09 09 28 69 + len slen)...(i
ec00: 66 20 28 6f 72 20 6e 7a 6c 69 73 74 20 28 7a 65 f (or nzlist (ze
ec10: 72 6f 3f 20 73 6c 65 6e 29 29 20 6e 7a 6c 69 73 ro? slen)) nzlis
ec20: 74 20 6c 69 73 29 0a 09 09 28 63 64 72 20 6c 69 t lis)...(cdr li
ec30: 73 29 29 29 0a 0a 09 20 20 28 63 6f 6e 64 20 28 s)))... (cond (
ec40: 28 7a 65 72 6f 3f 20 6c 65 6e 29 20 28 73 75 62 (zero? len) (sub
ec50: 73 74 72 69 6e 67 2f 73 68 61 72 65 64 20 66 69 string/shared fi
ec60: 6e 61 6c 20 30 20 65 6e 64 29 29 0a 0a 09 09 3b nal 0 end))....;
ec70: 3b 20 4c 45 4e 20 3e 20 30 2c 20 73 6f 20 4e 5a ; LEN > 0, so NZ
ec80: 4c 49 53 54 20 69 73 20 6e 6f 6e 2d 65 6d 70 74 LIST is non-empt
ec90: 79 2e 0a 0a 09 09 28 28 61 6e 64 20 28 7a 65 72 y.....((and (zer
eca0: 6f 3f 20 65 6e 64 29 20 28 3d 20 6c 65 6e 20 28 o? end) (= len (
ecb0: 73 74 72 69 6e 67 2d 6c 65 6e 67 74 68 20 28 63 string-length (c
ecc0: 61 72 20 6e 7a 6c 69 73 74 29 29 29 29 0a 09 09 ar nzlist))))...
ecd0: 20 28 63 61 72 20 6e 7a 6c 69 73 74 29 29 0a 0a (car nzlist))..
ece0: 09 09 28 65 6c 73 65 20 28 25 66 69 6e 69 73 68 ..(else (%finish
ecf0: 2d 73 74 72 69 6e 67 2d 63 6f 6e 63 61 74 65 6e -string-concaten
ed00: 61 74 65 2d 72 65 76 65 72 73 65 20 6c 65 6e 20 ate-reverse len
ed10: 6e 7a 6c 69 73 74 20 66 69 6e 61 6c 20 65 6e 64 nzlist final end
ed20: 29 29 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 )))))))..(define
ed30: 20 28 25 66 69 6e 69 73 68 2d 73 74 72 69 6e 67 (%finish-string
ed40: 2d 63 6f 6e 63 61 74 65 6e 61 74 65 2d 72 65 76 -concatenate-rev
ed50: 65 72 73 65 20 6c 65 6e 20 73 74 72 69 6e 67 2d erse len string-
ed60: 6c 69 73 74 20 66 69 6e 61 6c 20 65 6e 64 29 0a list final end).
ed70: 20 20 28 6c 65 74 20 28 28 61 6e 73 20 28 6d 61 (let ((ans (ma
ed80: 6b 65 2d 73 74 72 69 6e 67 20 28 2b 20 65 6e 64 ke-string (+ end
ed90: 20 6c 65 6e 29 29 29 29 0a 20 20 20 20 28 25 73 len)))). (%s
eda0: 74 72 69 6e 67 2d 63 6f 70 79 21 20 61 6e 73 20 tring-copy! ans
edb0: 6c 65 6e 20 66 69 6e 61 6c 20 30 20 65 6e 64 29 len final 0 end)
edc0: 0a 20 20 20 20 28 6c 65 74 20 6c 70 20 28 28 69 . (let lp ((i
edd0: 20 6c 65 6e 29 20 28 6c 69 73 20 73 74 72 69 6e len) (lis strin
ede0: 67 2d 6c 69 73 74 29 29 0a 20 20 20 20 20 20 28 g-list)). (
edf0: 69 66 20 28 70 61 69 72 3f 20 6c 69 73 29 0a 09 if (pair? lis)..
ee00: 20 20 28 6c 65 74 2a 20 28 28 73 20 20 20 28 63 (let* ((s (c
ee10: 61 72 20 6c 69 73 29 29 0a 09 09 20 28 6c 69 73 ar lis))... (lis
ee20: 20 28 63 64 72 20 6c 69 73 29 29 0a 09 09 20 28 (cdr lis))... (
ee30: 73 6c 65 6e 20 28 73 74 72 69 6e 67 2d 6c 65 6e slen (string-len
ee40: 67 74 68 20 73 29 29 0a 09 09 20 28 69 20 28 2d gth s))... (i (-
ee50: 20 69 20 73 6c 65 6e 29 29 29 0a 09 20 20 20 20 i slen)))..
ee60: 28 25 73 74 72 69 6e 67 2d 63 6f 70 79 21 20 61 (%string-copy! a
ee70: 6e 73 20 69 20 73 20 30 20 73 6c 65 6e 29 0a 09 ns i s 0 slen)..
ee80: 20 20 20 20 28 6c 70 20 69 20 6c 69 73 29 29 29 (lp i lis)))
ee90: 29 0a 20 20 20 20 61 6e 73 29 29 0a 0a 0a 0a 0a ). ans)).....
eea0: 3b 3b 3b 20 73 74 72 69 6e 67 2d 72 65 70 6c 61 ;;; string-repla
eeb0: 63 65 20 73 31 20 73 32 20 73 74 61 72 74 31 20 ce s1 s2 start1
eec0: 65 6e 64 31 20 5b 73 74 61 72 74 32 20 65 6e 64 end1 [start2 end
eed0: 32 5d 20 2d 3e 20 73 74 72 69 6e 67 0a 3b 3b 3b 2] -> string.;;;
eee0: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
eef0: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
ef00: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
ef10: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
ef20: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 0a 3b 3b 3b ;;;;;;;;;;;;.;;;
ef30: 20 52 65 70 6c 61 63 65 20 53 31 5b 53 54 41 52 Replace S1[STAR
ef40: 54 31 2c 45 4e 44 31 29 20 77 69 74 68 20 53 32 T1,END1) with S2
ef50: 5b 53 54 41 52 54 32 2c 45 4e 44 32 29 2e 0a 0a [START2,END2)...
ef60: 28 64 65 66 69 6e 65 20 28 73 74 72 69 6e 67 2d (define (string-
ef70: 72 65 70 6c 61 63 65 20 73 31 20 73 32 20 73 74 replace s1 s2 st
ef80: 61 72 74 31 20 65 6e 64 31 20 2e 20 6d 61 79 62 art1 end1 . mayb
ef90: 65 2d 73 74 61 72 74 2b 65 6e 64 29 0a 20 20 28 e-start+end). (
efa0: 63 68 65 63 6b 2d 73 75 62 73 74 72 69 6e 67 2d check-substring-
efb0: 73 70 65 63 20 73 74 72 69 6e 67 2d 72 65 70 6c spec string-repl
efc0: 61 63 65 20 73 31 20 73 74 61 72 74 31 20 65 6e ace s1 start1 en
efd0: 64 31 29 0a 20 20 28 6c 65 74 2d 73 74 72 69 6e d1). (let-strin
efe0: 67 2d 73 74 61 72 74 2b 65 6e 64 20 28 73 74 61 g-start+end (sta
eff0: 72 74 32 20 65 6e 64 32 29 20 73 74 72 69 6e 67 rt2 end2) string
f000: 2d 72 65 70 6c 61 63 65 20 73 32 20 6d 61 79 62 -replace s2 mayb
f010: 65 2d 73 74 61 72 74 2b 65 6e 64 0a 20 20 20 20 e-start+end.
f020: 28 6c 65 74 2a 20 28 28 73 6c 65 6e 31 20 28 73 (let* ((slen1 (s
f030: 74 72 69 6e 67 2d 6c 65 6e 67 74 68 20 73 31 29 tring-length s1)
f040: 29 0a 09 20 20 20 28 73 75 62 6c 65 6e 32 20 28 ).. (sublen2 (
f050: 2d 20 65 6e 64 32 20 73 74 61 72 74 32 29 29 0a - end2 start2)).
f060: 09 20 20 20 28 61 6c 65 6e 20 28 2b 20 28 2d 20 . (alen (+ (-
f070: 73 6c 65 6e 31 20 28 2d 20 65 6e 64 31 20 73 74 slen1 (- end1 st
f080: 61 72 74 31 29 29 20 73 75 62 6c 65 6e 32 29 29 art1)) sublen2))
f090: 0a 09 20 20 20 28 61 6e 73 20 28 6d 61 6b 65 2d .. (ans (make-
f0a0: 73 74 72 69 6e 67 20 61 6c 65 6e 29 29 29 0a 20 string alen))).
f0b0: 20 20 20 20 20 28 25 73 74 72 69 6e 67 2d 63 6f (%string-co
f0c0: 70 79 21 20 61 6e 73 20 30 20 73 31 20 30 20 73 py! ans 0 s1 0 s
f0d0: 74 61 72 74 31 29 0a 20 20 20 20 20 20 28 25 73 tart1). (%s
f0e0: 74 72 69 6e 67 2d 63 6f 70 79 21 20 61 6e 73 20 tring-copy! ans
f0f0: 73 74 61 72 74 31 20 73 32 20 73 74 61 72 74 32 start1 s2 start2
f100: 20 65 6e 64 32 29 0a 20 20 20 20 20 20 28 25 73 end2). (%s
f110: 74 72 69 6e 67 2d 63 6f 70 79 21 20 61 6e 73 20 tring-copy! ans
f120: 28 2b 20 73 74 61 72 74 31 20 73 75 62 6c 65 6e (+ start1 sublen
f130: 32 29 20 73 31 20 65 6e 64 31 20 73 6c 65 6e 31 2) s1 end1 slen1
f140: 29 0a 20 20 20 20 20 20 61 6e 73 29 29 29 0a 0a ). ans)))..
f150: 0a 3b 3b 3b 20 73 74 72 69 6e 67 2d 74 6f 6b 65 .;;; string-toke
f160: 6e 69 7a 65 20 73 20 5b 74 6f 6b 65 6e 2d 73 65 nize s [token-se
f170: 74 20 73 74 61 72 74 20 65 6e 64 5d 20 2d 3e 20 t start end] ->
f180: 6c 69 73 74 0a 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b list.;;;;;;;;;;;
f190: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
f1a0: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
f1b0: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
f1c0: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
f1d0: 3b 3b 3b 3b 0a 3b 3b 3b 20 42 72 65 61 6b 20 53 ;;;;.;;; Break S
f1e0: 20 75 70 20 69 6e 74 6f 20 61 20 6c 69 73 74 20 up into a list
f1f0: 6f 66 20 74 6f 6b 65 6e 20 73 74 72 69 6e 67 73 of token strings
f200: 2c 20 77 68 65 72 65 20 61 20 74 6f 6b 65 6e 20 , where a token
f210: 69 73 20 61 20 6d 61 78 69 6d 61 6c 0a 3b 3b 3b is a maximal.;;;
f220: 20 6e 6f 6e 2d 65 6d 70 74 79 20 63 6f 6e 74 69 non-empty conti
f230: 67 75 6f 75 73 20 73 65 71 75 65 6e 63 65 20 6f guous sequence o
f240: 66 20 63 68 61 72 73 20 62 65 6c 6f 6e 67 69 6e f chars belongin
f250: 67 20 74 6f 20 54 4f 4b 45 4e 2d 53 45 54 2e 0a g to TOKEN-SET..
f260: 3b 3b 3b 20 28 73 74 72 69 6e 67 2d 74 6f 6b 65 ;;; (string-toke
f270: 6e 69 7a 65 20 22 68 65 6c 6c 6f 2c 20 77 6f 72 nize "hello, wor
f280: 6c 64 22 29 20 3d 3e 20 28 22 68 65 6c 6c 6f 2c ld") => ("hello,
f290: 22 20 22 77 6f 72 6c 64 22 29 0a 0a 28 64 65 66 " "world")..(def
f2a0: 69 6e 65 20 28 73 74 72 69 6e 67 2d 74 6f 6b 65 ine (string-toke
f2b0: 6e 69 7a 65 20 73 20 2e 20 74 6f 6b 65 6e 2d 63 nize s . token-c
f2c0: 68 61 72 73 2b 73 74 61 72 74 2b 65 6e 64 29 0a hars+start+end).
f2d0: 20 20 28 6c 65 74 2d 6f 70 74 69 6f 6e 61 6c 73 (let-optionals
f2e0: 2a 20 74 6f 6b 65 6e 2d 63 68 61 72 73 2b 73 74 * token-chars+st
f2f0: 61 72 74 2b 65 6e 64 0a 20 20 20 20 20 20 20 20 art+end.
f300: 20 20 20 20 20 20 20 20 20 20 28 28 74 6f 6b 65 ((toke
f310: 6e 2d 63 68 61 72 73 20 63 68 61 72 2d 73 65 74 n-chars char-set
f320: 3a 67 72 61 70 68 69 63 20 28 63 68 61 72 2d 73 :graphic (char-s
f330: 65 74 3f 20 74 6f 6b 65 6e 2d 63 68 61 72 73 29 et? token-chars)
f340: 29 20 72 65 73 74 29 0a 20 20 20 20 28 6c 65 74 ) rest). (let
f350: 2d 73 74 72 69 6e 67 2d 73 74 61 72 74 2b 65 6e -string-start+en
f360: 64 20 28 73 74 61 72 74 20 65 6e 64 29 20 73 74 d (start end) st
f370: 72 69 6e 67 2d 74 6f 6b 65 6e 69 7a 65 20 73 20 ring-tokenize s
f380: 72 65 73 74 0a 20 20 20 20 20 20 28 6c 65 74 20 rest. (let
f390: 6c 70 20 28 28 69 20 65 6e 64 29 20 28 61 6e 73 lp ((i end) (ans
f3a0: 20 27 28 29 29 29 0a 09 28 63 6f 6e 64 20 28 28 '()))..(cond ((
f3b0: 61 6e 64 20 28 3c 20 73 74 61 72 74 20 69 29 20 and (< start i)
f3c0: 28 73 74 72 69 6e 67 2d 69 6e 64 65 78 2d 72 69 (string-index-ri
f3d0: 67 68 74 20 73 20 74 6f 6b 65 6e 2d 63 68 61 72 ght s token-char
f3e0: 73 20 73 74 61 72 74 20 69 29 29 20 3d 3e 0a 09 s start i)) =>..
f3f0: 20 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 (lambda (
f400: 74 65 6e 64 2d 31 29 0a 09 09 20 28 6c 65 74 20 tend-1)... (let
f410: 28 28 74 65 6e 64 20 28 2b 20 31 20 74 65 6e 64 ((tend (+ 1 tend
f420: 2d 31 29 29 29 0a 09 09 20 20 20 28 63 6f 6e 64 -1)))... (cond
f430: 20 28 28 73 74 72 69 6e 67 2d 73 6b 69 70 2d 72 ((string-skip-r
f440: 69 67 68 74 20 73 20 74 6f 6b 65 6e 2d 63 68 61 ight s token-cha
f450: 72 73 20 73 74 61 72 74 20 74 65 6e 64 2d 31 29 rs start tend-1)
f460: 20 3d 3e 0a 09 09 09 20 20 28 6c 61 6d 62 64 61 =>.... (lambda
f470: 20 28 74 73 74 61 72 74 2d 31 29 0a 09 09 09 20 (tstart-1)....
f480: 20 20 20 28 6c 70 20 74 73 74 61 72 74 2d 31 0a (lp tstart-1.
f490: 09 09 09 09 28 63 6f 6e 73 20 28 73 75 62 73 74 ....(cons (subst
f4a0: 72 69 6e 67 20 73 20 28 2b 20 31 20 74 73 74 61 ring s (+ 1 tsta
f4b0: 72 74 2d 31 29 20 74 65 6e 64 29 0a 09 09 09 09 rt-1) tend).....
f4c0: 20 20 20 20 20 20 61 6e 73 29 29 29 29 0a 09 09 ans))))...
f4d0: 09 20 28 65 6c 73 65 20 28 63 6f 6e 73 20 28 73 . (else (cons (s
f4e0: 75 62 73 74 72 69 6e 67 20 73 20 73 74 61 72 74 ubstring s start
f4f0: 20 74 65 6e 64 29 20 61 6e 73 29 29 29 29 29 29 tend) ans))))))
f500: 0a 09 20 20 20 20 20 20 28 65 6c 73 65 20 61 6e .. (else an
f510: 73 29 29 29 29 29 29 0a 0a 0c 0a 3b 3b 3b 20 78 s))))))....;;; x
f520: 73 75 62 73 74 72 69 6e 67 20 73 20 66 72 6f 6d substring s from
f530: 20 5b 74 6f 20 73 74 61 72 74 20 65 6e 64 5d 20 [to start end]
f540: 2d 3e 20 73 74 72 69 6e 67 0a 3b 3b 3b 3b 3b 3b -> string.;;;;;;
f550: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
f560: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
f570: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
f580: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
f590: 3b 3b 3b 3b 3b 3b 3b 3b 3b 0a 3b 3b 3b 20 53 20 ;;;;;;;;;.;;; S
f5a0: 69 73 20 61 20 73 74 72 69 6e 67 3b 20 53 54 41 is a string; STA
f5b0: 52 54 20 61 6e 64 20 45 4e 44 20 61 72 65 20 6f RT and END are o
f5c0: 70 74 69 6f 6e 61 6c 20 61 72 67 75 6d 65 6e 74 ptional argument
f5d0: 73 20 74 68 61 74 20 64 65 6d 61 72 63 61 74 65 s that demarcate
f5e0: 0a 3b 3b 3b 20 61 20 73 75 62 73 74 72 69 6e 67 .;;; a substring
f5f0: 20 6f 66 20 53 2c 20 64 65 66 61 75 6c 74 69 6e of S, defaultin
f600: 67 20 74 6f 20 30 20 61 6e 64 20 74 68 65 20 6c g to 0 and the l
f610: 65 6e 67 74 68 20 6f 66 20 53 20 28 65 2e 67 2e ength of S (e.g.
f620: 2c 20 74 68 65 20 77 68 6f 6c 65 0a 3b 3b 3b 20 , the whole.;;;
f630: 73 74 72 69 6e 67 29 2e 20 52 65 70 6c 69 63 61 string). Replica
f640: 74 65 20 74 68 69 73 20 73 75 62 73 74 72 69 6e te this substrin
f650: 67 20 75 70 20 61 6e 64 20 64 6f 77 6e 20 69 6e g up and down in
f660: 64 65 78 20 73 70 61 63 65 2c 20 69 6e 20 62 6f dex space, in bo
f670: 74 68 20 74 68 65 0a 3b 3b 20 20 70 6f 73 69 74 th the.;; posit
f680: 69 76 65 20 61 6e 64 20 6e 65 67 61 74 69 76 65 ive and negative
f690: 20 64 69 72 65 63 74 69 6f 6e 73 2e 20 46 6f 72 directions. For
f6a0: 20 65 78 61 6d 70 6c 65 2c 20 69 66 20 53 20 3d example, if S =
f6b0: 20 22 61 62 63 64 65 66 67 22 2c 20 53 54 41 52 "abcdefg", STAR
f6c0: 54 3d 33 2c 20 0a 3b 3b 3b 20 61 6e 64 20 45 4e T=3, .;;; and EN
f6d0: 44 3d 36 2c 20 74 68 65 6e 20 77 65 20 68 61 76 D=6, then we hav
f6e0: 65 20 74 68 65 20 63 6f 6e 63 65 70 74 75 61 6c e the conceptual
f6f0: 20 62 69 64 69 72 65 63 74 69 6f 6e 61 6c 6c 79 bidirectionally
f700: 2d 69 6e 66 69 6e 69 74 65 20 73 74 72 69 6e 67 -infinite string
f710: 0a 3b 3b 3b 20 20 20 20 20 2e 2e 2e 20 20 64 20 .;;; ... d
f720: 20 65 20 20 66 20 20 64 20 20 65 20 20 66 20 20 e f d e f
f730: 64 20 20 65 20 20 66 20 20 64 20 20 65 20 20 66 d e f d e f
f740: 20 20 64 20 20 65 20 20 66 20 20 64 20 20 65 20 d e f d e
f750: 20 66 20 20 64 20 20 65 20 20 66 20 2e 2e 2e 0a f d e f ....
f760: 3b 3b 3b 20 20 20 20 20 2e 2e 2e 20 2d 39 20 2d ;;; ... -9 -
f770: 38 20 2d 37 20 2d 36 20 2d 35 20 2d 34 20 2d 33 8 -7 -6 -5 -4 -3
f780: 20 2d 32 20 2d 31 20 20 30 20 20 31 20 20 32 20 -2 -1 0 1 2
f790: 20 33 20 20 34 20 20 35 20 20 36 20 20 37 20 20 3 4 5 6 7
f7a0: 38 20 20 39 20 2e 2e 2e 0a 3b 3b 3b 20 58 53 55 8 9 ....;;; XSU
f7b0: 42 53 54 52 49 4e 47 20 72 65 74 75 72 6e 73 20 BSTRING returns
f7c0: 74 68 65 20 73 75 62 73 74 72 69 6e 67 20 6f 66 the substring of
f7d0: 20 74 68 69 73 20 73 74 72 69 6e 67 20 62 65 67 this string beg
f7e0: 69 6e 6e 69 6e 67 20 61 74 20 69 6e 64 65 78 20 inning at index
f7f0: 46 52 4f 4d 2c 0a 3b 3b 3b 20 61 6e 64 20 65 6e FROM,.;;; and en
f800: 64 69 6e 67 20 61 74 20 54 4f 20 28 77 68 69 63 ding at TO (whic
f810: 68 20 64 65 66 61 75 6c 74 73 20 74 6f 20 46 52 h defaults to FR
f820: 4f 4d 2b 28 45 4e 44 2d 53 54 41 52 54 29 29 2e OM+(END-START)).
f830: 0a 3b 3b 3b 20 0a 3b 3b 3b 20 59 6f 75 20 63 61 .;;; .;;; You ca
f840: 6e 20 75 73 65 20 58 53 55 42 53 54 52 49 4e 47 n use XSUBSTRING
f850: 20 69 6e 20 6d 61 6e 79 20 77 61 79 73 3a 0a 3b in many ways:.;
f860: 3b 3b 20 2d 20 54 6f 20 72 6f 74 61 74 65 20 61 ;; - To rotate a
f870: 20 73 74 72 69 6e 67 20 6c 65 66 74 3a 20 20 28 string left: (
f880: 78 73 75 62 73 74 72 69 6e 67 20 22 61 62 63 64 xsubstring "abcd
f890: 65 66 22 20 32 29 20 20 3d 3e 20 22 63 64 65 66 ef" 2) => "cdef
f8a0: 61 62 22 0a 3b 3b 3b 20 2d 20 54 6f 20 72 6f 74 ab".;;; - To rot
f8b0: 61 74 65 20 61 20 73 74 72 69 6e 67 20 72 69 67 ate a string rig
f8c0: 68 74 3a 20 28 78 73 75 62 73 74 72 69 6e 67 20 ht: (xsubstring
f8d0: 22 61 62 63 64 65 66 22 20 2d 32 29 20 3d 3e 20 "abcdef" -2) =>
f8e0: 22 65 66 61 62 63 64 22 0a 3b 3b 3b 20 2d 20 54 "efabcd".;;; - T
f8f0: 6f 20 72 65 70 6c 69 63 61 74 65 20 61 20 73 74 o replicate a st
f900: 72 69 6e 67 3a 20 20 20 20 28 78 73 75 62 73 74 ring: (xsubst
f910: 72 69 6e 67 20 22 61 62 63 22 20 30 20 37 29 20 ring "abc" 0 7)
f920: 3d 3e 20 22 61 62 63 61 62 63 61 22 0a 3b 3b 3b => "abcabca".;;;
f930: 0a 3b 3b 3b 20 4e 6f 74 65 20 74 68 61 74 20 0a .;;; Note that .
f940: 3b 3b 3b 20 20 20 2d 20 54 68 65 20 46 52 4f 4d ;;; - The FROM
f950: 2f 54 4f 20 69 6e 64 69 63 65 73 20 67 69 76 65 /TO indices give
f960: 20 61 20 68 61 6c 66 2d 6f 70 65 6e 20 72 61 6e a half-open ran
f970: 67 65 20 2d 2d 20 74 68 65 20 63 68 61 72 61 63 ge -- the charac
f980: 74 65 72 73 20 66 72 6f 6d 0a 3b 3b 3b 20 20 20 ters from.;;;
f990: 20 20 69 6e 64 65 78 20 46 52 4f 4d 20 75 70 20 index FROM up
f9a0: 74 6f 2c 20 62 75 74 20 6e 6f 74 20 69 6e 63 6c to, but not incl
f9b0: 75 64 69 6e 67 20 69 6e 64 65 78 20 54 4f 2e 0a uding index TO..
f9c0: 3b 3b 3b 20 20 20 2d 20 54 68 65 20 46 52 4f 4d ;;; - The FROM
f9d0: 2f 54 4f 20 69 6e 64 69 63 65 73 20 61 72 65 20 /TO indices are
f9e0: 6e 6f 74 20 69 6e 20 74 65 72 6d 73 20 6f 66 20 not in terms of
f9f0: 74 68 65 20 69 6e 64 65 78 20 73 70 61 63 65 20 the index space
fa00: 66 6f 72 20 73 74 72 69 6e 67 20 53 2e 0a 3b 3b for string S..;;
fa10: 3b 20 20 20 20 20 54 68 65 79 20 61 72 65 20 69 ; They are i
fa20: 6e 20 74 65 72 6d 73 20 6f 66 20 74 68 65 20 72 n terms of the r
fa30: 65 70 6c 69 63 61 74 65 64 20 69 6e 64 65 78 20 eplicated index
fa40: 73 70 61 63 65 20 6f 66 20 74 68 65 20 73 75 62 space of the sub
fa50: 73 74 72 69 6e 67 0a 3b 3b 3b 20 20 20 20 20 64 string.;;; d
fa60: 65 66 69 6e 65 64 20 62 79 20 53 2c 20 53 54 41 efined by S, STA
fa70: 52 54 2c 20 61 6e 64 20 45 4e 44 2e 0a 3b 3b 3b RT, and END..;;;
fa80: 0a 3b 3b 3b 20 49 74 20 69 73 20 61 6e 20 65 72 .;;; It is an er
fa90: 72 6f 72 20 69 66 20 53 54 41 52 54 3d 45 4e 44 ror if START=END
faa0: 20 2d 2d 20 61 6c 74 68 6f 75 67 68 20 74 68 69 -- although thi
fab0: 73 20 69 73 20 61 6c 6c 6f 77 65 64 20 62 79 20 s is allowed by
fac0: 73 70 65 63 69 61 6c 0a 3b 3b 3b 20 64 69 73 70 special.;;; disp
fad0: 65 6e 73 61 74 69 6f 6e 20 77 68 65 6e 20 46 52 ensation when FR
fae0: 4f 4d 3d 54 4f 2e 0a 0a 28 64 65 66 69 6e 65 20 OM=TO...(define
faf0: 28 78 73 75 62 73 74 72 69 6e 67 20 73 20 66 72 (xsubstring s fr
fb00: 6f 6d 20 2e 20 6d 61 79 62 65 2d 74 6f 2b 73 74 om . maybe-to+st
fb10: 61 72 74 2b 65 6e 64 29 0a 20 20 28 63 68 65 63 art+end). (chec
fb20: 6b 2d 61 72 67 20 28 6c 61 6d 62 64 61 20 28 76 k-arg (lambda (v
fb30: 61 6c 29 20 28 61 6e 64 20 28 69 6e 74 65 67 65 al) (and (intege
fb40: 72 3f 20 76 61 6c 29 20 28 65 78 61 63 74 3f 20 r? val) (exact?
fb50: 76 61 6c 29 29 29 0a 09 20 20 20 20 20 66 72 6f val))).. fro
fb60: 6d 20 78 73 75 62 73 74 72 69 6e 67 29 0a 20 20 m xsubstring).
fb70: 28 72 65 63 65 69 76 65 20 28 74 6f 20 73 74 61 (receive (to sta
fb80: 72 74 20 65 6e 64 29 0a 20 20 20 20 20 20 20 20 rt end).
fb90: 20 20 20 28 69 66 20 28 70 61 69 72 3f 20 6d 61 (if (pair? ma
fba0: 79 62 65 2d 74 6f 2b 73 74 61 72 74 2b 65 6e 64 ybe-to+start+end
fbb0: 29 0a 09 20 20 20 20 20 20 20 28 6c 65 74 2d 73 ).. (let-s
fbc0: 74 72 69 6e 67 2d 73 74 61 72 74 2b 65 6e 64 20 tring-start+end
fbd0: 28 73 74 61 72 74 20 65 6e 64 29 20 78 73 75 62 (start end) xsub
fbe0: 73 74 72 69 6e 67 20 73 20 28 63 64 72 20 6d 61 string s (cdr ma
fbf0: 79 62 65 2d 74 6f 2b 73 74 61 72 74 2b 65 6e 64 ybe-to+start+end
fc00: 29 0a 09 09 20 28 6c 65 74 20 28 28 74 6f 20 28 )... (let ((to (
fc10: 63 61 72 20 6d 61 79 62 65 2d 74 6f 2b 73 74 61 car maybe-to+sta
fc20: 72 74 2b 65 6e 64 29 29 29 0a 09 09 20 20 20 28 rt+end)))... (
fc30: 63 68 65 63 6b 2d 61 72 67 20 28 6c 61 6d 62 64 check-arg (lambd
fc40: 61 20 28 76 61 6c 29 20 28 61 6e 64 20 28 69 6e a (val) (and (in
fc50: 74 65 67 65 72 3f 20 76 61 6c 29 0a 09 09 09 09 teger? val).....
fc60: 09 09 20 28 65 78 61 63 74 3f 20 76 61 6c 29 0a .. (exact? val).
fc70: 09 09 09 09 09 09 20 28 3c 3d 20 66 72 6f 6d 20 ...... (<= from
fc80: 76 61 6c 29 29 29 0a 09 09 09 20 20 20 20 20 20 val)))....
fc90: 74 6f 20 78 73 75 62 73 74 72 69 6e 67 29 0a 09 to xsubstring)..
fca0: 09 20 20 20 28 76 61 6c 75 65 73 20 74 6f 20 73 . (values to s
fcb0: 74 61 72 74 20 65 6e 64 29 29 29 0a 09 20 20 20 tart end)))..
fcc0: 20 20 20 20 28 6c 65 74 20 28 28 73 6c 65 6e 20 (let ((slen
fcd0: 28 73 74 72 69 6e 67 2d 6c 65 6e 67 74 68 20 28 (string-length (
fce0: 63 68 65 63 6b 2d 61 72 67 20 73 74 72 69 6e 67 check-arg string
fcf0: 3f 20 73 20 78 73 75 62 73 74 72 69 6e 67 29 29 ? s xsubstring))
fd00: 29 29 0a 09 09 20 28 76 61 6c 75 65 73 20 28 2b ))... (values (+
fd10: 20 66 72 6f 6d 20 73 6c 65 6e 29 20 30 20 73 6c from slen) 0 sl
fd20: 65 6e 29 29 29 0a 20 20 20 20 28 6c 65 74 20 28 en))). (let (
fd30: 28 73 6c 65 6e 20 20 20 28 2d 20 65 6e 64 20 73 (slen (- end s
fd40: 74 61 72 74 29 29 0a 09 20 20 28 61 6e 73 6c 65 tart)).. (ansle
fd50: 6e 20 28 2d 20 74 6f 20 20 66 72 6f 6d 29 29 29 n (- to from)))
fd60: 0a 20 20 20 20 20 20 28 63 6f 6e 64 20 28 28 7a . (cond ((z
fd70: 65 72 6f 3f 20 61 6e 73 6c 65 6e 29 20 22 22 29 ero? anslen) "")
fd80: 0a 09 20 20 20 20 28 28 7a 65 72 6f 3f 20 73 6c .. ((zero? sl
fd90: 65 6e 29 20 28 65 72 72 6f 72 20 22 43 61 6e 6e en) (error "Cann
fda0: 6f 74 20 72 65 70 6c 69 63 61 74 65 20 65 6d 70 ot replicate emp
fdb0: 74 79 20 28 73 75 62 29 73 74 72 69 6e 67 22 0a ty (sub)string".
fdc0: 09 09 09 09 20 20 78 73 75 62 73 74 72 69 6e 67 .... xsubstring
fdd0: 20 73 20 66 72 6f 6d 20 74 6f 20 73 74 61 72 74 s from to start
fde0: 20 65 6e 64 29 29 0a 0a 09 20 20 20 20 28 28 3d end))... ((=
fdf0: 20 31 20 73 6c 65 6e 29 09 09 3b 20 46 61 73 74 1 slen)..; Fast
fe00: 20 70 61 74 68 20 66 6f 72 20 31 2d 63 68 61 72 path for 1-char
fe10: 20 72 65 70 6c 69 63 61 74 69 6f 6e 2e 0a 09 20 replication...
fe20: 20 20 20 20 28 6d 61 6b 65 2d 73 74 72 69 6e 67 (make-string
fe30: 20 61 6e 73 6c 65 6e 20 28 73 74 72 69 6e 67 2d anslen (string-
fe40: 72 65 66 20 73 20 73 74 61 72 74 29 29 29 0a 0a ref s start)))..
fe50: 09 20 20 20 20 3b 3b 20 53 65 6c 65 63 74 65 64 . ;; Selected
fe60: 20 74 65 78 74 20 66 61 6c 6c 73 20 65 6e 74 69 text falls enti
fe70: 72 65 6c 79 20 77 69 74 68 69 6e 20 6f 6e 65 20 rely within one
fe80: 73 70 61 6e 2e 0a 09 20 20 20 20 28 28 3d 20 28 span... ((= (
fe90: 66 6c 6f 6f 72 20 28 2f 20 66 72 6f 6d 20 73 6c floor (/ from sl
fea0: 65 6e 29 29 20 28 66 6c 6f 6f 72 20 28 2f 20 74 en)) (floor (/ t
feb0: 6f 20 73 6c 65 6e 29 29 29 0a 09 20 20 20 20 20 o slen)))..
fec0: 28 73 75 62 73 74 72 69 6e 67 20 73 20 28 2b 20 (substring s (+
fed0: 73 74 61 72 74 20 28 6d 6f 64 75 6c 6f 20 66 72 start (modulo fr
fee0: 6f 6d 20 73 6c 65 6e 29 29 0a 09 09 09 20 20 28 om slen)).... (
fef0: 2b 20 73 74 61 72 74 20 28 6d 6f 64 75 6c 6f 20 + start (modulo
ff00: 74 6f 20 20 20 73 6c 65 6e 29 29 29 29 0a 0a 09 to slen))))...
ff10: 20 20 20 20 3b 3b 20 53 65 6c 65 63 74 65 64 20 ;; Selected
ff20: 74 65 78 74 20 72 65 71 75 69 72 65 73 20 6d 75 text requires mu
ff30: 6c 74 69 70 6c 65 20 73 70 61 6e 73 2e 0a 09 20 ltiple spans...
ff40: 20 20 20 28 65 6c 73 65 20 28 6c 65 74 20 28 28 (else (let ((
ff50: 61 6e 73 20 28 6d 61 6b 65 2d 73 74 72 69 6e 67 ans (make-string
ff60: 20 61 6e 73 6c 65 6e 29 29 29 0a 09 09 20 20 20 anslen)))...
ff70: 20 28 25 6d 75 6c 74 69 73 70 61 6e 2d 72 65 70 (%multispan-rep
ff80: 63 6f 70 79 21 20 61 6e 73 20 30 20 73 20 66 72 copy! ans 0 s fr
ff90: 6f 6d 20 74 6f 20 73 74 61 72 74 20 65 6e 64 29 om to start end)
ffa0: 0a 09 09 20 20 20 20 61 6e 73 29 29 29 29 29 29 ... ans))))))
ffb0: 0a 0a 0a 3b 3b 3b 20 73 74 72 69 6e 67 2d 78 63 ...;;; string-xc
ffc0: 6f 70 79 21 20 74 61 72 67 65 74 20 74 73 74 61 opy! target tsta
ffd0: 72 74 20 73 20 73 66 72 6f 6d 20 5b 73 74 6f 20 rt s sfrom [sto
ffe0: 73 74 61 72 74 20 65 6e 64 5d 20 2d 3e 20 75 6e start end] -> un
fff0: 73 70 65 63 69 66 69 63 0a 3b 3b 3b 3b 3b 3b 3b specific.;;;;;;;
10000 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
10010 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
10020 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
10030 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
10040 3b 3b 3b 3b 3b 3b 3b 3b 0a 3b 3b 3b 20 45 78 61 ;;;;;;;;.;;; Exa
10050 63 74 6c 79 20 74 68 65 20 73 61 6d 65 20 61 73 ctly the same as
10060 20 78 73 75 62 73 74 72 69 6e 67 2c 20 62 75 74 xsubstring, but
10070 20 74 68 65 20 65 78 74 72 61 63 74 65 64 20 74 the extracted t
10080 65 78 74 20 69 73 20 77 72 69 74 74 65 6e 0a 3b ext is written.;
10090 3b 3b 20 69 6e 74 6f 20 74 68 65 20 73 74 72 69 ;; into the stri
100a0 6e 67 20 54 41 52 47 45 54 20 73 74 61 72 74 69 ng TARGET starti
100b0 6e 67 20 61 74 20 69 6e 64 65 78 20 54 53 54 41 ng at index TSTA
100c0 52 54 2e 0a 3b 3b 3b 20 54 68 69 73 20 6f 70 65 RT..;;; This ope
100d0 72 61 74 69 6f 6e 20 69 73 20 6e 6f 74 20 64 65 ration is not de
100e0 66 69 6e 65 64 20 69 66 20 28 45 51 3f 20 54 41 fined if (EQ? TA
100f0 52 47 45 54 20 53 29 20 2d 2d 20 79 6f 75 20 63 RGET S) -- you c
10100 61 6e 6e 6f 74 20 63 6f 70 79 0a 3b 3b 3b 20 61 annot copy.;;; a
10110 20 73 74 72 69 6e 67 20 6f 6e 20 74 6f 70 20 6f string on top o
10120 66 20 69 74 73 65 6c 66 2e 0a 0a 28 64 65 66 69 f itself...(defi
10130 6e 65 20 28 73 74 72 69 6e 67 2d 78 63 6f 70 79 ne (string-xcopy
10140 21 20 74 61 72 67 65 74 20 74 73 74 61 72 74 20 ! target tstart
10150 73 20 73 66 72 6f 6d 20 2e 20 6d 61 79 62 65 2d s sfrom . maybe-
10160 73 74 6f 2b 73 74 61 72 74 2b 65 6e 64 29 0a 20 sto+start+end).
10170 20 28 63 68 65 63 6b 2d 61 72 67 20 28 6c 61 6d (check-arg (lam
10180 62 64 61 20 28 76 61 6c 29 20 28 61 6e 64 20 28 bda (val) (and (
10190 69 6e 74 65 67 65 72 3f 20 76 61 6c 29 20 28 65 integer? val) (e
101a0 78 61 63 74 3f 20 76 61 6c 29 29 29 0a 09 20 20 xact? val)))..
101b0 20 20 20 73 66 72 6f 6d 20 73 74 72 69 6e 67 2d sfrom string-
101c0 78 63 6f 70 79 21 29 0a 20 20 28 72 65 63 65 69 xcopy!). (recei
101d0 76 65 20 28 73 74 6f 20 73 74 61 72 74 20 65 6e ve (sto start en
101e0 64 29 0a 20 20 20 20 20 20 20 20 20 20 20 28 69 d). (i
101f0 66 20 28 70 61 69 72 3f 20 6d 61 79 62 65 2d 73 f (pair? maybe-s
10200 74 6f 2b 73 74 61 72 74 2b 65 6e 64 29 0a 09 20 to+start+end)..
10210 20 20 20 20 20 20 28 6c 65 74 2d 73 74 72 69 6e (let-strin
10220 67 2d 73 74 61 72 74 2b 65 6e 64 20 28 73 74 61 g-start+end (sta
10230 72 74 20 65 6e 64 29 20 73 74 72 69 6e 67 2d 78 rt end) string-x
10240 63 6f 70 79 21 20 73 20 28 63 64 72 20 6d 61 79 copy! s (cdr may
10250 62 65 2d 73 74 6f 2b 73 74 61 72 74 2b 65 6e 64 be-sto+start+end
10260 29 0a 09 09 20 28 6c 65 74 20 28 28 73 74 6f 20 )... (let ((sto
10270 28 63 61 72 20 6d 61 79 62 65 2d 73 74 6f 2b 73 (car maybe-sto+s
10280 74 61 72 74 2b 65 6e 64 29 29 29 0a 09 09 20 20 tart+end)))...
10290 20 28 63 68 65 63 6b 2d 61 72 67 20 28 6c 61 6d (check-arg (lam
102a0 62 64 61 20 28 76 61 6c 29 20 28 61 6e 64 20 28 bda (val) (and (
102b0 69 6e 74 65 67 65 72 3f 20 76 61 6c 29 20 28 65 integer? val) (e
102c0 78 61 63 74 3f 20 76 61 6c 29 29 29 0a 09 09 09 xact? val)))....
102d0 20 20 20 20 20 20 73 74 6f 20 73 74 72 69 6e 67 sto string
102e0 2d 78 63 6f 70 79 21 29 0a 09 09 20 20 20 28 76 -xcopy!)... (v
102f0 61 6c 75 65 73 20 73 74 6f 20 73 74 61 72 74 20 alues sto start
10300 65 6e 64 29 29 29 0a 09 20 20 20 20 20 20 20 28 end))).. (
10310 6c 65 74 20 28 28 73 6c 65 6e 20 28 73 74 72 69 let ((slen (stri
10320 6e 67 2d 6c 65 6e 67 74 68 20 73 29 29 29 0a 09 ng-length s)))..
10330 09 20 28 76 61 6c 75 65 73 20 28 2b 20 73 66 72 . (values (+ sfr
10340 6f 6d 20 73 6c 65 6e 29 20 30 20 73 6c 65 6e 29 om slen) 0 slen)
10350 29 29 0a 0a 20 20 20 20 28 6c 65 74 2a 20 28 28 )).. (let* ((
10360 74 6f 63 6f 70 79 20 28 2d 20 73 74 6f 20 73 66 tocopy (- sto sf
10370 72 6f 6d 29 29 0a 09 20 20 20 28 74 65 6e 64 20 rom)).. (tend
10380 28 2b 20 74 73 74 61 72 74 20 74 6f 63 6f 70 79 (+ tstart tocopy
10390 29 29 0a 09 20 20 20 28 73 6c 65 6e 20 28 2d 20 )).. (slen (-
103a0 65 6e 64 20 73 74 61 72 74 29 29 29 0a 20 20 20 end start))).
103b0 20 20 20 28 63 68 65 63 6b 2d 73 75 62 73 74 72 (check-substr
103c0 69 6e 67 2d 73 70 65 63 20 73 74 72 69 6e 67 2d ing-spec string-
103d0 78 63 6f 70 79 21 20 74 61 72 67 65 74 20 74 73 xcopy! target ts
103e0 74 61 72 74 20 74 65 6e 64 29 0a 20 20 20 20 20 tart tend).
103f0 20 28 63 6f 6e 64 20 28 28 7a 65 72 6f 3f 20 74 (cond ((zero? t
10400 6f 63 6f 70 79 29 29 0a 09 20 20 20 20 28 28 7a ocopy)).. ((z
10410 65 72 6f 3f 20 73 6c 65 6e 29 20 28 65 72 72 6f ero? slen) (erro
10420 72 20 22 43 61 6e 6e 6f 74 20 72 65 70 6c 69 63 r "Cannot replic
10430 61 74 65 20 65 6d 70 74 79 20 28 73 75 62 29 73 ate empty (sub)s
10440 74 72 69 6e 67 22 0a 09 09 09 09 20 73 74 72 69 tring"..... stri
10450 6e 67 2d 78 63 6f 70 79 21 0a 09 09 09 09 20 74 ng-xcopy!..... t
10460 61 72 67 65 74 20 74 73 74 61 72 74 20 73 20 73 arget tstart s s
10470 66 72 6f 6d 20 73 74 6f 20 73 74 61 72 74 20 65 from sto start e
10480 6e 64 29 29 0a 0a 09 20 20 20 20 28 28 3d 20 31 nd))... ((= 1
10490 20 73 6c 65 6e 29 09 09 09 3b 20 46 61 73 74 20 slen)...; Fast
104a0 70 61 74 68 20 66 6f 72 20 31 2d 63 68 61 72 20 path for 1-char
104b0 72 65 70 6c 69 63 61 74 69 6f 6e 2e 0a 09 20 20 replication...
104c0 20 20 20 28 73 74 72 69 6e 67 2d 66 69 6c 6c 21 (string-fill!
104d0 20 74 61 72 67 65 74 20 28 73 74 72 69 6e 67 2d target (string-
104e0 72 65 66 20 73 20 73 74 61 72 74 29 20 74 73 74 ref s start) tst
104f0 61 72 74 20 74 65 6e 64 29 29 0a 0a 09 20 20 20 art tend))...
10500 20 3b 3b 20 53 65 6c 65 63 74 65 64 20 74 65 78 ;; Selected tex
10510 74 20 66 61 6c 6c 73 20 65 6e 74 69 72 65 6c 79 t falls entirely
10520 20 77 69 74 68 69 6e 20 6f 6e 65 20 73 70 61 6e within one span
10530 2e 0a 09 20 20 20 20 28 28 3d 20 28 66 6c 6f 6f ... ((= (floo
10540 72 20 28 2f 20 73 66 72 6f 6d 20 73 6c 65 6e 29 r (/ sfrom slen)
10550 29 20 28 66 6c 6f 6f 72 20 28 2f 20 73 74 6f 20 ) (floor (/ sto
10560 73 6c 65 6e 29 29 29 0a 09 20 20 20 20 20 28 25 slen))).. (%
10570 73 74 72 69 6e 67 2d 63 6f 70 79 21 20 74 61 72 string-copy! tar
10580 67 65 74 20 74 73 74 61 72 74 20 73 20 0a 09 09 get tstart s ...
10590 09 20 20 20 20 28 2b 20 73 74 61 72 74 20 28 6d . (+ start (m
105a0 6f 64 75 6c 6f 20 73 66 72 6f 6d 20 73 6c 65 6e odulo sfrom slen
105b0 29 29 0a 09 09 09 20 20 20 20 28 2b 20 73 74 61 )).... (+ sta
105c0 72 74 20 28 6d 6f 64 75 6c 6f 20 73 74 6f 20 20 rt (modulo sto
105d0 20 73 6c 65 6e 29 29 29 29 0a 0a 09 20 20 20 20 slen))))...
105e0 3b 3b 20 4d 75 6c 74 69 2d 73 70 61 6e 20 63 6f ;; Multi-span co
105f0 70 79 2e 0a 09 20 20 20 20 28 65 6c 73 65 20 28 py... (else (
10600 25 6d 75 6c 74 69 73 70 61 6e 2d 72 65 70 63 6f %multispan-repco
10610 70 79 21 20 74 61 72 67 65 74 20 74 73 74 61 72 py! target tstar
10620 74 20 73 20 73 66 72 6f 6d 20 73 74 6f 20 73 74 t s sfrom sto st
10630 61 72 74 20 65 6e 64 29 29 29 29 29 29 0a 0a 3b art end))))))..;
10640 3b 3b 20 54 68 69 73 20 69 73 20 74 68 65 20 63 ;; This is the c
10650 6f 72 65 20 63 6f 70 79 69 6e 67 20 6c 6f 6f 70 ore copying loop
10660 20 66 6f 72 20 58 53 55 42 53 54 52 49 4e 47 20 for XSUBSTRING
10670 61 6e 64 20 53 54 52 49 4e 47 2d 58 43 4f 50 59 and STRING-XCOPY
10680 21 0a 3b 3b 3b 20 49 6e 74 65 72 6e 61 6c 20 2d !.;;; Internal -
10690 2d 20 6e 6f 74 20 65 78 70 6f 72 74 65 64 2c 20 - not exported,
106a0 6e 6f 20 63 61 72 65 66 75 6c 20 61 72 67 20 63 no careful arg c
106b0 68 65 63 6b 69 6e 67 2e 0a 28 64 65 66 69 6e 65 hecking..(define
106c0 20 28 25 6d 75 6c 74 69 73 70 61 6e 2d 72 65 70 (%multispan-rep
106d0 63 6f 70 79 21 20 74 61 72 67 65 74 20 74 73 74 copy! target tst
106e0 61 72 74 20 73 20 73 66 72 6f 6d 20 73 74 6f 20 art s sfrom sto
106f0 73 74 61 72 74 20 65 6e 64 29 0a 20 20 28 6c 65 start end). (le
10700 74 2a 20 28 28 73 6c 65 6e 20 28 2d 20 65 6e 64 t* ((slen (- end
10710 20 73 74 61 72 74 29 29 0a 09 20 28 69 30 20 28 start)).. (i0 (
10720 2b 20 73 74 61 72 74 20 28 6d 6f 64 75 6c 6f 20 + start (modulo
10730 73 66 72 6f 6d 20 73 6c 65 6e 29 29 29 0a 09 20 sfrom slen)))..
10740 28 74 6f 74 61 6c 2d 63 68 61 72 73 20 28 2d 20 (total-chars (-
10750 73 74 6f 20 73 66 72 6f 6d 29 29 29 0a 0a 20 20 sto sfrom)))..
10760 20 20 3b 3b 20 43 6f 70 79 20 74 68 65 20 70 61 ;; Copy the pa
10770 72 74 69 61 6c 20 73 70 61 6e 20 40 20 74 68 65 rtial span @ the
10780 20 62 65 67 69 6e 6e 69 6e 67 0a 20 20 20 20 28 beginning. (
10790 25 73 74 72 69 6e 67 2d 63 6f 70 79 21 20 74 61 %string-copy! ta
107a0 72 67 65 74 20 74 73 74 61 72 74 20 73 20 69 30 rget tstart s i0
107b0 20 65 6e 64 29 0a 09 09 20 20 20 20 0a 20 20 20 end)... .
107c0 20 28 6c 65 74 2a 20 28 28 6e 63 6f 70 69 65 64 (let* ((ncopied
107d0 20 28 2d 20 65 6e 64 20 69 30 29 29 09 09 09 3b (- end i0))...;
107e0 20 57 65 27 76 65 20 63 6f 70 69 65 64 20 74 68 We've copied th
107f0 69 73 20 6d 61 6e 79 2e 0a 09 20 20 20 28 6e 6c is many... (nl
10800 65 66 74 20 28 2d 20 74 6f 74 61 6c 2d 63 68 61 eft (- total-cha
10810 72 73 20 6e 63 6f 70 69 65 64 29 29 09 3b 20 23 rs ncopied)).; #
10820 20 63 68 61 72 73 20 6c 65 66 74 20 74 6f 20 63 chars left to c
10830 6f 70 79 2e 0a 09 20 20 20 28 6e 73 70 61 6e 73 opy... (nspans
10840 20 28 71 75 6f 74 69 65 6e 74 20 6e 6c 65 66 74 (quotient nleft
10850 20 73 6c 65 6e 29 29 29 09 3b 20 23 20 77 68 6f slen))).; # who
10860 6c 65 20 73 70 61 6e 73 20 74 6f 20 63 6f 70 79 le spans to copy
10870 0a 09 09 09 20 20 20 0a 20 20 20 20 20 20 3b 3b .... . ;;
10880 20 43 6f 70 79 20 74 68 65 20 77 68 6f 6c 65 20 Copy the whole
10890 73 70 61 6e 73 20 69 6e 20 74 68 65 20 6d 69 64 spans in the mid
108a0 64 6c 65 2e 0a 20 20 20 20 20 20 28 64 6f 20 28 dle.. (do (
108b0 28 69 20 28 2b 20 74 73 74 61 72 74 20 6e 63 6f (i (+ tstart nco
108c0 70 69 65 64 29 20 28 2b 20 69 20 73 6c 65 6e 29 pied) (+ i slen)
108d0 29 09 3b 20 43 75 72 72 65 6e 74 20 74 61 72 67 ).; Current targ
108e0 65 74 20 69 6e 64 65 78 2e 0a 09 20 20 20 28 6e et index... (n
108f0 73 70 61 6e 73 20 6e 73 70 61 6e 73 20 28 2d 20 spans nspans (-
10900 6e 73 70 61 6e 73 20 31 29 29 29 09 3b 20 23 20 nspans 1))).; #
10910 73 70 61 6e 73 20 74 6f 20 63 6f 70 79 0a 09 20 spans to copy..
10920 20 28 28 7a 65 72 6f 3f 20 6e 73 70 61 6e 73 29 ((zero? nspans)
10930 0a 09 20 20 20 3b 3b 20 43 6f 70 79 20 74 68 65 .. ;; Copy the
10940 20 70 61 72 74 69 61 6c 2d 73 70 61 6e 20 40 20 partial-span @
10950 74 68 65 20 65 6e 64 20 26 20 77 65 27 72 65 20 the end & we're
10960 64 6f 6e 65 2e 0a 09 20 20 20 28 25 73 74 72 69 done... (%stri
10970 6e 67 2d 63 6f 70 79 21 20 74 61 72 67 65 74 20 ng-copy! target
10980 69 20 73 20 73 74 61 72 74 20 28 2b 20 73 74 61 i s start (+ sta
10990 72 74 20 28 2d 20 74 6f 74 61 6c 2d 63 68 61 72 rt (- total-char
109a0 73 20 28 2d 20 69 20 74 73 74 61 72 74 29 29 29 s (- i tstart)))
109b0 29 29 0a 0a 09 28 25 73 74 72 69 6e 67 2d 63 6f ))...(%string-co
109c0 70 79 21 20 74 61 72 67 65 74 20 69 20 73 20 73 py! target i s s
109d0 74 61 72 74 20 65 6e 64 29 29 29 29 29 3b 20 43 tart end))))); C
109e0 6f 70 79 20 61 20 77 68 6f 6c 65 20 73 70 61 6e opy a whole span
109f0 2e 0a 0a 0a 0c 0a 3b 3b 3b 20 28 73 74 72 69 6e ......;;; (strin
10a00 67 2d 6a 6f 69 6e 20 73 74 72 69 6e 67 2d 6c 69 g-join string-li
10a10 73 74 20 5b 64 65 6c 69 6d 69 74 65 72 20 67 72 st [delimiter gr
10a20 61 6d 6d 61 72 5d 29 20 3d 3e 20 73 74 72 69 6e ammar]) => strin
10a30 67 0a 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b g.;;;;;;;;;;;;;;
10a40 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
10a50 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
10a60 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
10a70 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
10a80 3b 0a 3b 3b 3b 20 50 61 73 74 65 20 73 74 72 69 ;.;;; Paste stri
10a90 6e 67 73 20 74 6f 67 65 74 68 65 72 20 75 73 69 ngs together usi
10aa0 6e 67 20 74 68 65 20 64 65 6c 69 6d 69 74 65 72 ng the delimiter
10ab0 20 73 74 72 69 6e 67 2e 0a 3b 3b 3b 0a 3b 3b 3b string..;;;.;;;
10ac0 20 28 6a 6f 69 6e 2d 73 74 72 69 6e 67 73 20 27 (join-strings '
10ad0 28 22 66 6f 6f 22 20 22 62 61 72 22 20 22 62 61 ("foo" "bar" "ba
10ae0 7a 22 29 20 22 3a 22 29 20 3d 3e 20 22 66 6f 6f z") ":") => "foo
10af0 3a 62 61 72 3a 62 61 7a 22 0a 3b 3b 3b 0a 3b 3b :bar:baz".;;;.;;
10b00 3b 20 44 45 4c 49 4d 49 54 45 52 20 64 65 66 61 ; DELIMITER defa
10b10 75 6c 74 73 20 74 6f 20 61 20 73 69 6e 67 6c 65 ults to a single
10b20 20 73 70 61 63 65 20 22 20 22 0a 3b 3b 3b 20 47 space " ".;;; G
10b30 52 41 4d 4d 41 52 20 69 73 20 6f 6e 65 20 6f 66 RAMMAR is one of
10b40 20 74 68 65 20 73 79 6d 62 6f 6c 73 20 7b 70 72 the symbols {pr
10b50 65 66 69 78 2c 20 69 6e 66 69 78 2c 20 73 74 72 efix, infix, str
10b60 69 63 74 2d 69 6e 66 69 78 2c 20 73 75 66 66 69 ict-infix, suffi
10b70 78 7d 20 0a 3b 3b 3b 20 61 6e 64 20 64 65 66 61 x} .;;; and defa
10b80 75 6c 74 73 20 74 6f 20 27 69 6e 66 69 78 2e 0a ults to 'infix..
10b90 3b 3b 3b 0a 3b 3b 3b 20 49 20 63 6f 75 6c 64 20 ;;;.;;; I could
10ba0 72 65 77 72 69 74 65 20 74 68 69 73 20 6d 6f 72 rewrite this mor
10bb0 65 20 65 66 66 69 63 69 65 6e 74 6c 79 20 2d 2d e efficiently --
10bc0 20 70 72 65 63 6f 6d 70 75 74 65 20 74 68 65 20 precompute the
10bd0 6c 65 6e 67 74 68 20 6f 66 20 74 68 65 0a 3b 3b length of the.;;
10be0 3b 20 61 6e 73 77 65 72 20 73 74 72 69 6e 67 2c ; answer string,
10bf0 20 74 68 65 6e 20 61 6c 6c 6f 63 61 74 65 20 26 then allocate &
10c00 20 66 69 6c 6c 20 69 74 20 69 6e 20 69 74 65 72 fill it in iter
10c10 61 74 69 76 65 6c 79 2e 20 55 73 69 6e 67 20 0a atively. Using .
10c20 3b 3b 3b 20 53 54 52 49 4e 47 2d 43 4f 4e 43 41 ;;; STRING-CONCA
10c30 54 45 4e 41 54 45 20 69 73 20 6c 65 73 73 20 65 TENATE is less e
10c40 66 66 69 63 69 65 6e 74 2e 0a 0a 28 64 65 66 69 fficient...(defi
10c50 6e 65 20 28 73 74 72 69 6e 67 2d 6a 6f 69 6e 20 ne (string-join
10c60 73 74 72 69 6e 67 73 20 2e 20 64 65 6c 69 6d 2b strings . delim+
10c70 67 72 61 6d 6d 61 72 29 0a 20 20 28 6c 65 74 2d grammar). (let-
10c80 6f 70 74 69 6f 6e 61 6c 73 2a 20 64 65 6c 69 6d optionals* delim
10c90 2b 67 72 61 6d 6d 61 72 20 28 28 64 65 6c 69 6d +grammar ((delim
10ca0 20 22 20 22 20 28 73 74 72 69 6e 67 3f 20 64 65 " " (string? de
10cb0 6c 69 6d 29 29 0a 09 09 09 09 20 28 67 72 61 6d lim))..... (gram
10cc0 6d 61 72 20 27 69 6e 66 69 78 29 29 0a 20 20 20 mar 'infix)).
10cd0 20 28 6c 65 74 20 28 28 62 75 69 6c 64 69 74 20 (let ((buildit
10ce0 28 6c 61 6d 62 64 61 20 28 6c 69 73 20 66 69 6e (lambda (lis fin
10cf0 61 6c 29 0a 09 09 20 20 20 20 20 28 6c 65 74 20 al)... (let
10d00 72 65 63 75 72 20 28 28 6c 69 73 20 6c 69 73 29 recur ((lis lis)
10d10 29 0a 09 09 20 20 20 20 20 20 20 28 69 66 20 28 )... (if (
10d20 70 61 69 72 3f 20 6c 69 73 29 0a 09 09 09 20 20 pair? lis)....
10d30 20 28 63 6f 6e 73 20 64 65 6c 69 6d 20 28 63 6f (cons delim (co
10d40 6e 73 20 28 63 61 72 20 6c 69 73 29 20 28 72 65 ns (car lis) (re
10d50 63 75 72 20 28 63 64 72 20 6c 69 73 29 29 29 29 cur (cdr lis))))
10d60 0a 09 09 09 20 20 20 66 69 6e 61 6c 29 29 29 29 .... final))))
10d70 29 0a 0a 20 20 20 20 20 20 28 63 6f 6e 64 20 28 ).. (cond (
10d80 28 70 61 69 72 3f 20 73 74 72 69 6e 67 73 29 0a (pair? strings).
10d90 09 20 20 20 20 20 28 73 74 72 69 6e 67 2d 63 6f . (string-co
10da0 6e 63 61 74 65 6e 61 74 65 0a 09 20 20 20 20 20 ncatenate..
10db0 20 28 63 61 73 65 20 67 72 61 6d 6d 61 72 0a 0a (case grammar..
10dc0 09 09 28 28 69 6e 66 69 78 20 73 74 72 69 63 74 ..((infix strict
10dd0 2d 69 6e 66 69 78 29 0a 09 09 20 28 63 6f 6e 73 -infix)... (cons
10de0 20 28 63 61 72 20 73 74 72 69 6e 67 73 29 20 28 (car strings) (
10df0 62 75 69 6c 64 69 74 20 28 63 64 72 20 73 74 72 buildit (cdr str
10e00 69 6e 67 73 29 20 27 28 29 29 29 29 0a 0a 09 09 ings) '())))....
10e10 28 28 70 72 65 66 69 78 29 20 28 62 75 69 6c 64 ((prefix) (build
10e20 69 74 20 73 74 72 69 6e 67 73 20 27 28 29 29 29 it strings '()))
10e30 0a 0a 09 09 28 28 73 75 66 66 69 78 29 0a 09 09 ....((suffix)...
10e40 20 28 63 6f 6e 73 20 28 63 61 72 20 73 74 72 69 (cons (car stri
10e50 6e 67 73 29 20 28 62 75 69 6c 64 69 74 20 28 63 ngs) (buildit (c
10e60 64 72 20 73 74 72 69 6e 67 73 29 20 28 6c 69 73 dr strings) (lis
10e70 74 20 64 65 6c 69 6d 29 29 29 29 0a 0a 09 09 28 t delim))))....(
10e80 65 6c 73 65 20 28 65 72 72 6f 72 20 22 49 6c 6c else (error "Ill
10e90 65 67 61 6c 20 6a 6f 69 6e 20 67 72 61 6d 6d 61 egal join gramma
10ea0 72 22 0a 09 09 09 20 20 20 20 20 67 72 61 6d 6d r".... gramm
10eb0 61 72 20 73 74 72 69 6e 67 2d 6a 6f 69 6e 29 29 ar string-join))
10ec0 29 29 29 0a 0a 09 20 20 20 20 20 28 28 6e 6f 74 )))... ((not
10ed0 20 28 6e 75 6c 6c 3f 20 73 74 72 69 6e 67 73 29 (null? strings)
10ee0 29 0a 09 20 20 20 20 20 20 28 65 72 72 6f 72 20 ).. (error
10ef0 22 53 54 52 49 4e 47 53 20 70 61 72 61 6d 65 74 "STRINGS paramet
10f00 65 72 20 6e 6f 74 20 6c 69 73 74 2e 22 20 73 74 er not list." st
10f10 72 69 6e 67 73 20 73 74 72 69 6e 67 2d 6a 6f 69 rings string-joi
10f20 6e 29 29 0a 0a 09 20 20 20 20 20 3b 3b 20 53 54 n))... ;; ST
10f30 52 49 4e 47 53 20 69 73 20 28 29 0a 0a 09 20 20 RINGS is ()...
10f40 20 20 20 28 28 65 71 3f 20 67 72 61 6d 6d 61 72 ((eq? grammar
10f50 20 27 73 74 72 69 63 74 2d 69 6e 66 69 78 29 0a 'strict-infix).
10f60 09 20 20 20 20 20 20 28 65 72 72 6f 72 20 22 45 . (error "E
10f70 6d 70 74 79 20 6c 69 73 74 20 63 61 6e 6e 6f 74 mpty list cannot
10f80 20 62 65 20 6a 6f 69 6e 65 64 20 77 69 74 68 20 be joined with
10f90 53 54 52 49 43 54 2d 49 4e 46 49 58 20 67 72 61 STRICT-INFIX gra
10fa0 6d 6d 61 72 2e 22 0a 09 09 20 20 20 20 20 73 74 mmar."... st
10fb0 72 69 6e 67 2d 6a 6f 69 6e 29 29 0a 0a 09 20 20 ring-join))...
10fc0 20 20 20 28 65 6c 73 65 20 22 22 29 29 29 29 29 (else "")))))
10fd0 09 09 3b 20 53 70 65 63 69 61 6c 2d 63 61 73 65 ..; Special-case
10fe0 64 20 66 6f 72 20 69 6e 66 69 78 20 67 72 61 6d d for infix gram
10ff0 6d 61 72 2e 0a 0a 0c 0a 3b 3b 3b 20 50 6f 72 74 mar.....;;; Port
11000 69 6e 67 20 26 20 70 65 72 66 6f 72 6d 61 6e 63 ing & performanc
11010 65 2d 74 75 6e 69 6e 67 20 6e 6f 74 65 73 0a 3b e-tuning notes.;
11020 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
11030 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
11040 3b 3b 3b 3b 3b 0a 3b 3b 3b 20 53 65 65 20 74 68 ;;;;;.;;; See th
11050 65 20 73 65 63 74 69 6f 6e 20 61 74 20 74 68 65 e section at the
11060 20 62 65 67 69 6e 6e 69 6e 67 20 6f 66 20 74 68 beginning of th
11070 69 73 20 66 69 6c 65 20 6f 6e 20 65 78 74 65 72 is file on exter
11080 6e 61 6c 20 64 65 70 65 6e 64 65 6e 63 69 65 73 nal dependencies
11090 2e 0a 3b 3b 3b 0a 3b 3b 3b 20 54 68 65 20 62 69 ..;;;.;;; The bi
110a0 67 67 65 73 74 20 69 73 73 75 65 20 77 69 74 68 ggest issue with
110b0 20 72 65 73 70 65 63 74 20 74 6f 20 70 6f 72 74 respect to port
110c0 69 6e 67 20 69 73 20 74 68 65 20 4c 45 54 2d 4f ing is the LET-O
110d0 50 54 49 4f 4e 41 4c 53 2a 20 6d 61 63 72 6f 2e PTIONALS* macro.
110e0 0a 3b 3b 3b 20 54 68 65 72 65 20 61 72 65 20 6d .;;; There are m
110f0 61 6e 79 2c 20 6d 61 6e 79 20 6f 70 74 69 6f 6e any, many option
11100 61 6c 20 61 72 67 75 6d 65 6e 74 73 20 69 6e 20 al arguments in
11110 74 68 69 73 20 6c 69 62 72 61 72 79 3b 20 74 68 this library; th
11120 65 20 63 6f 6d 70 6c 65 78 69 74 79 0a 3b 3b 3b e complexity.;;;
11130 20 6f 66 20 70 61 72 73 69 6e 67 2c 20 64 65 66 of parsing, def
11140 61 75 6c 74 69 6e 67 20 26 20 74 79 70 65 2d 74 aulting & type-t
11150 65 73 74 69 6e 67 20 74 68 65 73 65 20 70 61 72 esting these par
11160 61 6d 65 74 65 72 73 20 69 73 20 68 61 6e 64 6c ameters is handl
11170 65 64 20 77 69 74 68 20 74 68 65 0a 3b 3b 3b 20 ed with the.;;;
11180 61 69 64 20 6f 66 20 74 68 69 73 20 6d 61 63 72 aid of this macr
11190 6f 2e 20 54 68 65 72 65 20 61 72 65 20 61 62 6f o. There are abo
111a0 75 74 20 31 35 20 75 73 65 73 20 6f 66 20 4c 45 ut 15 uses of LE
111b0 54 2d 4f 50 54 49 4f 4e 41 4c 53 2a 2e 20 59 6f T-OPTIONALS*. Yo
111c0 75 20 63 61 6e 0a 3b 3b 3b 20 72 65 77 72 69 74 u can.;;; rewrit
111d0 65 20 74 68 65 20 75 73 65 73 2c 20 70 6f 72 74 e the uses, port
111e0 20 74 68 65 20 68 61 69 72 79 20 6d 61 63 72 6f the hairy macro
111f0 20 64 65 66 69 6e 69 74 69 6f 6e 20 28 77 68 69 definition (whi
11200 63 68 20 69 73 20 69 6d 70 6c 65 6d 65 6e 74 65 ch is implemente
11210 64 0a 3b 3b 3b 20 75 73 69 6e 67 20 61 20 43 6c d.;;; using a Cl
11220 69 6e 67 65 72 2d 52 65 65 73 20 6c 6f 77 2d 6c inger-Rees low-l
11230 65 76 65 6c 20 65 78 70 6c 69 63 69 74 2d 72 65 evel explicit-re
11240 6e 61 6d 69 6e 67 20 6d 61 63 72 6f 20 73 79 73 naming macro sys
11250 74 65 6d 29 2c 20 6f 72 20 70 6f 72 74 0a 3b 3b tem), or port.;;
11260 3b 20 74 68 65 20 73 69 6d 70 6c 65 2c 20 68 69 ; the simple, hi
11270 67 68 2d 6c 65 76 65 6c 20 64 65 66 69 6e 69 74 gh-level definit
11280 69 6f 6e 2c 20 77 68 69 63 68 20 69 73 20 6c 65 ion, which is le
11290 73 73 20 65 66 66 69 63 69 65 6e 74 2e 0a 3b 3b ss efficient..;;
112a0 3b 0a 3b 3b 3b 20 54 68 65 72 65 20 69 73 20 61 ;.;;; There is a
112b0 20 66 61 69 72 20 61 6d 6f 75 6e 74 20 6f 66 20 fair amount of
112c0 61 72 67 75 6d 65 6e 74 20 63 68 65 63 6b 69 6e argument checkin
112d0 67 2e 20 54 68 69 73 20 69 73 2c 20 73 74 72 69 g. This is, stri
112e0 63 74 6c 79 20 73 70 65 61 6b 69 6e 67 2c 0a 3b ctly speaking,.;
112f0 3b 3b 20 75 6e 6e 65 63 65 73 73 61 72 79 20 2d ;; unnecessary -
11300 2d 20 74 68 65 20 61 63 74 75 61 6c 20 62 6f 64 - the actual bod
11310 79 20 6f 66 20 74 68 65 20 70 72 6f 63 65 64 75 y of the procedu
11320 72 65 73 20 77 69 6c 6c 20 62 6c 6f 77 20 75 70 res will blow up
11330 20 69 66 2c 20 73 61 79 2c 20 61 0a 3b 3b 3b 20 if, say, a.;;;
11340 53 54 41 52 54 2f 45 4e 44 20 69 6e 64 65 78 20 START/END index
11350 69 73 20 69 6d 70 72 6f 70 65 72 2e 20 48 6f 77 is improper. How
11360 65 76 65 72 2c 20 74 68 65 20 65 72 72 6f 72 20 ever, the error
11370 6d 65 73 73 61 67 65 20 77 69 6c 6c 20 6e 6f 74 message will not
11380 20 62 65 20 61 73 0a 3b 3b 3b 20 67 6f 6f 64 20 be as.;;; good
11390 61 73 20 69 66 20 74 68 65 20 65 72 72 6f 72 20 as if the error
113a0 77 65 72 65 20 63 61 75 67 68 74 20 61 74 20 74 were caught at t
113b0 68 65 20 22 68 69 67 68 65 72 20 6c 65 76 65 6c he "higher level
113c0 2e 22 20 41 6c 73 6f 2c 20 61 20 76 65 72 79 2c ." Also, a very,
113d0 20 76 65 72 79 0a 3b 3b 3b 20 73 6d 61 72 74 20 very.;;; smart
113e0 53 63 68 65 6d 65 20 63 6f 6d 70 69 6c 65 72 20 Scheme compiler
113f0 6d 61 79 20 62 65 20 61 62 6c 65 20 74 6f 20 65 may be able to e
11400 78 70 6c 6f 69 74 20 68 61 76 69 6e 67 20 74 68 xploit having th
11410 65 20 74 79 70 65 20 63 68 65 63 6b 73 20 64 6f e type checks do
11420 6e 65 0a 3b 3b 3b 20 65 61 72 6c 79 2c 20 73 6f ne.;;; early, so
11430 20 74 68 61 74 20 74 68 65 20 61 63 74 75 61 6c that the actual
11440 20 62 6f 64 79 20 6f 66 20 74 68 65 20 70 72 6f body of the pro
11450 63 65 64 75 72 65 73 20 63 61 6e 20 61 73 73 75 cedures can assu
11460 6d 65 20 70 72 6f 70 65 72 20 76 61 6c 75 65 73 me proper values
11470 2e 0a 3b 3b 3b 20 54 68 69 73 20 69 73 6e 27 74 ..;;; This isn't
11480 20 6c 69 6b 65 6c 79 3b 20 74 68 69 73 20 6b 69 likely; this ki
11490 6e 64 20 6f 66 20 63 6f 6d 70 69 6c 65 72 20 74 nd of compiler t
114a0 65 63 68 6e 6f 6c 6f 67 79 20 69 73 6e 27 74 20 echnology isn't
114b0 63 6f 6d 6d 6f 6e 20 61 6e 79 20 0a 3b 3b 3b 20 common any .;;;
114c0 6c 6f 6e 67 65 72 2e 0a 3b 3b 3b 20 0a 3b 3b 3b longer..;;; .;;;
114d0 20 54 68 65 20 6f 76 65 72 68 65 61 64 20 6f 66 The overhead of
114e0 20 6f 70 74 69 6f 6e 61 6c 2d 61 72 67 75 6d 65 optional-argume
114f0 6e 74 20 70 61 72 73 69 6e 67 20 69 73 20 69 72 nt parsing is ir
11500 72 69 74 61 74 69 6e 67 2e 20 54 68 65 20 6f 70 ritating. The op
11510 74 69 6f 6e 61 6c 0a 3b 3b 3b 20 61 72 67 75 6d tional.;;; argum
11520 65 6e 74 73 20 6d 75 73 74 20 62 65 20 63 6f 6e ents must be con
11530 73 65 64 20 69 6e 74 6f 20 61 20 72 65 73 74 20 sed into a rest
11540 6c 69 73 74 20 6f 6e 20 65 6e 74 72 79 2c 20 61 list on entry, a
11550 6e 64 20 74 68 65 6e 20 70 61 72 73 65 64 20 6f nd then parsed o
11560 75 74 2e 0a 3b 3b 3b 20 46 75 6e 63 74 69 6f 6e ut..;;; Function
11570 20 63 61 6c 6c 20 73 68 6f 75 6c 64 20 62 65 20 call should be
11580 61 20 6d 61 74 74 65 72 20 6f 66 20 61 20 66 65 a matter of a fe
11590 77 20 72 65 67 69 73 74 65 72 20 6d 6f 76 65 73 w register moves
115a0 20 61 6e 64 20 61 20 6a 75 6d 70 3b 20 69 74 0a and a jump; it.
115b0 3b 3b 3b 20 73 68 6f 75 6c 64 20 6e 6f 74 20 69 ;;; should not i
115c0 6e 76 6f 6c 76 65 20 68 65 61 70 20 61 6c 6c 6f nvolve heap allo
115d0 63 61 74 69 6f 6e 21 20 59 6f 75 72 20 53 63 68 cation! Your Sch
115e0 65 6d 65 20 73 79 73 74 65 6d 20 6d 61 79 20 68 eme system may h
115f0 61 76 65 20 61 20 73 75 70 65 72 69 6f 72 0a 3b ave a superior.;
11600 3b 3b 20 6e 6f 6e 2d 52 35 52 53 20 6f 70 74 69 ;; non-R5RS opti
11610 6f 6e 61 6c 2d 61 72 67 75 6d 65 6e 74 20 73 79 onal-argument sy
11620 73 74 65 6d 20 74 68 61 74 20 63 61 6e 20 65 6c stem that can el
11630 69 6d 69 6e 61 74 65 20 74 68 69 73 20 6f 76 65 iminate this ove
11640 72 68 65 61 64 2e 20 49 66 20 73 6f 2c 0a 3b 3b rhead. If so,.;;
11650 3b 20 74 68 65 6e 20 74 68 69 73 20 69 73 20 61 ; then this is a
11660 20 70 72 69 6d 65 20 63 61 6e 64 69 64 61 74 65 prime candidate
11670 20 66 6f 72 20 6f 70 74 69 6d 69 73 69 6e 67 20 for optimising
11680 74 68 65 73 65 20 70 72 6f 63 65 64 75 72 65 73 these procedures
11690 2c 0a 3b 3b 3b 20 2a 65 73 70 65 63 69 61 6c 6c ,.;;; *especiall
116a0 79 2a 20 74 68 65 20 6d 61 6e 79 20 6f 70 74 69 y* the many opti
116b0 6f 6e 61 6c 20 53 54 41 52 54 2f 45 4e 44 20 69 onal START/END i
116c0 6e 64 65 78 20 70 61 72 61 6d 65 74 65 72 73 2e ndex parameters.
116d0 0a 3b 3b 3b 0a 3b 3b 3b 20 4e 6f 74 65 20 74 68 .;;;.;;; Note th
116e0 61 74 20 6f 70 74 69 6f 6e 61 6c 20 61 72 67 75 at optional argu
116f0 6d 65 6e 74 73 20 61 72 65 20 61 6c 73 6f 20 61 ments are also a
11700 20 62 61 72 72 69 65 72 20 74 6f 20 70 72 6f 63 barrier to proc
11710 65 64 75 72 65 20 69 6e 74 65 67 72 61 74 69 6f edure integratio
11720 6e 2e 0a 3b 3b 3b 20 49 66 20 79 6f 75 72 20 53 n..;;; If your S
11730 63 68 65 6d 65 20 73 79 73 74 65 6d 20 70 65 72 cheme system per
11740 6d 69 74 73 20 79 6f 75 20 74 6f 20 73 70 65 63 mits you to spec
11750 69 66 79 20 61 6c 74 65 72 6e 61 74 65 20 65 6e ify alternate en
11760 74 72 79 20 70 6f 69 6e 74 73 0a 3b 3b 3b 20 66 try points.;;; f
11770 6f 72 20 61 20 63 61 6c 6c 20 77 68 65 6e 20 74 or a call when t
11780 68 65 20 6e 75 6d 62 65 72 20 6f 66 20 6f 70 74 he number of opt
11790 69 6f 6e 61 6c 20 61 72 67 75 6d 65 6e 74 73 20 ional arguments
117a0 69 73 20 6b 6e 6f 77 6e 20 69 6e 20 61 20 6d 61 is known in a ma
117b0 6e 6e 65 72 0a 3b 3b 3b 20 74 68 61 74 20 65 6e nner.;;; that en
117c0 61 62 6c 65 73 20 69 6e 6c 69 6e 69 6e 67 2f 69 ables inlining/i
117d0 6e 74 65 67 72 61 74 69 6f 6e 2c 20 74 68 69 73 ntegration, this
117e0 20 63 61 6e 20 70 72 6f 76 69 64 65 20 70 65 72 can provide per
117f0 66 6f 72 6d 61 6e 63 65 20 0a 3b 3b 3b 20 69 6d formance .;;; im
11800 70 72 6f 76 65 6d 65 6e 74 73 2e 0a 3b 3b 3b 0a provements..;;;.
11810 3b 3b 3b 20 54 68 65 72 65 20 69 73 20 65 6e 6f ;;; There is eno
11820 75 67 68 20 2a 65 78 70 6c 69 63 69 74 2a 20 65 ugh *explicit* e
11830 72 72 6f 72 20 63 68 65 63 6b 69 6e 67 20 74 68 rror checking th
11840 61 74 20 2a 61 6c 6c 2a 20 73 74 72 69 6e 67 2d at *all* string-
11850 69 6e 64 65 78 0a 3b 3b 3b 20 6f 70 65 72 61 74 index.;;; operat
11860 69 6f 6e 73 20 73 68 6f 75 6c 64 20 2a 6e 65 76 ions should *nev
11870 65 72 2a 20 70 72 6f 64 75 63 65 20 61 20 62 6f er* produce a bo
11880 75 6e 64 73 20 65 72 72 6f 72 2e 20 50 65 72 69 unds error. Peri
11890 6f 64 2e 20 46 65 65 6c 20 6c 69 6b 65 0a 3b 3b od. Feel like.;;
118a0 3b 20 6c 69 76 69 6e 67 20 64 61 6e 67 65 72 6f ; living dangero
118b0 75 73 6c 79 3f 20 2a 42 69 67 2a 20 70 65 72 66 usly? *Big* perf
118c0 6f 72 6d 61 6e 63 65 20 77 69 6e 20 74 6f 20 62 ormance win to b
118d0 65 20 68 61 64 20 62 79 20 72 65 70 6c 61 63 69 e had by replaci
118e0 6e 67 0a 3b 3b 3b 20 53 54 52 49 4e 47 2d 52 45 ng.;;; STRING-RE
118f0 46 27 73 20 61 6e 64 20 53 54 52 49 4e 47 2d 53 F's and STRING-S
11900 45 54 21 27 73 20 77 69 74 68 20 75 6e 73 61 66 ET!'s with unsaf
11910 65 20 65 71 75 69 76 61 6c 65 6e 74 73 20 69 6e e equivalents in
11920 20 74 68 65 20 6c 6f 6f 70 73 2e 20 0a 3b 3b 3b the loops. .;;;
11930 20 53 69 6d 69 6c 61 72 6c 79 2c 20 66 69 78 6e Similarly, fixn
11940 75 6d 2d 73 70 65 63 69 66 69 63 20 6f 70 65 72 um-specific oper
11950 61 74 6f 72 73 20 63 61 6e 20 73 70 65 65 64 20 ators can speed
11960 75 70 20 74 68 65 20 61 72 69 74 68 6d 65 74 69 up the arithmeti
11970 63 20 64 6f 6e 65 20 6f 6e 20 0a 3b 3b 3b 20 74 c done on .;;; t
11980 68 65 20 69 6e 64 65 78 20 76 61 6c 75 65 73 20 he index values
11990 69 6e 20 74 68 65 20 69 6e 6e 65 72 20 6c 6f 6f in the inner loo
119a0 70 73 2e 20 54 68 65 20 6f 6e 6c 79 20 61 72 67 ps. The only arg
119b0 75 6d 65 6e 74 73 20 74 68 61 74 20 61 72 65 20 uments that are
119c0 6e 6f 74 0a 3b 3b 3b 20 63 6f 6d 70 6c 65 74 65 not.;;; complete
119d0 6c 79 20 65 72 72 6f 72 20 63 68 65 63 6b 65 64 ly error checked
119e0 20 61 72 65 0a 3b 3b 3b 20 20 20 2d 20 73 74 72 are.;;; - str
119f0 69 6e 67 20 6c 69 73 74 73 20 28 63 6f 6d 70 6c ing lists (compl
11a00 65 74 65 20 63 68 65 63 6b 69 6e 67 20 72 65 71 ete checking req
11a10 75 69 72 65 73 20 74 69 6d 65 20 70 72 6f 70 6f uires time propo
11a20 72 74 69 6f 6e 61 6c 20 74 6f 20 74 68 65 0a 3b rtional to the.;
11a30 3b 3b 20 20 20 20 20 6c 65 6e 67 74 68 20 6f 66 ;; length of
11a40 20 74 68 65 20 6c 69 73 74 29 0a 3b 3b 3b 20 20 the list).;;;
11a50 20 2d 20 70 72 6f 63 65 64 75 72 65 20 61 72 67 - procedure arg
11a60 75 6d 65 6e 74 73 2c 20 73 75 63 68 20 61 73 20 uments, such as
11a70 63 68 61 72 2d 3e 63 68 61 72 20 6d 61 70 73 20 char->char maps
11a80 26 20 70 72 65 64 69 63 61 74 65 73 2e 0a 3b 3b & predicates..;;
11a90 3b 20 20 20 20 20 54 68 65 72 65 20 69 73 20 6e ; There is n
11aa0 6f 20 77 61 79 20 74 6f 20 63 68 65 63 6b 20 74 o way to check t
11ab0 68 65 20 72 61 6e 67 65 20 26 20 64 6f 6d 61 69 he range & domai
11ac0 6e 20 6f 66 20 70 72 6f 63 65 64 75 72 65 73 20 n of procedures
11ad0 69 6e 20 53 63 68 65 6d 65 2e 0a 3b 3b 3b 20 50 in Scheme..;;; P
11ae0 72 6f 63 65 64 75 72 65 73 20 74 68 61 74 20 74 rocedures that t
11af0 61 6b 65 20 74 68 65 73 65 20 70 61 72 61 6d 65 ake these parame
11b00 74 65 72 73 20 63 61 6e 6e 6f 74 20 66 75 6c 6c ters cannot full
11b10 79 20 63 68 65 63 6b 20 74 68 65 69 72 0a 3b 3b y check their.;;
11b20 3b 20 61 72 67 75 6d 65 6e 74 73 2e 20 42 75 74 ; arguments. But
11b30 20 61 6c 6c 20 6f 74 68 65 72 20 74 79 70 65 73 all other types
11b40 20 74 6f 20 61 6c 6c 20 6f 74 68 65 72 20 70 72 to all other pr
11b50 6f 63 65 64 75 72 65 73 20 61 72 65 20 66 75 6c ocedures are ful
11b60 6c 79 0a 3b 3b 3b 20 63 68 65 63 6b 65 64 2e 0a ly.;;; checked..
11b70 3b 3b 3b 0a 3b 3b 3b 20 54 68 69 73 20 64 6f 65 ;;;.;;; This doe
11b80 73 20 6f 70 65 6e 20 75 70 20 74 68 65 20 61 6c s open up the al
11b90 74 65 72 6e 61 74 65 20 70 6f 73 73 69 62 69 6c ternate possibil
11ba0 69 74 79 20 6f 66 20 73 69 6d 70 6c 79 20 2a 72 ity of simply *r
11bb0 65 6d 6f 76 69 6e 67 2a 20 74 68 65 73 65 20 0a emoving* these .
11bc0 3b 3b 3b 20 63 68 65 63 6b 73 2c 20 61 6e 64 20 ;;; checks, and
11bd0 6c 65 74 74 69 6e 67 20 74 68 65 20 73 61 66 65 letting the safe
11be0 20 70 72 69 6d 69 74 69 76 65 73 20 72 61 69 73 primitives rais
11bf0 65 20 74 68 65 20 65 72 72 6f 72 73 2e 20 4f 6e e the errors. On
11c00 20 61 20 64 75 6d 62 0a 3b 3b 3b 20 53 63 68 65 a dumb.;;; Sche
11c10 6d 65 20 73 79 73 74 65 6d 2c 20 74 68 69 73 20 me system, this
11c20 77 6f 75 6c 64 20 70 72 6f 76 69 64 65 20 73 70 would provide sp
11c30 65 65 64 20 28 62 79 20 65 6c 69 6d 69 6e 61 74 eed (by eliminat
11c40 69 6e 67 20 74 68 65 20 72 65 64 75 6e 64 61 6e ing the redundan
11c50 74 0a 3b 3b 3b 20 65 72 72 6f 72 20 63 68 65 63 t.;;; error chec
11c60 6b 73 29 20 61 74 20 74 68 65 20 63 6f 73 74 20 ks) at the cost
11c70 6f 66 20 65 72 72 6f 72 2d 6d 65 73 73 61 67 65 of error-message
11c80 20 63 6c 61 72 69 74 79 2e 0a 3b 3b 3b 0a 3b 3b clarity..;;;.;;
11c90 3b 20 53 65 65 20 74 68 65 20 63 6f 6d 6d 65 6e ; See the commen
11ca0 74 73 20 70 72 65 63 65 64 69 6e 67 20 74 68 65 ts preceding the
11cb0 20 68 61 73 68 20 66 75 6e 63 74 69 6f 6e 20 63 hash function c
11cc0 6f 64 65 20 66 6f 72 20 6e 6f 74 65 73 20 6f 6e ode for notes on
11cd0 20 74 75 6e 69 6e 67 0a 3b 3b 3b 20 74 68 65 20 tuning.;;; the
11ce0 64 65 66 61 75 6c 74 20 62 6f 75 6e 64 20 73 6f default bound so
11cf0 20 74 68 61 74 20 74 68 65 20 63 6f 64 65 20 6e that the code n
11d00 65 76 65 72 20 6f 76 65 72 66 6c 6f 77 73 20 79 ever overflows y
11d10 6f 75 72 20 69 6d 70 6c 65 6d 65 6e 74 61 74 69 our implementati
11d20 6f 6e 27 73 0a 3b 3b 3b 20 66 69 78 6e 75 6d 20 on's.;;; fixnum
11d30 73 69 7a 65 20 69 6e 74 6f 20 62 69 67 6e 75 6d size into bignum
11d40 20 63 61 6c 63 75 6c 61 74 69 6f 6e 2e 0a 3b 3b calculation..;;
11d50 3b 0a 3b 3b 3b 20 49 6e 20 61 6e 20 69 6e 74 65 ;.;;; In an inte
11d60 72 70 72 65 74 65 64 20 53 63 68 65 6d 65 2c 20 rpreted Scheme,
11d70 73 6f 6d 65 20 6f 66 20 74 68 65 73 65 20 70 72 some of these pr
11d80 6f 63 65 64 75 72 65 73 2c 20 6f 72 20 74 68 65 ocedures, or the
11d90 20 69 6e 74 65 72 6e 61 6c 0a 3b 3b 3b 20 72 6f internal.;;; ro
11da0 75 74 69 6e 65 73 20 77 69 74 68 20 25 20 70 72 utines with % pr
11db0 65 66 69 78 65 73 2c 20 61 72 65 20 65 78 63 65 efixes, are exce
11dc0 6c 6c 65 6e 74 20 63 61 6e 64 69 64 61 74 65 73 llent candidates
11dd0 20 66 6f 72 20 62 65 69 6e 67 20 72 65 77 72 69 for being rewri
11de0 74 74 65 6e 0a 3b 3b 3b 20 69 6e 20 43 2e 20 43 tten.;;; in C. C
11df0 6f 6e 73 69 64 65 72 20 53 54 52 49 4e 47 2d 48 onsider STRING-H
11e00 41 53 48 2c 20 25 53 54 52 49 4e 47 2d 43 4f 4d ASH, %STRING-COM
11e10 50 41 52 45 2c 20 74 68 65 20 0a 3b 3b 3b 20 25 PARE, the .;;; %
11e20 53 54 52 49 4e 47 2d 7b 53 55 46 2c 50 52 45 7d STRING-{SUF,PRE}
11e30 46 49 58 2d 4c 45 4e 47 54 48 20 72 6f 75 74 69 FIX-LENGTH routi
11e40 6e 65 73 2c 20 53 54 52 49 4e 47 2d 43 4f 50 59 nes, STRING-COPY
11e50 21 2c 20 53 54 52 49 4e 47 2d 49 4e 44 45 58 20 !, STRING-INDEX
11e60 26 0a 3b 3b 3b 20 53 54 52 49 4e 47 2d 53 4b 49 &.;;; STRING-SKI
11e70 50 20 28 63 68 61 72 2d 73 65 74 20 26 20 63 68 P (char-set & ch
11e80 61 72 20 63 61 73 65 73 29 2c 20 53 55 42 53 54 ar cases), SUBST
11e90 52 49 4e 47 20 61 6e 64 20 53 55 42 53 54 52 49 RING and SUBSTRI
11ea0 4e 47 2f 53 48 41 52 45 44 2c 0a 3b 3b 3b 20 25 NG/SHARED,.;;; %
11eb0 4b 4d 50 2d 53 45 41 52 43 48 2c 20 61 6e 64 20 KMP-SEARCH, and
11ec0 25 4d 55 4c 54 49 53 50 41 4e 2d 52 45 50 43 4f %MULTISPAN-REPCO
11ed0 50 59 21 2e 0a 3b 3b 3b 0a 3b 3b 3b 20 49 74 20 PY!..;;;.;;; It
11ee0 77 6f 75 6c 64 20 61 6c 73 6f 20 62 65 20 6e 69 would also be ni
11ef0 63 65 20 74 6f 20 68 61 76 65 20 74 68 65 20 61 ce to have the a
11f00 62 69 6c 69 74 79 20 74 6f 20 6d 61 72 6b 20 73 bility to mark s
11f10 6f 6d 65 20 6f 66 20 74 68 65 73 65 0a 3b 3b 3b ome of these.;;;
11f20 20 72 6f 75 74 69 6e 65 73 20 61 73 20 63 61 6e routines as can
11f30 64 69 64 61 74 65 73 20 66 6f 72 20 69 6e 6c 69 didates for inli
11f40 6e 69 6e 67 2f 69 6e 74 65 67 72 61 74 69 6f 6e ning/integration
11f50 2e 0a 3b 3b 3b 20 0a 3b 3b 3b 20 41 6c 6c 20 74 ..;;; .;;; All t
11f60 68 65 20 25 2d 70 72 65 66 69 78 65 64 20 72 6f he %-prefixed ro
11f70 75 74 69 6e 65 73 20 69 6e 20 74 68 69 73 20 73 utines in this s
11f80 6f 75 72 63 65 20 63 6f 64 65 20 61 72 65 20 77 ource code are w
11f90 72 69 74 74 65 6e 0a 3b 3b 3b 20 74 6f 20 62 65 ritten.;;; to be
11fa0 20 63 61 6c 6c 65 64 20 69 6e 74 65 72 6e 61 6c called internal
11fb0 6c 79 20 74 6f 20 74 68 69 73 20 6c 69 62 72 61 ly to this libra
11fc0 72 79 2e 20 54 68 65 79 20 64 6f 20 2a 6e 6f 74 ry. They do *not
11fd0 2a 20 70 65 72 66 6f 72 6d 0a 3b 3b 3b 20 66 72 * perform.;;; fr
11fe0 69 65 6e 64 6c 79 20 65 72 72 6f 72 20 63 68 65 iendly error che
11ff0 63 6b 73 20 6f 6e 20 74 68 65 20 69 6e 70 75 74 cks on the input
12000 73 3b 20 74 68 65 79 20 61 73 73 75 6d 65 20 65 s; they assume e
12010 76 65 72 79 74 68 69 6e 67 20 69 73 0a 3b 3b 3b verything is.;;;
12020 20 70 72 6f 70 65 72 2e 20 54 68 65 79 20 61 6c proper. They al
12030 73 6f 20 64 6f 20 6e 6f 74 20 74 61 6b 65 20 6f so do not take o
12040 70 74 69 6f 6e 61 6c 20 61 72 67 75 6d 65 6e 74 ptional argument
12050 73 2e 20 54 68 65 73 65 20 74 77 6f 20 70 72 6f s. These two pro
12060 70 65 72 74 69 65 73 0a 3b 3b 3b 20 73 61 76 65 perties.;;; save
12070 20 63 61 6c 6c 69 6e 67 20 6f 76 65 72 68 65 61 calling overhea
12080 64 20 61 6e 64 20 65 6e 61 62 6c 65 20 70 72 6f d and enable pro
12090 63 65 64 75 72 65 20 69 6e 74 65 67 72 61 74 69 cedure integrati
120a0 6f 6e 20 2d 2d 20 62 75 74 20 74 68 65 79 0a 3b on -- but they.;
120b0 3b 3b 20 61 72 65 20 6e 6f 74 20 61 70 70 72 6f ;; are not appro
120c0 70 72 69 61 74 65 20 66 6f 72 20 65 78 70 6f 72 priate for expor
120d0 74 65 64 20 72 6f 75 74 69 6e 65 73 2e 0a 0a 0c ted routines....
120e0 0a 3b 3b 3b 20 43 6f 70 79 72 69 67 68 74 20 64 .;;; Copyright d
120f0 65 74 61 69 6c 73 0a 3b 3b 3b 3b 3b 3b 3b 3b 3b etails.;;;;;;;;;
12100 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
12110 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
12120 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
12130 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
12140 3b 3b 3b 3b 3b 3b 0a 3b 3b 3b 20 54 68 65 20 70 ;;;;;;.;;; The p
12150 72 65 66 69 78 2f 73 75 66 66 69 78 20 61 6e 64 refix/suffix and
12160 20 63 6f 6d 70 61 72 69 73 6f 6e 20 72 6f 75 74 comparison rout
12170 69 6e 65 73 20 69 6e 20 74 68 69 73 20 63 6f 64 ines in this cod
12180 65 20 68 61 64 20 28 65 78 74 72 65 6d 65 6c 79 e had (extremely
12190 0a 3b 3b 3b 20 64 69 73 74 61 6e 74 29 20 6f 72 .;;; distant) or
121a0 69 67 69 6e 73 20 69 6e 20 4d 49 54 20 53 63 68 igins in MIT Sch
121b0 65 6d 65 27 73 20 73 74 72 69 6e 67 20 6c 69 62 eme's string lib
121c0 2c 20 61 6e 64 20 77 61 73 20 73 75 62 73 74 61 , and was substa
121d0 6e 74 69 61 6c 6c 79 0a 3b 3b 3b 20 72 65 77 6f ntially.;;; rewo
121e0 72 6b 65 64 20 62 79 20 4f 6c 69 6e 20 53 68 69 rked by Olin Shi
121f0 76 65 72 73 20 28 73 68 69 76 65 72 73 40 61 69 vers (shivers@ai
12200 2e 6d 69 74 2e 65 64 75 29 20 39 2f 39 38 2e 20 .mit.edu) 9/98.
12210 41 73 20 73 75 63 68 2c 20 69 74 20 69 73 0a 3b As such, it is.;
12220 3b 3b 20 63 6f 76 65 72 65 64 20 62 79 20 4d 49 ;; covered by MI
12230 54 20 53 63 68 65 6d 65 27 73 20 6f 70 65 6e 20 T Scheme's open
12240 73 6f 75 72 63 65 20 63 6f 70 79 72 69 67 68 74 source copyright
12250 2e 20 53 65 65 20 62 65 6c 6f 77 20 66 6f 72 20 . See below for
12260 64 65 74 61 69 6c 73 2e 0a 3b 3b 3b 20 0a 3b 3b details..;;; .;;
12270 3b 20 54 68 65 20 4b 4d 50 20 73 74 72 69 6e 67 ; The KMP string
12280 2d 73 65 61 72 63 68 20 63 6f 64 65 20 77 61 73 -search code was
12290 20 69 6e 66 6c 75 65 6e 63 65 64 20 62 79 20 69 influenced by i
122a0 6d 70 6c 65 6d 65 6e 74 61 74 69 6f 6e 73 20 77 mplementations w
122b0 72 69 74 74 65 6e 0a 3b 3b 3b 20 62 79 20 53 74 ritten.;;; by St
122c0 65 70 68 65 6e 20 42 65 76 61 6e 2c 20 42 72 69 ephen Bevan, Bri
122d0 61 6e 20 44 65 68 6e 65 79 65 72 20 61 6e 64 20 an Dehneyer and
122e0 57 69 6c 6c 20 46 69 74 7a 67 65 72 61 6c 64 2e Will Fitzgerald.
122f0 20 48 6f 77 65 76 65 72 2c 20 74 68 69 73 0a 3b However, this.;
12300 3b 3b 20 76 65 72 73 69 6f 6e 20 77 61 73 20 77 ;; version was w
12310 72 69 74 74 65 6e 20 66 72 6f 6d 20 73 63 72 61 ritten from scra
12320 74 63 68 20 62 79 20 6d 79 73 65 6c 66 2e 0a 3b tch by myself..;
12330 3b 3b 0a 3b 3b 3b 20 54 68 65 20 72 65 6d 61 69 ;;.;;; The remai
12340 6e 64 65 72 20 6f 66 20 74 68 69 73 20 63 6f 64 nder of this cod
12350 65 20 77 61 73 20 77 72 69 74 74 65 6e 20 66 72 e was written fr
12360 6f 6d 20 73 63 72 61 74 63 68 20 62 79 20 6d 79 om scratch by my
12370 73 65 6c 66 20 66 6f 72 20 73 63 73 68 2e 0a 3b self for scsh..;
12380 3b 3b 20 54 68 65 20 73 63 73 68 20 63 6f 70 79 ;; The scsh copy
12390 72 69 67 68 74 20 69 73 20 61 20 42 53 44 2d 73 right is a BSD-s
123a0 74 79 6c 65 20 6f 70 65 6e 20 73 6f 75 72 63 65 tyle open source
123b0 20 63 6f 70 79 72 69 67 68 74 2e 20 53 65 65 20 copyright. See
123c0 62 65 6c 6f 77 20 66 6f 72 0a 3b 3b 3b 20 64 65 below for.;;; de
123d0 74 61 69 6c 73 2e 0a 3b 3b 3b 20 20 20 20 20 2d tails..;;; -
123e0 4f 6c 69 6e 20 53 68 69 76 65 72 73 0a 0a 3b 3b Olin Shivers..;;
123f0 3b 20 4d 49 54 20 53 63 68 65 6d 65 20 63 6f 70 ; MIT Scheme cop
12400 79 72 69 67 68 74 20 74 65 72 6d 73 0a 3b 3b 3b yright terms.;;;
12410 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
12420 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
12430 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
12440 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
12450 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 0a 3b 3b 3b ;;;;;;;;;;;;.;;;
12460 20 54 68 69 73 20 6d 61 74 65 72 69 61 6c 20 77 This material w
12470 61 73 20 64 65 76 65 6c 6f 70 65 64 20 62 79 20 as developed by
12480 74 68 65 20 53 63 68 65 6d 65 20 70 72 6f 6a 65 the Scheme proje
12490 63 74 20 61 74 20 74 68 65 20 4d 61 73 73 61 63 ct at the Massac
124a0 68 75 73 65 74 74 73 0a 3b 3b 3b 20 49 6e 73 74 husetts.;;; Inst
124b0 69 74 75 74 65 20 6f 66 20 54 65 63 68 6e 6f 6c itute of Technol
124c0 6f 67 79 2c 20 44 65 70 61 72 74 6d 65 6e 74 20 ogy, Department
124d0 6f 66 20 45 6c 65 63 74 72 69 63 61 6c 20 45 6e of Electrical En
124e0 67 69 6e 65 65 72 69 6e 67 20 61 6e 64 0a 3b 3b gineering and.;;
124f0 3b 20 43 6f 6d 70 75 74 65 72 20 53 63 69 65 6e ; Computer Scien
12500 63 65 2e 20 20 50 65 72 6d 69 73 73 69 6f 6e 20 ce. Permission
12510 74 6f 20 63 6f 70 79 20 61 6e 64 20 6d 6f 64 69 to copy and modi
12520 66 79 20 74 68 69 73 20 73 6f 66 74 77 61 72 65 fy this software
12530 2c 20 74 6f 0a 3b 3b 3b 20 72 65 64 69 73 74 72 , to.;;; redistr
12540 69 62 75 74 65 20 65 69 74 68 65 72 20 74 68 65 ibute either the
12550 20 6f 72 69 67 69 6e 61 6c 20 73 6f 66 74 77 61 original softwa
12560 72 65 20 6f 72 20 61 20 6d 6f 64 69 66 69 65 64 re or a modified
12570 20 76 65 72 73 69 6f 6e 2c 20 61 6e 64 0a 3b 3b version, and.;;
12580 3b 20 74 6f 20 75 73 65 20 74 68 69 73 20 73 6f ; to use this so
12590 66 74 77 61 72 65 20 66 6f 72 20 61 6e 79 20 70 ftware for any p
125a0 75 72 70 6f 73 65 20 69 73 20 67 72 61 6e 74 65 urpose is grante
125b0 64 2c 20 73 75 62 6a 65 63 74 20 74 6f 20 74 68 d, subject to th
125c0 65 0a 3b 3b 3b 20 66 6f 6c 6c 6f 77 69 6e 67 20 e.;;; following
125d0 72 65 73 74 72 69 63 74 69 6f 6e 73 20 61 6e 64 restrictions and
125e0 20 75 6e 64 65 72 73 74 61 6e 64 69 6e 67 73 2e understandings.
125f0 0a 3b 3b 3b 20 0a 3b 3b 3b 20 31 2e 20 41 6e 79 .;;; .;;; 1. Any
12600 20 63 6f 70 79 20 6d 61 64 65 20 6f 66 20 74 68 copy made of th
12610 69 73 20 73 6f 66 74 77 61 72 65 20 6d 75 73 74 is software must
12620 20 69 6e 63 6c 75 64 65 20 74 68 69 73 20 63 6f include this co
12630 70 79 72 69 67 68 74 20 6e 6f 74 69 63 65 0a 3b pyright notice.;
12640 3b 3b 20 69 6e 20 66 75 6c 6c 2e 0a 3b 3b 3b 20 ;; in full..;;;
12650 0a 3b 3b 3b 20 32 2e 20 55 73 65 72 73 20 6f 66 .;;; 2. Users of
12660 20 74 68 69 73 20 73 6f 66 74 77 61 72 65 20 61 this software a
12670 67 72 65 65 20 74 6f 20 6d 61 6b 65 20 74 68 65 gree to make the
12680 69 72 20 62 65 73 74 20 65 66 66 6f 72 74 73 20 ir best efforts
12690 28 61 29 20 74 6f 0a 3b 3b 3b 20 72 65 74 75 72 (a) to.;;; retur
126a0 6e 20 74 6f 20 74 68 65 20 4d 49 54 20 53 63 68 n to the MIT Sch
126b0 65 6d 65 20 70 72 6f 6a 65 63 74 20 61 6e 79 20 eme project any
126c0 69 6d 70 72 6f 76 65 6d 65 6e 74 73 20 6f 72 20 improvements or
126d0 65 78 74 65 6e 73 69 6f 6e 73 20 74 68 61 74 0a extensions that.
126e0 3b 3b 3b 20 74 68 65 79 20 6d 61 6b 65 2c 20 73 ;;; they make, s
126f0 6f 20 74 68 61 74 20 74 68 65 73 65 20 6d 61 79 o that these may
12700 20 62 65 20 69 6e 63 6c 75 64 65 64 20 69 6e 20 be included in
12710 66 75 74 75 72 65 20 72 65 6c 65 61 73 65 73 3b future releases;
12720 20 61 6e 64 20 28 62 29 0a 3b 3b 3b 20 74 6f 20 and (b).;;; to
12730 69 6e 66 6f 72 6d 20 4d 49 54 20 6f 66 20 6e 6f inform MIT of no
12740 74 65 77 6f 72 74 68 79 20 75 73 65 73 20 6f 66 teworthy uses of
12750 20 74 68 69 73 20 73 6f 66 74 77 61 72 65 2e 0a this software..
12760 3b 3b 3b 20 0a 3b 3b 3b 20 33 2e 20 41 6c 6c 20 ;;; .;;; 3. All
12770 6d 61 74 65 72 69 61 6c 73 20 64 65 76 65 6c 6f materials develo
12780 70 65 64 20 61 73 20 61 20 63 6f 6e 73 65 71 75 ped as a consequ
12790 65 6e 63 65 20 6f 66 20 74 68 65 20 75 73 65 20 ence of the use
127a0 6f 66 20 74 68 69 73 0a 3b 3b 3b 20 73 6f 66 74 of this.;;; soft
127b0 77 61 72 65 20 73 68 61 6c 6c 20 64 75 6c 79 20 ware shall duly
127c0 61 63 6b 6e 6f 77 6c 65 64 67 65 20 73 75 63 68 acknowledge such
127d0 20 75 73 65 2c 20 69 6e 20 61 63 63 6f 72 64 61 use, in accorda
127e0 6e 63 65 20 77 69 74 68 20 74 68 65 20 75 73 75 nce with the usu
127f0 61 6c 0a 3b 3b 3b 20 73 74 61 6e 64 61 72 64 73 al.;;; standards
12800 20 6f 66 20 61 63 6b 6e 6f 77 6c 65 64 67 69 6e of acknowledgin
12810 67 20 63 72 65 64 69 74 20 69 6e 20 61 63 61 64 g credit in acad
12820 65 6d 69 63 20 72 65 73 65 61 72 63 68 2e 0a 3b emic research..;
12830 3b 3b 20 0a 3b 3b 3b 20 34 2e 20 4d 49 54 20 68 ;; .;;; 4. MIT h
12840 61 73 20 6d 61 64 65 20 6e 6f 20 77 61 72 72 61 as made no warra
12850 6e 74 65 65 20 6f 72 20 72 65 70 72 65 73 65 6e ntee or represen
12860 74 61 74 69 6f 6e 20 74 68 61 74 20 74 68 65 20 tation that the
12870 6f 70 65 72 61 74 69 6f 6e 20 6f 66 0a 3b 3b 3b operation of.;;;
12880 20 74 68 69 73 20 73 6f 66 74 77 61 72 65 20 77 this software w
12890 69 6c 6c 20 62 65 20 65 72 72 6f 72 2d 66 72 65 ill be error-fre
128a0 65 2c 20 61 6e 64 20 4d 49 54 20 69 73 20 75 6e e, and MIT is un
128b0 64 65 72 20 6e 6f 20 6f 62 6c 69 67 61 74 69 6f der no obligatio
128c0 6e 20 74 6f 0a 3b 3b 3b 20 70 72 6f 76 69 64 65 n to.;;; provide
128d0 20 61 6e 79 20 73 65 72 76 69 63 65 73 2c 20 62 any services, b
128e0 79 20 77 61 79 20 6f 66 20 6d 61 69 6e 74 65 6e y way of mainten
128f0 61 6e 63 65 2c 20 75 70 64 61 74 65 2c 20 6f 72 ance, update, or
12900 20 6f 74 68 65 72 77 69 73 65 2e 0a 3b 3b 3b 20 otherwise..;;;
12910 0a 3b 3b 3b 20 35 2e 20 49 6e 20 63 6f 6e 6a 75 .;;; 5. In conju
12920 6e 63 74 69 6f 6e 20 77 69 74 68 20 70 72 6f 64 nction with prod
12930 75 63 74 73 20 61 72 69 73 69 6e 67 20 66 72 6f ucts arising fro
12940 6d 20 74 68 65 20 75 73 65 20 6f 66 20 74 68 69 m the use of thi
12950 73 20 6d 61 74 65 72 69 61 6c 2c 0a 3b 3b 3b 20 s material,.;;;
12960 74 68 65 72 65 20 73 68 61 6c 6c 20 62 65 20 6e there shall be n
12970 6f 20 75 73 65 20 6f 66 20 74 68 65 20 6e 61 6d o use of the nam
12980 65 20 6f 66 20 74 68 65 20 4d 61 73 73 61 63 68 e of the Massach
12990 75 73 65 74 74 73 20 49 6e 73 74 69 74 75 74 65 usetts Institute
129a0 20 6f 66 0a 3b 3b 3b 20 54 65 63 68 6e 6f 6c 6f of.;;; Technolo
129b0 67 79 20 6e 6f 72 20 6f 66 20 61 6e 79 20 61 64 gy nor of any ad
129c0 61 70 74 61 74 69 6f 6e 20 74 68 65 72 65 6f 66 aptation thereof
129d0 20 69 6e 20 61 6e 79 20 61 64 76 65 72 74 69 73 in any advertis
129e0 69 6e 67 2c 0a 3b 3b 3b 20 70 72 6f 6d 6f 74 69 ing,.;;; promoti
129f0 6f 6e 61 6c 2c 20 6f 72 20 73 61 6c 65 73 20 6c onal, or sales l
12a00 69 74 65 72 61 74 75 72 65 20 77 69 74 68 6f 75 iterature withou
12a10 74 20 70 72 69 6f 72 20 77 72 69 74 74 65 6e 20 t prior written
12a20 63 6f 6e 73 65 6e 74 20 66 72 6f 6d 0a 3b 3b 3b consent from.;;;
12a30 20 4d 49 54 20 69 6e 20 65 61 63 68 20 63 61 73 MIT in each cas
12a40 65 2e 0a 0a 3b 3b 3b 20 53 63 73 68 20 63 6f 70 e...;;; Scsh cop
12a50 79 72 69 67 68 74 20 74 65 72 6d 73 0a 3b 3b 3b yright terms.;;;
12a60 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
12a70 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
12a80 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
12a90 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
12aa0 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 0a 3b 3b 3b ;;;;;;;;;;;;.;;;
12ab0 20 41 6c 6c 20 72 69 67 68 74 73 20 72 65 73 65 All rights rese
12ac0 72 76 65 64 2e 0a 3b 3b 3b 20 0a 3b 3b 3b 20 52 rved..;;; .;;; R
12ad0 65 64 69 73 74 72 69 62 75 74 69 6f 6e 20 61 6e edistribution an
12ae0 64 20 75 73 65 20 69 6e 20 73 6f 75 72 63 65 20 d use in source
12af0 61 6e 64 20 62 69 6e 61 72 79 20 66 6f 72 6d 73 and binary forms
12b00 2c 20 77 69 74 68 20 6f 72 20 77 69 74 68 6f 75 , with or withou
12b10 74 0a 3b 3b 3b 20 6d 6f 64 69 66 69 63 61 74 69 t.;;; modificati
12b20 6f 6e 2c 20 61 72 65 20 70 65 72 6d 69 74 74 65 on, are permitte
12b30 64 20 70 72 6f 76 69 64 65 64 20 74 68 61 74 20 d provided that
12b40 74 68 65 20 66 6f 6c 6c 6f 77 69 6e 67 20 63 6f the following co
12b50 6e 64 69 74 69 6f 6e 73 0a 3b 3b 3b 20 61 72 65 nditions.;;; are
12b60 20 6d 65 74 3a 0a 3b 3b 3b 20 31 2e 20 52 65 64 met:.;;; 1. Red
12b70 69 73 74 72 69 62 75 74 69 6f 6e 73 20 6f 66 20 istributions of
12b80 73 6f 75 72 63 65 20 63 6f 64 65 20 6d 75 73 74 source code must
12b90 20 72 65 74 61 69 6e 20 74 68 65 20 61 62 6f 76 retain the abov
12ba0 65 20 63 6f 70 79 72 69 67 68 74 0a 3b 3b 3b 20 e copyright.;;;
12bb0 20 20 20 6e 6f 74 69 63 65 2c 20 74 68 69 73 20 notice, this
12bc0 6c 69 73 74 20 6f 66 20 63 6f 6e 64 69 74 69 6f list of conditio
12bd0 6e 73 20 61 6e 64 20 74 68 65 20 66 6f 6c 6c 6f ns and the follo
12be0 77 69 6e 67 20 64 69 73 63 6c 61 69 6d 65 72 2e wing disclaimer.
12bf0 0a 3b 3b 3b 20 32 2e 20 52 65 64 69 73 74 72 69 .;;; 2. Redistri
12c00 62 75 74 69 6f 6e 73 20 69 6e 20 62 69 6e 61 72 butions in binar
12c10 79 20 66 6f 72 6d 20 6d 75 73 74 20 72 65 70 72 y form must repr
12c20 6f 64 75 63 65 20 74 68 65 20 61 62 6f 76 65 20 oduce the above
12c30 63 6f 70 79 72 69 67 68 74 0a 3b 3b 3b 20 20 20 copyright.;;;
12c40 20 6e 6f 74 69 63 65 2c 20 74 68 69 73 20 6c 69 notice, this li
12c50 73 74 20 6f 66 20 63 6f 6e 64 69 74 69 6f 6e 73 st of conditions
12c60 20 61 6e 64 20 74 68 65 20 66 6f 6c 6c 6f 77 69 and the followi
12c70 6e 67 20 64 69 73 63 6c 61 69 6d 65 72 20 69 6e ng disclaimer in
12c80 20 74 68 65 0a 3b 3b 3b 20 20 20 20 64 6f 63 75 the.;;; docu
12c90 6d 65 6e 74 61 74 69 6f 6e 20 61 6e 64 2f 6f 72 mentation and/or
12ca0 20 6f 74 68 65 72 20 6d 61 74 65 72 69 61 6c 73 other materials
12cb0 20 70 72 6f 76 69 64 65 64 20 77 69 74 68 20 74 provided with t
12cc0 68 65 20 64 69 73 74 72 69 62 75 74 69 6f 6e 2e he distribution.
12cd0 0a 3b 3b 3b 20 33 2e 20 54 68 65 20 6e 61 6d 65 .;;; 3. The name
12ce0 20 6f 66 20 74 68 65 20 61 75 74 68 6f 72 73 20 of the authors
12cf0 6d 61 79 20 6e 6f 74 20 62 65 20 75 73 65 64 20 may not be used
12d00 74 6f 20 65 6e 64 6f 72 73 65 20 6f 72 20 70 72 to endorse or pr
12d10 6f 6d 6f 74 65 20 70 72 6f 64 75 63 74 73 0a 3b omote products.;
12d20 3b 3b 20 20 20 20 64 65 72 69 76 65 64 20 66 72 ;; derived fr
12d30 6f 6d 20 74 68 69 73 20 73 6f 66 74 77 61 72 65 om this software
12d40 20 77 69 74 68 6f 75 74 20 73 70 65 63 69 66 69 without specifi
12d50 63 20 70 72 69 6f 72 20 77 72 69 74 74 65 6e 20 c prior written
12d60 70 65 72 6d 69 73 73 69 6f 6e 2e 0a 3b 3b 3b 20 permission..;;;
12d70 0a 3b 3b 3b 20 54 48 49 53 20 53 4f 46 54 57 41 .;;; THIS SOFTWA
12d80 52 45 20 49 53 20 50 52 4f 56 49 44 45 44 20 42 RE IS PROVIDED B
12d90 59 20 54 48 45 20 41 55 54 48 4f 52 53 20 60 60 Y THE AUTHORS ``
12da0 41 53 20 49 53 27 27 20 41 4e 44 20 41 4e 59 20 AS IS'' AND ANY
12db0 45 58 50 52 45 53 53 20 4f 52 0a 3b 3b 3b 20 49 EXPRESS OR.;;; I
12dc0 4d 50 4c 49 45 44 20 57 41 52 52 41 4e 54 49 45 MPLIED WARRANTIE
12dd0 53 2c 20 49 4e 43 4c 55 44 49 4e 47 2c 20 42 55 S, INCLUDING, BU
12de0 54 20 4e 4f 54 20 4c 49 4d 49 54 45 44 20 54 4f T NOT LIMITED TO
12df0 2c 20 54 48 45 20 49 4d 50 4c 49 45 44 20 57 41 , THE IMPLIED WA
12e00 52 52 41 4e 54 49 45 53 0a 3b 3b 3b 20 4f 46 20 RRANTIES.;;; OF
12e10 4d 45 52 43 48 41 4e 54 41 42 49 4c 49 54 59 20 MERCHANTABILITY
12e20 41 4e 44 20 46 49 54 4e 45 53 53 20 46 4f 52 20 AND FITNESS FOR
12e30 41 20 50 41 52 54 49 43 55 4c 41 52 20 50 55 52 A PARTICULAR PUR
12e40 50 4f 53 45 20 41 52 45 20 44 49 53 43 4c 41 49 POSE ARE DISCLAI
12e50 4d 45 44 2e 0a 3b 3b 3b 20 49 4e 20 4e 4f 20 45 MED..;;; IN NO E
12e60 56 45 4e 54 20 53 48 41 4c 4c 20 54 48 45 20 41 VENT SHALL THE A
12e70 55 54 48 4f 52 53 20 42 45 20 4c 49 41 42 4c 45 UTHORS BE LIABLE
12e80 20 46 4f 52 20 41 4e 59 20 44 49 52 45 43 54 2c FOR ANY DIRECT,
12e90 20 49 4e 44 49 52 45 43 54 2c 0a 3b 3b 3b 20 49 INDIRECT,.;;; I
12ea0 4e 43 49 44 45 4e 54 41 4c 2c 20 53 50 45 43 49 NCIDENTAL, SPECI
12eb0 41 4c 2c 20 45 58 45 4d 50 4c 41 52 59 2c 20 4f AL, EXEMPLARY, O
12ec0 52 20 43 4f 4e 53 45 51 55 45 4e 54 49 41 4c 20 R CONSEQUENTIAL
12ed0 44 41 4d 41 47 45 53 20 28 49 4e 43 4c 55 44 49 DAMAGES (INCLUDI
12ee0 4e 47 2c 20 42 55 54 0a 3b 3b 3b 20 4e 4f 54 20 NG, BUT.;;; NOT
12ef0 4c 49 4d 49 54 45 44 20 54 4f 2c 20 50 52 4f 43 LIMITED TO, PROC
12f00 55 52 45 4d 45 4e 54 20 4f 46 20 53 55 42 53 54 UREMENT OF SUBST
12f10 49 54 55 54 45 20 47 4f 4f 44 53 20 4f 52 20 53 ITUTE GOODS OR S
12f20 45 52 56 49 43 45 53 3b 20 4c 4f 53 53 20 4f 46 ERVICES; LOSS OF
12f30 20 55 53 45 2c 0a 3b 3b 3b 20 44 41 54 41 2c 20 USE,.;;; DATA,
12f40 4f 52 20 50 52 4f 46 49 54 53 3b 20 4f 52 20 42 OR PROFITS; OR B
12f50 55 53 49 4e 45 53 53 20 49 4e 54 45 52 52 55 50 USINESS INTERRUP
12f60 54 49 4f 4e 29 20 48 4f 57 45 56 45 52 20 43 41 TION) HOWEVER CA
12f70 55 53 45 44 20 41 4e 44 20 4f 4e 20 41 4e 59 0a USED AND ON ANY.
12f80 3b 3b 3b 20 54 48 45 4f 52 59 20 4f 46 20 4c 49 ;;; THEORY OF LI
12f90 41 42 49 4c 49 54 59 2c 20 57 48 45 54 48 45 52 ABILITY, WHETHER
12fa0 20 49 4e 20 43 4f 4e 54 52 41 43 54 2c 20 53 54 IN CONTRACT, ST
12fb0 52 49 43 54 20 4c 49 41 42 49 4c 49 54 59 2c 20 RICT LIABILITY,
12fc0 4f 52 20 54 4f 52 54 0a 3b 3b 3b 20 28 49 4e 43 OR TORT.;;; (INC
12fd0 4c 55 44 49 4e 47 20 4e 45 47 4c 49 47 45 4e 43 LUDING NEGLIGENC
12fe0 45 20 4f 52 20 4f 54 48 45 52 57 49 53 45 29 20 E OR OTHERWISE)
12ff0 41 52 49 53 49 4e 47 20 49 4e 20 41 4e 59 20 57 ARISING IN ANY W
13000 41 59 20 4f 55 54 20 4f 46 20 54 48 45 20 55 53 AY OUT OF THE US
13010 45 20 4f 46 0a 3b 3b 3b 20 54 48 49 53 20 53 4f E OF.;;; THIS SO
13020 46 54 57 41 52 45 2c 20 45 56 45 4e 20 49 46 20 FTWARE, EVEN IF
13030 41 44 56 49 53 45 44 20 4f 46 20 54 48 45 20 50 ADVISED OF THE P
13040 4f 53 53 49 42 49 4c 49 54 59 20 4f 46 20 53 55 OSSIBILITY OF SU
13050 43 48 20 44 41 4d 41 47 45 2e 0a CH DAMAGE..