basis/io/encodings/8-bit/8-bit.factor

   1 ! Copyright (C) 2008 Daniel Ehrenberg, Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: arrays assocs biassocs kernel io.encodings math.parser
   4 sequences hashtables io.encodings.ascii generic parser
   5 classes.tuple words words.symbol io io.files splitting
   6 namespaces math compiler.units accessors classes.singleton
   7 classes.mixin io.encodings.iana fry simple-flat-file lexer ;
   8 IN: io.encodings.8-bit
   9
  10 <PRIVATE
  11
  12 : encoding-file ( file-name -- stream )
  13     "vocab:io/encodings/8-bit/" ".TXT" surround ;
  14
  15 SYMBOL: 8-bit-encodings
  16 8-bit-encodings [ H{ } clone ] initialize
  17
  18 TUPLE: 8-bit { biassoc biassoc read-only } ;
  19
  20 : 8-bit-encode ( char 8-bit -- byte )
  21     biassoc>> value-at [ encode-error ] unless* ; inline
  22
  23 M: 8-bit encode-char
  24     swap [ 8-bit-encode ] dip stream-write1 ;
  25
  26 M: 8-bit encode-string
  27     swap [ '[ _ 8-bit-encode ] B{ } map-as ] dip stream-write ;
  28
  29 M: 8-bit decode-char
  30     swap stream-read1 dup
  31     [ swap biassoc>> at [ replacement-char ] unless* ]
  32     [ 2drop f ]
  33     if ;
  34
  35 MIXIN: 8-bit-encoding
  36
  37 M: 8-bit-encoding <encoder>
  38     8-bit-encodings get-global at <encoder> ;
  39
  40 M: 8-bit-encoding <decoder>
  41     8-bit-encodings get-global at <decoder> ;
  42
  43 : create-encoding ( name -- word )
  44     create-word-in
  45     [ define-singleton-class ]
  46     [ 8-bit-encoding add-mixin-instance ]
  47     [ ] tri ;
  48
  49 : load-encoding ( name iana-name file-name -- )
  50     [ create-encoding dup ]
  51     [ register-encoding ]
  52     [ encoding-file flat-file>biassoc 8-bit boa ] tri*
  53     swap 8-bit-encodings get-global set-at ;
  54
  55 PRIVATE>
  56
  57 SYNTAX: 8-BIT: scan-token scan-token scan-token load-encoding ;