-! Copyright (C) 2006, 2007 Daniel Ehrenberg.
+! Copyright (C) 2006, 2009 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
-USING: math kernel sequences sbufs vectors namespaces io.binary
-io.encodings combinators splitting io byte-arrays ;
+USING: accessors alien.accessors byte-arrays io io.binary
+io.encodings kernel math math.private sequences
+sequences.private strings strings.private ;
IN: io.encodings.utf16
-SYMBOL: double
-SYMBOL: quad1
-SYMBOL: quad2
-SYMBOL: quad3
-SYMBOL: ignore
+SINGLETON: utf16be
-: do-ignore ( -- ch state ) 0 ignore ;
+SINGLETON: utf16le
+
+SINGLETON: utf16
+
+ERROR: missing-bom ;
+
+<PRIVATE
+
+! UTF-16BE decoding
: append-nums ( byte ch -- ch )
- 8 shift bitor ;
-
-: end-multibyte ( buf byte ch -- buf ch state )
- append-nums decoded ;
-
-: begin-utf16be ( buf byte -- buf ch state )
- dup -3 shift BIN: 11011 number= [
- dup BIN: 00000100 bitand zero?
- [ BIN: 11 bitand quad1 ]
- [ drop do-ignore ] if
- ] [ double ] if ;
-
-: handle-quad2be ( byte ch -- ch state )
- swap dup -2 shift BIN: 110111 number= [
- >r 2 shift r> BIN: 11 bitand bitor quad3
- ] [ 2drop do-ignore ] if ;
-
-: decode-utf16be-step ( buf byte ch state -- buf ch state )
- {
- { begin [ drop begin-utf16be ] }
- { double [ end-multibyte ] }
- { quad1 [ append-nums quad2 ] }
- { quad2 [ handle-quad2be ] }
- { quad3 [ append-nums HEX: 10000 + decoded ] }
- { ignore [ 2drop push-replacement ] }
- } case ;
-
-: decode-utf16be ( seq -- str )
- [ decode-utf16be-step ] decode ;
-
-: handle-double ( buf byte ch -- buf ch state )
- swap dup -3 shift BIN: 11011 = [
- dup BIN: 100 bitand 0 number=
- [ BIN: 11 bitand 8 shift bitor quad2 ]
- [ 2drop push-replacement ] if
- ] [ end-multibyte ] if ;
-
-: handle-quad3le ( buf byte ch -- buf ch state )
- swap dup -2 shift BIN: 110111 = [
- BIN: 11 bitand append-nums HEX: 10000 + decoded
- ] [ 2drop push-replacement ] if ;
-
-: decode-utf16le-step ( buf byte ch state -- buf ch state )
- {
- { begin [ drop double ] }
- { double [ handle-double ] }
- { quad1 [ append-nums quad2 ] }
- { quad2 [ 10 shift bitor quad3 ] }
- { quad3 [ handle-quad3le ] }
- } case ;
-
-: decode-utf16le ( seq -- str )
- [ decode-utf16le-step ] decode ;
-
-: encode-first
+ over [ 8 shift bitor ] [ 2drop replacement-char ] if ;
+
+: double-be ( stream byte -- stream char )
+ over stream-read1 swap append-nums ;
+
+: quad-be ( stream byte -- stream char )
+ double-be over stream-read1 [
+ dup -2 shift 0b110111 number= [
+ [ 2 shift ] dip 0b11 bitand bitor
+ over stream-read1 swap append-nums 0x10000 +
+ ] [ 2drop dup stream-read1 drop replacement-char ] if
+ ] when* ;
+
+: ignore ( stream -- stream char )
+ dup stream-read1 drop replacement-char ;
+
+: begin-utf16be ( stream byte -- stream char )
+ dup -3 shift 0b11011 number= [
+ dup 0b00000100 bitand zero?
+ [ 0b11 bitand quad-be ]
+ [ drop ignore ] if
+ ] [ double-be ] if ;
+
+M: utf16be decode-char
+ drop dup stream-read1 dup [ begin-utf16be ] when nip ;
+
+! UTF-16LE decoding
+
+: quad-le ( stream ch -- stream char )
+ over stream-read1 swap 10 shift bitor
+ over stream-read1 dup -2 shift 0b110111 = [
+ 0b11 bitand append-nums 0x10000 +
+ ] [ 2drop replacement-char ] if ;
+
+: double-le ( stream byte1 byte2 -- stream char )
+ dup -3 shift 0b11011 = [
+ dup 0b100 bitand 0 number=
+ [ 0b11 bitand 8 shift bitor quad-le ]
+ [ 2drop replacement-char ] if
+ ] [ append-nums ] if ;
+
+: begin-utf16le ( stream byte -- stream char )
+ over stream-read1 [ double-le ] [ drop replacement-char ] if* ;
+
+M: utf16le decode-char
+ drop dup stream-read1 dup [ begin-utf16le ] when nip ;
+
+! UTF-16LE/BE encoding
+
+: encode-first ( char -- byte1 byte2 )
-10 shift
- dup -8 shift BIN: 11011000 bitor
- swap HEX: FF bitand ;
+ [ -8 shift 0b11011000 bitor ] [ 0xFF bitand ] bi ; inline
+
+: encode-second ( char -- byte3 byte4 )
+ 0b1111111111 bitand
+ [ -8 shift 0b11011100 bitor ] [ 0b11111111 bitand ] bi ; inline
+
+: stream-write2 ( char1 char2 stream -- )
+ [ B{ } 2sequence ] dip stream-write ; inline
+ ! [ stream-write1 ] curry bi@ ; inline
-: encode-second
- BIN: 1111111111 bitand
- dup -8 shift BIN: 11011100 bitor
- swap BIN: 11111111 bitand ;
+: char>utf16be ( char stream -- )
+ over 0xFFFF > [
+ [ 0x10000 - ] dip
+ [ [ encode-first ] dip stream-write2 ]
+ [ [ encode-second ] dip stream-write2 ] 2bi
+ ] [ [ h>b/b swap ] dip stream-write2 ] if ; inline
-: char>utf16be ( char -- )
- dup HEX: FFFF > [
- HEX: 10000 -
- dup encode-first swap , ,
- encode-second swap , ,
- ] [ h>b/b , , ] if ;
+M: utf16be encode-char ( char stream encoding -- )
+ drop char>utf16be ;
-: encode-utf16be ( str -- seq )
- [ [ char>utf16be ] each ] B{ } make ;
+: char>utf16le ( char stream -- )
+ over 0xFFFF > [
+ [ 0x10000 - ] dip
+ [ [ encode-first swap ] dip stream-write2 ]
+ [ [ encode-second swap ] dip stream-write2 ] 2bi
+ ] [ [ h>b/b ] dip stream-write2 ] if ; inline
-: char>utf16le ( char -- )
- dup HEX: FFFF > [
- HEX: 10000 -
- dup encode-first , ,
- encode-second , ,
- ] [ h>b/b swap , , ] if ;
+M: utf16le encode-char ( char stream encoding -- )
+ drop char>utf16le ;
-: encode-utf16le ( str -- seq )
- [ [ char>utf16le ] each ] B{ } make ;
+: ascii-char>utf16-byte-array ( off n byte-array string -- )
+ overd string-nth-fast -rot
+ [ 2 fixnum*fast rot fixnum+fast ] dip
+ set-nth-unsafe ; inline
-: bom-le B{ HEX: ff HEX: fe } ; inline
+: ascii-string>utf16-byte-array ( off string -- byte-array )
+ [ length >fixnum [ <iota> ] [ 2 fixnum*fast <byte-array> ] bi ] keep
+ [ [ ascii-char>utf16-byte-array ] 2curry with each ] keepd ; inline
-: bom-be B{ HEX: fe HEX: ff } ; inline
+: ascii-string>utf16le ( string stream -- )
+ [ 0 swap ascii-string>utf16-byte-array ] dip stream-write ; inline
+: ascii-string>utf16be ( string stream -- )
+ [ 1 swap ascii-string>utf16-byte-array ] dip stream-write ; inline
-: encode-utf16 ( str -- seq )
- encode-utf16le bom-le swap append ;
+GENERIC#: encode-string-utf16le 1 ( string stream -- )
-: start-utf16le? ( seq1 -- seq2 ? ) bom-le ?head ;
+M: object encode-string-utf16le
+ [ char>utf16le ] curry each ; inline
-: start-utf16be? ( seq1 -- seq2 ? ) bom-be ?head ;
+M: string encode-string-utf16le
+ over aux>>
+ [ call-next-method ]
+ [ ascii-string>utf16le ] if ; inline
-: decode-utf16 ( seq -- str )
- {
- { [ start-utf16le? ] [ decode-utf16le ] }
- { [ start-utf16be? ] [ decode-utf16be ] }
- { [ t ] [ decode-error ] }
- } cond ;
+M: utf16le encode-string drop encode-string-utf16le ;
-TUPLE: utf16le ;
-INSTANCE: utf16le encoding-stream
+GENERIC#: encode-string-utf16be 1 ( string stream -- )
-M: utf16le encode-string drop encode-utf16le ;
-M: utf16le decode-step drop decode-utf16le-step ;
+M: object encode-string-utf16be
+ [ char>utf16be ] curry each ; inline
-TUPLE: utf16be ;
-INSTANCE: utf16be encoding-stream
+M: string encode-string-utf16be
+ over aux>>
+ [ call-next-method ]
+ [ ascii-string>utf16be ] if ; inline
-M: utf16be encode-string drop encode-utf16be ;
-M: utf16be decode-step drop decode-utf16be-step ;
+M: utf16be encode-string drop encode-string-utf16be ;
-TUPLE: utf16 encoding ;
-INSTANCE: utf16 encoding-stream
-M: utf16 underlying-stream delegate dup delegate [ ] [ ] ?if ; ! necessary?
-M: utf16 set-underlying-stream delegate set-delegate ; ! necessary?
+M: utf16le guess-encoded-length drop 2 * ; inline
+M: utf16le guess-decoded-length drop 2 /i ; inline
-M: utf16 encode-string
- >r encode-utf16le r>
- dup utf16-encoding [ drop ]
- [ t swap set-utf16-encoding bom-le swap append ] if ;
+M: utf16be guess-encoded-length drop 2 * ; inline
+M: utf16be guess-decoded-length drop 2 /i ; inline
+
+! UTF-16
+
+CONSTANT: bom-le B{ 0xff 0xfe }
+
+CONSTANT: bom-be B{ 0xfe 0xff }
: bom>le/be ( bom -- le/be )
dup bom-le sequence= [ drop utf16le ] [
- bom-be sequence= [ utf16be ] [ decode-error ] if
+ bom-be sequence= [ utf16be ] [ missing-bom ] if
] if ;
-: read-bom ( utf16 -- encoding )
- 2 over delegate stream-read bom>le/be construct-empty
- [ swap set-utf16-encoding ] keep ;
+M: utf16 <decoder> ( stream utf16 -- decoder )
+ drop 2 over stream-read bom>le/be <decoder> ;
+
+M: utf16 <encoder> ( stream utf16 -- encoder )
+ drop bom-le over stream-write utf16le <encoder> ;
+
+: le? ( -- ? ) B{ 1 0 0 0 } 0 alien-unsigned-4 1 = ; foldable
+
+PRIVATE>
-M: utf16 decode-step
- ! inefficient: checks if bom is done many times
- ! This should transform itself into utf16be or utf16le after reading BOM
- dup utf16-encoding [ ] [ read-bom ] ?if decode-step ;
+: utf16n ( -- value ) le? utf16le utf16be ? ;
projects / factor.git / blobdiff