UNIT lib_rw;  {-*-Mode: fundamental-mode}
INTERFACE
USES base, dictionary, gpc;

(*----------- INTERFACE: Presentation of data primitives --------------------------*)
type
  lib_control_t  = (version, index,                 {up to 255 controls allowed}
                    dic_keyword, dic_identifier,    {typically take 2 bytes on disk file}
                    program_name, module_name,      {more frequently used controls occupy}
                    end_list);                      {single byte on disk file (e.g. end_list)}

  keyword_t      = 0 .. 383;                        { maximum is 128 + 256 -1 = 383}

  obj_type_t     = (kw, id, bool, ch, int, r4, r8, str, ctrl, eop);  {kept short in order to keep text files short}

  lib_handle_p_t = ^lib_handle_t;
  lib_handle_t   = record
                     fh             : file of char;
                     r_open, w_open : boolean;
                     case obj_type_t of             {return values with different types}
                       kw   : (v_keyword    : keyword_t);
                       id   : (v_identifier : dic_indx);
                       bool : (v_boolean    : boolean);
                       ch   : (v_char       : char);
                       int  : (v_ShortInt   : integer);
                       r4   : (v_real       : real);
                       r8   : (v_double     : double);
                       str  : (v_string     : dic_sym);
                       ctrl : (v_control    : lib_control_t);
                       eop  : ();
                       end;

procedure lib_open_read      (var h: lib_handle_p_t; path_name    : path_name_t);              
procedure lib_open_write     (var h: lib_handle_p_t; path_name    : path_name_t);               
procedure lib_close          (var h: lib_handle_p_t);

procedure lib_put_keyword    (h: lib_handle_p_t; val_keyword      : keyword_t);{0 .. 383}      
procedure lib_put_identifier (h: lib_handle_p_t; val_identifier   : dic_indx);  {1 .. 2**16-1}  
procedure lib_put_boolean    (h: lib_handle_p_t; val_boolean      : boolean);                   
procedure lib_put_char       (h: lib_handle_p_t; val_char         : char);                      
procedure lib_put_ShortInt   (h: lib_handle_p_t; val_int          : integer);                
procedure lib_put_real       (h: lib_handle_p_t; val_real         : real);                     
procedure lib_put_double     (h: lib_handle_p_t; val_double       : double);                   
procedure lib_put_string     (h: lib_handle_p_t; val_string       : dic_sym);                
procedure lib_put_control    (h: lib_handle_p_t; val_control      : lib_control_t);            

function  lib_get_record     (h: lib_handle_p_t): obj_type_t;                                     

(*  {problems with read/write enumerated types}
procedure lib_ascii_to_bin   (asc_path_name, bin_path_name           : path_name_t);              
procedure lib_bin_to_ascii   (bin_path_name, asc_path_name           : path_name_t);              
*)

IMPLEMENTATION
const
 {Basic Class           Header byte       Extentions          range/subclass/value          }
 {------------------------------------------------------------------------------------------}
  keyword_0     =  0;  {0 k k k k k k k                          0 .. 127                   }
  identifier_1  =128;  {1 0 0 i i i i i   i i i i i i i i        1 .. 2**13-1               }
  c_int_0       =160;  {1 0 1 i i i i i                        -16 .. 15                    }
  c_str_0       =192;  {1 1 0 n n n n n   0 .. 31 chars         '' .. 'up to 31 bytes'      }

  identifier_2  =224;  {1 1 1 0 0 0 0 0   i1 i0              2**13 .. 2**16-1               }
  c_real_4      =225;  {1 1 1 0 0 0 0 1   r3 r2 r1 r0           IEEE real                   }
  c_real_8      =226;  {1 1 1 0 0 0 1 0   d7 .. d0              IEEE double                 }
  keyword_1     =227;  {1 1 1 0 0 0 1 1   k                    128 .. 128+k (max=383)       }
  c_int_1       =228;  {1 1 1 0 0 1 0 0   i0                 -2**7 .. 2**7-1                }
  c_int_2       =229;  {1 1 1 0 0 1 0 1   i1 i0             -2**15 .. 2**15-1               }
  c_int_4       =230;  {1 1 1 0 0 1 1 0   i3 i2 i1 i0       -2**31 .. 2**31-1               }
  c_int_8       =231;  {1 1 1 0 0 1 1 1   i7 .. i0          -2**63 .. 2**63-1 not supported }
  c_str_1       =232;  {1 1 1 0 1 0 0 0   n     n-chars         '' .. 'up to 255 chars'     }
  c_str_2       =233;  {1 1 1 0 1 0 0 1   n1 n0 n-chars         '' .. 'up to 2**16-1 chars' }
  lib_control_0 =234;  {1 1 1 0 1 0 1 0   c0                     0 .. 255                   }
  lib_control_1 =235;  {1 1 1 0 1 0 1 1                          end_list (space saving)    }
  lib_e_o_f     =236;  {1 1 1 0 1 1 0 0                          Library last byte (EOF)    }
  c_bool_0      =237;  {1 1 1 0 1 1 0 1                          false                      }
  c_bool_1      =238;  {1 1 1 0 1 1 1 0                          true                       }
  c_char        =239;  {1 1 1 0 1 1 1 1   char                   character                  }
                       {Values above 239 reserved                                           }

