From: Chris Hanson Date: Mon, 27 Mar 2017 03:59:27 +0000 (-0700) Subject: Change NFC_QC to be a boolean-valued table and exploit that. X-Git-Tag: mit-scheme-pucked-9.2.12~158^2~69 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=0b42f5a4223f9c68225fada26307a053a48cfcfb;p=mit-scheme.git Change NFC_QC to be a boolean-valued table and exploit that. --- diff --git a/src/etc/ucd-converter.scm b/src/etc/ucd-converter.scm index ec6cbe689..7675d9480 100644 --- a/src/etc/ucd-converter.scm +++ b/src/etc/ucd-converter.scm @@ -592,7 +592,8 @@ USA. (define (metadata->code-generator metadata) (let ((name (metadata-name metadata)) (type-spec (metadata-type-spec metadata))) - (cond ((eq? type-spec 'boolean) code-generator:boolean) + (cond ((string=? name "NFC_QC") code-generator:boolean) + ((eq? type-spec 'boolean) code-generator:boolean) ((eq? type-spec 'ccc) code-generator:ccc) ((eq? type-spec 'code-point) code-generator:code-point) ((eq? type-spec 'code-point*) code-generator:code-point*) diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index 2062b386d..342b68ed9 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -1322,6 +1322,7 @@ USA. char-changes-when-lower-cased? char-changes-when-upper-cased? char-full-composition-exclusion? + char-nfc-quick-check? char-nfd-quick-check? ucd-canonical-cm-second-keys ucd-canonical-cm-second-values @@ -1331,7 +1332,6 @@ USA. ucd-cf-value ucd-gcb-value ucd-lc-value - ucd-nfc_qc-value ucd-tc-value ucd-uc-value ucd-wb-value)) diff --git a/src/runtime/ucd-table-nfc_qc.scm b/src/runtime/ucd-table-nfc_qc.scm index 28825c598..66a97fc94 100644 --- a/src/runtime/ucd-table-nfc_qc.scm +++ b/src/runtime/ucd-table-nfc_qc.scm @@ -30,27 +30,10 @@ USA. (declare (usual-integrations)) -(define (ucd-nfc_qc-value char) - (let ((sv (char->integer char))) - (vector-ref |ucd-NFC_QC-table-5| (bytevector-u8-ref |ucd-NFC_QC-table-4| (fix:or (fix:lsh (bytevector-u8-ref |ucd-NFC_QC-table-3| (fix:or (fix:lsh (bytevector-u8-ref |ucd-NFC_QC-table-2| (fix:or (fix:lsh (bytevector-u8-ref |ucd-NFC_QC-table-1| (fix:or (fix:lsh (bytevector-u8-ref |ucd-NFC_QC-table-0| (fix:lsh sv -16)) 4) (fix:and 15 (fix:lsh sv -12)))) 4) (fix:and 15 (fix:lsh sv -8)))) 4) (fix:and 15 (fix:lsh sv -4)))) 4) (fix:and 15 sv)))))) +(define (char-nfc-quick-check? char) + (char-in-set? char char-set:nfc-quick-check)) -(define-deferred |ucd-NFC_QC-table-0| - (vector->bytevector '#(0 1 2 3 3 3 3 3 3 3 3 3 3 3 3 3 3))) - -(define-deferred |ucd-NFC_QC-table-1| - (vector->bytevector '#(0 1 2 3 4 4 4 4 4 4 4 4 4 4 4 5 4 6 4 4 4 4 4 4 4 4 4 4 4 7 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 8 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4))) - -(define-deferred |ucd-NFC_QC-table-2| - (vector->bytevector '#(0 0 0 1 0 0 2 0 0 3 4 5 6 7 0 8 9 10 0 0 0 0 0 0 0 0 0 11 0 0 0 12 13 14 0 15 0 0 0 0 0 0 16 0 0 0 0 0 17 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 18 19 20 0 0 0 0 21 22 0 23 24 25 0 0 0 0 0 0 0 0 0 0 0 26 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 18 18 27 0 0 0 0 0))) - -(define-deferred |ucd-NFC_QC-table-3| - (vector->bytevector - '#(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 2 3 4 5 0 0 6 7 0 0 0 0 0 0 0 0 0 0 0 0 8 0 0 0 0 0 0 0 0 0 0 0 0 0 9 0 10 0 0 0 0 0 11 0 12 0 0 0 0 0 13 0 14 0 0 0 0 0 0 0 0 0 0 0 0 0 11 0 15 0 0 0 0 0 11 0 16 0 0 0 0 0 0 0 17 0 0 0 0 0 0 18 19 0 0 0 0 0 11 0 16 0 0 0 0 0 0 20 21 0 0 0 0 0 0 22 23 24 25 26 22 23 24 0 0 0 0 0 0 11 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 27 28 0 0 29 30 31 0 0 0 0 0 0 32 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 33 0 0 0 34 35 36 37 38 39 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 40 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 41 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 42 0 0 0 0 0 0 0 0 0 0 0 43 0 0 0 0 0 0 44 44 44 44 44 44 44 44 44 44 44 44 44 44 44 44 45 46 47 44 44 44 45 44 44 44 44 44 44 48 0 0 0 49 50 51 52 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 53 0 0 0 0 0 0 16 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 11 0 16 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 54 0 0 0 0 0 0 0 0 0 0 0 0 0 0 21 0 0 0 0 0 0 0 0 0 0 55 56 0 0 0 0 57 58 0 0 0 44 45 0 0 0 0 0 0 0 0 0 0 0 0 0 0))) - -(define-deferred |ucd-NFC_QC-table-4| - (vector->bytevector - '#(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 1 1 1 0 1 1 1 1 1 1 1 0 0 1 0 1 0 1 1 0 0 0 0 0 0 1 0 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 1 1 0 1 1 0 0 0 0 0 0 1 0 0 0 0 0 0 0 2 2 1 2 2 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2 0 0 0 0 0 0 0 0 0 2 0 0 0 0 0 0 0 0 2 0 0 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 2 2 2 2 2 2 2 2 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 1 0 0 0 0 2 2 0 2 0 0 0 2 0 0 2 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2 2 2 0 0 2 0 0 0 0 0 0 0 1 1 0 0 0 0 2 2 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 2 0 0 0 0 0 0 0 0 0 2 0 0 0 0 2 0 0 0 0 2 0 0 0 0 2 0 0 0 0 0 0 0 0 0 0 0 0 2 0 0 0 0 0 0 0 0 0 2 0 2 2 0 2 0 0 0 0 0 0 0 0 2 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 - 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 2 0 2 0 2 0 2 0 2 0 2 0 2 0 0 0 0 0 0 0 0 0 0 0 0 0 2 0 0 2 0 0 0 0 0 0 0 0 0 0 2 0 2 0 0 0 0 0 0 0 2 0 0 0 0 0 0 0 2 0 0 0 0 0 0 0 2 0 0 0 0 0 0 0 2 0 0 2 2 0 0 0 0 0 0 0 0 0 2 0 2 0 2 0 0 2 2 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2 0 0 0 2 2 0 0 0 0 0 0 0 0 0 0 0 0 0 2 2 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2 0 0 0 0 0 0 0 0 0 0 0 0 1 1 0 0 0 0 0 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 0 0 2 0 2 0 0 2 2 2 2 2 2 2 2 2 2 0 2 0 2 0 0 2 2 0 0 0 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2 0 2 0 0 0 0 0 0 0 0 0 0 2 2 2 2 2 2 2 2 2 2 2 2 2 0 2 2 2 2 2 0 2 0 2 2 0 2 2 0 2 2 2 2 2 2 2 2 2 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 1 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2 2 2 2 2 2 2 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2 2 2 2 2 2 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0))) - -(define-deferred |ucd-NFC_QC-table-5| - #(yes maybe no)) +(define-deferred char-set:nfc-quick-check + (char-set* + '((0 . 768) 773 (781 . 783) 784 786 (789 . 795) (796 . 803) (809 . 813) 815 (818 . 824) (825 . 832) (838 . 884) (885 . 894) (895 . 903) (904 . 1619) (1622 . 2364) (2365 . 2392) (2400 . 2494) (2495 . 2519) (2520 . 2524) 2526 (2528 . 2611) (2612 . 2614) (2615 . 2649) (2652 . 2654) (2655 . 2878) (2879 . 2902) (2904 . 2908) (2910 . 3006) (3007 . 3031) (3032 . 3158) (3159 . 3266) (3267 . 3285) (3287 . 3390) (3391 . 3415) (3416 . 3530) (3531 . 3535) (3536 . 3551) (3552 . 3907) (3908 . 3917) (3918 . 3922) (3923 . 3927) (3928 . 3932) (3933 . 3945) (3946 . 3955) 3956 3959 (3961 . 3969) (3970 . 3987) (3988 . 3997) (3998 . 4002) (4003 . 4007) (4008 . 4012) (4013 . 4025) (4026 . 4142) (4143 . 4449) + (4470 . 4520) (4547 . 6965) (6966 . 8049) 8050 8052 8054 8056 8058 8060 (8062 . 8123) (8124 . 8126) (8127 . 8137) 8138 (8140 . 8147) (8148 . 8155) (8156 . 8163) (8164 . 8171) (8172 . 8174) (8176 . 8185) 8186 8188 (8190 . 8192) (8194 . 8486) (8487 . 8490) (8492 . 9001) (9003 . 10972) (10973 . 12441) (12443 . 63744) (64014 . 64016) 64017 (64019 . 64021) 64031 64033 (64035 . 64037) (64039 . 64042) (64110 . 64112) (64218 . 64285) 64286 (64288 . 64298) 64311 64317 64319 64322 64325 (64335 . 69818) (69819 . 69927) (69928 . 70462) (70463 . 70487) (70488 . 70832) (70833 . 70842) (70843 . 70845) (70846 . 71087) (71088 . 119134) (119141 . 119227) (119233 . 194560) (195102 . 1114112)))) diff --git a/src/runtime/ustring.scm b/src/runtime/ustring.scm index 6532d9fda..7d58e41c0 100644 --- a/src/runtime/ustring.scm +++ b/src/runtime/ustring.scm @@ -580,40 +580,27 @@ USA. (canonical-ordering! (canonical-decomposition string)))) (define (string->nfc string) - (if (eq? #t (string-in-nfc? string)) + (if (string-in-nfc? string) string (canonical-composition (string->nfd string)))) -(define (string-in-nfd? string) - (let ((end (string-length string))) - (let loop ((i 0) (last-ccc 0)) - (if (fix:< i end) - (let ((char (string-ref string i))) - (if (fix:< (char->integer char) #xC0) - (loop (fix:+ i 1) 0) - (let ((ccc (ucd-ccc-value char))) - (and (or (fix:= ccc 0) - (fix:>= ccc last-ccc)) - (char-nfd-quick-check? char) - (loop (fix:+ i 1) ccc))))) - #t)))) +(define-integrable (string-nqc-maker cp-limit char-nqc?) + (lambda (string) + (let ((end (string-length string))) + (let loop ((i 0) (last-ccc 0)) + (if (fix:< i end) + (let ((char (string-ref string i))) + (if (fix:< (char->integer char) cp-limit) + (loop (fix:+ i 1) 0) + (let ((ccc (ucd-ccc-value char))) + (and (or (fix:= ccc 0) (fix:>= ccc last-ccc)) + (char-nqc? char) + (loop (fix:+ i 1) ccc))))) + #t))))) + +(define string-in-nfd? (string-nqc-maker #xC0 char-nfd-quick-check?)) +(define string-in-nfc? (string-nqc-maker #x300 char-nfc-quick-check?)) -(define (string-in-nfc? string) - (let ((end (string-length string))) - (let loop ((i 0) (last-ccc 0) (result #t)) - (if (fix:< i end) - (let ((char (string-ref string i))) - (if (fix:< (char->integer char) #x300) - (loop (fix:+ i 1) 0 result) - (let ((ccc (ucd-ccc-value char))) - (and (or (fix:= ccc 0) - (fix:>= ccc last-ccc)) - (case (ucd-nfc_qc-value char) - ((yes) (loop (fix:+ i 1) ccc result)) - ((maybe) (loop (fix:+ i 1) ccc 'maybe)) - (else #f)))))) - result)))) - (define (canonical-decomposition string) (let ((end (string-length string)) (builder (string-builder '->nfc? #f)))