1 ! Copyright (C) 2006, 2008 Daniel Ehrenberg.
2 ! See https://factorcode.org/license.txt for BSD license.
3 USING: accessors combinators io io.encodings
4 io.encodings.private kernel math math.order sequences strings ;
13 : starts-2? ( char -- ? )
14 dup [ -6 shift 0b10 number= ] when ; inline
16 : append-nums ( stream byte -- stream char )
17 over stream-read1 dup starts-2?
18 [ [ 6 shift ] dip 0b111111 bitand bitor ]
19 [ 2drop replacement-char ] if ; inline
21 : minimum-code-point ( char minimum -- char )
22 over > [ drop replacement-char ] when ; inline
24 : maximum-code-point ( char maximum -- char )
25 over < [ drop replacement-char ] when ; inline
27 : double ( stream byte -- stream char )
28 0b11111 bitand append-nums
29 0x80 minimum-code-point ; inline
31 : triple ( stream byte -- stream char )
32 0b1111 bitand append-nums append-nums
33 0x800 minimum-code-point ; inline
35 : quadruple ( stream byte -- stream char )
36 0b111 bitand append-nums append-nums append-nums
37 0x10000 minimum-code-point
38 0x10FFFF maximum-code-point ; inline
40 : begin-utf8 ( stream byte -- stream char )
43 { [ dup -5 shift 0b110 = ] [ double ] }
44 { [ dup -4 shift 0b1110 = ] [ triple ] }
45 { [ dup -3 shift 0b11110 = ] [ quadruple ] }
46 [ drop replacement-char ]
50 : decode-utf8 ( stream -- char/f )
51 dup stream-read1 dup [ begin-utf8 ] when nip ; inline
54 drop decode-utf8 ; inline
56 M: utf8 decode-until (decode-until) ;
60 : encoded ( stream char -- )
61 0b111111 bitand 0b10000000 bitor swap stream-write1 ; inline
63 : char>utf8 ( char stream -- )
64 over 127 <= [ stream-write1 ] [
66 { [ dup -11 shift zero? ] [
67 2dup -6 shift 0b11000000 bitor swap stream-write1
70 { [ dup -16 shift zero? ] [
71 2dup -12 shift 0b11100000 bitor swap stream-write1
76 2dup -18 shift 0b11110000 bitor swap stream-write1
77 2dup -12 shift encoded
87 GENERIC#: encode-string-utf8 1 ( string stream -- )
89 M: object encode-string-utf8
90 [ char>utf8 ] curry each ; inline
92 M: string encode-string-utf8
95 [ [ string>byte-array-fast ] dip stream-write ] if ; inline
97 M: utf8 encode-string drop encode-string-utf8 ;
101 : code-point-length ( n -- x )
104 { [ dup 0 6 between? ] [ 1 ] }
105 { [ dup 7 10 between? ] [ 2 ] }
106 { [ dup 11 15 between? ] [ 3 ] }
107 { [ dup 16 20 between? ] [ 4 ] }
111 : code-point-offsets ( string -- indices )
112 0 [ code-point-length + ] accumulate swap suffix ;
114 : utf8-index> ( n string -- n' )
115 code-point-offsets [ <= ] with find drop ;
117 : >utf8-index ( n string -- n' )
118 code-point-offsets nth ;