type
  common_t = record case obj_type_t of  {used for type conversion from and to char}
              kw         : (b1, b0, b3, b2, b5, b4, b7, b6 : char);         {general byte presentation}
              id         : (x2                             : dic_indx);      {unsigned 2 byte ShortInt}
              int        : (i4                             : integer);    {signed 4 byte ShortInt}
              r4         : (real4                          : real);         {IEEE float}
              r8         : (real8                          : double);       {IEEE float double}
              str        : (i2                             : ShortInt);    {converts length (str)}
              ctrl       : (LC                             : lib_control_t);{enumerated lib control}
              eop        : ();                                              {Library end of file}
              end;

procedure fault (err: ShortInt); 
begin writeln ('Error: ', err:3); abort ('Error in lib.module') end;

procedure lib_open_read    (var h: lib_handle_p_t; path_name : path_name_t);
begin
  new (h);
  with h^ do
    begin     {file must exist, reopening an already open file aborts the program}
      assign (fh, path_name);
      reset (fh); w_open:= false; r_open:= true
    end
end;

procedure lib_open_write   (var h: lib_handle_p_t; path_name : path_name_t);
begin
  new (h);
  with h^ do
    begin     {file may exist or not, reopening an already open file aborts the program}
      assign  (fh, path_name);
      rewrite (fh); w_open:= true; r_open:= false
    end
end;

procedure lib_close      (var h: lib_handle_p_t);
begin
  with h^ do
    begin                                               {closing a never opened file crashes the program}
      if w_open=r_open then fault (1);                  {file open (both or none) is an error}
      if w_open then write (fh, char (lib_e_o_f));      {automatically append end_of_file}
      close (fh);                                       {close the file}
    end;
  dispose (h);                                          {give up control block}
  h:= nil                                               {invalidate the handle}
end;

procedure lib_put_keyword       (h: lib_handle_p_t; val_keyword      : keyword_t);  {0 .. 384}
begin
with h^ do if w_open
 then
  begin
    if val_keyword <= 127
      then write (fh, chr (val_keyword))                         {  0 .. 127, header with immediade data}
      else if val_keyword <= 383
         then write (fh, chr (keyword_1), chr (val_keyword-128)) {128 .. 383, header + 0..255}
         else fault (2) {put_keyword: val_keyword > 383}
  end
 else fault (3) {file not open}
end;  {put_keyword}

procedure lib_put_identifier    (h: lib_handle_p_t; val_identifier   : dic_indx);  {1 .. 2**16-1}
var common : common_t;
begin
with h^, common do if w_open
 then
  begin
    x2:= val_identifier;
    if x2 < 2 pow 13
      then write (fh, chr (identifier_1 + ord (b1)), b0) {}
      else write (fh, chr (identifier_2), b1, b0)        {}
  end
 else fault (4) {file not open}
end;

procedure lib_put_boolean    (h: lib_handle_p_t; val_boolean      : boolean);
var common : common_t;
begin
with h^, common do if w_open
 then if val_boolean then write (fh, chr (c_bool_1))
                     else write (fh, chr (c_bool_0))
 else fault (5) {file not open}
end; 

procedure lib_put_char       (h: lib_handle_p_t; val_char         : char);
var common : common_t;
begin
with h^, common do if w_open
 then write (fh, chr (c_char), val_char)
 else fault (5) {file not open}
end;

