core/io/encodings/utf8/utf8.factor

   1 ! Copyright (C) 2006, 2008 Daniel Ehrenberg.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: math kernel sequences sbufs vectors growable io continuations
   4 namespaces io.encodings combinators strings ;
   5 IN: io.encodings.utf8
   6
   7 ! Decoding UTF-8
   8
   9 SINGLETON: utf8
  10
  11 <PRIVATE
  12
  13 : starts-2? ( char -- ? )
  14     dup [ -6 shift BIN: 10 number= ] when ; inline
  15
  16 : append-nums ( stream byte -- stream char )
  17     over stream-read1 dup starts-2?
  18     [ swap 6 shift swap BIN: 111111 bitand bitor ]
  19     [ 2drop replacement-char ] if ; inline
  20
  21 : double ( stream byte -- stream char )
  22     BIN: 11111 bitand append-nums ; inline
  23
  24 : triple ( stream byte -- stream char )
  25     BIN: 1111 bitand append-nums append-nums ; inline
  26
  27 : quadruple ( stream byte -- stream char )
  28     BIN: 111 bitand append-nums append-nums append-nums ; inline
  29
  30 : begin-utf8 ( stream byte -- stream char )
  31     {
  32         { [ dup -7 shift zero? ] [ ] }
  33         { [ dup -5 shift BIN: 110 number= ] [ double ] }
  34         { [ dup -4 shift BIN: 1110 number= ] [ triple ] }
  35         { [ dup -3 shift BIN: 11110 number= ] [ quadruple ] }
  36         [ drop replacement-char ]
  37     } cond ; inline
  38
  39 : decode-utf8 ( stream -- char/f )
  40     dup stream-read1 dup [ begin-utf8 ] when nip ; inline
  41
  42 M: utf8 decode-char
  43     drop decode-utf8 ;
  44
  45 ! Encoding UTF-8
  46
  47 : encoded ( stream char -- )
  48     BIN: 111111 bitand BIN: 10000000 bitor swap stream-write1 ;
  49
  50 : char>utf8 ( stream char -- )
  51     {
  52         { [ dup -7 shift zero? ] [ swap stream-write1 ] }
  53         { [ dup -11 shift zero? ] [
  54             2dup -6 shift BIN: 11000000 bitor swap stream-write1
  55             encoded
  56         ] }
  57         { [ dup -16 shift zero? ] [
  58             2dup -12 shift BIN: 11100000 bitor swap stream-write1
  59             2dup -6 shift encoded
  60             encoded
  61         ] }
  62         [
  63             2dup -18 shift BIN: 11110000 bitor swap stream-write1
  64             2dup -12 shift encoded
  65             2dup -6 shift encoded
  66             encoded
  67         ]
  68     } cond ;
  69
  70 M: utf8 encode-char
  71     drop swap char>utf8 ;
  72
  73 PRIVATE>