diff --git a/lib/init-7.scm b/lib/init-7.scm index aae56127..4277aa78 100644 --- a/lib/init-7.scm +++ b/lib/init-7.scm @@ -369,11 +369,6 @@ (if (<= n 9) (integer->char (+ n (char->integer #\0))) (integer->char (+ (- n 10) (char->integer #\A))))) -(define (digit-value ch) - (if (char-numeric? ch) - (- (char->integer ch) (char->integer #\0)) - (and (<= 65 (char->integer (char-upcase ch)) 70) - (- (char->integer (char-upcase ch)) 55)))) (define (%number->string num) (call-with-output-string (lambda (out) (write num out)))) diff --git a/lib/scheme/char.sld b/lib/scheme/char.sld index eae10fd1..604715a7 100644 --- a/lib/scheme/char.sld +++ b/lib/scheme/char.sld @@ -5,8 +5,7 @@ (full-unicode (import (chibi char-set full) (chibi char-set base) - (chibi iset base) - (only (chibi) digit-value)) + (chibi iset base)) (include "char/full.scm") (include "char/case-offsets.scm")) (else @@ -18,6 +17,7 @@ char-alphabetic? char-lower-case? char-numeric? char-upper-case? char-whitespace? digit-value char-upcase char-downcase)))) + (include "digit-value.scm") (export char-alphabetic? char-ci<=? char-ci=? char-ci>? char-downcase char-foldcase char-lower-case? char-numeric? diff --git a/lib/scheme/digit-value.scm b/lib/scheme/digit-value.scm new file mode 100644 index 00000000..c09cf010 --- /dev/null +++ b/lib/scheme/digit-value.scm @@ -0,0 +1,64 @@ + +(cond-expand + (full-unicode + (define zeros + '#(#\x0030 ;DIGIT ZERO + #\x0660 ;ARABIC-INDIC DIGIT ZERO + #\x06F0 ;EXTENDED ARABIC-INDIC DIGIT ZERO + #\x07C0 ;NKO DIGIT ZERO + #\x0966 ;DEVANAGARI DIGIT ZERO + #\x09E6 ;BENGALI DIGIT ZERO + #\x0A66 ;GURMUKHI DIGIT ZERO + #\x0AE6 ;GUJARATI DIGIT ZERO + #\x0B66 ;ORIYA DIGIT ZERO + #\x0BE6 ;TAMIL DIGIT ZERO + #\x0C66 ;TELUGU DIGIT ZERO + #\x0CE6 ;KANNADA DIGIT ZERO + #\x0D66 ;MALAYALAM DIGIT ZERO + #\x0E50 ;THAI DIGIT ZERO + #\x0ED0 ;LAO DIGIT ZERO + #\x0F20 ;TIBETAN DIGIT ZERO + #\x1040 ;MYANMAR DIGIT ZERO + #\x1090 ;MYANMAR SHAN DIGIT ZERO + #\x17E0 ;KHMER DIGIT ZERO + #\x1810 ;MONGOLIAN DIGIT ZERO + #\x1946 ;LIMBU DIGIT ZERO + #\x19D0 ;NEW TAI LUE DIGIT ZERO + #\x1A80 ;TAI THAM HORA DIGIT ZERO + #\x1A90 ;TAI THAM THAM DIGIT ZERO + #\x1B50 ;BALINESE DIGIT ZERO + #\x1BB0 ;SUNDANESE DIGIT ZERO + #\x1C40 ;LEPCHA DIGIT ZERO + #\x1C50 ;OL CHIKI DIGIT ZERO + #\xA620 ;VAI DIGIT ZERO + #\xA8D0 ;SAURASHTRA DIGIT ZERO + #\xA900 ;KAYAH LI DIGIT ZERO + #\xA9D0 ;JAVANESE DIGIT ZERO + #\xAA50 ;CHAM DIGIT ZERO + #\xABF0 ;MEETEI MAYEK DIGIT ZERO + #\xFF10 ;FULLWIDTH DIGIT ZERO + #\x104A0 ;OSMANYA DIGIT ZERO + #\x11066 ;BRAHMI DIGIT ZERO + #\x1D7CE ;MATHEMATICAL BOLD DIGIT ZERO + #\x1D7D8 ;MATHEMATICAL DOUBLE-STRUCK DIGIT ZERO + #\x1D7E2 ;MATHEMATICAL SANS-SERIF DIGIT ZERO + #\x1D7EC ;MATHEMATICAL SANS-SERIF BOLD DIGIT ZERO + #\x1D7F6 ;MATHEMATICAL MONOSPACE DIGIT ZERO + ))) + (else + (define zeros #(#\0)))) + +(define (digit-value ch) + (let ((n (char->integer ch))) + (let lp ((lo 0) (hi (- (vector-length zeros) 1))) + (if (> lo hi) + #f + (let* ((mid (+ lo (quotient (- hi lo) 2))) + (mid-zero (char->integer (vector-ref zeros mid)))) + (cond + ((<= mid-zero n (+ mid-zero 9)) + (- n mid-zero)) + ((< n mid-zero) + (lp lo (- mid 1))) + (else + (lp (+ mid 1) hi)))))))) diff --git a/tests/r7rs-tests.scm b/tests/r7rs-tests.scm index bf560f33..9f0a12f5 100644 --- a/tests/r7rs-tests.scm +++ b/tests/r7rs-tests.scm @@ -855,9 +855,13 @@ (test #f (char-lower-case? #\A)) (test #f (char-lower-case? #\3)) +(test 0 (digit-value #\0)) (test 3 (digit-value #\3)) -;; (test 4 (digit-value #\x0664)) -;; (test 0 (digit-value #\x0EA6)) +(test 9 (digit-value #\9)) +(test 4 (digit-value #\x0664)) +(test 0 (digit-value #\x0AE6)) +(test #f (digit-value #\.)) +(test #f (digit-value #\-)) (test 97 (char->integer #\a)) (test #\a (integer->char 97)) @@ -1468,7 +1472,7 @@ ;; Each test is of the form: ;; -;; (input-str expected-value (expected-write-values ...)) +;; (input-str expected-value expected-write-values ...) ;; ;; where the input should be eqv? to the expected-value, and the ;; written output the same as any of the expected-write-values. The