From 7a3f0a73625462c67c3e3c6e2dc7119f59d4d2ed Mon Sep 17 00:00:00 2001
From: Alex Shinn <ashinn@users.noreply.github.com>
Date: Sun, 29 Sep 2013 15:09:21 +0900
Subject: [PATCH] Adding special handling for final sigma in (scheme char) case
 mappings. Fixes issue #147.

---
 lib/scheme/char/full.scm | 41 ++++++++++++++++++++++++++--------------
 tests/r7rs-tests.scm     |  9 +++++++++
 2 files changed, 36 insertions(+), 14 deletions(-)

diff --git a/lib/scheme/char/full.scm b/lib/scheme/char/full.scm
index 27b075ca..31c3b32a 100644
--- a/lib/scheme/char/full.scm
+++ b/lib/scheme/char/full.scm
@@ -64,15 +64,13 @@
 
 (define (char-get-special-case ch off)
   (let ((i (char->integer ch)))
-    (let loop ((a 0) (b (vector-length special-cases)))
-      (if (= a b)
-          #f
-          (let* ((mid (+ a (quotient (- b a) 2)))
-                 (vec (vector-ref special-cases mid))
-                 (val (vector-ref vec 0)))
-            (cond ((< i val) (if (= mid b) #f (loop a mid)))
-                  ((> i val) (if (= mid a) #f (loop mid b)))
-                  (else (vector-ref vec off))))))))
+    (let lp ((a 0) (b (vector-length special-cases)))
+      (let* ((mid (+ a (quotient (- b a) 2)))
+             (vec (vector-ref special-cases mid))
+             (val (vector-ref vec 0)))
+        (cond ((< i val) (and (< mid b) (lp a mid)))
+              ((> i val) (and (> mid a) (lp mid b)))
+              (else (vector-ref vec off)))))))
 
 (define (call-with-output-string proc)
   (let ((out (open-output-string)))
@@ -82,10 +80,21 @@
 (define (string-downcase str)
   (call-with-output-string
     (lambda (out)
-      (string-for-each
-       (lambda (ch)
-         (display (or (char-get-special-case ch 1) (char-downcase ch)) out))
-       str))))
+      (let ((in (open-input-string str)))
+        (let lp ()
+          (let ((ch (read-char in)))
+            (cond
+             ((not (eof-object? ch))
+              (display
+               (if (eqv? ch #\x03A3)
+                   (let ((ch2 (peek-char in)))
+                     (if (or (eof-object? ch2)
+                             (not (char-set-contains? char-set:letter ch2)))
+                         #\x03C2
+                         #\x03C3))
+                   (or (char-get-special-case ch 1) (char-downcase ch)))
+               out)
+              (lp)))))))))
 
 (define string-foldcase string-downcase)
 
@@ -94,7 +103,11 @@
     (lambda (out)
       (string-for-each
        (lambda (ch)
-         (display (or (char-get-special-case ch 3) (char-upcase ch)) out))
+         (display (if (memv ch '(#\x03C2 #\x03C3))
+                      #\x03A3
+                      (or (char-get-special-case ch 3)
+                          (char-upcase ch)))
+                  out))
        str))))
 
 (define (string-cmp-ci op a ls)
diff --git a/tests/r7rs-tests.scm b/tests/r7rs-tests.scm
index 5050b2ca..4f865056 100644
--- a/tests/r7rs-tests.scm
+++ b/tests/r7rs-tests.scm
@@ -1128,6 +1128,15 @@
 (test "i̇" (string-foldcase "İ"))
 (test "J̌" (string-upcase "ǰ"))
 
+;; context-sensitive (final sigma)
+(test "ΓΛΏΣΣΑ" (string-upcase "γλώσσα"))
+(test "γλώσσα" (string-downcase "ΓΛΏΣΣΑ"))
+(test "γλώσσα" (string-foldcase "ΓΛΏΣΣΑ"))
+(test "ΜΈΛΟΣ" (string-upcase "μέλος"))
+(test "μέλος" (string-downcase "ΜΈΛΟΣ"))
+(test "μέλος" (string-foldcase "ΜΈΛΟΣ"))
+(test "μέλος ενός" (string-downcase "ΜΈΛΟΣ ΕΝΌΣ"))
+
 (test "" (substring "" 0 0))
 (test "" (substring "a" 0 0))
 (test "" (substring "abc" 1 1))