basis/io/encodings/utf32/utf32.factor

   1 ! Copyright (C) 2009 Daniel Ehrenberg.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: math kernel io.encodings combinators io io.encodings.utf16
   4 sequences io.binary io.encodings.iana ;
   5 IN: io.encodings.utf32
   6
   7 SINGLETON: utf32be
   8
   9 utf32be "UTF-32BE" register-encoding
  10
  11 SINGLETON: utf32le
  12
  13 utf32le "UTF-32LE" register-encoding
  14
  15 SINGLETON: utf32
  16
  17 utf32 "UTF-32" register-encoding
  18
  19 <PRIVATE
  20
  21 ! Decoding
  22
  23 : char> ( stream encoding quot -- ch )
  24     nip swap 4 swap stream-read dup length {
  25         { 0 [ 2drop f ] }
  26         { 4 [ swap call ] }
  27         [ 3drop replacement-char ]
  28     } case ; inline
  29
  30 M: utf32be decode-char
  31     [ be> ] char> ;
  32
  33 M: utf32le decode-char
  34     [ le> ] char> ;
  35
  36 ! Encoding
  37
  38 : >char ( char stream encoding quot -- )
  39     nip 4 swap curry dip stream-write ; inline
  40
  41 M: utf32be encode-char
  42     [ >be ] >char ;
  43
  44 M: utf32le encode-char
  45     [ >le ] >char ;
  46
  47 ! UTF-32
  48
  49 CONSTANT: bom-le B{ 0xff 0xfe 0 0 }
  50
  51 CONSTANT: bom-be B{ 0 0 0xfe 0xff }
  52
  53 : bom>le/be ( bom -- le/be )
  54     dup bom-le sequence= [ drop utf32le ] [
  55         bom-be sequence= [ utf32be ] [ missing-bom ] if
  56     ] if ;
  57
  58 M: utf32 <decoder> ( stream utf32 -- decoder )
  59     drop 4 over stream-read bom>le/be <decoder> ;
  60
  61 M: utf32 <encoder> ( stream utf32 -- encoder )
  62     drop bom-le over stream-write utf32le <encoder> ;