69 lines
1.8 KiB
Factor
69 lines
1.8 KiB
Factor
! Copyright (C) 2009 Daniel Ehrenberg, Jonghyouk Yun.
|
|
! See http://factorcode.org/license.txt for BSD license.
|
|
USING: kernel io.encodings accessors assocs sequences biassocs generic
|
|
math.order simple-flat-file io io.binary byte-arrays locals combinators
|
|
words classes.singleton fry classes.parser parser quotations ;
|
|
IN: io.encodings.euc
|
|
|
|
TUPLE: euc { table biassoc } ;
|
|
|
|
<PRIVATE
|
|
|
|
: byte? ( ch -- ? )
|
|
0x0 0xff between? ;
|
|
|
|
M: euc encode-char ( char stream encoding -- )
|
|
swapd table>> value-at [
|
|
dup byte?
|
|
[ swap stream-write1 ] [
|
|
h>b/b swap 2byte-array
|
|
swap stream-write
|
|
] if
|
|
] [ encode-error ] if* ;
|
|
|
|
: euc-multibyte? ( ch -- ? )
|
|
0x81 0xfe between? ;
|
|
|
|
:: decode-multibyte ( ch stream encoding -- char )
|
|
stream stream-read1
|
|
[ ch swap 2byte-array be> encoding table>> at ]
|
|
[ replacement-char ] if* ;
|
|
|
|
M:: euc decode-char ( stream encoding -- char/f )
|
|
stream stream-read1
|
|
{
|
|
{ [ dup not ] [ drop f ] }
|
|
{ [ dup euc-multibyte? ] [ stream encoding decode-multibyte ] }
|
|
[ encoding table>> at ]
|
|
} cond ;
|
|
|
|
: define-method ( class word definition -- )
|
|
[ create-method ] dip define ;
|
|
|
|
SYMBOL: euc-table
|
|
|
|
: setup-euc ( word file-name -- singleton-class biassoc )
|
|
[ dup define-singleton-class ]
|
|
[ flat-file>biassoc ] bi* ;
|
|
|
|
:: define-recursive-methods ( class data words -- )
|
|
words [| word |
|
|
class word [ drop data word execute ] define-method
|
|
] each ;
|
|
|
|
: euc-methods ( singleton-class biassoc -- )
|
|
[ euc-table set-word-prop ] [
|
|
euc boa
|
|
{ <encoder> <decoder> }
|
|
define-recursive-methods
|
|
] 2bi ;
|
|
|
|
: define-euc ( word file-name -- )
|
|
setup-euc euc-methods ;
|
|
|
|
PRIVATE>
|
|
|
|
SYNTAX: EUC:
|
|
! EUC: euc-kr "vocab:io/encodings/korean/cp949.txt"
|
|
scan-new-class scan-object define-euc ;
|