From b50288c5b50ba7a31becc7332c5448bf122a2cd7 Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Thu, 11 May 2017 20:14:23 -0700
Subject: [PATCH] Implement a basic test for testing string searches.
---
tests/check.scm | 1 +
tests/runtime/test-string-search-data | 2204 +++++++++++++++++++++++++
tests/runtime/test-string-search.scm | 113 ++
3 files changed, 2318 insertions(+)
create mode 100644 tests/runtime/test-string-search-data
create mode 100644 tests/runtime/test-string-search.scm
diff --git a/tests/check.scm b/tests/check.scm
index cce540fb7..5e07df496 100644
--- a/tests/check.scm
+++ b/tests/check.scm
@@ -71,6 +71,7 @@ USA.
"runtime/test-rgxcmp"
"runtime/test-string"
"runtime/test-string-normalization"
+ "runtime/test-string-search"
"runtime/test-thread-queue"
"runtime/test-url"
("runtime/test-wttree" (runtime wt-tree))
diff --git a/tests/runtime/test-string-search-data b/tests/runtime/test-string-search-data
new file mode 100644
index 000000000..d5fbd5361
--- /dev/null
+++ b/tests/runtime/test-string-search-data
@@ -0,0 +1,2204 @@
+#| -*-Scheme-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+ 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+ 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
+ 2017 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; Unicode strings
+;;; package: (runtime ustring)
+
+;;; For simplicity, the implementation uses a 24-bit encoding for non-8-bit
+;;; strings. This is not a good long-term approach and should be revisited once
+;;; the runtime system has been converted to this string abstraction.
+
+(declare (usual-integrations))
+
+(define-primitives
+ (allocate-nm-vector 2)
+ (legacy-string? string? 1)
+ (legacy-string-allocate string-allocate 1)
+ (primitive-byte-ref 2)
+ (primitive-byte-set! 3)
+ (primitive-datum-ref 2)
+ (primitive-datum-set! 3)
+ (primitive-type-ref 2)
+ (primitive-type-set! 3))
+
+(define-integrable (ustring? object)
+ (object-type? (ucode-type unicode-string) object))
+
+(define (mutable-string? object)
+ (%string-mutable? object (lambda () #f)))
+
+(define (string-mutable? string)
+ (%string-mutable? string
+ (lambda ()
+ (error:not-a string? string 'string-mutable?))))
+
+(define (%string-mutable? string fail)
+ (cond ((legacy-string? string))
+ ((ustring? string) (%ustring-mutable? string))
+ ((slice? string) (slice-mutable? string))
+ (else (fail))))
+
+(define (immutable-string? object)
+ (%string-immutable? object (lambda () #f)))
+
+(define (string-immutable? string)
+ (%string-immutable? string
+ (lambda ()
+ (error:not-a string? string 'string-immutable?))))
+
+(define (%string-immutable? string fail)
+ (cond ((legacy-string? string) #f)
+ ((ustring? string) (%ustring-immutable? string))
+ ((slice? string) (not (slice-mutable? string)))
+ (else (fail))))
+
+(define (register-ustring-predicates!)
+ (register-predicate! string? 'string)
+ (register-predicate! mutable-string? 'mutable-string '<= string?)
+ (register-predicate! immutable-string? 'immutable-string '<= string?)
+ (register-predicate! nfc-string? 'nfc-string '<= string?)
+ (register-predicate! legacy-string? 'legacy-string
+ '<= string?
+ '<= mutable-string?)
+ (register-predicate! ustring? 'unicode-string '<= string?)
+ (register-predicate! slice? 'string-slice '<= string?)
+ (register-predicate! 8-bit-string? '8-bit-string '<= string?))
+
+;;;; Unicode string layout
+
+(select-on-bytes-per-word
+ ;; 32-bit words
+ (begin
+ (define-integrable byte->object-offset 3)
+ (define-integrable byte->object-shift -2)
+ (define-integrable byte0-index 8))
+ ;; 64-bit words
+ (begin
+ (define-integrable byte->object-offset 7)
+ (define-integrable byte->object-shift -3)
+ (define-integrable byte0-index 16)))
+
+(define (%ustring-allocate n-bytes length cp-size)
+ (let ((string
+ (allocate-nm-vector (ucode-type unicode-string)
+ (fix:+ 1
+ (fix:lsh (fix:+ n-bytes byte->object-offset)
+ byte->object-shift)))))
+ (%set-ustring-length! string length)
+ (%set-ustring-flags! string cp-size) ;assumes cp-size in bottom bits
+ string))
+
+(define-integrable (ustring-length string)
+ (primitive-datum-ref string 1))
+
+(define-integrable (%set-ustring-length! string length)
+ (primitive-datum-set! string 1 length))
+
+(define-integrable (%ustring-flags string)
+ (primitive-type-ref string 1))
+
+(define-integrable (%set-ustring-flags! string flags)
+ (primitive-type-set! string 1 flags))
+
+(define (%ustring-cp-size string)
+ (fix:and #x03 (%ustring-flags string)))
+
+(define (%set-ustring-cp-size! string cp-size)
+ (%set-ustring-flags! string
+ (fix:or (fix:andc (%ustring-flags string) #x03)
+ cp-size)))
+
+(define-integrable (%ustring-mutable? string)
+ (fix:= 0 (%ustring-cp-size string)))
+
+(define-integrable (%ustring-immutable? string)
+ (not (%ustring-mutable? string)))
+
+(define-integrable flag:nfc #x04)
+(define-integrable flag:nfc-set #x08)
+(define-integrable flag:nfd #x10)
+
+(define-integrable (%make-flag-tester flag)
+ (lambda (string)
+ (not (fix:= 0 (fix:and flag (%ustring-flags string))))))
+
+(define ustring-in-nfc? (%make-flag-tester flag:nfc))
+(define ustring-in-nfc-set? (%make-flag-tester flag:nfc-set))
+(define ustring-in-nfd? (%make-flag-tester flag:nfd))
+
+(define (ustring-in-nfc! string nfc?)
+ (%set-ustring-flags! string
+ (fix:or (fix:andc (%ustring-flags string)
+ (fix:or flag:nfc flag:nfc-set))
+ (if nfc?
+ (fix:or flag:nfc flag:nfc-set)
+ flag:nfc-set))))
+
+(define (ustring-in-nfd! string nfd?)
+ (%set-ustring-flags! string
+ (if nfd?
+ (fix:or (%ustring-flags string) flag:nfd)
+ (fix:andc (%ustring-flags string) flag:nfd))))
+
+(define-integrable (ustring1-ref string index)
+ (integer->char (cp1-ref string index)))
+
+(define-integrable (ustring1-set! string index char)
+ (cp1-set! string index (char->integer char)))
+
+(define-integrable (cp1-ref string index)
+ (primitive-byte-ref string (cp1-index index)))
+
+(define-integrable (cp1-set! string index cp)
+ (primitive-byte-set! string (cp1-index index) cp))
+
+(define-integrable (cp1-index index)
+ (fix:+ byte0-index index))
+
+(define-integrable (ustring2-ref string index)
+ (integer->char (cp2-ref string index)))
+
+(define-integrable (ustring2-set! string index char)
+ (cp2-set! string index (char->integer char)))
+
+(define (cp2-ref string index)
+ (let ((i (cp2-index index)))
+ (fix:or (primitive-byte-ref string i)
+ (fix:lsh (primitive-byte-ref string (fix:+ i 1)) 8))))
+
+(define (cp2-set! string index cp)
+ (let ((i (cp2-index index)))
+ (primitive-byte-set! string i (fix:and cp #xFF))
+ (primitive-byte-set! string (fix:+ i 1) (fix:lsh cp -8))))
+
+(define-integrable (cp2-index index)
+ (fix:+ byte0-index (fix:* 2 index)))
+
+(define-integrable (ustring3-ref string index)
+ (integer->char (cp3-ref string index)))
+
+(define-integrable (ustring3-set! string index char)
+ (cp3-set! string index (char->integer char)))
+
+(define (cp3-ref string index)
+ (let ((i (cp3-index index)))
+ (fix:or (primitive-byte-ref string i)
+ (fix:or (fix:lsh (primitive-byte-ref string (fix:+ i 1)) 8)
+ (fix:lsh (primitive-byte-ref string (fix:+ i 2)) 16)))))
+
+(define (cp3-set! string index cp)
+ (let ((i (cp3-index index)))
+ (primitive-byte-set! string i (fix:and cp #xFF))
+ (primitive-byte-set! string (fix:+ i 1) (fix:and (fix:lsh cp -8) #xFF))
+ (primitive-byte-set! string (fix:+ i 2) (fix:lsh cp -16))))
+
+(define-integrable (cp3-index index)
+ (fix:+ byte0-index (fix:* 3 index)))
+
+(define (mutable-ustring-allocate n)
+ (%ustring-allocate (fix:* 3 n) n 0))
+
+(define (immutable-ustring-allocate n max-cp)
+ (cond ((fix:< max-cp #x100)
+ (let ((s (%ustring-allocate (fix:+ n 1) n 1)))
+ (ustring-in-nfc! s #t)
+ (if (fix:< max-cp #xC0)
+ (ustring-in-nfd! s #t))
+ (ustring1-set! s n #\null) ;zero-terminate for C
+ s))
+ ((fix:< max-cp #x10000)
+ (let ((s (%ustring-allocate (fix:* 2 n) n 2)))
+ (if (fix:< max-cp #x300)
+ (ustring-in-nfc! s #t))
+ s))
+ (else
+ (%ustring-allocate (fix:* 3 n) n 3))))
+
+;;; Used during cold load.
+(define (%ustring1? object)
+ (or (and (ustring? object)
+ (fix:= 1 (%ustring-cp-size object)))
+ (legacy-string? object)))
+
+;;; Used during cold load.
+(define (%ascii-ustring! string)
+ (%set-ustring-cp-size! string 1)
+ (ustring-in-nfc! string #t)
+ (ustring-in-nfd! string #t))
+
+;;; Used during cold load.
+(define (%ascii-ustring-allocate n)
+ (let ((s (%ustring-allocate (fix:+ n 1) n 1)))
+ (ustring-in-nfc! s #t)
+ (ustring-in-nfd! s #t)
+ (ustring1-set! s n #\null) ;zero-terminate for C
+ s))
+
+(define (ustring-ref string index)
+ (case (ustring-cp-size string)
+ ((1) (ustring1-ref string index))
+ ((2) (ustring2-ref string index))
+ (else (ustring3-ref string index))))
+
+(define (ustring-set! string index char)
+ (case (ustring-cp-size string)
+ ((1) (ustring1-set! string index char))
+ ((2) (ustring2-set! string index char))
+ (else (ustring3-set! string index char))))
+
+(define (ustring-cp-size string)
+ (if (legacy-string? string)
+ 1
+ (%ustring-cp-size string)))
+
+(define (mutable-ustring? object)
+ (or (legacy-string? object)
+ (and (ustring? object)
+ (%ustring-mutable? object))))
+
+(define (ustring-mutable? string)
+ (or (legacy-string? string)
+ (%ustring-mutable? string)))
+
+;;;; String slices
+
+(define (slice? object)
+ (and (%record? object)
+ (fix:= 4 (%record-length object))
+ (eq? %slice-tag (%record-ref object 0))))
+
+(define-integrable (make-slice string start length)
+ (%record %slice-tag string start length))
+
+(define-integrable %slice-tag
+ '|#[(runtime ustring)slice]|)
+
+(define-integrable (slice-string slice) (%record-ref slice 1))
+(define-integrable (slice-start slice) (%record-ref slice 2))
+(define-integrable (slice-length slice) (%record-ref slice 3))
+
+(define (slice-end slice)
+ (fix:+ (slice-start slice) (slice-length slice)))
+
+(define (slice-mutable? slice)
+ (ustring-mutable? (slice-string slice)))
+
+(define (unpack-slice string k)
+ (if (slice? string)
+ (k (slice-string string) (slice-start string) (slice-end string))
+ (k string 0 (ustring-length string))))
+
+(define (translate-slice string start end k)
+ (if (slice? string)
+ (k (slice-string string)
+ (fix:+ (slice-start string) start)
+ (fix:+ (slice-start string) end))
+ (k string start end)))
+
+;;;; Basic operations
+
+(define (string? object)
+ (or (legacy-string? object)
+ (ustring? object)
+ (slice? object)))
+
+(define (make-string k #!optional char)
+ (guarantee index-fixnum? k 'make-string)
+ (let ((string (mutable-ustring-allocate k)))
+ (if (not (default-object? char))
+ (do ((i 0 (fix:+ i 1)))
+ ((not (fix:< i k)))
+ (ustring3-set! string i char)))
+ string))
+
+(define (string-length string)
+ (cond ((or (legacy-string? string) (ustring? string)) (ustring-length string))
+ ((slice? string) (slice-length string))
+ (else (error:not-a string? string 'string-length))))
+
+(define (string-ref string index)
+ (guarantee index-fixnum? index 'string-ref)
+ (cond ((or (legacy-string? string) (ustring? string))
+ (if (not (fix:< index (ustring-length string)))
+ (error:bad-range-argument index 'string-ref))
+ (ustring-ref string index))
+ ((slice? string)
+ (if (not (fix:< index (slice-length string)))
+ (error:bad-range-argument index 'string-ref))
+ (ustring-ref (slice-string string)
+ (fix:+ (slice-start string) index)))
+ (else
+ (error:not-a string? string 'string-ref))))
+
+(define (string-set! string index char)
+ (guarantee mutable-string? string 'string-set!)
+ (guarantee index-fixnum? index 'string-set!)
+ (guarantee bitless-char? char 'string-set!)
+ (if (not (fix:< index (string-length string)))
+ (error:bad-range-argument index 'string-set!))
+ (if (slice? string)
+ (ustring-set! (slice-string string)
+ (fix:+ (slice-start string) index)
+ char)
+ (ustring-set! string index char)))
+
+;;;; Slice/Copy
+
+(define (string-slice string #!optional start end)
+ (let* ((len (string-length string))
+ (end (fix:end-index end len 'string-slice))
+ (start (fix:start-index start end 'string-slice)))
+ (cond ((and (fix:= start 0) (fix:= end len))
+ string)
+ ((slice? string)
+ (make-slice (slice-string string)
+ (fix:+ (slice-start string) start)
+ (fix:- end start)))
+ (else
+ (make-slice string
+ start
+ (fix:- end start))))))
+
+(define (string-copy! to at from #!optional start end)
+ (let* ((end (fix:end-index end (string-length from) 'string-copy!))
+ (start (fix:start-index start end 'string-copy!)))
+ (guarantee index-fixnum? at 'string-copy!)
+ (let ((final-at (fix:+ at (fix:- end start))))
+ (if (not (fix:<= final-at (string-length to)))
+ (error:bad-range-argument at 'string-copy!))
+ (if (not (string-mutable? to))
+ (error:bad-range-argument to 'string-copy!))
+ (receive (to at)
+ (if (slice? to)
+ (values (slice-string to)
+ (fix:+ (slice-start to) at))
+ (values to at))
+ (translate-slice from start end
+ (lambda (from start end)
+ (%general-copy! to at from start end))))
+ final-at)))
+
+(define (string-copy string #!optional start end)
+ (let* ((end (fix:end-index end (string-length string) 'string-copy))
+ (start (fix:start-index start end 'string-copy)))
+ (translate-slice string start end
+ (lambda (string start end)
+ (let* ((n (fix:- end start))
+ (to
+ (if (legacy-string? string)
+ (legacy-string-allocate n)
+ (mutable-ustring-allocate n))))
+ (%general-copy! to 0 string start end)
+ to)))))
+
+(define (substring string #!optional start end)
+ (let* ((len (string-length string))
+ (end (fix:end-index end (string-length string) 'substring))
+ (start (fix:start-index start end 'substring)))
+ ;; It shouldn't be necessary to copy immutable substrings, but some of these
+ ;; find their way to Edwin so we can't return a slice here. We will
+ ;; probably need to implement a procedure to map an arbitrary string to a
+ ;; legacy string for Edwin's use.
+ (if (and (fix:= start 0)
+ (fix:= end len)
+ (not (slice? string))
+ (ustring-in-nfc? string))
+ string
+ (translate-slice string start end
+ (lambda (string start end)
+ (let ((to
+ (immutable-ustring-allocate
+ (fix:- end start)
+ (%general-max-cp string start end))))
+ (%general-copy! to 0 string start end)
+ to))))))
+
+(define (string-head string end)
+ (substring string 0 end))
+
+(define (string-tail string start)
+ (substring string start))
+
+(define (%general-copy! to at from start end)
+
+ (define-integrable (copy! j i o)
+ (primitive-byte-set! to (fix:+ j o) (primitive-byte-ref from (fix:+ i o))))
+
+ (define-integrable (zero! j o)
+ (primitive-byte-set! to (fix:+ j o) 0))
+
+ (case (ustring-cp-size from)
+ ((1)
+ (let ((start (cp1-index start))
+ (end (cp1-index end)))
+ (case (ustring-cp-size to)
+ ((1)
+ (do ((i start (fix:+ i 1))
+ (j (cp1-index at) (fix:+ j 1)))
+ ((not (fix:< i end)))
+ (copy! j i 0)))
+ ((2)
+ (do ((i start (fix:+ i 1))
+ (j (cp2-index at) (fix:+ j 2)))
+ ((not (fix:< i end)))
+ (copy! j i 0)
+ (zero! j 1)))
+ (else
+ (do ((i start (fix:+ i 1))
+ (j (cp3-index at) (fix:+ j 3)))
+ ((not (fix:< i end)))
+ (copy! j i 0)
+ (zero! j 1)
+ (zero! j 2))))))
+ ((2)
+ (let ((start (cp2-index start))
+ (end (cp2-index end)))
+ (case (ustring-cp-size to)
+ ((1)
+ (do ((i start (fix:+ i 2))
+ (j (cp1-index at) (fix:+ j 1)))
+ ((not (fix:< i end)))
+ (copy! j i 0)))
+ ((2)
+ (do ((i start (fix:+ i 2))
+ (j (cp2-index at) (fix:+ j 2)))
+ ((not (fix:< i end)))
+ (copy! j i 0)
+ (copy! j i 1)))
+ (else
+ (do ((i start (fix:+ i 2))
+ (j (cp3-index at) (fix:+ j 3)))
+ ((not (fix:< i end)))
+ (copy! j i 0)
+ (copy! j i 1)
+ (zero! j 2))))))
+ (else
+ (let ((start (cp3-index start))
+ (end (cp3-index end)))
+ (case (ustring-cp-size to)
+ ((1)
+ (do ((i start (fix:+ i 3))
+ (j (cp1-index at) (fix:+ j 1)))
+ ((not (fix:< i end)))
+ (copy! j i 0)))
+ ((2)
+ (do ((i start (fix:+ i 3))
+ (j (cp2-index at) (fix:+ j 2)))
+ ((not (fix:< i end)))
+ (copy! j i 0)
+ (copy! j i 1)))
+ (else
+ (do ((i start (fix:+ i 3))
+ (j (cp3-index at) (fix:+ j 3)))
+ ((not (fix:< i end)))
+ (copy! j i 0)
+ (copy! j i 1)
+ (copy! j i 2))))))))
+
+(define (%general-max-cp string start end)
+
+ (define-integrable (max-loop cp-ref)
+ (do ((i start (fix:+ i 1))
+ (max-cp 0
+ (let ((cp (cp-ref string i)))
+ (if (fix:> cp max-cp)
+ cp
+ max-cp))))
+ ((not (fix:< i end)) max-cp)))
+
+ (case (ustring-cp-size string)
+ ((1) (max-loop cp1-ref))
+ ((2) (max-loop cp2-ref))
+ (else (max-loop cp3-ref))))
+
+(define (%string->immutable string)
+ (if (and (ustring? string) (%ustring-immutable? string))
+ string
+ (unpack-slice string
+ (lambda (string* start end)
+ (let ((result
+ (immutable-ustring-allocate
+ (fix:- end start)
+ (%general-max-cp string* start end))))
+ (%general-copy! result 0 string* start end)
+ result)))))
+
+;;;; Streaming builder
+
+(define (string-builder #!optional buffer-length)
+ (let ((builder
+ (%make-string-builder
+ (if (default-object? buffer-length)
+ 16
+ (begin
+ (guarantee positive-fixnum? buffer-length 'string-builder)
+ buffer-length)))))
+ (let ((append-char! (builder 'append-char!))
+ (append-string! (builder 'append-string!))
+ (build (builder 'build)))
+ (lambda (#!optional object)
+ (cond ((bitless-char? object) (append-char! object))
+ ((string? object) (append-string! object))
+ (else
+ (case object
+ ((#!default nfc) (build build-string:nfc))
+ ((immutable) (build build-string:immutable))
+ ((mutable) (build build-string:mutable))
+ ((legacy) (build build-string:legacy))
+ ((empty? count max-cp reset!) ((builder object)))
+ (else (error "Unsupported argument:" object)))))))))
+
+(define (build-string:nfc strings count max-cp)
+ (string->nfc (build-string:immutable strings count max-cp)))
+
+(define (build-string:immutable strings count max-cp)
+ (let ((result (immutable-ustring-allocate count max-cp)))
+ (fill-result! strings result)
+ result))
+
+(define (build-string:mutable strings count max-cp)
+ (declare (ignore max-cp))
+ (let ((result (mutable-ustring-allocate count)))
+ (fill-result! strings result)
+ result))
+
+(define (build-string:legacy strings count max-cp)
+ (if (not (fix:< max-cp #x100))
+ (error "Can't build legacy string:" max-cp))
+ (let ((result (legacy-string-allocate count)))
+ (fill-result! strings result)
+ result))
+
+(define (fill-result! strings result)
+ (do ((strings strings (cdr strings))
+ (i 0 (fix:+ i (string-length (car strings)))))
+ ((not (pair? strings)))
+ (unpack-slice (car strings)
+ (lambda (string start end)
+ (%general-copy! result i string start end)))))
+
+(define (%make-string-builder buffer-length)
+ (let ((buffers)
+ (buffer)
+ (start)
+ (index)
+ (count)
+ (max-cp))
+
+ (define (reset!)
+ (set! buffers '())
+ (set! buffer (mutable-ustring-allocate buffer-length))
+ (set! start 0)
+ (set! index 0)
+ (set! count 0)
+ (set! max-cp 0)
+ unspecific)
+
+ (define (get-partial)
+ (string-slice buffer start index))
+
+ (define (append-char! char)
+ (ustring3-set! buffer index char)
+ (set! index (fix:+ index 1))
+ (set! count (fix:+ count 1))
+ (set! max-cp (fix:max max-cp (char->integer char)))
+ (if (not (fix:< index buffer-length))
+ (begin
+ (set! buffers (cons (get-partial) buffers))
+ (set! buffer (mutable-ustring-allocate buffer-length))
+ (set! start 0)
+ (set! index 0)
+ unspecific)))
+
+ (define (append-string! string)
+ (let ((length (string-length string)))
+ (if (fix:> length 0)
+ (begin
+ (if (fix:> index start)
+ (begin
+ (set! buffers (cons (get-partial) buffers))
+ (set! start index)))
+ (set! buffers (cons string buffers))
+ (set! count (fix:+ count length))
+ (set! max-cp
+ (fix:max max-cp
+ (unpack-slice string %general-max-cp)))
+ unspecific))))
+
+ (define (build finish)
+ (finish (reverse
+ (if (fix:> index start)
+ (cons (get-partial) buffers)
+ buffers))
+ count
+ max-cp))
+
+ (reset!)
+ (lambda (operator)
+ (case operator
+ ((append-char!) append-char!)
+ ((append-string!) append-string!)
+ ((build) build)
+ ((empty?) (lambda () (fix:= count 0)))
+ ((count) (lambda () count))
+ ((max-cp) (lambda () max-cp))
+ ((reset!) reset!)
+ (else (error "Unknown operator:" operator))))))
+
+;;;; Compare
+
+(define (string-compare string1 string2 if= if< if>)
+ (%string-compare (string->nfc string1)
+ (string->nfc string2)
+ if= if< if>))
+
+(define (string-compare-ci string1 string2 if= if< if>)
+ (%string-compare (string-foldcase string1)
+ (string-foldcase string2)
+ if= if< if>))
+
+;; Non-Unicode implementation, acceptable to R7RS.
+(define-integrable (%string-compare string1 string2 if= if< if>)
+ (let ((end1 (string-length string1))
+ (end2 (string-length string2)))
+ (let ((end (fix:min end1 end2)))
+ (let loop ((i 0))
+ (if (fix:< i end)
+ (let ((c1 (string-ref string1 i))
+ (c2 (string-ref string2 i)))
+ (cond ((char<? c1 c2) (if<))
+ ((char<? c2 c1) (if>))
+ (else (loop (fix:+ i 1)))))
+ (cond ((fix:< end1 end2) (if<))
+ ((fix:< end2 end1) (if>))
+ (else (if=))))))))
+
+(define-integrable (true) #t)
+(define-integrable (false) #f)
+
+(define-integrable (%string-comparison-maker if= if< if>)
+ (lambda (string1 string2)
+ (%string-compare string1 string2 if= if< if>)))
+
+(define %string=? (%string-comparison-maker true false false))
+(define %string<? (%string-comparison-maker false true false))
+(define %string<=? (%string-comparison-maker true true false))
+(define %string>? (%string-comparison-maker false false true))
+(define %string>=? (%string-comparison-maker true false true))
+
+(define-integrable (string-comparison-maker preprocess compare)
+ (lambda (string1 string2 . strings)
+ (let loop
+ ((string1 (preprocess string1))
+ (string2 (preprocess string2))
+ (strings strings))
+ (if (pair? strings)
+ (and (compare string1 string2)
+ (loop string2 (preprocess (car strings)) (cdr strings)))
+ (compare string1 string2)))))
+
+(define string=? (string-comparison-maker string->nfc %string=?))
+(define string<? (string-comparison-maker string->nfc %string<?))
+(define string<=? (string-comparison-maker string->nfc %string<=?))
+(define string>? (string-comparison-maker string->nfc %string>?))
+(define string>=? (string-comparison-maker string->nfc %string>=?))
+
+(define string-ci=? (string-comparison-maker string-foldcase %string=?))
+(define string-ci<? (string-comparison-maker string-foldcase %string<?))
+(define string-ci<=? (string-comparison-maker string-foldcase %string<=?))
+(define string-ci>? (string-comparison-maker string-foldcase %string>?))
+(define string-ci>=? (string-comparison-maker string-foldcase %string>=?))
+
+;;;; Match
+
+(define (string-match-forward string1 string2)
+ (guarantee nfc-string? string1 'string-match-forward)
+ (guarantee nfc-string? string2 'string-match-forward)
+ (let ((end1 (string-length string1))
+ (end2 (string-length string2)))
+ (let ((end (fix:min end1 end2)))
+ (let loop ((i 0))
+ (if (and (fix:< i end)
+ (char=? (string-ref string1 i)
+ (string-ref string2 i)))
+ (loop (fix:+ i 1))
+ i)))))
+
+(define (string-match-backward string1 string2)
+ (guarantee nfc-string? string1 'string-match-backward)
+ (guarantee nfc-string? string2 'string-match-backward)
+ (let ((s1 (fix:- (string-length string1) 1)))
+ (let loop ((i s1) (j (fix:- (string-length string2) 1)))
+ (if (and (fix:>= i 0)
+ (fix:>= j 0)
+ (char=? (string-ref string1 i)
+ (string-ref string2 j)))
+ (loop (fix:- i 1)
+ (fix:- j 1))
+ (fix:- s1 i)))))
+
+(define (string-prefix? prefix string #!optional start end)
+ (%string-prefix? (string->nfc prefix)
+ (string->nfc (string-slice string start end))))
+
+(define (string-prefix-ci? prefix string #!optional start end)
+ (%string-prefix? (string-foldcase prefix)
+ (string-foldcase (string-slice string start end))))
+
+(define (%string-prefix? prefix string)
+ (let ((n (string-length prefix)))
+ (and (fix:<= n (string-length string))
+ (let loop ((i 0) (j 0))
+ (if (fix:< i n)
+ (and (eq? (string-ref prefix i) (string-ref string j))
+ (loop (fix:+ i 1) (fix:+ j 1)))
+ #t)))))
+
+(define (string-suffix? suffix string #!optional start end)
+ (%string-suffix? (string->nfc suffix)
+ (string->nfc (string-slice string start end))))
+
+(define (string-suffix-ci? suffix string #!optional start end)
+ (%string-suffix? (string-foldcase suffix)
+ (string-foldcase (string-slice string start end))))
+
+(define (%string-suffix? suffix string)
+ (let ((n (string-length suffix))
+ (n* (string-length string)))
+ (and (fix:<= n n*)
+ (let loop ((i 0) (j (fix:- n* n)))
+ (if (fix:< i n)
+ (and (eq? (string-ref suffix i) (string-ref string j))
+ (loop (fix:+ i 1) (fix:+ j 1)))
+ #t)))))
+
+;;;; Case
+
+(define (string-downcase string)
+ (case-transform ucd-lc-value string))
+
+(define (string-foldcase string)
+ (case-transform ucd-cf-value string))
+
+(define (string-upcase string)
+ (case-transform ucd-uc-value string))
+
+(define (case-transform transform string)
+ (let ((builder (string-builder))
+ (end (string-length string)))
+ (do ((index 0 (fix:+ index 1)))
+ ((not (fix:< index end)))
+ (builder (transform (string-ref string index))))
+ (builder)))
+
+(define (string-titlecase string)
+ (let ((builder (string-builder)))
+ (find-word-breaks string 0
+ (lambda (end start)
+ (maybe-titlecase string start end builder)
+ end))
+ (builder)))
+
+(define (maybe-titlecase string start end builder)
+ (let loop ((index start))
+ (if (fix:< index end)
+ (let ((char (string-ref string index)))
+ (if (char-cased? char)
+ (begin
+ (builder (ucd-tc-value char))
+ (do ((index (fix:+ index 1) (fix:+ index 1)))
+ ((not (fix:< index end)))
+ (builder (ucd-lc-value (string-ref string index)))))
+ (begin
+ (builder char)
+ (loop (fix:+ index 1))))))))
+
+(define (string-lower-case? string)
+ (nfd-string-lower-case? (string->nfd string)))
+
+(define (string-upper-case? string)
+ (nfd-string-upper-case? (string->nfd string)))
+
+(define (nfd-string-lower-case? nfd)
+ (let ((end (string-length nfd)))
+ (let loop ((i 0))
+ (if (fix:< i end)
+ (and (not (char-changes-when-lower-cased? (string-ref nfd i)))
+ (loop (fix:+ i 1)))
+ #t))))
+
+(define (nfd-string-upper-case? nfd)
+ (let ((end (string-length nfd)))
+ (let loop ((i 0))
+ (if (fix:< i end)
+ (and (not (char-changes-when-upper-cased? (string-ref nfd i)))
+ (loop (fix:+ i 1)))
+ #t))))
+
+(define (nfd-string-case-folded? nfd)
+ (let ((end (string-length nfd)))
+ (let loop ((i 0))
+ (if (fix:< i end)
+ (and (not (char-changes-when-case-folded? (string-ref nfd i)))
+ (loop (fix:+ i 1)))
+ #t))))
+
+;;;; Normalization
+
+(define (nfc-string? string)
+ (and (string? string)
+ (string-in-nfc? string)))
+
+(define (string-in-nfc? string)
+ (let ((full-check
+ (lambda ()
+ (let ((qc (string-nfc-qc string 'string-in-nfc?)))
+ (if (eq? qc 'maybe)
+ (%string=? string (%string->nfc string))
+ qc)))))
+ (if (and (ustring? string)
+ (%ustring-immutable? string))
+ (if (ustring-in-nfc-set? string)
+ (ustring-in-nfc? string)
+ (let ((nfc? (full-check)))
+ (ustring-in-nfc! string nfc?)
+ nfc?))
+ (full-check))))
+
+(define (string->nfc string)
+ (if (and (ustring? string)
+ (%ustring-immutable? string))
+ (if (ustring-in-nfc-set? string)
+ string
+ (let ((nfc
+ (case (string-nfc-qc string 'string->nfc)
+ ((#t)
+ string)
+ ((maybe)
+ (let ((nfc (%string->nfc string)))
+ (if (%string=? string nfc)
+ string
+ nfc)))
+ (else
+ (%string->nfc string)))))
+ (ustring-in-nfc! nfc #t)
+ nfc))
+ (let ((nfc
+ (if (eq? #t (string-nfc-qc string 'string->nfc))
+ (%string->immutable string)
+ (%string->nfc string))))
+ (ustring-in-nfc! nfc #t)
+ nfc)))
+
+(define (%string->nfc string)
+ (canonical-composition
+ (if (string-in-nfd? string)
+ string
+ (canonical-decomposition&ordering string
+ (lambda (string* n max-cp)
+ (declare (ignore n max-cp))
+ string*)))))
+
+(define (string-nfc-qc string caller)
+ (cond ((legacy-string? string)
+ #t)
+ ((ustring? string)
+ (if (and (%ustring-immutable? string)
+ (ustring-in-nfc-set? string))
+ (ustring-in-nfc? string)
+ (ustring-nfc-qc string 0 (string-length string))))
+ ((slice? string)
+ (unpack-slice string ustring-nfc-qc))
+ (else
+ (error:not-a string? string caller))))
+
+(define (ustring-nfc-qc string start end)
+ (let ((scan
+ (lambda (sref)
+ (let loop ((i start) (last-ccc 0) (result #t))
+ (if (fix:< i end)
+ (let ((char (sref string i)))
+ (if (fix:< (char->integer char) #x300)
+ (loop (fix:+ i 1) 0 result)
+ (let ((ccc (ucd-ccc-value char)))
+ (and (or (fix:= ccc 0) (fix:>= ccc last-ccc))
+ (case (ucd-nfc_qc-value char)
+ ((yes) (loop (fix:+ i 1) ccc result))
+ ((maybe) (loop (fix:+ i 1) ccc 'maybe))
+ (else #f))))))
+ result)))))
+ (case (ustring-cp-size string)
+ ((1) #t)
+ ((2) (scan ustring2-ref))
+ (else (scan ustring3-ref)))))
+
+(define (string-in-nfd? string)
+ (cond ((legacy-string? string)
+ (ustring-nfd-qc? string 0 (ustring-length string)))
+ ((ustring? string)
+ (or (ustring-in-nfd? string)
+ (ustring-nfd-qc? string 0 (ustring-length string))))
+ ((slice? string)
+ (unpack-slice string ustring-nfd-qc?))
+ (else
+ (error:not-a string? string 'string-in-nfd?))))
+
+(define (ustring-nfd-qc? string start end)
+ (let ((scan
+ (lambda (sref)
+ (let loop ((i start) (last-ccc 0))
+ (if (fix:< i end)
+ (let ((char (sref string i)))
+ (if (fix:< (char->integer char) #xC0)
+ (loop (fix:+ i 1) 0)
+ (let ((ccc (ucd-ccc-value char)))
+ (and (or (fix:= ccc 0) (fix:>= ccc last-ccc))
+ (char-nfd-quick-check? char)
+ (loop (fix:+ i 1) ccc)))))
+ #t)))))
+ (case (ustring-cp-size string)
+ ((1) (scan ustring1-ref))
+ ((2) (scan ustring2-ref))
+ (else (scan ustring3-ref)))))
+
+(define (string->nfd string)
+ (if (string-in-nfd? string)
+ (let ((result (%string->immutable string)))
+ (ustring-in-nfd! result #t)
+ result)
+ (canonical-decomposition&ordering string
+ (lambda (string* n max-cp)
+ (let ((result (immutable-ustring-allocate n max-cp)))
+ (%general-copy! result 0 string* 0 n)
+ (ustring-in-nfd! result #t)
+ result)))))
+
+(define (canonical-decomposition&ordering string k)
+ (let ((end (string-length string))
+ (builder (string-builder)))
+ (do ((i 0 (fix:+ i 1)))
+ ((not (fix:< i end)))
+ (let loop ((char (string-ref string i)))
+ (if (jamo-precomposed? char)
+ (jamo-decompose char builder)
+ (let ((dm (ucd-canonical-dm-value char)))
+ (cond ((eqv? dm char)
+ (builder char))
+ ;; Canonical decomposition always length 1 or 2.
+ ;; First char might need recursion, second doesn't:
+ ((char? dm)
+ (loop dm))
+ (else
+ (loop (string-ref dm 0))
+ (builder (string-ref dm 1))))))))
+ (let* ((string (builder 'mutable))
+ (end (ustring-length string)))
+
+ (define (scan-for-non-starter i)
+ (if (fix:< i end)
+ (let ((ccc (ucd-ccc-value (ustring3-ref string i))))
+ (if (fix:= 0 ccc)
+ (scan-for-non-starter (fix:+ i 1))
+ (scan-for-non-starter-pair (list ccc) (fix:+ i 1))))))
+
+ (define (scan-for-non-starter-pair previous i)
+ (if (fix:< i end)
+ (let ((ccc (ucd-ccc-value (ustring3-ref string i))))
+ (if (fix:= 0 ccc)
+ (scan-for-non-starter (fix:+ i 1))
+ (scan-for-non-starter-pair (maybe-twiddle previous i ccc)
+ (fix:+ i 1))))))
+
+ (define (maybe-twiddle previous i ccc)
+ (if (and (pair? previous)
+ (fix:< ccc (car previous)))
+ (begin
+ (let ((char (ustring3-ref string (fix:- i 1))))
+ (ustring3-set! string (fix:- i 1) (ustring3-ref string i))
+ (ustring3-set! string i char))
+ (cons (car previous)
+ (maybe-twiddle (cdr previous) (fix:- i 1) ccc)))
+ (cons ccc previous)))
+
+ (scan-for-non-starter 0)
+ (k string end (builder 'max-cp)))))
+
+(define (canonical-composition string)
+ (let ((end (string-length string))
+ (builder (string-builder))
+ (sk ucd-canonical-cm-second-keys)
+ (sv ucd-canonical-cm-second-values))
+
+ (define (scan-for-first-char i)
+ (if (fix:< i end)
+ (let ((fc (string-ref string i)))
+ (if (and (jamo-leading? fc)
+ (fix:< (fix:+ i 1) end)
+ (jamo-vowel? (string-ref string (fix:+ i 1))))
+ (if (and (fix:< (fix:+ i 2) end)
+ (jamo-trailing? (string-ref string (fix:+ i 2))))
+ (begin
+ (builder
+ (jamo-compose fc
+ (string-ref string (fix:+ i 1))
+ (string-ref string (fix:+ i 2))))
+ (scan-for-first-char (fix:+ i 3)))
+ (begin
+ (builder
+ (jamo-compose fc
+ (string-ref string (fix:+ i 1))
+ #f))
+ (scan-for-first-char (fix:+ i 2))))
+ (test-first-char (fix:+ i 1) fc)))))
+
+ (define (test-first-char i+1 fc)
+ (let ((fc-index (and (fix:< i+1 end) (ucd-canonical-cm-value fc))))
+ (if fc-index
+ (let ((combiners (get-combiners i+1)))
+ (if (pair? combiners)
+ (let ((j (fix:+ i+1 (length combiners))))
+ (scan-combiners fc fc-index combiners)
+ (scan-for-first-char j))
+ (let ((fc* (match-second fc-index (string-ref string i+1))))
+ (if fc*
+ (test-first-char (fix:+ i+1 1) fc*)
+ (begin
+ (builder fc)
+ (scan-for-first-char i+1))))))
+ (begin
+ (builder fc)
+ (scan-for-first-char i+1)))))
+
+ (define (get-combiners j)
+ (if (fix:< j end)
+ (let* ((char (string-ref string j))
+ (ccc (ucd-ccc-value char)))
+ (if (fix:= 0 ccc)
+ '()
+ (cons (cons char ccc) (get-combiners (fix:+ j 1)))))
+ '()))
+
+ (define (scan-combiners fc fc-index combiners)
+ (let loop ((cs combiners) (last-ccc 0))
+ (if (pair? cs)
+ (let* ((c (car cs))
+ (fc*
+ (and (fix:> (cdr c) last-ccc)
+ (match-second fc-index (car c)))))
+ (if fc*
+ (let ((fc-index* (ucd-canonical-cm-value fc*))
+ (combiners* (remove-combiner! c combiners)))
+ (if fc-index*
+ (scan-combiners fc* fc-index* combiners*)
+ (done-matching fc* combiners*)))
+ (loop (cdr cs) (cdr c))))
+ (done-matching fc combiners))))
+
+ (define (remove-combiner! combiner combiners)
+ (if (eq? combiner (car combiners))
+ (cdr combiners)
+ (begin
+ (let loop ((this (cdr combiners)) (prev combiners))
+ (if (eq? combiner (car this))
+ (set-cdr! prev (cdr this))
+ (loop (cdr this) this)))
+ combiners)))
+
+ (define (done-matching fc combiners)
+ (builder fc)
+ (for-each (lambda (combiner) (builder (car combiner)))
+ combiners))
+
+ (define (match-second fc-index sc)
+ (let ((keys (vector-ref sk fc-index)))
+ (let loop ((start 0) (end (string-length keys)))
+ (and (fix:< start end)
+ (let ((m (fix:quotient (fix:+ start end) 2)))
+ (let ((key (string-ref keys m)))
+ (cond ((char<? sc key) (loop start m))
+ ((char<? key sc) (loop (fix:+ m 1) end))
+ (else (string-ref (vector-ref sv fc-index) m)))))))))
+
+ (scan-for-first-char 0)
+ (builder 'immutable)))
+
+(define-integrable jamo-leading-start #x1100)
+(define-integrable jamo-leading-end #x1113)
+(define-integrable jamo-vowel-start #x1161)
+(define-integrable jamo-vowel-end #x1176)
+(define-integrable jamo-trailing-start #x11A8)
+(define-integrable jamo-trailing-end #x11C3)
+(define-integrable jamo-precomposed-start #xAC00)
+(define-integrable jamo-precomposed-end #xD7A4)
+
+(define-integrable jamo-vowel-size
+ (fix:- jamo-vowel-end jamo-vowel-start))
+
+(define-integrable jamo-trailing-size
+ (fix:- jamo-trailing-end jamo-trailing-start))
+
+(define-integrable jamo-tbase (fix:- jamo-trailing-start 1))
+
+;;; These can be integrable after 9.3 is released.
+;;; Otherwise they trip a bug in the 9.2 compiler.
+(define jamo-tcount (fix:+ jamo-trailing-size 1))
+(define jamo-ncount (fix:* jamo-vowel-size jamo-tcount))
+
+(define (jamo-leading? char)
+ (and (fix:>= (char->integer char) jamo-leading-start)
+ (fix:< (char->integer char) jamo-leading-end)))
+
+(define (jamo-vowel? char)
+ (and (fix:>= (char->integer char) jamo-vowel-start)
+ (fix:< (char->integer char) jamo-vowel-end)))
+
+(define (jamo-trailing? char)
+ (and (fix:>= (char->integer char) jamo-trailing-start)
+ (fix:< (char->integer char) jamo-trailing-end)))
+
+(define (jamo-precomposed? char)
+ (and (fix:>= (char->integer char) jamo-precomposed-start)
+ (fix:< (char->integer char) jamo-precomposed-end)))
+
+(define (jamo-decompose precomposed builder)
+ (let ((pi (fix:- (char->integer precomposed) jamo-precomposed-start)))
+ (builder
+ (integer->char (fix:+ jamo-leading-start (fix:quotient pi jamo-ncount))))
+ (builder
+ (integer->char
+ (fix:+ jamo-vowel-start
+ (fix:quotient (fix:remainder pi jamo-ncount) jamo-tcount))))
+ (let ((ti (fix:remainder pi jamo-tcount)))
+ (if (fix:> ti 0)
+ (builder (integer->char (fix:+ jamo-tbase ti)))))))
+
+(define (jamo-compose leading vowel trailing)
+ (integer->char
+ (fix:+ jamo-precomposed-start
+ (fix:+ (fix:+ (fix:* (fix:- (char->integer leading)
+ jamo-leading-start)
+ jamo-ncount)
+ (fix:* (fix:- (char->integer vowel)
+ jamo-vowel-start)
+ jamo-tcount))
+ (if trailing
+ (fix:- (char->integer trailing) jamo-tbase)
+ 0)))))
+
+;;;; Grapheme clusters
+
+(define (grapheme-cluster-length string)
+ (let ((breaks
+ (find-grapheme-cluster-breaks string
+ 0
+ (lambda (i count)
+ (declare (ignore i))
+ (fix:+ count 1)))))
+ (if (fix:> breaks 0)
+ (fix:- breaks 1)
+ breaks)))
+
+(define (grapheme-cluster-slice string start end)
+ ;; START and END refer to the cluster breaks, they must be <= the number of
+ ;; clusters in STRING.
+ (guarantee index-fixnum? start 'grapheme-cluster-slice)
+ (guarantee index-fixnum? end 'grapheme-cluster-slice)
+ (if (not (fix:<= start end))
+ (error:bad-range-argument start 'grapheme-cluster-slice))
+ (let ((start-index #f)
+ (end-index #f))
+ (find-grapheme-cluster-breaks string
+ 0
+ (lambda (index count)
+ (if (fix:= count start)
+ (set! start-index index))
+ (if (fix:= count end)
+ (set! end-index index))
+ (fix:+ count 1)))
+ (if (not start-index)
+ (error:bad-range-argument start 'grapheme-cluster-slice))
+ (if (not end-index)
+ (error:bad-range-argument end 'grapheme-cluster-slice))
+ (string-slice string start-index end-index)))
+
+(define (grapheme-cluster-breaks string)
+ (reverse! (find-grapheme-cluster-breaks string '() cons)))
+
+(define (find-grapheme-cluster-breaks string initial-ctx break)
+ (let ((n (string-length string)))
+
+ (define (get-gcb i)
+ (ucd-gcb-value (string-ref string i)))
+
+ (define (transition gcb i ctx)
+ (let ((i* (fix:+ i 1)))
+ (if (fix:< i* n)
+ ((vector-ref gcb-states gcb)
+ (get-gcb i*)
+ (lambda (gcb* break?)
+ (transition gcb* i* (if break? (break i* ctx) ctx))))
+ (break n ctx))))
+
+ (if (fix:> n 0)
+ (transition (get-gcb 0) 0 (break 0 initial-ctx))
+ initial-ctx)))
+
+(define gcb-names
+ '#(control
+ carriage-return
+ emoji-base
+ emoji-base-gaz
+ emoji-modifier
+ extend
+ glue-after-zwj
+ hst=l
+ linefeed
+ hst=lv
+ hst=lvt
+ prepend
+ regional-indicator
+ spacing-mark
+ hst=t
+ hst=v
+ other
+ zwj))
+
+(define (name->code namev name)
+ (let ((end (vector-length namev)))
+ (let loop ((code 0))
+ (if (not (fix:< code end))
+ (error "Unknown name:" name))
+ (if (eq? (vector-ref namev code) name)
+ code
+ (loop (fix:+ code 1))))))
+
+(define (make-!selector namev names)
+ (let loop
+ ((names names)
+ (mask (fix:- (fix:lsh 1 (vector-length namev)) 1)))
+ (if (pair? names)
+ (loop (cdr names)
+ (fix:andc mask (fix:lsh 1 (name->code namev (car names)))))
+ (lambda (code)
+ (not (fix:= 0 (fix:and mask (fix:lsh 1 code))))))))
+
+(define (make-selector namev names)
+ (let loop
+ ((names names)
+ (mask 0))
+ (if (pair? names)
+ (loop (cdr names)
+ (fix:or mask (fix:lsh 1 (name->code namev (car names)))))
+ (lambda (code)
+ (not (fix:= 0 (fix:and mask (fix:lsh 1 code))))))))
+
+(define gcb-states
+ (let ((simple-state
+ (lambda (break?)
+ (lambda (gcb k)
+ (k gcb (break? gcb)))))
+ (gcb-code
+ (lambda (name)
+ (name->code gcb-names name)))
+ (make-no-breaks
+ (lambda (names)
+ (make-!selector gcb-names names)))
+ (make-breaks
+ (lambda (names)
+ (make-selector gcb-names names))))
+ (let ((state:control (simple-state (make-no-breaks '())))
+ (state:emoji-base
+ (let ((gcb:extend (gcb-code 'extend))
+ (gcb:emoji-base (gcb-code 'emoji-base))
+ (break?
+ (make-no-breaks '(emoji-modifier extend spacing-mark zwj))))
+ (lambda (gcb k)
+ (if (fix:= gcb gcb:extend)
+ (k gcb:emoji-base #f)
+ (k gcb (break? gcb))))))
+ (state:extend
+ (simple-state (make-no-breaks '(extend spacing-mark zwj))))
+ (state:hst=v
+ (simple-state
+ (make-no-breaks '(hst=t hst=v extend spacing-mark zwj))))
+ (state:hst=t
+ (simple-state (make-no-breaks '(hst=t extend spacing-mark zwj)))))
+ (vector state:control
+ (simple-state (make-no-breaks '(linefeed)))
+ state:emoji-base
+ state:emoji-base
+ state:extend
+ state:extend
+ state:extend
+ (simple-state
+ (make-no-breaks
+ '(hst=l hst=lv hst=lvt hst=v extend spacing-mark zwj)))
+ state:control
+ state:hst=v
+ state:hst=t
+ (simple-state (make-breaks '(control carriage-return linefeed)))
+ (let ((gcb:regional-indicator (gcb-code 'regional-indicator))
+ (gcb:extend (gcb-code 'extend))
+ (break? (make-no-breaks '(extend spacing-mark zwj))))
+ (lambda (gcb k)
+ (let ((gcb
+ (if (fix:= gcb gcb:regional-indicator)
+ gcb:extend
+ gcb)))
+ (k gcb (break? gcb)))))
+ state:extend
+ state:hst=t
+ state:hst=v
+ state:extend
+ (simple-state
+ (make-no-breaks
+ '(emoji-base-gaz glue-after-zwj extend spacing-mark zwj)))))))
+
+;;;; Word breaks
+
+(define (string-word-breaks string)
+ (reverse! (find-word-breaks string '() cons)))
+
+(define (find-word-breaks string initial-ctx break)
+ (let ((n (string-length string)))
+
+ (define (get-wb i)
+ (ucd-wb-value (string-ref string i)))
+
+ (define (t1 wb0 i0 ctx)
+ (if (select:breaker wb0)
+ (t1-breaker wb0 i0 ctx)
+ (t1-!breaker wb0 i0 ctx)))
+
+ (define (t1-breaker wb0 i0 ctx)
+ (let ((i1 (fix:+ i0 1)))
+ (if (fix:< i1 n)
+ (let ((wb1 (get-wb i1)))
+ ((vector-ref wb-states wb0)
+ wb1
+ #f
+ (lambda (wb1* break?)
+ (t1 wb1* i1 (if break? (break i1 ctx) ctx)))
+ k2-none))
+ ctx)))
+
+ (define (t1-!breaker wb0 i0 ctx)
+ (let ((i1 (fix:+ i0 1)))
+ (if (fix:< i1 n)
+ (let ((wb1 (get-wb i1)))
+ (cond ((select:extender wb1)
+ (t1-!breaker (if (select:zwj wb0) wb1 wb0) i1 ctx))
+ ((select:breaker wb1)
+ (t1-breaker wb1 i1 (break i1 ctx)))
+ (else
+ (t2 wb0 wb1 i1 ctx))))
+ ctx)))
+
+ (define (t2 wb0 wb1 i1 ctx)
+ (let find-i2 ((i2 (fix:+ i1 1)))
+ (if (fix:< i2 n)
+ (let ((wb2 (get-wb i2)))
+ (if (select:extender wb2)
+ (find-i2 (fix:+ i2 1))
+ ((vector-ref wb-states wb0)
+ wb1
+ wb2
+ (lambda (wb1* break?)
+ (t2 wb1* wb2 i2 (if break? (break i1 ctx) ctx)))
+ (lambda ()
+ (t1 wb2 i2 ctx)))))
+ ((vector-ref wb-states wb0)
+ wb1
+ #f
+ (lambda (wb1* break?)
+ (declare (ignore wb1*))
+ (if break? (break i1 ctx) ctx))
+ k2-none))))
+
+ (define (k2-none)
+ (error "Should never be called"))
+
+ (if (fix:< 0 n)
+ (break n (t1 (get-wb 0) 0 (break 0 initial-ctx)))
+ initial-ctx)))
+
+(define wb-names
+ '#(carriage-return
+ double-quote
+ emoji-base
+ emoji-base-gaz
+ emoji-modifier
+ extend-num-let
+ extend
+ format
+ glue-after-zwj
+ hebrew-letter
+ katakana
+ letter
+ linefeed
+ mid-num-let
+ mid-letter
+ mid-number
+ newline
+ numeric
+ regional-indicator
+ single-quote
+ other
+ zwj))
+
+(define select:breaker
+ (make-selector wb-names '(carriage-return linefeed newline)))
+
+(define select:extender
+ (make-selector wb-names '(extend format zwj)))
+
+(define select:zwj
+ (make-selector wb-names '(zwj)))
+
+(define wb-states
+ (make-vector (vector-length wb-names)
+ (lambda (wb1 wb2 k1 k2)
+ (declare (ignore wb2 k2))
+ (k1 wb1 #t))))
+
+(let ((select:mb/ml/sq
+ (make-selector wb-names '(mid-num-let mid-letter single-quote)))
+ (select:mb/mn/sq
+ (make-selector wb-names '(mid-num-let mid-number single-quote)))
+ (select:hl/le (make-selector wb-names '(hebrew-letter letter)))
+ (select:hl (make-selector wb-names '(hebrew-letter)))
+ (select:numeric (make-selector wb-names '(numeric)))
+ (select:dq (make-selector wb-names '(double-quote)))
+ (select:ri (make-selector wb-names '(regional-indicator)))
+ (break?:hl
+ (make-!selector wb-names
+ '(extend-num-let hebrew-letter letter numeric
+ single-quote)))
+ (break?:alphanum
+ (make-!selector wb-names
+ '(extend-num-let hebrew-letter letter numeric)))
+ (wb:extend (name->code wb-names 'extend)))
+
+ (define (define-state name state)
+ (vector-set! wb-states (name->code wb-names name) state))
+
+ (for-each
+ (lambda (n.b)
+ (define-state (car n.b)
+ (let ((break? (make-!selector wb-names (cdr n.b))))
+ (lambda (wb1 wb2 k1 k2)
+ (declare (ignore wb2 k2))
+ (k1 wb1 (break? wb1))))))
+ '((carriage-return linefeed)
+ (emoji-base emoji-modifier)
+ (emoji-base-gaz emoji-modifier)
+ (katakana extend-num-let katakana)
+ (zwj emoji-base-gaz glue-after-zwj)
+ (extend-num-let extend-num-let hebrew-letter katakana letter numeric)))
+
+ (define-state 'hebrew-letter
+ (lambda (wb1 wb2 k1 k2)
+ (if (and wb2
+ (or (and (select:mb/ml/sq wb1)
+ (select:hl/le wb2))
+ (and (select:dq wb1)
+ (select:hl wb2))))
+ (k2)
+ (k1 wb1 (break?:hl wb1)))))
+
+ (define-state 'letter
+ (lambda (wb1 wb2 k1 k2)
+ (if (and wb2
+ (select:mb/ml/sq wb1)
+ (select:hl/le wb2))
+ (k2)
+ (k1 wb1 (break?:alphanum wb1)))))
+
+ (define-state 'numeric
+ (lambda (wb1 wb2 k1 k2)
+ (if (and wb2
+ (select:mb/mn/sq wb1)
+ (select:numeric wb2))
+ (k2)
+ (k1 wb1 (break?:alphanum wb1)))))
+
+ (define-state 'regional-indicator
+ (let ()
+ (lambda (wb1 wb2 k1 k2)
+ (declare (ignore wb2 k2))
+ (if (select:ri wb1)
+ (k1 wb:extend #f)
+ (k1 wb1 #t))))))
+
+;;;; Naive search algorithm
+
+(define (naive-search-forward pattern pend text tstart tend)
+ (let ((tlast (fix:- tend pend)))
+ (let find-match ((tindex tstart))
+ (and (fix:<= tindex tlast)
+ (let match ((pi 0) (ti tindex))
+ (if (fix:< pi pend)
+ (if (char=? (string-ref pattern pi)
+ (string-ref text ti))
+ (match (fix:+ pi 1) (fix:+ ti 1))
+ (find-match (fix:+ tindex 1)))
+ tindex))))))
+
+(define (naive-search-backward pattern pend text tstart tend)
+ (let ((tlast (fix:- tend pend)))
+ (let find-match ((tindex tlast))
+ (and (fix:>= tindex tstart)
+ (let match ((pi 0) (ti tindex))
+ (if (fix:< pi pend)
+ (if (char=? (string-ref pattern pi)
+ (string-ref text ti))
+ (match (fix:+ pi 1) (fix:+ ti 1))
+ (find-match (fix:- tindex 1)))
+ ti))))))
+
+(define (naive-search-all pattern pend text tstart tend)
+ (let ((tlast (fix:- tend pend)))
+ (let find-match ((tindex tlast) (matches '()))
+ (if (fix:>= tindex tstart)
+ (find-match (fix:- tindex 1)
+ (let match ((pi 0) (ti tindex))
+ (if (fix:< pi pend)
+ (if (char=? (string-ref pattern pi)
+ (string-ref text ti))
+ (match (fix:+ pi 1) (fix:+ ti 1))
+ matches)
+ (cons tindex matches))))
+ matches))))
+
+;;; Knuth-Morris-Pratt algorithm
+
+;;; Donald E. Knuth, James H. Morris, Jr., and Vaughan R. Pratt. Fast pattern
+;;; matching in strings. SIAM Journal on Computing, 6(2):323â350, 1977.
+
+;;; Thomas H. Cormen, Charles E. Leiserson, Ronald L. Rivest, and Clifford
+;;; Stein, "Introduction to Algorithms, third edition" (Cambridge: The MIT
+;;; Press, 2009), section 32.4.
+
+(define (kmp-search-forward pattern pend text tstart tend)
+ (receive (pi new-prefix) (kmp-prefix-function pattern pend)
+ (let loop ((i tstart) (n-matched 0))
+ (and (fix:< i tend)
+ (let ((n-matched (new-prefix (string-ref text i) n-matched)))
+ (if (fix:< n-matched pend)
+ (loop (fix:+ i 1) n-matched)
+ (fix:- i (fix:- pend 1))))))))
+
+(define (kmp-search-all pattern pend text tstart tend)
+ (receive (pi new-prefix) (kmp-prefix-function pattern pend)
+ (let loop ((i tstart) (n-matched 0) (matches '()))
+ (if (fix:< i tend)
+ (let ((n-matched (new-prefix (string-ref text i) n-matched)))
+ (if (fix:< n-matched pend)
+ (loop (fix:+ i 1) n-matched matches)
+ (loop (fix:+ i 1)
+ (vector-ref pi (fix:- n-matched 1))
+ (cons (fix:- i (fix:- pend 1)) matches))))
+ (reverse matches)))))
+
+(define (kmp-prefix-function pattern pend)
+ (let ((pi (make-vector pend)))
+
+ (define (compute-pi q k)
+ (vector-set! pi q k)
+ (let ((q (fix:+ q 1)))
+ (if (fix:< q pend)
+ (compute-pi q (new-prefix (string-ref pattern q) k)))))
+
+ (define (new-prefix char n-matched)
+ (let loop ((n-matched n-matched))
+ (cond ((char=? (string-ref pattern n-matched) char) (fix:+ n-matched 1))
+ ((fix:> n-matched 0) (loop (vector-ref pi (fix:- n-matched 1))))
+ (else 0))))
+
+ (compute-pi 0 0)
+ (values pi new-prefix)))
+
+;;;; Search top level
+
+(define-integrable (string-matcher caller naive kmp)
+ (lambda (pattern text #!optional start end)
+ (guarantee nfc-string? pattern caller)
+ (guarantee nfc-string? text caller)
+ (let ((pend (string-length pattern)))
+ (if (fix:= 0 pend)
+ (error:bad-range-argument pend caller))
+ (let* ((tend (fix:end-index end (string-length text) caller))
+ (tstart (fix:start-index start end caller)))
+ (if (fix:< pend kmp-pattern-min)
+ (naive pattern pend text tstart tend)
+ (kmp pattern pend text tstart tend))))))
+
+(define-integrable kmp-pattern-min 8)
+
+(define string-search-forward
+ (string-matcher 'string-search-forward
+ naive-search-forward
+ kmp-search-forward))
+
+(define string-search-backward
+ (string-matcher 'string-search-backward
+ naive-search-backward
+ naive-search-backward))
+
+(define string-search-all
+ (string-matcher 'string-search-all
+ naive-search-all
+ kmp-search-all))
+
+(define (substring? pattern text)
+ (and (or (fix:= 0 (string-length pattern))
+ (string-search-forward (string->nfc pattern) (string->nfc text)))
+ #t))
+
+;;;; Sequence converters
+
+(define (list->string chars)
+ (let ((builder (string-builder)))
+ (for-each (lambda (char)
+ (guarantee bitless-char? char 'list->string)
+ (builder char))
+ chars)
+ (builder 'immutable)))
+
+(define (string->list string #!optional start end)
+ (let* ((end (fix:end-index end (string-length string) 'string->list))
+ (start (fix:start-index start end 'string->list)))
+ (translate-slice string start end
+ (lambda (string start end)
+
+ (define-integrable (%string->list sref)
+ (do ((i (fix:- end 1) (fix:- i 1))
+ (chars '() (cons (sref string i) chars)))
+ ((not (fix:>= i start)) chars)))
+
+ (case (ustring-cp-size string)
+ ((1) (%string->list ustring1-ref))
+ ((2) (%string->list ustring2-ref))
+ (else (%string->list ustring3-ref)))))))
+
+(define (vector->string vector #!optional start end)
+ (let* ((end (fix:end-index end (vector-length vector) 'vector->string))
+ (start (fix:start-index start end 'vector->string))
+ (builder (string-builder)))
+ (do ((i start (fix:+ i 1)))
+ ((not (fix:< i end)))
+ (let ((char (vector-ref vector i)))
+ (guarantee bitless-char? char 'vector->string)
+ (builder char)))
+ (builder 'immutable)))
+
+(define (string->vector string #!optional start end)
+ (let* ((end (fix:end-index end (string-length string) 'string->vector))
+ (start (fix:start-index start end 'string->vector)))
+ (translate-slice string start end
+ (lambda (string start end)
+ (let ((to (make-vector (fix:- end start))))
+ (do ((i start (fix:+ i 1))
+ (j 0 (fix:+ j 1)))
+ ((not (fix:< i end)))
+ (vector-set! to j (ustring-ref string i)))
+ to)))))
+
+;;;; Append
+
+(define (string-append . strings)
+ (string-append* strings))
+
+(define (string-append* strings)
+ (let ((builder (string-builder)))
+ (for-each (lambda (string)
+ (guarantee string? string 'string-append)
+ (builder string))
+ strings)
+ (builder)))
+
+(define (string . objects)
+ (string* objects))
+
+(define (string* objects)
+ (let ((builder (string-builder)))
+ (for-each (lambda (object)
+ (if object
+ (builder
+ (cond ((bitless-char? object) object)
+ ((string? object) object)
+ ;; Needed during boot load:
+ ((symbol? object) (symbol->string object))
+ (else
+ (call-with-output-string
+ (lambda (port)
+ (display object port))))))))
+ objects)
+ (builder)))
+
+;;;; Mapping
+
+(define (mapper-values proc string strings)
+ (cond ((null? strings)
+ (values (string-length string)
+ (lambda (i)
+ (proc (string-ref string i)))))
+ ((null? (cdr strings))
+ (let* ((string2 (car strings))
+ (n (fix:min (string-length string)
+ (string-length string2))))
+ (values n
+ (lambda (i)
+ (proc (string-ref string i)
+ (string-ref string2 i))))))
+ (else
+ (let ((n (min-length string-length string strings)))
+ (values n
+ (lambda (i)
+ (apply proc
+ (string-ref string i)
+ (map (lambda (string)
+ (string-ref string i))
+ strings))))))))
+
+(define (min-length string-length string strings)
+ (do ((strings strings (cdr strings))
+ (n (string-length string)
+ (fix:min n (string-length (car strings)))))
+ ((null? strings) n)))
+
+(define (string-for-each proc string . strings)
+ (receive (n proc) (mapper-values proc string strings)
+ (do ((i 0 (fix:+ i 1)))
+ ((not (fix:< i n)))
+ (proc i))))
+
+(define (string-map proc string . strings)
+ (receive (n proc) (mapper-values proc string strings)
+ (let ((builder (string-builder)))
+ (do ((i 0 (fix:+ i 1)))
+ ((not (fix:< i n)))
+ (builder (proc i)))
+ (builder))))
+
+(define (string-count proc string . strings)
+ (receive (n proc) (mapper-values proc string strings)
+ (let loop ((i 0) (count 0))
+ (if (fix:< i n)
+ (loop (fix:+ i 1)
+ (if (proc i)
+ (fix:+ count 1)
+ count))
+ count))))
+
+(define (string-any proc string . strings)
+ (receive (n proc) (mapper-values proc string strings)
+ (let loop ((i 0))
+ (and (fix:< i n)
+ (if (proc i)
+ #t
+ (loop (fix:+ i 1)))))))
+
+(define (string-every proc string . strings)
+ (receive (n proc) (mapper-values proc string strings)
+ (let loop ((i 0))
+ (if (fix:< i n)
+ (and (proc i)
+ (loop (fix:+ i 1)))
+ #t))))
+
+(define (string-find-first-index proc string . strings)
+ (guarantee nfc-string? string 'string-find-first-index)
+ (guarantee-list-of nfc-string? strings 'string-find-first-index)
+ (receive (n proc) (mapper-values proc string strings)
+ (let loop ((i 0))
+ (and (fix:< i n)
+ (if (proc i)
+ i
+ (loop (fix:+ i 1)))))))
+
+(define (string-find-last-index proc string . strings)
+ (guarantee nfc-string? string 'string-find-last-index)
+ (guarantee-list-of nfc-string? strings 'string-find-last-index)
+ (receive (n proc) (mapper-values proc string strings)
+ (let loop ((i (fix:- n 1)))
+ (and (fix:>= i 0)
+ (if (proc i)
+ i
+ (loop (fix:- i 1)))))))
+
+;;;; Joiner
+
+(define (string-joiner . options)
+ (let ((joiner (%string-joiner options 'string-joiner)))
+ (lambda strings
+ (joiner strings))))
+
+(define (string-joiner* . options)
+ (%string-joiner options 'string-joiner*))
+
+(define (%string-joiner options caller)
+ (receive (infix prefix suffix) (string-joiner-options options caller)
+ (let ((infix (string-append suffix infix prefix)))
+ (lambda (strings)
+ (if (pair? strings)
+ (let ((builder (string-builder)))
+ (builder prefix)
+ (builder (car strings))
+ (for-each (lambda (string)
+ (builder infix)
+ (builder string))
+ (cdr strings))
+ (builder suffix)
+ (builder))
+ "")))))
+
+(define-deferred string-joiner-options
+ (keyword-option-parser
+ (list (list 'infix string? "")
+ (list 'prefix string? "")
+ (list 'suffix string? ""))))
+
+;;;; Splitter
+
+(define (string-splitter . options)
+ (receive (delimiter allow-runs? copy?)
+ (string-splitter-options options 'string-splitter)
+ (let ((predicate (char-matcher->predicate delimiter 'string-splitter))
+ (get-part (if copy? substring string-slice)))
+
+ (lambda (string #!optional start end)
+ (let* ((end (fix:end-index end (string-length string) 'string-splitter))
+ (start (fix:start-index start end 'string-splitter)))
+
+ (define (find-start start)
+ (if allow-runs?
+ (let loop ((index start))
+ (if (fix:< index end)
+ (if (predicate (string-ref string index))
+ (loop (fix:+ index 1))
+ (find-end index (fix:+ index 1)))
+ '()))
+ (find-end start start)))
+
+ (define (find-end start index)
+ (let loop ((index index))
+ (if (fix:< index end)
+ (if (predicate (string-ref string index))
+ (cons (get-part string start index)
+ (find-start (fix:+ index 1)))
+ (loop (fix:+ index 1)))
+ (list (get-part string start end)))))
+
+ (find-start start))))))
+
+(define-deferred string-splitter-options
+ (keyword-option-parser
+ (list (list 'delimiter char-matcher? char-whitespace?)
+ (list 'allow-runs? boolean? #t)
+ (list 'copy? boolean? #f))))
+
+(define (char-matcher->predicate matcher caller)
+ (cond ((char? matcher) (char=-predicate matcher))
+ ((char-set? matcher) (char-set-predicate matcher))
+ ((unary-procedure? matcher) matcher)
+ (else (error:not-a char-matcher? matcher caller))))
+
+(define (char-matcher? object)
+ (or (char? object)
+ (char-set? object)
+ (unary-procedure? object)))
+
+;;;; Trimmer/Padder
+
+(define (string-trimmer . options)
+ (receive (where to-trim copy?)
+ (string-trimmer-options options 'string-trimmer)
+ (let ((predicate (char-matcher->predicate to-trim 'string-trimmer))
+ (get-trimmed (if copy? substring string-slice)))
+ (lambda (string)
+ (let ((end (string-length string)))
+ (get-trimmed
+ string
+ (if (eq? where 'trailing)
+ 0
+ (let loop ((index 0))
+ (if (and (fix:< index end)
+ (predicate (string-ref string index)))
+ (loop (fix:+ index 1))
+ index)))
+ (if (eq? where 'leading)
+ end
+ (let loop ((index end))
+ (if (and (fix:> index 0)
+ (predicate (string-ref string (fix:- index 1))))
+ (loop (fix:- index 1))
+ index)))))))))
+
+(define-deferred string-trimmer-options
+ (keyword-option-parser
+ (list (list 'where '(leading trailing both) 'both)
+ (list 'to-trim char-matcher? char-whitespace?)
+ (list 'copy? boolean? #f))))
+
+(define (string-padder . options)
+ (receive (where fill-with clip?)
+ (string-padder-options options 'string-padder)
+ (lambda (string n)
+ (guarantee index-fixnum? n 'string-padder)
+ (let ((cluster-length (grapheme-cluster-length string)))
+ (cond ((fix:= n cluster-length)
+ string)
+ ((fix:< n cluster-length)
+ (if clip?
+ (if (eq? where 'leading)
+ (grapheme-cluster-slice string
+ (fix:- cluster-length n)
+ cluster-length)
+ (grapheme-cluster-slice string 0 n))
+ string))
+ (else
+ (let ((builder (string-builder)))
+ (if (eq? where 'trailing)
+ (builder string))
+ (do ((i cluster-length (fix:+ i 1)))
+ ((not (fix:< i n)))
+ (builder fill-with))
+ (if (eq? where 'leading)
+ (builder string))
+ (builder))))))))
+
+(define (grapheme-cluster-string? object)
+ (and (string? object)
+ (fix:= 1 (grapheme-cluster-length object))))
+
+(define-deferred string-padder-options
+ (keyword-option-parser
+ (list (list 'where '(leading trailing) 'leading)
+ (list 'fill-with grapheme-cluster-string? " ")
+ (list 'clip? boolean? #t))))
+
+;;;; Miscellaneous
+
+(define (string-fill! string char #!optional start end)
+ (guarantee mutable-string? string 'string-fill)
+ (guarantee bitless-char? char 'string-fill!)
+ (let* ((end (fix:end-index end (string-length string) 'string-fill!))
+ (start (fix:start-index start end 'string-fill!)))
+ (translate-slice string start end
+ (lambda (string start end)
+ (do ((index start (fix:+ index 1)))
+ ((not (fix:< index end)) unspecific)
+ (ustring-set! string index char))))))
+
+(define (string-replace string char1 char2)
+ (guarantee bitless-char? char1 'string-replace)
+ (guarantee bitless-char? char2 'string-replace)
+ (string-map (lambda (char)
+ (if (char=? char char1) char2 char))
+ string))
+
+(define (string-hash string #!optional modulus)
+ (let ((string* (string-for-primitive (string->nfc string))))
+ (if (default-object? modulus)
+ ((ucode-primitive string-hash) string*)
+ ((ucode-primitive string-hash-mod) string* modulus))))
+
+(define (string-hash-ci string #!optional modulus)
+ (string-hash (string-foldcase string) modulus))
+
+(define (8-bit-string? object)
+ (and (string? object)
+ (string-8-bit? object)))
+
+(define (string-8-bit? string)
+ (unpack-slice string
+ (lambda (string start end)
+ (case (ustring-cp-size string)
+ ((1) #t)
+ ((2) (every-loop char-8-bit? ustring2-ref string start end))
+ (else (every-loop char-8-bit? ustring3-ref string start end))))))
+
+(define (string-for-primitive string)
+ (if (and (not (slice? string))
+ (let ((end (string-length string)))
+ (case (ustring-cp-size string)
+ ((1) (every-loop char-ascii? ustring1-ref string 0 end))
+ ((2) (every-loop char-ascii? ustring2-ref string 0 end))
+ (else (every-loop char-ascii? ustring3-ref string 0 end)))))
+ string
+ (string->utf8 string)))
+
+(define-integrable (every-loop proc ref string start end)
+ (let loop ((i start))
+ (if (fix:< i end)
+ (and (proc (ref string i))
+ (loop (fix:+ i 1)))
+ #t)))
+
+;;;;Backwards compatibility
+
+(define-integrable (string-find-maker finder key->predicate)
+ (lambda (string key #!optional start end)
+ (let* ((start (if (default-object? start) 0 start))
+ (index
+ (finder (key->predicate key)
+ (string-slice string start end))))
+ (and index
+ (fix:+ start index)))))
+
+(define string-find-next-char
+ (string-find-maker string-find-first-index char=-predicate))
+
+(define string-find-next-char-ci
+ (string-find-maker string-find-first-index char-ci=-predicate))
+
+(define string-find-next-char-in-set
+ (string-find-maker string-find-first-index char-set-predicate))
+
+(define string-find-previous-char
+ (string-find-maker string-find-last-index char=-predicate))
+
+(define string-find-previous-char-ci
+ (string-find-maker string-find-last-index char-ci=-predicate))
+
+(define string-find-previous-char-in-set
+ (string-find-maker string-find-last-index char-set-predicate))
+
+(define-integrable (substring-find-maker string-find)
+ (lambda (string start end key)
+ (string-find string key start end)))
+
+(define substring-find-next-char
+ (substring-find-maker string-find-next-char))
+
+(define substring-find-next-char-ci
+ (substring-find-maker string-find-next-char-ci))
+
+(define substring-find-next-char-in-set
+ (substring-find-maker string-find-next-char-in-set))
+
+(define substring-find-previous-char
+ (substring-find-maker string-find-previous-char))
+
+(define substring-find-previous-char-ci
+ (substring-find-maker string-find-previous-char-ci))
+
+(define substring-find-previous-char-in-set
+ (substring-find-maker string-find-previous-char-in-set))
+
+(define (string-move! string1 string2 start2)
+ (string-copy! string2 start2 string1))
+
+(define (substring-move! string1 start1 end1 string2 start2)
+ (string-copy! string2 start2 string1 start1 end1))
+
+(define (substring-ci<? string1 start1 end1 string2 start2 end2)
+ (string-ci<? (string-slice string1 start1 end1)
+ (string-slice string2 start2 end2)))
+
+(define (substring-ci=? string1 start1 end1 string2 start2 end2)
+ (string-ci=? (string-slice string1 start1 end1)
+ (string-slice string2 start2 end2)))
+
+(define (substring<? string1 start1 end1 string2 start2 end2)
+ (string<? (string-slice string1 start1 end1)
+ (string-slice string2 start2 end2)))
+
+(define (substring=? string1 start1 end1 string2 start2 end2)
+ (string=? (string-slice string1 start1 end1)
+ (string-slice string2 start2 end2)))
+
+(define (substring-prefix? string1 start1 end1 string2 start2 end2)
+ (string-prefix? (string-slice string1 start1 end1)
+ (string-slice string2 start2 end2)))
+
+(define (substring-prefix-ci? string1 start1 end1 string2 start2 end2)
+ (string-prefix-ci? (string-slice string1 start1 end1)
+ (string-slice string2 start2 end2)))
+
+(define (substring-suffix? string1 start1 end1 string2 start2 end2)
+ (string-suffix? (string-slice string1 start1 end1)
+ (string-slice string2 start2 end2)))
+
+(define (substring-suffix-ci? string1 start1 end1 string2 start2 end2)
+ (string-suffix-ci? (string-slice string1 start1 end1)
+ (string-slice string2 start2 end2)))
+
+(define (substring-fill! string start end char)
+ (string-fill! string char start end))
+
+(define (substring-lower-case? string start end)
+ (string-lower-case? (string-slice string start end)))
+
+(define (substring-upper-case? string start end)
+ (string-upper-case? (string-slice string start end)))
+
+(define (string-null? string)
+ (fix:= 0 (string-length string)))
+
+(define (char->string char)
+ (guarantee bitless-char? char 'char->string)
+ (let ((s (immutable-ustring-allocate 1 (char->integer char))))
+ (ustring-set! s 0 char)
+ s))
+
+(define (legacy-string-trimmer where)
+ (lambda (string #!optional char-set)
+ ((string-trimmer 'where where
+ 'copy? #t
+ 'to-trim
+ (if (default-object? char-set)
+ char-set:whitespace
+ (char-set-invert char-set)))
+ string)))
+
+(define string-trim-left (legacy-string-trimmer 'leading))
+(define string-trim-right (legacy-string-trimmer 'trailing))
+(define string-trim (legacy-string-trimmer 'both))
+
+(define (legacy-string-padder where)
+ (lambda (string n #!optional char)
+ ((string-padder 'where where
+ 'fill-with (if (default-object? char)
+ char
+ (char->string char)))
+ string n)))
+
+(define string-pad-left (legacy-string-padder 'leading))
+(define string-pad-right (legacy-string-padder 'trailing))
+
+(define (decorated-string-append prefix infix suffix strings)
+ ((string-joiner* 'prefix prefix
+ 'infix infix
+ 'suffix suffix)
+ strings))
+
+(define (burst-string string delimiter allow-runs?)
+ ((string-splitter 'delimiter delimiter
+ 'allow-runs? allow-runs?
+ 'copy? #t)
+ string))
\ No newline at end of file
diff --git a/tests/runtime/test-string-search.scm b/tests/runtime/test-string-search.scm
new file mode 100644
index 000000000..a9d9a410e
--- /dev/null
+++ b/tests/runtime/test-string-search.scm
@@ -0,0 +1,113 @@
+#| -*-Scheme-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+ 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+ 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
+ 2017 Massachusetts Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; Tests of string search
+
+(declare (usual-integrations))
+
+(define text
+ (call-with-input-file
+ (merge-pathnames "test-string-search-data"
+ (directory-pathname (current-load-pathname)))
+ (lambda (port)
+ (let ((builder (string-builder))
+ (buffer (make-string #x1000)))
+ (let loop ()
+ (let ((n (read-string! buffer port)))
+ (if (> n 0)
+ (begin
+ (builder (substring buffer 0 n))
+ (loop)))))
+ (builder 'immutable)))))
+
+(define patterns
+ '(
+ ;; occur frequently:
+ "define"
+ "mutable"
+ "ustring"
+ "immutable"
+ "lambda"
+ ;; occur near start:
+ "MIT/GNU Scheme"
+ "Software"
+ ;; occur near middle:
+ "test-first-char"
+ "ucd-canonical-cm-value"
+ ;; occur near end:
+ "decorated-string-append"
+ "burst-string"))
+
+(define (find-instances pattern)
+ (let ((pend (string-length pattern))
+ (tend (string-length text)))
+
+ (define (loop ti matches)
+ (if (fix:< ti tend)
+ (loop (fix:+ ti 1)
+ (if (match-1 0 ti)
+ (cons ti matches)
+ matches))
+ (cons pattern (reverse! matches))))
+
+ (define (match-1 pi ti)
+ (if (and (fix:< pi pend)
+ (fix:< ti tend))
+ (and (char=? (string-ref pattern pi)
+ (string-ref text ti))
+ (match-1 (fix:+ pi 1)
+ (fix:+ ti 1)))
+ #t))
+
+ (loop 0 '())))
+
+(define pattern-instances
+ (map find-instances patterns))
+
+(define-test 'search-tests
+ (map (lambda (entry)
+ (let ((pattern (car entry))
+ (indices (cdr entry)))
+ (list
+ (lambda ()
+ (with-test-properties
+ (lambda ()
+ (assert-equal (string-search-forward pattern text)
+ (car indices)))
+ 'expression `(string-search-forward ,pattern)))
+ (lambda ()
+ (with-test-properties
+ (lambda ()
+ (assert-equal (string-search-backward pattern text)
+ (last indices)))
+ 'expression `(string-search-backward ,pattern)))
+ (lambda ()
+ (with-test-properties
+ (lambda ()
+ (assert-equal (string-search-all pattern text)
+ indices))
+ 'expression `(string-search-all ,pattern))))))
+ pattern-instances))
\ No newline at end of file
--
2.25.1