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 generalizations sequences ;
   5 IN: io.encodings.utf32
   6
   7 SINGLETON: utf32be
   8
   9 SINGLETON: utf32le
  10
  11 SINGLETON: utf32
  12
  13 <PRIVATE
  14
  15 : 4spin ( a b c d -- b c d a )
  16     4 nrev ; inline
  17
  18 ! Decoding
  19
  20 : stream-read4 ( stream -- a b c d )
  21     {
  22         [ stream-read1 ]
  23         [ stream-read1 ]
  24         [ stream-read1 ]
  25         [ stream-read1 ]
  26     } cleave ;
  27
  28 : with-replacement ( _ _ _ ch quot -- new-ch )
  29     [ 3drop replacement-char ] if* ; inline
  30
  31 : >char ( d c b a -- abcd )
  32     [
  33         24 shift -roll [
  34             16 shift -rot [
  35                 8 shift swap [
  36                     bitor bitor bitor
  37                 ] with-replacement
  38             ] with-replacement
  39         ] with-replacement
  40     ] with-replacement ;
  41
  42 M: utf32be decode-char
  43     drop stream-read4 4spin
  44     [ >char ] [ 3drop f ] if* ;
  45
  46 M: utf32le decode-char
  47     drop stream-read4 4 npick
  48     [ >char ] [ 2drop 2drop f ] if ;
  49
  50 ! Encoding
  51
  52 : split-off ( ab -- b a )
  53     [ HEX: FF bitand ] [ -8 shift ] bi ;
  54
  55 : char> ( abcd -- d b c a )
  56     split-off split-off split-off ;
  57
  58 : stream-write4 ( d c b a stream -- )
  59     {
  60         [ stream-write1 ]
  61         [ stream-write1 ]
  62         [ stream-write1 ]
  63         [ stream-write1 ]
  64     } cleave ;
  65
  66 M: utf32be encode-char
  67     drop [ char> ] dip stream-write4 ;
  68
  69 M: utf32le encode-char
  70     drop [ char> 4spin ] dip stream-write4 ;
  71
  72 ! UTF-32
  73
  74 : bom-le B{ HEX: ff HEX: fe 0 0 } ; inline
  75
  76 : bom-be B{ 0 0 HEX: fe HEX: ff } ; inline
  77
  78 : bom>le/be ( bom -- le/be )
  79     dup bom-le sequence= [ drop utf32le ] [
  80         bom-be sequence= [ utf32be ] [ missing-bom ] if
  81     ] if ;
  82
  83 M: utf32 <decoder> ( stream utf32 -- decoder )
  84     drop 4 over stream-read bom>le/be <decoder> ;
  85
  86 M: utf32 <encoder> ( stream utf32 -- encoder )
  87     drop bom-le over stream-write utf32le <encoder> ;