Patch title: Release 93 bulk changes
Abstract:
File: /language/stream/lzw.pli
Key:
    Removed line
    Added line
   
module "/pliant/language/unsafe.pli"
module "/pliant/language/stream.pli"
module "/pliant/language/stream/filesystembase.pli"
module "/pliant/language/stream/multi.pli"


constant INIT_CODE_SIZE 9

function INIT_HASH p -> h # Initial hash value
  arg Int p h
  h := (p+3)*301 

constant CLEAR_CODE 100h
constant EOI_CODE 101h
constant READ_BUF_SIZE 32768
constant WRITE_BUF_SIZE 32768

type DICT
  field uInt tail
  field Byte col


type LzwUncompressStreamDriver
  # uncompress
  field Int inx size # Index and size in bits
  field Int code_size # Number of bits to return at once
  field Int read_mask # 2^code_size-1
  field Int16 max_code # 1 << code_size
  field Int clear_code # Code to clear table
  field Int eoi_code # End of information code
  field Int first_free_code # First free code
  field Int free_code # Next available free code slot
  field Int dictionary_size
  field Int out_count ; field uInt16 old_code fin_char
  field Address prefix suffix outcode
  field CBool table_full
  field Address buffer # Buffer holding bits
  field Address cache cache_start cache_stop
  field CBool eof
  field Link:Stream cpr

StreamDriver maybe LzwUncompressStreamDriver


type LzwCompressStreamDriver
  field Array:DICT dict
  field (Array Pointer:DICT) hashtable
  field Link:Stream cpr

StreamDriver maybe LzwCompressStreamDriver


method drv read_code -> code
  oarg_rw LzwUncompressStreamDriver drv ; arg Int code
  implicit drv
    if inx+code_size>size
      var Int bytes_to_lose := inx\2^3
      memory_copy (buffer translate Byte bytes_to_lose) buffer 3
      inx := inx .and. 7 ; size -= bytes_to_lose*2^3
      var Int bytes := READ_BUF_SIZE-size\2^3
      cpr raw_read (buffer translate Byte size\2^3) bytes
      size += bytes*2^3
    var Address buf := buffer translate Byte inx\2^3
    var Int raw_code := ( (buf map uInt8 0)*2^16 + (buf map uInt8 1)*2^8 + (buf map uInt8 2) )*2^(inx .and. 7)\2^(24-code_size)
    buf := buf translate uInt8 3
    inx += code_size
    code := raw_code .and. read_mask

method drv read adr mini maxi -> red
  oarg_rw LzwUncompressStreamDriver drv ; arg Address adr ; arg Int mini maxi red
  implicit drv
    if eof
      return 0
    var Address curset := adr
    var Address stop := curset translate Byte (max mini maxi\2)
    var Address stop2 := curset translate Byte maxi
    if cache_stop<>cache_start
      var Int use := min (cast cache_stop Int).-.(cast cache_start Int) (cast stop2 Int).-.(cast curset Int)
      memory_copy cache_start curset use
      curset := curset translate Byte use; cache_start := cache_start translate Byte use
    while (cast curset Int).-.(cast stop Int)<0
      var Int code := read_code
      if code=eoi_code
        eof := true
        return (cast curset Int).-.(cast adr Int)
      eif code=clear_code
        code_size := INIT_CODE_SIZE
        read_mask := 2^INIT_CODE_SIZE-1
        max_code := 2^INIT_CODE_SIZE
        free_code := first_free_code
        code := read_code
        old_code := code
        if code=eoi_code
          eof := true
          return (cast curset Int).-.(cast adr Int)
        fin_char := code
        curset map uInt8 := code ; curset := curset translate uInt8 1
        table_full := false
      else
        var Int in_code := code
        if code>=free_code
          code := old_code
          outcode map uInt16 out_count := fin_char ; out_count += 1
        while code>0FFh
          if out_count>dictionary_size
            # notice_crash("corrupted file");
            return 0
          outcode map uInt16 out_count := suffix map uInt16 code ; out_count += 1
          code := prefix map uInt16 code
        fin_char := code
        outcode map uInt16 out_count := fin_char ; out_count += 1
        if out_count<=(cast stop2 Int).-.(cast curset Int)
          while out_count>0
            out_count -= 1 ; curset map uInt8 := outcode map uInt16 out_count ; curset := curset translate uInt8
        else
          while curset<>stop2
            out_count -= 1 ; curset map uInt8 := outcode map uInt16 out_count ; curset := curset translate uInt8
          cache_start := cache
          cache_stop := cache
          while out_count>0
            out_count -= 1 ; cache_stop map uInt8 := outcode map uInt16 out_count ; cache_stop := cache_stop translate uInt8
        if not table_full
          prefix map uInt16 free_code := old_code
          suffix map uInt16 free_code := fin_char
          free_code += 1
          if free_code>=max_code-1
            if code_size<12
              code_size +=1
              max_code*=2
              read_mask := 2^code_size-1
            else
              table_full := true
        old_code := in_code
    return (cast curset Int).-.(cast adr Int)


