Ticket #1182: utf8-validation.diff

tests/utf8-test.scm

@@ -1 +1 @@
 
-(use test utf8 utf8-srfi-13 utf8-srfi-14)
+(use test utf8 utf8-srfi-13 utf8-srfi-14 utf8-validation)
+(import (prefix scheme core-))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; R5RS
@@ -547 +548 @@
 (test-assert (char-set-contains? char-set:full #\a))
 (test-assert (char-set-contains? char-set:full (string-ref "あ" 0)))
 
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; utf8-validation
+
+(test-assert "stray continuation byte"
+             (not (utf8-string? (core-string #\x (integer->char #b10101010) #\x))))
+
+(test-assert "overlong"
+             (not (utf8-string? (core-list->string `(#\x ,@(map integer->char '(#b11000000 #b10100111)) #\x)))))
+
+(test-assert "incomplete"
+             (not (utf8-string? (core-string #\x (integer->char #b11000001)))))
+
+(test-assert (utf8-string? "Є"))
+(test-assert (utf8-string? "☭"))
+(test-assert (utf8-string? "😈"))
+(test-assert (utf8-string? "xЄ☭😈x"))
+
 (test-end)

utf8-validation.scm

@@ +1 @@
+(module utf8-validation
+
+(utf8-string?)
+
+(import chicken
+        scheme)
+
+(define (fxand= a b c)
+  (fx= (fxand a b) c))
+
+(define (char<= a b c)
+  (and (char<=? a b)
+       (char<=? b c)))
+
+(define (utf8-tail? c)
+  (char<= #\x80 c #\xBF))
+
+(define (utf8-2? c0 c1)
+  (and (char<= #\xC2 c0 #\xDF)
+       (utf8-tail? c1)))
+
+(define (utf8-3? c0 c1 c2)
+  (and (utf8-tail? c2)
+       (cond ((char=? c0 #\xE0)
+              (char<= #\xA0 c1 #\xBF))
+             ((char<= #\xE1 c0 #\xEC)
+              (utf8-tail? c1))
+             ((char=? c0 #\xED)
+              (char<= #\x80 c1 #\x9F))
+             ((char<= #\xEE c0 #\xEF)
+              (utf8-tail? c1))
+             (else #f))))
+
+(define (utf8-4? c0 c1 c2 c3)
+  (and (utf8-tail? c2)
+       (utf8-tail? c3)
+       (cond ((char=? c0 #\xF0)
+              (char<= #\x90 c1 #\xBF))
+             ((char<= #\xF1 c0 #\xF3)
+              (utf8-tail? c1))
+             ((char=? c0 #\xF4)
+              (char<= #\x80 c1 #\x8F))
+             (else #f))))
+
+(define (utf8-string? str)
+  (let ((len (string-length str)))
+    (let loop ((pos 0))
+      (or (fx= pos len)
+          (let* ((c0 (string-ref str pos))
+                 (i0 (char->integer c0)))
+            (let-syntax ((validate (syntax-rules ()
+                                     ((_ valid? c ... n)
+                                      (and (fx<= n (fx- len pos))
+                                           (valid? c0 (string-ref str (fx+ pos c)) ...)
+                                           (loop (fx+ pos n)))))))
+              (cond ((fx<= i0 #x7F)
+                     (loop (fx+ pos 1)))
+                    ((fxand= i0 #xE0 #xC0)
+                     (validate utf8-2? 1 2))
+                    ((fxand= i0 #xF0 #xE0)
+                     (validate utf8-3? 1 2 3))
+                    ((fxand= i0 #xF8 #xF0)
+                     (validate utf8-4? 1 2 3 4))
+                    (else #f))))))))
+
+)

utf8.setup

@@ -30 +30 @@
        ("utf8-srfi-13.so" ("utf8-srfi-13.scm")
         (compile -fixnum-arithmetic -inline -local -s -O2 -d1
                  -j utf8-srfi-13 utf8-srfi-13.scm)
-        (compile -s -O2 -d0 utf8-srfi-13.import.scm)))
+        (compile -s -O2 -d0 utf8-srfi-13.import.scm))
+       ("utf8-validation.so" ("utf8-validation.scm")
+        (compile -s -O3 -d1
+                 -j utf8-validation utf8-validation.scm)
+        (compile -s -O2 -d0 utf8-validation.import.scm)))
   '("utf8-lolevel.so" "utf8.so" "utf8-srfi-14.so"
-    "unicode-char-sets.so" "utf8-case-map.so" "utf8-srfi-13.so"))
+    "unicode-char-sets.so" "utf8-case-map.so" "utf8-srfi-13.so"
+    "utf8-validation.so"))
 
 (install-extension 'utf8-lolevel
  '("utf8-lolevel.so" "utf8-lolevel.import.so")
@@ -58 +63 @@
 (install-extension 'utf8-srfi-13
  '("utf8-srfi-13.so" "utf8-srfi-13.import.so")
  `((version ,version)))
+
+(install-extension 'utf8-validation
+ '("utf8-validation.so" "utf8-validation.import.so")
+ `((version ,version)))