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