method drv write_code code0
  oarg_rw LzwCompressStreamDriver drv ; arg Int code0
  implicit drv
    var Int code := code*2^(24-code_size)\2^(inx .and. 7)
    var Address buf := buffer translate Byte inx\2^3
    buf map uInt8 := (buf map uInt8) .or. code\2^16
    buf map uInt8 1 := code\2^8 .and. 0FFh
    buf map uInt8 2 := code .and. 0FFh
    buf := buf translate uInt8 3
    inx += code_size
    if inx>=WRITE_BUF_SIZE*8
      cpr raw_write buffer WRITE_BUF_SIZE
      memory_copy (buffer translate Byte WRITE_BUF_SIZE) buffer 2
      memory_clear (buffer translate Byte 2) WRITE_BUF_SIZE
      inx -= WRITE_BUF_SIZE*8

method drv write adr mini maxi -> written
  oarg_rw LzwCompressStreamDriver drv ; arg Address adr ; arg Int mini maxi written
  implicit drv
    var Address curset := adr ; var Address stop := curset translate Byte maxi
    while curset<>stop
      var Int col := curset map uInt8 ; curset := curset translate uInt8
      lenstring += 1
      if lenstring=1
        tail := col
        hashvalue := INIT_HASH col
      else
        hashvalue *= col + lenstring + 4
        hashvalue %= hash_size
        var Int j := hashvalue
        while (exists hashtable:j) and (hashtable:j:tail<>tail || hashtable[j]->col != col))
          j += 1
          if h>=hash_size
            j := 0
        if(hashtable[j] != NULL) {
          tail = (hashtable[j]-dict);
        else
          write_code(tail);
          hashtable[j]       = dict + ++last_code;
          hashtable[j]->tail = tail;
          hashtable[j]->col  = col;
          tail               = col;
          hashvalue          = INIT_HASH(col);
          lenstring          = 1;
          if (last_code >= max_code-1) {
            max_code <<= 1;
            code_size++;
          orif(last_code >= dictionary_size-2)
            write_code(tail),write_code(CLEAR_CODE);
            lenstring = 0;
            last_code = EOI_CODE;
            code_size = INIT_CODE_SIZE;
            max_code = ( 1 << INIT_CODE_SIZE );
            mem_clear(hashtable,hash_size); } } } }
    written := maxi


method drv query command stream answer -> status
  oarg_rw LzwStreamDriver drv ; arg Str command ; arg_rw Stream stream ; arg_w Str answer ; arg ExtendedStatus status 
  status := drv:cpr:stream_driver query command drv:cpr answer


method drv close -> status
  oarg_rw LzwStreamDriver drv ; arg ExtendedStatus status


type LzwFileSystem
  void
FileSystem maybe LzwFileSystem

method fs open name options flags stream support -> status
  oarg_rw LzwFileSystem fs ; arg Str name options ; arg Int flags ; arg_rw Stream stream support ; arg ExtendedStatus status
  var Link:LzwStreamDriver drv :> new LzwStreamDriver
  if exists:support
    drv cpr :> support
  else
    drv cpr :> new Stream
    drv:cpr open name options (flags .and. in+out+append+safe)
    if drv:cpr=failure
      return failure
  
  implicit drv
    dictionary_size := options option "dictionary_size" Int 4096
    eof := false
    inx := 0
    size := 0
    code_size := INIT_CODE_SIZE
    read_mask := 2^INIT_CODE_SIZE-1 
    out_count := 0
    table_full := false
    buffer := memory_allocate READ_BUF_SIZE+3 addressof:drv
    prefix := memory_allocate dictionary_size*uInt16:size addressof:drv
    suffix := memory_allocate dictionary_size*uInt16:size addressof:drv
    outcode := memory_allocate (dictionary_size+1)*uInt16:size addressof:drv
    cache := memory_allocate (dictionary_size+1)*uInt16:size addressof:drv
    cache_start := null
    cache_stop := null
    # 2^min_code size accounts for all colours in file
    clear_code := 2^INIT_CODE_SIZE-1
    eoi_code := clear_code+1
    free_code := clear_code+2
    first_free_code := clear_code+2
    max_code := 2^INIT_CODE_SIZE
  stream stream_driver :> drv
  status := success

gvar LzwFileSystem lzw_file_system
pliant_multi_file_system mount "lzw:" "" lzw_file_system