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: accessors byte-arrays math math.order kernel sequences
   4 sbufs vectors growable io continuations namespaces io.encodings
   5 combinators strings ;
   6 IN: io.encodings.utf8
   7
   8 ! Decoding UTF-8
   9
  10 SINGLETON: utf8
  11
  12 <PRIVATE
  13
  14 : starts-2? ( char -- ? )
  15     dup [ -6 shift BIN: 10 number= ] when ; inline
  16
  17 : append-nums ( stream byte -- stream char )
  18     over stream-read1 dup starts-2?
  19     [ swap 6 shift swap BIN: 111111 bitand bitor ]
  20     [ 2drop replacement-char ] if ; inline
  21
  22 : minimum-code-point ( char minimum -- char )
  23     over > [ drop replacement-char ] when ;
  24
  25 : double ( stream byte -- stream char )
  26     BIN: 11111 bitand append-nums
  27     HEX: 80 minimum-code-point ; inline
  28
  29 : triple ( stream byte -- stream char )
  30     BIN: 1111 bitand append-nums append-nums
  31     HEX: 800 minimum-code-point ; inline
  32
  33 : quadruple ( stream byte -- stream char )
  34     BIN: 111 bitand append-nums append-nums append-nums
  35     HEX: 10000 minimum-code-point ; inline
  36
  37 : begin-utf8 ( stream byte -- stream char )
  38     {
  39         { [ dup -7 shift zero? ] [ ] }
  40         { [ dup -5 shift BIN: 110 = ] [ double ] }
  41         { [ dup -4 shift BIN: 1110 = ] [ triple ] }
  42         { [ dup -3 shift BIN: 11110 = ] [ quadruple ] }
  43         [ drop replacement-char ]
  44     } cond ; inline
  45
  46 : decode-utf8 ( stream -- char/f )
  47     dup stream-read1 dup [ begin-utf8 ] when nip ; inline
  48
  49 M: utf8 decode-char
  50     drop decode-utf8 ; inline
  51
  52 ! Encoding UTF-8
  53
  54 : encoded ( stream char -- )
  55     BIN: 111111 bitand BIN: 10000000 bitor swap stream-write1 ; inline
  56
  57 : char>utf8 ( char stream -- )
  58     swap {
  59         { [ dup -7 shift zero? ] [ swap stream-write1 ] }
  60         { [ dup -11 shift zero? ] [
  61             2dup -6 shift BIN: 11000000 bitor swap stream-write1
  62             encoded
  63         ] }
  64         { [ dup -16 shift zero? ] [
  65             2dup -12 shift BIN: 11100000 bitor swap stream-write1
  66             2dup -6 shift encoded
  67             encoded
  68         ] }
  69         [
  70             2dup -18 shift BIN: 11110000 bitor swap stream-write1
  71             2dup -12 shift encoded
  72             2dup -6 shift encoded
  73             encoded
  74         ]
  75     } cond ; inline
  76
  77 M: utf8 encode-char
  78     drop char>utf8 ;
  79
  80 M: utf8 encode-string
  81     drop
  82     over aux>>
  83     [ [ char>utf8 ] curry each ]
  84     [ [ >byte-array ] dip stream-write ] if ;
  85
  86 PRIVATE>
  87
  88 : code-point-length ( n -- x )
  89     [ 1 ] [
  90         log2 {
  91             { [ dup 0 6 between? ] [ 1 ] }
  92             { [ dup 7 10 between? ] [ 2 ] }
  93             { [ dup 11 15 between? ] [ 3 ] }
  94             { [ dup 16 20 between? ] [ 4 ] }
  95         } cond nip
  96     ] if-zero ;
  97
  98 : code-point-offsets ( string -- indices )
  99     0 [ code-point-length + ] accumulate swap suffix ;
 100
 101 : utf8-index> ( n string -- n' )
 102     code-point-offsets [ <= ] with find drop ;
 103
 104 : >utf8-index ( n string -- n' )
 105     code-point-offsets nth ;