Implement string-padder; promote grapheme clusters.

* Rename count-grapheme-clusters to grapheme-cluster-length.
* Implement grapheme-cluster-slice.
* Update string-pad-X to use string-padder.

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index b4c23e9557bc379bfe4290bd4ec00210fa258d93..83cceb90a5759e84c30b19bb8f536238bab1ee75 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -977,8 +977,6 @@ USA.
          guarantee-substring
          guarantee-substring-end-index
          guarantee-substring-start-index
-         string-pad-left
-         string-pad-right
          string-search-all
          string-search-backward
          string-search-forward
@@ -1006,6 +1004,8 @@ USA.
          string-find-previous-char-ci
          string-find-previous-char-in-set
          string-move!
+         string-pad-left
+         string-pad-right
          string-trim
          string-trim-left
          string-trim-right
@@ -1029,7 +1029,8 @@ USA.
          substring=?)
   (export ()
          (substring string-copy)
-         count-grapheme-clusters
+         grapheme-cluster-length
+         grapheme-cluster-slice
          list->string
          make-string
          string
@@ -1071,6 +1072,7 @@ USA.
          string-match-forward
          string-match-forward-ci
          string-null?
+         string-padder
          string-prefix-ci?
          string-prefix?
          string-ref

diff --git a/src/runtime/string.scm b/src/runtime/string.scm
index e732548c4eea673b3ee48dfd61af3d4bd3cdb369..3b89c7b886b0155849861fe4d70e4b8292a01998 100644 (file)
--- a/src/runtime/string.scm
+++ b/src/runtime/string.scm
@@ -72,51 +72,6 @@ USA.
                          ascii
                          (integer->char ascii))))
 \f
-;;;; Pad
-
-(define (string-pad-right string n #!optional char)
-  (guarantee-string string 'STRING-PAD-RIGHT)
-  (guarantee-string-index n 'STRING-PAD-RIGHT)
-  (let ((length (string-length string)))
-    (if (fix:= length n)
-       string
-       (let ((result (string-allocate n)))
-         (if (fix:> length n)
-             (string-copy! result 0 string 0 n)
-             (begin
-               (string-copy! result 0 string 0 length)
-               (string-fill! result
-                             (if (default-object? char)
-                                 #\space
-                                 (begin
-                                   (guarantee-char char 'STRING-PAD-RIGHT)
-                                   char))
-                             length
-                             n)))
-         result))))
-
-(define (string-pad-left string n #!optional char)
-  (guarantee-string string 'STRING-PAD-LEFT)
-  (guarantee-string-index n 'STRING-PAD-LEFT)
-  (let ((length (string-length string)))
-    (if (fix:= length n)
-       string
-       (let ((result (string-allocate n))
-             (i (fix:- n length)))
-         (if (fix:< i 0)
-             (string-copy! result 0 string (fix:- 0 i) length)
-             (begin
-               (string-fill! result
-                             (if (default-object? char)
-                                 #\space
-                                 (begin
-                                   (guarantee-char char 'STRING-PAD-RIGHT)
-                                   char))
-                             0
-                             i)
-               (string-copy! result i string 0 length)))
-         result))))
-\f
 ;;;; String search
 
 (define (substring? pattern text)

diff --git a/src/runtime/ustring.scm b/src/runtime/ustring.scm
index fc4198a5d1d0d915aac749dab68fad961a58c7c3..f066bad343f186e37263ea562df3013f67d87bca 100644 (file)
--- a/src/runtime/ustring.scm
+++ b/src/runtime/ustring.scm
@@ -566,7 +566,7 @@ USA.
          result))))
 |#
 \f
-(define (count-grapheme-clusters string)
+(define (grapheme-cluster-length string)
   (let ((breaks
         (find-grapheme-cluster-breaks string
                                       0
@@ -576,6 +576,29 @@ USA.
     (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)))
 \f
 ;;;; Grapheme-cluster breaks
 
@@ -1210,14 +1233,52 @@ USA.
                     (loop (fix:- index 1))
                     index)))))))))
 
+(define (one-of values)
+  (lambda (object)
+    (memq object values)))
+
 (define-deferred string-trimmer-options
   (keyword-option-parser
-   (list (list 'where where-value? 'both)
+   (list (list 'where (one-of '(leading trailing both)) 'both)
         (list 'copy? boolean? #t)
         (list 'trim-char? unary-procedure? char-whitespace?))))
 
-(define (where-value? object)
-  (memq object '(leading trailing both)))
+(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 0 (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 (one-of '(leading trailing)) 'leading)
+        (list 'fill-with grapheme-cluster-string? " ")
+        (list 'clip? boolean? #t))))
 \f
 (define (string-8-bit? string)
   (receive (string start end) (translate-slice string 0 (string-length string))
@@ -1359,7 +1420,7 @@ USA.
             (full-string-allocate 1))))
     (string-set! s 0 char)
     s))
-
+\f
 (define (legacy-string-trimmer where)
   (lambda (string #!optional char-set)
     ((string-trimmer 'where where
@@ -1372,4 +1433,15 @@ USA.
 
 (define string-trim-left (legacy-string-trimmer 'leading))
 (define string-trim-right (legacy-string-trimmer 'trailing))
-(define string-trim (legacy-string-trimmer 'both))
\ No newline at end of file
+(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))
\ No newline at end of file