(guarantee-http-headers headers caller)
(if body
(begin
- (guarantee-string body caller)
+ (guarantee string? body caller)
(let ((n (%get-content-length headers))
(m (vector-8b-length body)))
(if n
(define-guarantee simple-http-response "simple HTTP response")
(define (make-simple-http-response body)
- (guarantee-string body 'MAKE-SIMPLE-HTTP-RESPONSE)
+ (guarantee string? body 'MAKE-SIMPLE-HTTP-RESPONSE)
(%make-http-response #f 200 (http-status-description 200) '() body))
(define (http-message? object)
(error:wrong-type-argument strings "list of strings"
'WRITE-STRINGS-IN-COLUMNS))
(guarantee textual-output-port? port 'WRITE-STRINGS-IN-COLUMNS)
- (guarantee-exact-positive-integer min-minor 'WRITE-STRINGS-IN-COLUMNS)
- (guarantee-string left-margin 'WRITE-STRINGS-IN-COLUMNS)
- (guarantee-string col-sep 'WRITE-STRINGS-IN-COLUMNS)
- (guarantee-string right-margin 'WRITE-STRINGS-IN-COLUMNS)
+ (guarantee exact-positive-integer? min-minor 'WRITE-STRINGS-IN-COLUMNS)
+ (guarantee string? left-margin 'WRITE-STRINGS-IN-COLUMNS)
+ (guarantee string? col-sep 'WRITE-STRINGS-IN-COLUMNS)
+ (guarantee string? right-margin 'WRITE-STRINGS-IN-COLUMNS)
(let ((n-strings (length strings))
(max-width (output-port/x-size port))
(lm-width (string-length left-margin))
(error:wrong-type-argument strings "non-empty list of strings"
'WRITE-STRINGS-IN-PARAGRAPH))
(guarantee textual-output-port? port 'WRITE-STRINGS-IN-PARAGRAPH)
- (guarantee-exact-positive-integer width 'WRITE-STRINGS-IN-PARAGRAPH)
- (guarantee-exact-nonnegative-integer indent 'WRITE-STRINGS-IN-PARAGRAPH)
- (guarantee-exact-nonnegative-integer first 'WRITE-STRINGS-IN-PARAGRAPH)
+ (guarantee exact-positive-integer? width 'WRITE-STRINGS-IN-PARAGRAPH)
+ (guarantee exact-nonnegative-integer? indent 'WRITE-STRINGS-IN-PARAGRAPH)
+ (guarantee exact-nonnegative-integer? first 'WRITE-STRINGS-IN-PARAGRAPH)
(if (< width (+ indent first (string-length (car strings))))
(error:bad-range-argument width 'WRITE-STRINGS-IN-PARAGRAPH))
(pq-unescape-bytea string))
\f
(define (exec-pgsql-query connection query)
- (guarantee-string query 'EXEC-PGSQL-QUERY)
+ (guarantee string? query 'EXEC-PGSQL-QUERY)
(let ((result
(let ((handle (connection->handle connection)))
(make-gc-finalized-object
(files "string")
(parent (runtime))
(export () deprecated:string
- (guarantee-vector-8b guarantee-string)
- (vector-8b-length string-length)
- (vector-8b? string?)
- error:not-string
- guarantee-string
- guarantee-string-index
+ (vector-8b? legacy-string?)
+ legacy-string?
make-legacy-string
make-vector-8b
- vector-8b-fill!
- vector-8b-find-next-char
- vector-8b-find-next-char-ci
- vector-8b-find-previous-char
- vector-8b-find-previous-char-ci
+ vector-8b-length
vector-8b-ref
- vector-8b-set!)
- (export ()
- string-search-all
- string-search-backward
- string-search-forward
- substring-search-all
- substring-search-backward
- substring-search-forward
- substring?))
+ vector-8b-set!))
(define-package (runtime ustring)
(files "ustring")
(parent (runtime))
(export () deprecated:ustring
(string-hash-mod string-hash)
+ (string-search-all string-find-all-matches)
+ (string-search-forward string-find-first-match)
(substring->list string->list)
(substring-move-left! substring-move!)
(substring-move-right! substring-move!)
string-move!
string-pad-left
string-pad-right
+ string-search-backward
string-trim
string-trim-left
string-trim-right
substring-move!
substring-prefix-ci?
substring-prefix?
+ substring-search-all
+ substring-search-backward
+ substring-search-forward
substring-suffix-ci?
substring-suffix?
substring-upper-case?
string-downcase
string-every
string-fill!
+ string-find-all-matches
string-find-first-index
+ string-find-first-match
string-find-last-index
+ string-find-last-match
string-foldcase
string-for-each
string-for-primitive ;export to (runtime) after 9.3
string>=?
string>?
string?
+ substring?
vector->string)
(export (runtime predicate-metadata)
register-ustring-predicates!)
|#
-;;;; Character String Operations
+;;;; Legacy Strings
;;; package: (runtime string)
-;;; This file is designed to be compiled with type and range checking
-;;; turned off. The advertised user-visible procedures all explicitly
-;;; check their arguments.
-;;;
-;;; Many of the procedures are split into several user versions that
-;;; just validate their arguments and pass them on to an internal
-;;; version (prefixed with `%') that assumes all arguments have been
-;;; checked. This avoids repeated argument checks.
-
-(declare (usual-integrations)
- (integrate-external "char")
- (integrate-external "chrset"))
-\f
-;;;; Primitives
+(declare (usual-integrations))
(define-primitives
(string-allocate 1)
- (string-length 1)
- (string-ref 2)
- (string-set! 3)
- (string? 1)
- vector-8b-fill!
- vector-8b-find-next-char
- vector-8b-find-next-char-ci
- vector-8b-find-previous-char
- vector-8b-find-previous-char-ci
+ (legacy-string? string? 1)
+ (vector-8b-length string-length 1)
(vector-8b-ref 2)
(vector-8b-set! 3))
-;;;; Basic Operations
-
(define (make-legacy-string k #!optional char)
(let ((string (string-allocate k)))
(if (not (default-object? char))
(make-legacy-string length
(if (default-object? ascii)
ascii
- (integer->char ascii))))
-\f
-;;;; String search
-
-(define (substring? pattern text)
- (and (string-search-forward pattern text) #t))
-
-(define (string-search-forward pattern text)
- (guarantee-string pattern 'STRING-SEARCH-FORWARD)
- (guarantee-string text 'STRING-SEARCH-FORWARD)
- (%substring-search-forward text 0 (string-length text)
- pattern 0 (string-length pattern)))
-
-(define (substring-search-forward pattern text tstart tend)
- (guarantee-string pattern 'SUBSTRING-SEARCH-FORWARD)
- (guarantee-substring text tstart tend 'SUBSTRING-SEARCH-FORWARD)
- (%substring-search-forward text tstart tend
- pattern 0 (string-length pattern)))
-
-(define (string-search-backward pattern text)
- (guarantee-string pattern 'STRING-SEARCH-BACKWARD)
- (guarantee-string text 'STRING-SEARCH-BACKWARD)
- (%substring-search-backward text 0 (string-length text)
- pattern 0 (string-length pattern)))
-
-(define (substring-search-backward pattern text tstart tend)
- (guarantee-string pattern 'SUBSTRING-SEARCH-BACKWARD)
- (guarantee-substring text tstart tend 'SUBSTRING-SEARCH-BACKWARD)
- (%substring-search-backward text tstart tend
- pattern 0 (string-length pattern)))
-
-(define (string-search-all pattern text)
- (guarantee-string pattern 'STRING-SEARCH-ALL)
- (guarantee-string text 'STRING-SEARCH-ALL)
- (%substring-search-all text 0 (string-length text)
- pattern 0 (string-length pattern)))
-
-(define (substring-search-all pattern text tstart tend)
- (guarantee-string pattern 'SUBSTRING-SEARCH-ALL)
- (guarantee-substring text tstart tend 'SUBSTRING-SEARCH-ALL)
- (%substring-search-all text tstart tend
- pattern 0 (string-length pattern)))
-\f
-(define (%substring-search-forward text tstart tend pattern pstart pend)
- ;; Returns index of first matched char, or #F.
- (if (fix:< (fix:- pend pstart) 4)
- (%dumb-substring-search-forward text tstart tend pattern pstart pend)
- (%bm-substring-search-forward text tstart tend pattern pstart pend)))
-
-(define (%dumb-substring-search-forward text tstart tend pattern pstart pend)
- (if (fix:= pstart pend)
- 0
- (let* ((leader (string-ref pattern pstart))
- (plen (fix:- pend pstart))
- (tend (fix:- tend plen)))
- (let loop ((tstart tstart))
- (let ((tstart
- (let find-leader ((tstart tstart))
- (and (fix:<= tstart tend)
- (if (char=? leader (string-ref text tstart))
- tstart
- (find-leader (fix:+ tstart 1)))))))
- (and tstart
- (if (substring=? text (fix:+ tstart 1) (fix:+ tstart plen)
- pattern (fix:+ pstart 1) pend)
- tstart
- (loop (fix:+ tstart 1)))))))))
-
-(define (%substring-search-backward text tstart tend pattern pstart pend)
- ;; Returns index following last matched char, or #F.
- (if (fix:< (fix:- pend pstart) 4)
- (%dumb-substring-search-backward text tstart tend pattern pstart pend)
- (%bm-substring-search-backward text tstart tend pattern pstart pend)))
-
-(define (%dumb-substring-search-backward text tstart tend pattern pstart pend)
- (if (fix:= pstart pend)
- 0
- (let* ((pend-1 (fix:- pend 1))
- (trailer (string-ref pattern pend-1))
- (plen (fix:- pend pstart))
- (tstart+plen (fix:+ tstart plen)))
- (let loop ((tend tend))
- (let ((tend
- (let find-trailer ((tend tend))
- (and (fix:<= tstart+plen tend)
- (if (char=? trailer (string-ref text (fix:- tend 1)))
- tend
- (find-trailer (fix:- tend 1)))))))
- (and tend
- (if (substring=? text (fix:- tend plen) (fix:- tend 1)
- pattern pstart pend-1)
- tend
- (loop (fix:- tend 1)))))))))
-
-(define (%substring-search-all text tstart tend pattern pstart pend)
- (let ((plen (fix:- pend pstart)))
- (cond ((fix:= plen 1)
- (let ((c (string-ref pattern pstart)))
- (let loop ((ti tend) (occurrences '()))
- (let ((index (substring-find-previous-char text tstart ti c)))
- (if index
- (loop index (cons index occurrences))
- occurrences)))))
- #; ;This may not be worthwhile -- I have no measurements.
- ((fix:< plen 4)
- (let loop ((ti tend) (occurrences '()))
- (let ((index
- (%dumb-substring-search-backward text tstart ti
- pattern pstart pend)))
- (if index
- (loop (fix:+ index (fix:- plen 1)) (cons index occurrences))
- occurrences))))
- (else
- (%bm-substring-search-all text tstart tend pattern pstart pend)))))
-\f
-;;;; Boyer-Moore String Search
-
-;;; Cormen, Leiserson, and Rivest, "Introduction to Algorithms",
-;;; Chapter 34, "String Matching".
-
-(define (%bm-substring-search-forward text tstart tend pattern pstart pend)
- (let ((m (fix:- pend pstart))
- (pstart-1 (fix:- pstart 1))
- (pend-1 (fix:- pend 1))
- (lambda* (compute-last-occurrence-function pattern pstart pend))
- (gamma
- (compute-good-suffix-function pattern pstart pend
- (compute-gamma0 pattern pstart pend))))
- (let ((tend-m (fix:- tend m))
- (m-1 (fix:- m 1)))
- (let outer ((s tstart))
- (and (fix:<= s tend-m)
- (let inner ((pj pend-1) (tj (fix:+ s m-1)))
- (if (fix:= (vector-8b-ref pattern pj) (vector-8b-ref text tj))
- (if (fix:= pstart pj)
- s
- (inner (fix:- pj 1) (fix:- tj 1)))
- (outer
- (fix:+ s
- (fix:max (fix:- (fix:- pj pstart-1)
- (lambda* (vector-8b-ref text tj)))
- (gamma (fix:- pj pstart))))))))))))
-
-(define (%bm-substring-search-backward text tstart tend pattern pstart pend)
- (let ((m (fix:- pend pstart))
- (pend-1 (fix:- pend 1))
- (rpattern (reverse-pattern pattern pstart pend)))
- (let ((tstart+m (fix:+ tstart m))
- (lambda* (compute-last-occurrence-function rpattern 0 m))
- (gamma
- (compute-good-suffix-function rpattern 0 m
- (compute-gamma0 rpattern 0 m))))
- (let outer ((s tend))
- (and (fix:>= s tstart+m)
- (let inner ((pj pstart) (tj (fix:- s m)))
- (if (fix:= (vector-8b-ref pattern pj) (vector-8b-ref text tj))
- (if (fix:= pend-1 pj)
- s
- (inner (fix:+ pj 1) (fix:+ tj 1)))
- (outer
- (fix:- s
- (fix:max (fix:- (fix:- pend pj)
- (lambda* (vector-8b-ref text tj)))
- (gamma (fix:- pend-1 pj))))))))))))
-
-(define (%bm-substring-search-all text tstart tend pattern pstart pend)
- (let ((m (fix:- pend pstart))
- (pstart-1 (fix:- pstart 1))
- (pend-1 (fix:- pend 1))
- (lambda* (compute-last-occurrence-function pattern pstart pend))
- (gamma0 (compute-gamma0 pattern pstart pend)))
- (let ((gamma (compute-good-suffix-function pattern pstart pend gamma0))
- (tend-m (fix:- tend m))
- (m-1 (fix:- m 1)))
- (let outer ((s tstart) (occurrences '()))
- (if (fix:<= s tend-m)
- (let inner ((pj pend-1) (tj (fix:+ s m-1)))
- (if (fix:= (vector-8b-ref pattern pj) (vector-8b-ref text tj))
- (if (fix:= pstart pj)
- (outer (fix:+ s gamma0) (cons s occurrences))
- (inner (fix:- pj 1) (fix:- tj 1)))
- (outer (fix:+ s
- (fix:max (fix:- (fix:- pj pstart-1)
- (lambda*
- (vector-8b-ref text tj)))
- (gamma (fix:- pj pstart))))
- occurrences)))
- (reverse! occurrences))))))
-\f
-(define (compute-last-occurrence-function pattern pstart pend)
- (let ((lam (make-vector 256 0)))
- (do ((j pstart (fix:+ j 1)))
- ((fix:= j pend))
- (vector-set! lam
- (vector-8b-ref pattern j)
- (fix:+ (fix:- j pstart) 1)))
- (lambda (symbol)
- (vector-ref lam symbol))))
-
-(define (compute-good-suffix-function pattern pstart pend gamma0)
- (let ((m (fix:- pend pstart)))
- (let ((pi
- (compute-prefix-function (reverse-pattern pattern pstart pend)
- 0
- m))
- (gamma (make-vector m gamma0))
- (m-1 (fix:- m 1)))
- (do ((l 0 (fix:+ l 1)))
- ((fix:= l m))
- (let ((j (fix:- m-1 (vector-ref pi l)))
- (k (fix:- (fix:+ 1 l) (vector-ref pi l))))
- (if (fix:< k (vector-ref gamma j))
- (vector-set! gamma j k))))
- (lambda (index)
- (vector-ref gamma index)))))
-
-(define (compute-gamma0 pattern pstart pend)
- (let ((m (fix:- pend pstart)))
- (fix:- m
- (vector-ref (compute-prefix-function pattern pstart pend)
- (fix:- m 1)))))
-
-(define (compute-prefix-function pattern pstart pend)
- (let* ((m (fix:- pend pstart))
- (pi (make-vector m)))
- (vector-set! pi 0 0)
- (let outer ((k 0) (q 1))
- (if (fix:< q m)
- (let ((k
- (let ((pq (vector-8b-ref pattern (fix:+ pstart q))))
- (let inner ((k k))
- (cond ((fix:= pq (vector-8b-ref pattern (fix:+ pstart k)))
- (fix:+ k 1))
- ((fix:= k 0)
- k)
- (else
- (inner (vector-ref pi (fix:- k 1)))))))))
- (vector-set! pi q k)
- (outer k (fix:+ q 1)))))
- pi))
-
-(define (reverse-pattern pattern pstart pend)
- (let ((builder (string-builder)))
- (do ((i (fix:- pend 1) (fix:- i 1)))
- ((not (fix:>= i pstart)))
- (builder (string-ref pattern i)))
- (builder)))
-\f
-;;;; Guarantors
-;;
-;; The guarantors are integrated. Most are structured as combination of
-;; simple tests which the compiler can open-code, followed by a call to a
-;; GUARANTEE-.../FAIL version which does the tests again to signal a
-;; meaningful message. Structuring the code this way significantly
-;; reduces code bloat from large integrated procedures.
-
-(declare (integrate-operator guarantee-string))
-(define-guarantee string "string")
-
-(define-integrable (guarantee-string-index object caller)
- (if (not (index-fixnum? object))
- (error:wrong-type-argument object "string index" caller)))
-
-(define-integrable (guarantee-substring string start end caller)
- (if (not (and (string? string)
- (index-fixnum? start)
- (index-fixnum? end)
- (fix:<= start end)
- (fix:<= end (string-length string))))
- (guarantee-substring/fail string start end caller)))
-
-(define (guarantee-substring/fail string start end caller)
- (guarantee-string string caller)
- (guarantee-substring-end-index end (string-length string) caller)
- (guarantee-substring-start-index start end caller))
-
-(define-integrable (guarantee-substring-end-index end length caller)
- (guarantee-string-index end caller)
- (if (not (fix:<= end length))
- (error:bad-range-argument end caller))
- end)
-
-(define-integrable (guarantee-substring-start-index start end caller)
- (guarantee-string-index start caller)
- (if (not (fix:<= start end))
- (error:bad-range-argument start caller))
- start)
-
-(define-integrable (guarantee-2-substrings string1 start1 end1
- string2 start2 end2
- procedure)
- (guarantee-substring string1 start1 end1 procedure)
- (guarantee-substring string2 start2 end2 procedure))
\ No newline at end of file
+ (integer->char ascii))))
\ No newline at end of file
(register-predicate! 8-bit-string? '8-bit-string '<= string?)
(register-predicate! ->string-component? '->string-component))
\f
-;;;; Strings
+;;;; Basic operations
(define (string? object)
(or (legacy-string? object)
start
(fix:- end start))))))
\f
+;;;; Streaming build
+
(define (string-builder)
(let ((builder
(make-sequence-builder (lambda () (full-string-allocate 16))
(string-copy! result i (caar parts) 0 (cdar parts)))
result))
\f
+;;;; Copy
+
(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!)))
(loop (fix:+ i 1)))
#t))))
\f
+;;;; Normalization
+
(define (string->nfd string)
(if (or (string-ascii? string) ;ASCII unaffected by normalization
(string-in-nfd? string))
(scan-for-non-starter 0))
string)
-#|
(define (quick-check string qc-value)
(let ((n (string-length string)))
(let loop ((i 0) (last-ccc 0) (result #t))
(loop (fix:+ i 1) ccc check)
(loop (fix:+ i 1) ccc result))))))
result))))
-|#
\f
+;;;; Grapheme clusters
+
(define (grapheme-cluster-length string)
(let ((breaks
(find-grapheme-cluster-breaks string
(if (not end-index)
(error:bad-range-argument end 'grapheme-cluster-slice))
(string-slice string start-index end-index)))
-\f
-;;;; Grapheme-cluster breaks
(define (find-grapheme-cluster-breaks string initial-ctx break)
(let ((n (string-length string)))
(if (fix:> n 0)
(transition (get-gcb 0) 0 (break 0 initial-ctx))
initial-ctx)))
-
+\f
(define gcb-names
'#(control
carriage-return
(make-!selector wb-names '(emoji-base-gaz glue-after-zwj)))
)))))
\f
+;;;; Search
+
+(define-integrable (string-matcher caller matcher)
+ (lambda (pattern text)
+ (guarantee string? pattern caller)
+ (guarantee string? text caller)
+ (let ((pend (string-length pattern)))
+ (if (fix:= 0 pend)
+ (error:bad-range-argument pend caller))
+ (matcher pattern pend text (fix:- (string-length text) pend)))))
+
+(define string-find-first-match
+ (string-matcher 'string-find-first-match
+ %dumb-string-find-first-match))
+
+(define string-find-last-match
+ (string-matcher 'string-find-last-match
+ %dumb-string-find-last-match))
+
+(define string-find-all-matches
+ (string-matcher 'string-find-all-matches
+ %dumb-string-find-all-matches))
+
+(define (%dumb-string-find-first-match pattern pend text tlast)
+ (and (fix:>= tlast 0)
+ (let find-match ((tstart 0))
+ (and (fix:<= tstart tlast)
+ (let match ((pi 0) (ti tstart))
+ (if (fix:< pi pend)
+ (if (char=? (string-ref pattern pi)
+ (string-ref text ti))
+ (match (fix:+ pi 1) (fix:+ ti 1))
+ (find-match (fix:+ tstart 1)))
+ tstart))))))
+
+(define (%dumb-string-find-last-match pattern pend text tlast)
+ (and (fix:>= tlast 0)
+ (let find-match ((tstart tlast))
+ (and (fix:>= tstart 0)
+ (let match ((pi 0) (ti tstart))
+ (if (fix:< pi pend)
+ (if (char=? (string-ref pattern pi)
+ (string-ref text ti))
+ (match (fix:+ pi 1) (fix:+ ti 1))
+ (find-match (fix:- tstart 1)))
+ tstart))))))
+
+(define (%dumb-string-find-all-matches pattern pend text tlast)
+ (if (fix:>= tlast 0)
+ (let find-match ((tstart tlast) (matches '()))
+ (if (fix:>= tstart 0)
+ (find-match (fix:- tstart 1)
+ (let match ((pi 0) (ti tstart))
+ (if (fix:< pi pend)
+ (if (char=? (string-ref pattern pi)
+ (string-ref text ti))
+ (match (fix:+ pi 1) (fix:+ ti 1))
+ matches)
+ (cons tstart matches))))
+ matches))
+ '()))
+\f
+;;;; Sequence converters
+
(define (list->string chars)
(if (every char-8-bit? chars)
(let ((string (legacy-string-allocate (length chars))))
%full-string-ref string start end)
to)))))
\f
+;;;; Append and general constructor
+
(define (string-append . strings)
(%string-append* strings))
(number? object)
(uri? object)))
\f
+;;;; Mapping
+
(define (mapper-values proc string strings)
(cond ((null? strings)
(values (string-length string)
((not (fix:< i n)))
(builder (proc i)))
(builder))))
-
+\f
(define (string-count proc string . strings)
(receive (n proc) (mapper-values proc string strings)
(let loop ((i 0) (count 0))
(fix:+ count 1)
count))
count))))
-\f
+
(define (string-any proc string . strings)
(receive (n proc) (mapper-values proc string strings)
(let loop ((i 0))
(if (proc i)
i
(loop (fix:- i 1)))))))
-
-(define (string-fill! string char #!optional start end)
- (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!)))
- (receive (string start end) (translate-slice string start end)
- (if (legacy-string? string)
- (do ((index start (fix:+ index 1)))
- ((not (fix:< index end)) unspecific)
- (legacy-string-set! string index char))
- (let ((bytes (%full-string-cp-vector string))
- (cp (char->integer char)))
- (do ((i start (fix:+ i 1)))
- ((not (fix:< i end)))
- (cp-vector-set! bytes i cp)))))))
-
-(define (string-hash string #!optional modulus)
- (let ((string* (string-for-primitive string)))
- (if (default-object? modulus)
- ((ucode-primitive string-hash) string*)
- ((ucode-primitive string-hash-mod) string* modulus))))
-
-(define (string-ci-hash string #!optional modulus)
- (string-hash (string-foldcase string) modulus))
\f
+;;;; Joiner/splitter
+
(define (string-joiner infix #!optional prefix suffix)
(let ((joiner (string-joiner* prefix infix suffix)))
(lambda strings
(if (char=? char char1) char2 char))
string))
\f
+;;;; Trimmer/padder
+
(define (string-trimmer . options)
(receive (where copy? trim-char?)
(string-trimmer-options options 'string-trimmer)
(list 'fill-with grapheme-cluster-string? " ")
(list 'clip? boolean? #t))))
\f
+;;;; Miscellaneous
+
+(define (string-fill! string char #!optional start end)
+ (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!)))
+ (receive (string start end) (translate-slice string start end)
+ (if (legacy-string? string)
+ (do ((index start (fix:+ index 1)))
+ ((not (fix:< index end)) unspecific)
+ (legacy-string-set! string index char))
+ (let ((bytes (%full-string-cp-vector string))
+ (cp (char->integer char)))
+ (do ((i start (fix:+ i 1)))
+ ((not (fix:< i end)))
+ (cp-vector-set! bytes i cp)))))))
+
+(define (string-hash string #!optional modulus)
+ (let ((string* (string-for-primitive string)))
+ (if (default-object? modulus)
+ ((ucode-primitive string-hash) string*)
+ ((ucode-primitive string-hash-mod) string* modulus))))
+
+(define (string-ci-hash string #!optional modulus)
+ (string-hash (string-foldcase string) modulus))
+
(define (8-bit-string? object)
(and (string? object)
(string-8-bit? object)))
(loop (fix:+ i 1)))
#t)))
\f
+;;;;Backwards compatibility
+
(define (string-find-next-char string char)
(string-find-first-index (char=-predicate char) string))
(define substring-find-previous-char-in-set
(substring-find-maker string-find-previous-char-in-set))
+
+(define (substring? pattern text)
+ (and (or (fix:= 0 (string-length pattern))
+ (string-find-first-match pattern text))
+ #t))
+
+(define (string-search-backward pattern text)
+ (let ((index (string-find-last-match pattern text)))
+ (and index
+ (fix:+ index (string-length pattern)))))
+
+(define-integrable (substring-search-maker string-search)
+ (lambda (pattern text tstart tend)
+ (let* ((slice (string-slice text tstart tend))
+ (index (string-search pattern slice)))
+ (and index
+ (fix:+ tstart index)))))
+
+(define substring-search-forward
+ (substring-search-maker string-find-first-match))
+
+(define substring-search-backward
+ (substring-search-maker string-search-backward))
+
+(define (substring-search-all pattern text tstart tend)
+ (let ((slice (string-slice text tstart tend)))
+ (map (lambda (index)
+ (fix:+ tstart index))
+ (string-find-all-matches pattern slice))))
\f
(define (string-move! string1 string2 start2)
(string-copy! string2 start2 string1))
(reverse! strings))))
(define (http-response-header keyword datum #!optional overwrite?)
- (guarantee-symbol keyword 'HTTP-RESPONSE-HEADER)
- (guarantee-string datum 'HTTP-RESPONSE-HEADER)
+ (guarantee symbol? keyword 'HTTP-RESPONSE-HEADER)
+ (guarantee string? datum 'HTTP-RESPONSE-HEADER)
(if (memq keyword '(STATUS CONTENT-LENGTH))
(error "Illegal header keyword:" keyword))
(if (or (eq? keyword 'CONTENT-TYPE)
(maybe-set-entity *current-request* *current-response* entity))
(define (http-status-response code . extra)
- (guarantee-exact-nonnegative-integer code 'HTTP-STATUS-RESPONSE)
+ (guarantee exact-nonnegative-integer? code 'HTTP-STATUS-RESPONSE)
(status-response! *current-response* code extra))
\f
;;;; MIME stuff
'handler handler))
(define (define-url-bindings url . klist)
- (guarantee-keyword-list klist 'define-url-bindings)
+ (guarantee keyword-list? klist 'define-url-bindings)
(let* ((binding
(find-matching-item url-bindings
(lambda (binding)
(copy-memory s ptr maxlen)
(global-unlock mem)
(close-clipboard)
- (substring s 0 (vector-8b-find-next-char s 0 maxlen 0))))))
+ (string-copy s
+ 0
+ (or (string-find-first-index (char=-predicate #\null) s)
+ maxlen))))))
(define (win32-screen-width)
(get-system-metrics SM_CXSCREEN))
projects / mit-scheme.git / commitdiff