basis/io/encodings/euc/euc.factor

   1 ! Copyright (C) 2009 Daniel Ehrenberg, Jonghyouk Yun.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors assocs biassocs byte-arrays classes.parser
   4 classes.singleton combinators endian generic io io.encodings
   5 kernel math.bitwise math.order parser sequences simple-flat-file
   6 words ;
   7 IN: io.encodings.euc
   8
   9 TUPLE: euc { table biassoc read-only } ;
  10
  11 <PRIVATE
  12
  13 : byte? ( ch -- ? )
  14     0x0 0xff between? ;
  15
  16 M: euc encode-char
  17     swapd table>> value-at [
  18         dup byte?
  19         [ swap stream-write1 ] [
  20             h>b/b swap 2byte-array
  21             swap stream-write
  22         ] if
  23     ] [ encode-error ] if* ;
  24
  25 : euc-multibyte? ( ch -- ? )
  26     0x81 0xfe between? ;
  27
  28 :: decode-multibyte ( ch stream encoding -- char )
  29     stream stream-read1
  30     [ ch swap 2byte-array be> encoding table>> at ]
  31     [ replacement-char ] if* ;
  32
  33 M:: euc decode-char ( stream encoding -- char/f )
  34     stream stream-read1
  35     {
  36         { [ dup not ] [ drop f ] }
  37         { [ dup euc-multibyte? ] [ stream encoding decode-multibyte ] }
  38         [ encoding table>> at ]
  39     } cond ;
  40
  41 : define-method ( class word definition -- )
  42     [ create-method ] dip define ;
  43
  44 SYMBOL: euc-table
  45
  46 : setup-euc ( word file-name -- singleton-class biassoc )
  47     [ dup define-singleton-class ]
  48     [ load-codetable-file ] bi* ;
  49
  50 :: define-recursive-methods ( class data words -- )
  51     words [| word |
  52         class word [ drop data word execute ] define-method
  53     ] each ;
  54
  55 : euc-methods ( singleton-class biassoc -- )
  56     [ euc-table set-word-prop ] [
  57         euc boa
  58         { <encoder> <decoder> }
  59         define-recursive-methods
  60     ] 2bi ;
  61
  62 : define-euc ( word file-name -- )
  63     setup-euc euc-methods ;
  64
  65 PRIVATE>
  66
  67 SYNTAX: EUC:
  68     ! EUC: euc-kr "vocab:io/encodings/korean/cp949.txt"
  69     scan-new-class scan-object define-euc ;