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