procedure lib_put_ShortInt (h: lib_handle_p_t; val_int: integer);
var common : common_t; 
begin 
with h^, common do if w_open 
 then 
   begin 
     i4:= val_int;
     if (i4 >= -16) and (i4 < 16)                                                                {write first high then low order bytes}
        then                                           write (fh, chr (c_int_0 + i4 and 31))     {write 1 byte     -16 .. 15}
        else if (i4 >= -128) and (i4 < 128)
               then                                    write (fh, chr (c_int_1),             b2) {write 2 bytes  -2**7 .. 2**7-1}
               else if (i4 >= -2 pow 15) and (i4 < 2 pow 15)
                      then                             write (fh, chr (c_int_2),         b3, b2) {write 3 bytes -2**15 .. 2**15-1}
                      else                             write (fh, chr (c_int_4), b1, b0, b3, b2) {write 5 bytes -2**31 .. 2**31-1}
                                                                                                 {64 bit ShortInt not supported}
   end 
 else fault (5) {file not open} 
end;

procedure lib_put_real    (h: lib_handle_p_t; val_real   : real);
var common : common_t;
begin
with h^, common do if w_open
 then
   begin
     real4:= val_real;
     write (fh, chr (c_real_4), b1, b0, b3, b2)            {write 5 bytes IEEE real 4}
   end
 else fault (6) {file not open}
end;

procedure lib_put_double  (h: lib_handle_p_t; val_double : double);
var common : common_t;
begin
with h^, common do if w_open
 then
   begin
     real8:= val_double;
     write (fh, chr (c_real_8), b1, b0, b3, b2, b5, b4, b7, b6) {write 5 bytes IEEE real 8}
   end
 else fault (7) {file not open}
end;

procedure lib_put_string  (h: lib_handle_p_t; val_string : dic_sym);
var common : common_t; i:ShortInt;
begin
with h^, common do if w_open
 then
   begin
     i2:= length (val_string);
     if i2 < 0 then fault (8);                             {length (str) < 0 is fatal error}
     if i2<=31
       then write (fh, chr (c_str_0 + i2 and 31))          {length (str)   0 .. 31}
       else if i2 <= 255
         then write (fh, chr (c_str_1),     b0)            {length (str)  32 .. 255}
         else write (fh, chr (c_str_2), b1, b0);           {length (str) 256 .. 2**15-1}
     for i:= 1 to i2 do write (fh, val_string [i])
   end
 else fault (9) {file not open}
end;

