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