Adding special handling for final sigma in (scheme char) case mappings.

Fixes issue #147.

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)))
+    (let lp ((a 0) (b (vector-length special-cases)))
-      (if (= a b)
+      (let* ((mid (+ a (quotient (- b a) 2)))
-          #f
+             (vec (vector-ref special-cases mid))
-          (let* ((mid (+ a (quotient (- b a) 2)))
+             (val (vector-ref vec 0)))
-                 (vec (vector-ref special-cases mid))
+        (cond ((< i val) (and (< mid b) (lp a mid)))
-                 (val (vector-ref vec 0)))
+              ((> i val) (and (> mid a) (lp mid b)))
-            (cond ((< i val) (if (= mid b) #f (loop a mid)))
+              (else (vector-ref vec off)))))))
-                  ((> i val) (if (= mid a) #f (loop 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
+      (let ((in (open-input-string str)))
-       (lambda (ch)
+        (let lp ()
-         (display (or (char-get-special-case ch 1) (char-downcase ch)) out))
+          (let ((ch (read-char in)))
-       str))))
+            (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)

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))