core/io/encodings/utf16/utf16.factor

   1 ! Copyright (C) 2006, 2009 Daniel Ehrenberg.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors alien.accessors byte-arrays io io.encodings
   4 kernel math math.private sequences sequences.private strings
   5 strings.private ;
   6 IN: io.encodings.utf16
   7
   8 SINGLETON: utf16be
   9
  10 SINGLETON: utf16le
  11
  12 SINGLETON: utf16
  13
  14 ERROR: missing-bom ;
  15
  16 <PRIVATE
  17
  18 ! UTF-16BE decoding
  19
  20 : append-nums ( byte ch -- ch )
  21     over [ 8 shift bitor ] [ 2drop replacement-char ] if ;
  22
  23 : double-be ( stream byte -- stream char )
  24     over stream-read1 swap append-nums ;
  25
  26 : quad-be ( stream byte -- stream char )
  27     double-be over stream-read1 [
  28         dup -2 shift 0b110111 number= [
  29             [ 2 shift ] dip 0b11 bitand bitor
  30             over stream-read1 swap append-nums 0x10000 +
  31         ] [ 2drop dup stream-read1 drop replacement-char ] if
  32     ] when* ;
  33
  34 : ignore ( stream -- stream char )
  35     dup stream-read1 drop replacement-char ;
  36
  37 : begin-utf16be ( stream byte -- stream char )
  38     dup -3 shift 0b11011 number= [
  39         dup 0b00000100 bitand zero?
  40         [ 0b11 bitand quad-be ]
  41         [ drop ignore ] if
  42     ] [ double-be ] if ;
  43
  44 M: utf16be decode-char
  45     drop dup stream-read1 dup [ begin-utf16be ] when nip ;
  46
  47 ! UTF-16LE decoding
  48
  49 : quad-le ( stream ch -- stream char )
  50     over stream-read1 swap 10 shift bitor
  51     over stream-read1 dup -2 shift 0b110111 = [
  52         0b11 bitand append-nums 0x10000 +
  53     ] [ 2drop replacement-char ] if ;
  54
  55 : double-le ( stream byte1 byte2 -- stream char )
  56     dup -3 shift 0b11011 = [
  57         dup 0b100 bitand 0 number=
  58         [ 0b11 bitand 8 shift bitor quad-le ]
  59         [ 2drop replacement-char ] if
  60     ] [ append-nums ] if ;
  61
  62 : begin-utf16le ( stream byte -- stream char )
  63     over stream-read1 [ double-le ] [ drop replacement-char ] if* ;
  64
  65 M: utf16le decode-char
  66     drop dup stream-read1 dup [ begin-utf16le ] when nip ;
  67
  68 ! UTF-16LE/BE encoding
  69
  70 : encode-first ( char -- byte1 byte2 )
  71     -10 shift
  72     [ -8 shift 0b11011000 bitor ] [ 0xFF bitand ] bi ; inline
  73
  74 : encode-second ( char -- byte3 byte4 )
  75     0b1111111111 bitand
  76     [ -8 shift 0b11011100 bitor ] [ 0b11111111 bitand ] bi ; inline
  77
  78 : stream-write2 ( char1 char2 stream -- )
  79     [ B{ } 2sequence ] dip stream-write ; inline
  80     ! [ stream-write1 ] curry bi@ ; inline
  81
  82 : split>b/b ( h -- b1 b2 ) ! duplicate from math.bitwise:h>b/b
  83     [ 0xff bitand ] [ -8 shift 0xff bitand ] bi ;
  84
  85 : char>utf16be ( char stream -- )
  86     over 0xFFFF > [
  87         [ 0x10000 - ] dip
  88         [ [ encode-first ] dip stream-write2 ]
  89         [ [ encode-second ] dip stream-write2 ] 2bi
  90     ] [ [ split>b/b swap ] dip stream-write2 ] if ; inline
  91
  92 M: utf16be encode-char
  93     drop char>utf16be ;
  94
  95 : char>utf16le ( char stream -- )
  96     over 0xFFFF > [
  97         [ 0x10000 - ] dip
  98         [ [ encode-first swap ] dip stream-write2 ]
  99         [ [ encode-second swap ] dip stream-write2 ] 2bi
 100     ] [ [ split>b/b ] dip stream-write2 ] if ; inline
 101
 102 M: utf16le encode-char
 103     drop char>utf16le ;
 104
 105 : ascii-char>utf16-byte-array ( off n byte-array string -- )
 106     overd string-nth-fast -rot
 107     [ 2 fixnum*fast rot fixnum+fast ] dip
 108     set-nth-unsafe ; inline
 109
 110 : ascii-string>utf16-byte-array ( off string -- byte-array )
 111     [ length >fixnum [ <iota> ] [ 2 fixnum*fast <byte-array> ] bi ] keep
 112     [ [ ascii-char>utf16-byte-array ] 2curry with each ] keepd ; inline
 113
 114 : ascii-string>utf16le ( string stream -- )
 115     [ 0 swap ascii-string>utf16-byte-array ] dip stream-write ; inline
 116 : ascii-string>utf16be ( string stream -- )
 117     [ 1 swap ascii-string>utf16-byte-array ] dip stream-write ; inline
 118
 119 GENERIC#: encode-string-utf16le 1 ( string stream -- )
 120
 121 M: object encode-string-utf16le
 122     [ char>utf16le ] curry each ; inline
 123
 124 M: string encode-string-utf16le
 125     over aux>>
 126     [ call-next-method ]
 127     [ ascii-string>utf16le ] if ; inline
 128
 129 M: utf16le encode-string drop encode-string-utf16le ;
 130
 131 GENERIC#: encode-string-utf16be 1 ( string stream -- )
 132
 133 M: object encode-string-utf16be
 134     [ char>utf16be ] curry each ; inline
 135
 136 M: string encode-string-utf16be
 137     over aux>>
 138     [ call-next-method ]
 139     [ ascii-string>utf16be ] if ; inline
 140
 141 M: utf16be encode-string drop encode-string-utf16be ;
 142
 143 M: utf16le guess-encoded-length drop 2 * ; inline
 144 M: utf16le guess-decoded-length drop 2 /i ; inline
 145
 146 M: utf16be guess-encoded-length drop 2 * ; inline
 147 M: utf16be guess-decoded-length drop 2 /i ; inline
 148
 149 ! UTF-16
 150
 151 CONSTANT: bom-le B{ 0xff 0xfe }
 152
 153 CONSTANT: bom-be B{ 0xfe 0xff }
 154
 155 : bom>le/be ( bom -- le/be )
 156     dup bom-le sequence= [ drop utf16le ] [
 157         bom-be sequence= [ utf16be ] [ missing-bom ] if
 158     ] if ;
 159
 160 M: utf16 <decoder>
 161     drop 2 over stream-read bom>le/be <decoder> ;
 162
 163 M: utf16 <encoder>
 164     drop bom-le over stream-write utf16le <encoder> ;
 165
 166 PRIVATE>
 167
 168 SINGLETON: utf16n
 169
 170 : choose-utf16-endian ( -- descriptor )
 171     B{ 1 0 0 0 } 0 alien-unsigned-4 1 = utf16le utf16be ? ; foldable
 172
 173 M: utf16n <decoder> drop choose-utf16-endian <decoder> ;
 174
 175 M: utf16n <encoder> drop choose-utf16-endian <encoder> ;