From 18c1fa1ad2564f47335f5503d8073572524880c5 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Sun, 19 Feb 2017 01:05:52 -0800 Subject: [PATCH] Move split/join code and string-null?. --- src/runtime/runtime.pkg | 12 +++---- src/runtime/string.scm | 76 ----------------------------------------- src/runtime/ustring.scm | 74 ++++++++++++++++++++++++++++++++++++++- 3 files changed, 79 insertions(+), 83 deletions(-) diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index a684b7809..5e790b85f 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -1041,10 +1041,8 @@ USA. vector-8b-set!) (export () ascii-string-copy - burst-string camel-case-string->lisp char->string - decorated-string-append guarantee-substring guarantee-substring-end-index guarantee-substring-start-index @@ -1063,14 +1061,11 @@ USA. string-compare-ci string-downcase! string-head! - string-joiner - string-joiner* string-match-backward string-match-backward-ci string-match-forward string-match-forward-ci string-maximum-length - string-null? string-pad-left string-pad-right string-replace @@ -1078,7 +1073,6 @@ USA. string-search-all string-search-backward string-search-forward - string-splitter string-trim string-trim-left string-trim-right @@ -1107,6 +1101,8 @@ USA. (substring->list string->list) (substring-move-left! substring-move!) (substring-move-right! substring-move!) + burst-string + decorated-string-append string-find-next-char string-find-next-char-ci string-find-next-char-in-set @@ -1162,14 +1158,18 @@ USA. string-for-primitive ;export to (runtime) after 9.3 string-hash string-head + string-joiner + string-joiner* string-length string-lower-case? string-map + string-null? string-prefix-ci? string-prefix? string-ref string-set! string-slice + string-splitter string-suffix-ci? string-suffix? string-tail diff --git a/src/runtime/string.scm b/src/runtime/string.scm index 4203a1769..3e0ac7a87 100644 --- a/src/runtime/string.scm +++ b/src/runtime/string.scm @@ -72,13 +72,6 @@ USA. (define (make-vector-8b length #!optional ascii) (make-string length (if (default-object? ascii) ascii (integer->char ascii)))) -(define (string-null? string) - (guarantee-string string 'STRING-NULL?) - (%string-null? string)) - -(define-integrable (%string-null? string) - (fix:= 0 (string-length string))) - (define (ascii-string-copy string) (guarantee-string string 'ASCII-STRING-COPY) (%ascii-string-copy string)) @@ -261,75 +254,6 @@ USA. (string-set! string j (string-ref string i)) (string-set! string i char))))) -(define (decorated-string-append prefix infix suffix strings) - ((string-joiner* infix prefix suffix) strings)) - -(define (string-joiner infix #!optional prefix suffix) - (let ((joiner (string-joiner* prefix infix suffix))) - (lambda strings - (joiner strings)))) - -(define (string-joiner* infix #!optional prefix suffix) - (let ((prefix (if (default-object? prefix) "" prefix)) - (suffix (if (default-object? suffix) "" suffix))) - (let ((infix (string-append suffix infix prefix))) - - (lambda (strings) - (string-append* - (if (pair? strings) - (cons* prefix - (car strings) - (let loop ((strings (cdr strings))) - (if (pair? strings) - (cons* infix - (car strings) - (loop (cdr strings))) - (list suffix)))) - '())))))) - -(define (burst-string string delimiter allow-runs?) - ((string-splitter delimiter allow-runs?) string)) - -(define (string-splitter delimiter #!optional allow-runs?) - (let ((predicate (splitter-delimiter->predicate delimiter)) - (allow-runs? (if (default-object? allow-runs?) #t allow-runs?))) - - (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 (string-copy string start index) - (find-start (fix:+ index 1))) - (loop (fix:+ index 1))) - (list (string-copy string start end))))) - - (find-start start))))) - -(define (splitter-delimiter->predicate delimiter) - (cond ((char? delimiter) (char=-predicate delimiter)) - ((char-set? delimiter) (char-set-predicate delimiter)) - ((unary-procedure? delimiter) delimiter) - (else (error:not-a splitter-delimiter? delimiter 'string-splitter)))) - -(define (splitter-delimiter? object) - (or (char? object) - (char-set? object) - (unary-procedure? object))) - (define (vector-8b->hexadecimal bytes) (define-integrable (hex-char k) (string-ref "0123456789abcdef" (fix:and k #x0F))) diff --git a/src/runtime/ustring.scm b/src/runtime/ustring.scm index e2c118f22..1068d7563 100644 --- a/src/runtime/ustring.scm +++ b/src/runtime/ustring.scm @@ -690,6 +690,75 @@ USA. (define (string-ci-hash string #!optional modulus) (string-hash (string-foldcase string) modulus)) +(define (string-joiner infix #!optional prefix suffix) + (let ((joiner (string-joiner* prefix infix suffix))) + (lambda strings + (joiner strings)))) + +(define (string-joiner* infix #!optional prefix suffix) + (let ((prefix (if (default-object? prefix) "" prefix)) + (suffix (if (default-object? suffix) "" suffix))) + (let ((infix (string-append suffix infix prefix))) + + (lambda (strings) + (string-append* + (if (pair? strings) + (cons* prefix + (car strings) + (let loop ((strings (cdr strings))) + (if (pair? strings) + (cons* infix + (car strings) + (loop (cdr strings))) + (list suffix)))) + '())))))) + +(define (string-splitter delimiter #!optional allow-runs?) + (let ((predicate (splitter-delimiter->predicate delimiter)) + (allow-runs? (if (default-object? allow-runs?) #t allow-runs?))) + + (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 (string-copy string start index) + (find-start (fix:+ index 1))) + (loop (fix:+ index 1))) + (list (string-copy string start end))))) + + (find-start start))))) + +(define (splitter-delimiter->predicate delimiter) + (cond ((char? delimiter) (char=-predicate delimiter)) + ((char-set? delimiter) (char-set-predicate delimiter)) + ((unary-procedure? delimiter) delimiter) + (else (error:not-a splitter-delimiter? delimiter 'string-splitter)))) + +(define (splitter-delimiter? object) + (or (char? object) + (char-set? object) + (unary-procedure? object))) + +(define (decorated-string-append prefix infix suffix strings) + ((string-joiner* infix prefix suffix) strings)) + +(define (burst-string string delimiter allow-runs?) + ((string-splitter delimiter allow-runs?) string)) + (define (ustring->legacy-string string) (if (legacy-string? string) string @@ -832,4 +901,7 @@ USA. (string-lower-case? (string-slice string start end))) (define (substring-upper-case? string start end) - (string-upper-case? (string-slice string start end))) \ No newline at end of file + (string-upper-case? (string-slice string start end))) + +(define (string-null? string) + (fix:= 0 (string-length string))) \ No newline at end of file -- 2.25.1