From b2112ee9c81678087f4990caf9aa235823258b90 Mon Sep 17 00:00:00 2001
From: Abdulaziz Ghuloum <aghuloum@cs.indiana.edu>
Date: Fri, 14 Dec 2007 21:04:54 -0500
Subject: [PATCH] changed implementation of string-foldcase to eliminate use of
 string ports. (reduce overhead)

---
 scheme/ikarus.unicode-data.ss | 59 ++++++++++++++++++++++++++---------
 scheme/last-revision          |  2 +-
 scheme/tests/strings.ss       |  2 ++
 3 files changed, 48 insertions(+), 15 deletions(-)

diff --git a/scheme/ikarus.unicode-data.ss b/scheme/ikarus.unicode-data.ss
index 4c496d5..faa610d 100644
--- a/scheme/ikarus.unicode-data.ss
+++ b/scheme/ikarus.unicode-data.ss
@@ -229,24 +229,55 @@
            (error 'char-ci>=? "not a char" x))]))
                
   (define ($string-foldcase str)
-    (let-values ([(p e) (open-string-output-port)])
-      (let f ([str str] [i 0] [n (string-length str)])
+    (define (extend-length str ac) 
+      (define (chars ac n)
         (cond
-          [($fx= i n) (e)]
+          [(null? ac) n]
+          [else 
+           (chars (cdr ac)
+             (let f ([p (cdar ac)] [n n])
+               (cond
+                 [(pair? p) (f (cdr p) (+ n 1))]
+                 [else n])))]))
+      (let ([dst-len (chars ac (string-length str))])
+        (let f ([str str] [dst (make-string dst-len)] [i 0] [j 0] [ac (reverse ac)])
+          (cond
+            [(null? ac) 
+             (string-copy! str i dst j (fx- (string-length str) i))
+             dst]
+            [else
+             (let ([idx (caar ac)] [c* (cdar ac)] [ac (cdr ac)])
+               (let ([cnt (fx- idx i)])
+                 (string-copy! str i dst j cnt)
+                 (let g ([str str]       [dst dst] 
+                         [i (fx+ i cnt)] [j (fx+ j cnt)] 
+                         [ac ac]         [c* c*]) 
+                   (cond
+                     [(pair? c*) 
+                      (string-set! dst j (car c*))
+                      (g str dst i (fx+ j 1) ac (cdr c*))]
+                     [else
+                      (string-set! dst j c*)
+                      (f str dst (fx+ i 1) (fx+ j 1) ac)]))))]))))
+    (let ([n (string-length str)])
+      (let f ([str str] [dst (make-string n)] [i 0] [n n] [ac '()])
+        (cond
+          [($fx= i n) 
+           (if (null? ac) 
+               dst 
+               (extend-length dst ac))]
           [else
-           (let* ([n ($char->fixnum ($string-ref str i))])
+           (let* ([cn ($char->fixnum ($string-ref str i))])
              (let ([n/ls
                     (vector-ref string-foldcase-adjustment-vector
-                      (binary-search n charcase-search-vector))])
-               (if (fixnum? n/ls)
-                   (write-char ($fixnum->char ($fx+ n n/ls)) p)
-                   (let f ([ls n/ls])
-                     (write-char ($car ls) p)
-                     (let ([ls ($cdr ls)])
-                       (if (pair? ls) 
-                           (f ls)
-                           (write-char ls p)))))))
-           (f str ($fxadd1 i) n)]))))
+                      (binary-search cn charcase-search-vector))])
+               (cond
+                 [(fixnum? n/ls)
+                  (string-set! dst i ($fixnum->char ($fx+ cn n/ls)))
+                  (f str dst ($fxadd1 i) n ac)]
+                 [else
+                  (f str dst (fxadd1 i) n 
+                     (cons (cons i n/ls) ac))])))]))))
 
   (define (string-foldcase str)
     (if (string? str)
diff --git a/scheme/last-revision b/scheme/last-revision
index bd9b507..afe70ec 100644
--- a/scheme/last-revision
+++ b/scheme/last-revision
@@ -1 +1 @@
-1242
+1244
diff --git a/scheme/tests/strings.ss b/scheme/tests/strings.ss
index c0f00d5..8963ebe 100644
--- a/scheme/tests/strings.ss
+++ b/scheme/tests/strings.ss
@@ -15,6 +15,8 @@
     ; (string-downcase "STRASSE")]
     [values (string-ci=? "Stra\xDF;e" "Strasse")]
     [values (string-ci=? "Stra\xDF;e" "STRASSE")]
+    [values (string-ci=? "\xDF;" "SS")]
+    [values (string-ci=? "\xDF;\xDF;" "SSSS")]
     ))