procedure lib_put_control   (h: lib_handle_p_t; val_control  : lib_control_t);
var common : common_t; i: ShortInt;
begin
with h^, common do if w_open
 then
   if val_control=end_list
     then write (fh, chr (lib_control_1))                             {space saving for end_list}
     else
       begin
         i:= ord (val_control);                   { ha ha: chr (val_control) dosn't work}
         write (fh, chr (lib_control_0), chr (i)) {less frequent controls take 2 bytes}
       end
 else fault (10) {file not open}
end;

function  lib_get_record    (h: lib_handle_p_t): obj_type_t;
var common : common_t;
  procedure sign_extend (sign: integer);
  begin                                    {             s           s        s            s   }
    with common, h^ do if (i4 and sign)=0  {remember:  00100 - 1 = 00011; ~(00100 - 1) = 11100 }
       then v_ShortInt:=i4 and (sign-1)    {i4 is positive, mask out high order bits to zero}
       else v_ShortInt:=i4 or {~}(sign-1); {ERROR, test, no GPC-negate?? i4 is negative, or ones into high order bits}
    lib_get_record:= int                   {set return type for all ShortInts here}
  end;

  procedure read_str; {length is in common.i2}
  var i: ShortInt;
  begin
    with common, h^ do
      begin
        {length (v_string):= i2;} {$X+}  SetLength (v_string, i2); {$X-}
        {check length should be done here}
        for i:=1 to length (v_string) do begin read (fh, b0); v_string [i]:= b0 end;
        lib_get_record:= str
      end
  end;

begin
with h^, common do if r_open
 then
   begin
     i4:= 0;                                           {initialize 4 bytes to 0}
     read (fh, b0);
     case (ord (b0) shr 5) and 7 of                    {isolate 3 high order bits}
      0, 1, 2, 3:
         begin                                         {keyword_0, 0 .. 127}
           v_identifier   := x2;                       {v_identifier used for type transformation to keyword_t}
           lib_get_record := kw
         end;
      4: begin                                         {identifier_1, 1 .. 2**13-1}
           b1:= chr (ord (b0) and 31);                 {warning: byte order may be wrong}
           read (fh, b0);
           v_identifier   := x2;
           lib_get_record := id
         end;
      5: begin
           b2:= b0;
           sign_extend (2 pow 4)                       {c_int_0, -16 .. 15}
         end;
      6: begin b0:= chr (ord (b0) and 31); read_str end; {c_str_0, up to 31 chars}
      7: case ord (b0) of
           identifier_2  : begin
                             read (fh, b1, b0);
                             v_identifier   := x2;
                             lib_get_record := id
                           end;
           c_real_4      : begin
                             read (fh, b1, b0, b3, b2);
                             v_real         := real4;
                             lib_get_record := r4
                           end;
           c_real_8      : begin
                             read (fh, b1, b0, b3, b2, b5, b4, b7, b6);
                             v_double       := real8;
                             lib_get_record := r8
                           end;
           keyword_1     : begin                           {keyword_1, 128 + (0 .. 2**8-1)}
                             read (fh, b0);
                             v_identifier   := x2 + 128;   {v_identifier used for type transformation to keyword_t}
                             lib_get_record := kw
                           end; 
           c_int_1       : begin read (fh,             b2); sign_extend (2 pow  7) end;  {ShortInt*1}
           c_int_2       : begin read (fh,         b3, b2); sign_extend (2 pow 15) end;  {ShortInt*2}
           c_int_4       : begin read (fh, b1, b0, b3, b2); sign_extend (2 pow 31) end;  {warning: trouble with sign ???}
           c_int_8       : fault (11);                                                   {64 bit ShortInts not imlemented}
           c_str_1       : begin read (fh,     b0);         read_str     end;            {warning: stringlength}
           c_str_2       : begin read (fh, b1, b0);         read_str     end;            {warning: stringlength}
           lib_control_0 : begin read (fh, b0); v_control  := LC;       lib_get_record := ctrl end;
           lib_control_1 : begin                v_control  := end_list; lib_get_record := ctrl end;
           lib_e_o_f     : begin                                        lib_get_record := eop  end;
           c_bool_0      : begin                v_boolean  := false;    lib_get_record := bool  end;
           c_bool_1      : begin                v_boolean  := true;     lib_get_record := bool  end;
           c_char        : begin read (fh, v_char);                     lib_get_record := ch    end;
           otherwise fault (12) end
      end
   end
 else fault (13) {file not open for read}
end;

(*
procedure lib_ascii_to_bin      (asc_path_name, bin_path_name         : path_name_t);
var ot: obj_type_t; fin: text; h: lib_handle_p_t; c: char;
begin
  assign (fin, asc_path_name);
  reset  (fin);
  lib_open_write (h, bin_path_name);
  with h^ do while not eof (fin) do
    begin
      read (fin, ot);
      case ot of
        kw   : begin readln (fin, v_keyword);      lib_put_keyword    (h, v_keyword)     end;
        id   : begin readln (fin, v_identifier);   lib_put_identifier (h, v_identifier)  end;
        bool : begin readln (fin, v_boolean);      lib_put_boolean    (h, v_boolean)     end;
        ch   : begin readln (fin, c, v_char);      lib_put_char       (h, v_char)        end;
        int  : begin readln (fin, v_ShortInt);      lib_put_ShortInt    (h, v_ShortInt)     end;
        r4   : begin readln (fin, v_real);         lib_put_real       (h, v_real)        end;
        r8   : begin readln (fin, v_double);       lib_put_double     (h, v_double)      end;
        str  : begin readln (fin, c, v_string);    lib_put_string     (h, v_string)      end; {skipping one! blank}
        ctrl : begin readln (fin, v_control);      lib_put_control    (h, v_control)     end;
        eop  : begin readln (fin); if not eof (fin) then abort ('lib_ascii_to_bin: Missing EOF') end;
        otherwise abort ('lib_ascii_to_bin: Fatal tag error')   {remove if program (and data) sre stable}
        end
    end;
  close     (fin);
  lib_close (h)
end;
*)

(*
procedure lib_bin_to_ascii   (bin_path_name, asc_path_name : path_name_t);
const f=11;
var h: lib_handle_p_t; obj: obj_type_t; fout: text;
begin
  assign (fout, asc_path_name);
  rewrite (fout);
  lib_open_read (h, bin_path_name);
  repeat
    obj:= lib_get_record (h);
    write (fout, obj:4, ' ');
    with h^ do case obj of
        kw   : writeln (fout, v_keyword    :f);
        id   : writeln (fout, v_identifier :f);
        bool : writeln (fout, v_boolean    :f);
        ch   : writeln (fout, v_char);
        int  : writeln (fout, v_ShortInt    :f);
        r4   : writeln (fout, v_real       :f);
        r8   : writeln (fout, v_double     :24);
        str  : writeln (fout, v_string);
        ctrl : writeln (fout, v_control    :f);
        eop  : writeln (fout);
        otherwise abort ('lib_bin_to_ascii_to: Fatal tag error')   {remove if program (and data) sre stable}
        end
    until obj=eop   
end;
*)

END.