From: Chris Hanson <org/chris-hanson/cph>
Date: Mon, 18 Nov 2019 07:42:20 +0000 (-0800)
Subject: Modify string-splitter and string-trimmer to accept copier arg.
X-Git-Tag: mit-scheme-pucked-10.1.20~11^2~6
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=079d23cbd647157e809d2a639291d361740169be;p=mit-scheme.git

Modify string-splitter and string-trimmer to accept copier arg.
---

diff --git a/src/runtime/string.scm b/src/runtime/string.scm
index 5607ac22d..5e78396e2 100644
--- a/src/runtime/string.scm
+++ b/src/runtime/string.scm
@@ -1930,10 +1930,10 @@ USA.
 ;;;; Splitter
 
 (define (string-splitter . options)
-  (receive (delimiter allow-runs? copy?)
+  (receive (delimiter allow-runs? copier copy?)
       (string-splitter-options options 'string-splitter)
     (let ((predicate (char-matcher->predicate delimiter 'string-splitter))
-	  (get-part (if copy? substring string-slice)))
+	  (copier (get-copier copier copy?)))
 
       (lambda (string #!optional start end)
 	(let* ((end (fix:end-index end (string-length string) 'string-splitter))
@@ -1953,10 +1953,10 @@ USA.
 	    (let loop ((index index))
 	      (if (fix:< index end)
 		  (if (predicate (string-ref string index))
-		      (cons (get-part string start index)
+		      (cons (copier string start index)
 			    (find-start (fix:+ index 1)))
 		      (loop (fix:+ index 1)))
-		  (list (get-part string start end)))))
+		  (list (copier string start end)))))
 
 	  (find-start start))))))
 
@@ -1964,7 +1964,8 @@ USA.
   (keyword-option-parser
    (list (list 'delimiter char-matcher? (lambda () char-whitespace?))
 	 (list 'allow-runs? boolean? (lambda () #t))
-	 (list 'copy? boolean? (lambda () #f)))))
+	 (list 'copier string-copier? (lambda () string-slice))
+	 (list 'copy? boolean? (lambda () #!default)))))
 
 (define (char-matcher->predicate matcher caller)
   (cond ((char? matcher) (char=-predicate matcher))
@@ -1976,14 +1977,26 @@ USA.
   (or (char? object)
       (char-set? object)
       (unary-procedure? object)))
+
+(define (string-copier? object)
+  (procedure-of-arity? object 3))
+
+(define (optional-boolean? object)
+  (or (boolean? object)
+      (default-object? object)))
+
+(define (get-copier copier copy?)
+  (if (default-object? copy?)
+      copier
+      (if copy? substring string-slice)))
 
 ;;;; Trimmer/Padder
 
 (define (string-trimmer . options)
-  (receive (where to-trim copy?)
+  (receive (where to-trim copier copy?)
       (string-trimmer-options options 'string-trimmer)
     (let ((predicate (char-matcher->predicate to-trim 'string-trimmer))
-	  (get-trimmed (if copy? substring string-slice)))
+	  (copier (get-copier copier copy?)))
       (lambda (string)
 	(let* ((end (string-length string))
 	       (start
@@ -1994,21 +2007,22 @@ USA.
 			       (predicate (string-ref string index)))
 			  (loop (fix:+ index 1))
 			  index)))))
-	  (get-trimmed string
-		       start
-		       (if (eq? where 'leading)
-			   end
-			   (let loop ((index end))
-			     (if (and (fix:> index start)
-				      (predicate
-				       (string-ref string (fix:- index 1))))
-				 (loop (fix:- index 1))
-				 index)))))))))
+	  (copier string
+		  start
+		  (if (eq? where 'leading)
+		      end
+		      (let loop ((index end))
+			(if (and (fix:> index start)
+				 (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? (lambda () char-whitespace?))
+	 (list 'copier string-copier? (lambda () string-slice))
 	 (list 'copy? boolean? (lambda () #f)))))
 
 (define (string-padder . options)
@@ -2233,7 +2247,7 @@ USA.
 (define (legacy-string-trimmer where)
   (lambda (string #!optional char-set)
     ((string-trimmer 'where where
-		     'copy? #t
+		     'copier substring
 		     'to-trim
 		     (if (default-object? char-set)
 			 char-set:whitespace
@@ -2264,5 +2278,5 @@ USA.
 (define (burst-string string delimiter allow-runs?)
   ((string-splitter 'delimiter delimiter
 		    'allow-runs? allow-runs?
-		    'copy? #t)
+		    'copier substring)
    string))
\ No newline at end of file