UNIT object; {-*-Mode: fundamental-mode}
{--------- object.interface -----------------------------------------------------------------------------------}
INTERFACE
USES base, lib_rw, dictionary, gpc, gpcutil;
type
  obj_param_t   = record
                    dic_handle_symbol,                       {dictionary handle: symbols}
                    dic_handle_value,                        {dictionary handle: ShortInt, real, text}
                    dic_handle_data   : dic_handle_t;        {dictionary handle: 'action text'}
                    out_bin           : boolean;             {output to binary file}
                    lib_handle        : lib_handle_p_t;      {if out_bin=true use the lib handle, binary mode}
                  { lib_handle        : pointer; }           {if out_bin=true use the lib handle, binary mode}

                                                             {if out_bin=true use the following parameters, ASCII}
                    f                 : text;                {file opened by application}
                    max_line_length   : ShortInt;
                    output_buffer     : dic_sym;           {output buffer buffer}
                    leader, trailler  : string (3);
                  end;


  object_t      = (obj_cntl,                                                         {object header control block}
                   obj_dic_txt, obj_dic_int, obj_dic_real, obj_dic_sym, obj_dic_dat, {various dictionary text}
                   obj_kw,                                                           {keyword}
                   obj_dic,                                                          {dictionary (symbol list)}
                   obj_bool, obj_chr,                                                {boolean, single character}
                   obj_id , obj_i2, obj_i4, obj_r4, obj_r8,                          {various numeric data}
                   obj_include, obj_macro);                                          {reference to other object}
                                                                                     {carefully increase}
                                                                                     {no lastof () }
  object_p_t    = ^object_cb_t;
  object_cb_t   = record
                    obj_tag  : object_t; gp_index: dic_indx; 
                    obj_next : object_p_t;
                    case object_t of
                      obj_cntl                : (obj_first,
                                                 obj_last     : object_p_t;
                                                 use_count    : ShortInt); 
                      obj_dic_txt, obj_dic_int, obj_dic_real, obj_dic_sym, obj_dic_dat, obj_bool, obj_chr,
                      obj_id , obj_i2         : ();
                      obj_kw                  : (dat_kw       : keyword_t);
                      obj_dic                 : (ptr_dic      : dic_handle_t);
                      obj_i4                  : (dat_i4       : integer);
                      obj_r4                  : (dat_r4       : real);
                      obj_r8                  : (dat_r8       : double);
                      obj_include             : (ptr_include  : object_p_t);
                      obj_macro               : (ptr_parameter,
                                                 ptr      : object_p_t);
                  end;

  obj_handle_t  = object_p_t;   {for application: pointer to self describing operand}

procedure obj_release_pool;                              {release the pool to sytem heap, callable at any time}                                                     
                                                                         {ni = not implemented}
procedure obj_assign      (var dst : obj_handle_t; src : obj_handle_t);  {ni dst:= src}             
procedure obj_delete      (var dst : obj_handle_t);                      {   dst:= nil}             
procedure obj_add_obj     (var dst : obj_handle_t; src : obj_handle_t);  {ni dst:= dst+src}         
procedure obj_inc_obj     (var dst : obj_handle_t; src : obj_handle_t);  {   dst:= dst+^src}        
procedure obj_mov_obj     (var dst : obj_handle_t;var src:obj_handle_t); {?? dst:=dst+src;src:=nil} 

procedure obj_add_dic_mac (var dst : obj_handle_t; index: dic_indx; mpar, macro: obj_handle_t);  
procedure obj_add_dic_txt (var dst : obj_handle_t; index: dic_indx);                                
procedure obj_add_dic_int (var dst : obj_handle_t; index: dic_indx);                                
procedure obj_add_dic_real(var dst : obj_handle_t; index: dic_indx);                                
procedure obj_add_dic_sym (var dst : obj_handle_t; index: dic_indx);                                
procedure obj_add_dic_dat (var dst : obj_handle_t; index: dic_indx);                                

procedure obj_add_kw      (var dst : obj_handle_t; kw  : keyword_t);                                
procedure obj_add_dic     (var dst : obj_handle_t; handle: dic_handle_t);                          

procedure obj_add_bool    (var dst : obj_handle_t; bool: boolean);                                 
procedure obj_add_chr     (var dst : obj_handle_t; ch  : char);                                    
procedure obj_add_ord     (var dst : obj_handle_t; x   : dic_indx);                                 
procedure obj_add_i2      (var dst : obj_handle_t; i2  : ShortInt);                               
procedure obj_add_i4      (var dst : obj_handle_t; i4  : integer);                               
procedure obj_add_r4      (var dst : obj_handle_t; r4  : real);                                    
procedure obj_add_r8      (var dst : obj_handle_t; r8  : double);                                  

function  obj_sym_exists  (    dst : obj_handle_t;                     index: dic_indx):boolean; 
function  obj_add_cond_ord(var dst : obj_handle_t; list: obj_handle_t; index: dic_indx):boolean; 
function  obj_expand_macro(var dst : obj_handle_t; m, p: obj_handle_t; index: dic_indx):boolean; 

procedure obj_reduce      (    obj : obj_handle_t);                                                   
procedure obj_write       (    src : obj_handle_t; var parameter: obj_param_t);                        
{--------- object.interface --- END ---------------------------------------------------------------------------}

IMPLEMENTATION
var
  pool : array [object_t] of object_p_t;  {!R! page; exit;}

{------- inernal routines --------------------------------------------------------------------------------------}
procedure not_impl (err : err_str_t);
begin abort ('Not implemented: ' + err) end;

procedure obj_initialize;    {init the pool, must be called once before using any object}
var i: object_t; begin for i:= obj_cntl to obj_macro do pool [i]:= nil end;

function single_obj_new     (object: object_t): object_p_t;  {get a single object from pool} 
var p: object_p_t; 
begin
  if pool [object] = nil
    then case object of
           obj_cntl    : new (p, obj_cntl);    obj_dic_txt, obj_dic_int, obj_dic_real,
           obj_dic_sym : new (p, obj_dic_sym); obj_dic_dat : new (p, obj_dic_dat);
           obj_dic     : new (p, obj_dic);     obj_bool    : new (p, obj_bool);
           obj_chr     : new (p, obj_chr);     obj_id      : new (p, obj_id );
           obj_i2      : new (p, obj_i2);      obj_kw      : new (p, obj_kw);
           obj_i4      : new (p, obj_i4);      obj_r4      : new (p, obj_r4);
           obj_r8      : new (p, obj_r8);      obj_include : new (p, obj_include);
           obj_macro   : new (p, obj_macro);
           otherwise abort ('single_obj_new: fatal tag') end
    else begin p:= pool [object]; pool [object]:= p^.obj_next end;
 with p^ do begin  obj_tag:= object; gp_index:= 0; obj_next:= nil end;
 single_obj_new:= p
end;

procedure single_obj_dispose (p: object_p_t);  {dispose a single object to pool}
begin with p^ do begin obj_next:= pool [obj_tag]; pool [obj_tag]:= p end end;

procedure single_obj_new_append (var dst: object_p_t; var p: object_p_t; object: object_t); 
begin
  p:= single_obj_new (object);
  if dst=nil
    then begin dst:= single_obj_new (obj_cntl); with dst^ do begin use_count:=1; obj_first:= p end end 
    else with dst^ do
           begin
             if obj_tag <> obj_cntl then abort ('single_obj_new_append: Cant append');
             if obj_last=nil
               then obj_first:= p
               else obj_last^.obj_next:=p
           end;
  dst^.obj_last:= p
end; 

procedure single_obj_new_append_copy (var dst: object_p_t; src: object_p_t);  
var p: object_p_t;  
begin
  if src=nil then abort ('cant copy empty object'); 
  with src^ do
    begin
      single_obj_new_append (dst, p, obj_tag);
      case obj_tag of
        obj_cntl    : abort ('cant make copy of obj_cntl'); 
        obj_dic_txt, obj_dic_int, obj_dic_real, obj_dic_sym, obj_dic_dat, obj_bool, obj_chr, obj_id, 
        obj_i2      : p^.gp_index := gp_index;     obj_kw  : p^.dat_kw := dat_kw;
        obj_dic     : p^.ptr_dic  := ptr_dic;      obj_i4  : p^.dat_i4 := dat_i4;
        obj_r4      : p^.dat_r4   := dat_r4;       obj_r8  : p^.dat_r8 := dat_r8;
        obj_include : begin
                        p^.ptr_include := ptr_include;
                        if ptr_include=nil
                          then abort ('Illegal object copy: ptr_include=nil')
                          else with ptr_include^ do if obj_tag=obj_cntl then use_count:= use_count+1
                      end;
        obj_macro   : begin p^.ptr_parameter :=ptr_parameter; p^.ptr:= ptr end; 
        otherwise abort ('copy: fatal tag') end
    end
end; 

function single_ith_obj (src: object_p_t; i: dic_indx): object_p_t; 
var p: object_p_t; k: dic_indx;
begin
  if src=nil then abort ('cant copy empty object');
  with src^ do
    begin
      if obj_tag<>obj_cntl then abort ('must be obj_cntl');
      k:= 1;
      p:= obj_first ;
      while (p<>nil) and (k<>i) do with p^ do begin k:= k+1; p:= obj_next end;
      single_ith_obj:= p;
    end
end;
{------- inernal routines ------------ END ---------------------------------------------------------------------} {!R! page; exit;}
procedure obj_release_pool;   {release the pool to heap, may be called at any time}
var i: object_t; p: object_p_t; 
begin
  for i:= obj_cntl to obj_macro  do  while pool [i] <> nil do
    begin
      p:= pool [i]; pool [i]:= p^.obj_next;
      case p^.obj_tag of
           obj_cntl    : dispose (p, obj_cntl);      obj_dic_txt, obj_dic_int, obj_dic_real, obj_dic_sym,
           obj_dic_dat : dispose (p, obj_dic_sym);   obj_dic     : dispose (p, obj_dic);
           obj_bool    : dispose (p, obj_bool);      obj_chr     : dispose (p, obj_chr);
           obj_id      : dispose (p, obj_id );       obj_i2      : dispose (p, obj_i2);
           obj_kw      : dispose (p, obj_kw);        obj_i4      : dispose (p, obj_i4);
           obj_r4      : dispose (p, obj_r4);        obj_r8      : dispose (p, obj_r8);
           obj_include : dispose (p, obj_include);   obj_macro   : dispose (p, obj_macro);
           otherwise abort ('obj_close: fatal tag') end;
    end
end;

procedure obj_assign      (var dst : obj_handle_t; src : obj_handle_t);  {dst:= src}
begin   obj_delete (dst)  end; {delete old dst then make a copy of src to dst, test, not ready}

procedure obj_delete      (var dst : obj_handle_t);                         {dst:= nil}
var p, p1: object_p_t; remove: boolean;
begin
  p:= dst;
  while p<>nil do with p^ do
    begin
      p1:= p; remove:= true;
      if obj_tag=obj_cntl then
        begin
           use_count:= use_count-1;                   {decrement number of owners}
           if use_count=0 then obj_delete (obj_first) {was the last owner, recursively remove daughters}
                          else remove:= false         {some other owners exist, do not remove}
        end;
      p:= obj_next;                                   {step to next object}
      if remove then single_obj_dispose (p1)
    end;
  dst:= nil
end;

procedure obj_add_obj     (var dst : obj_handle_t; src : obj_handle_t);  {dst:= dst+src}
begin not_impl ('obj_add_obj') end; 

procedure obj_inc_obj (var dst : obj_handle_t; src : obj_handle_t);  {dst:= dst+^src}
var p: object_p_t;
begin
  if src<>nil then  {empty objects need not to be included} 
    begin 
      single_obj_new_append (dst, p, obj_include); p^.ptr_include:= src;
      p:= src; 
      with p^ do begin if obj_tag<>obj_cntl then abort ('obj_inc_obj'){test}; use_count:= use_count+1 end
    end 
end;   

procedure obj_mov_obj (var dst, src : obj_handle_t);  {dst:= dst+src; src:=nil}
var d, s, p: object_p_t;
begin
  d:= dst; s:= src;          {use_count not changed, ownership is transferred to a new owner}
  if s<>nil then if d=nil
     then dst:= s       
     else if (s^.use_count>1) or (s^.obj_next<>nil)
             then      {other ownership exists or used in some others chain, new control block needed}
                begin
                  single_obj_new_append (dst, p, obj_cntl); 
                  with p^ do begin obj_first:= src; obj_last:= src end
                end
             else with d^ do
                begin
                  if s^.obj_first<>nil then
                     begin
                       if obj_last=nil then  obj_first:= s^.obj_first else obj_last^.obj_next := s^.obj_first;
                       obj_last:= s^.obj_last
                     end;
                  single_obj_dispose (s)
                end;
     src:= nil
end;

procedure obj_add_dic_mac (var dst : obj_handle_t; index: dic_indx; mpar, macro: obj_handle_t);
var p: object_p_t;
begin
  if macro=nil
   then abort ('empty macro ')  {do not include empty macro objects, but parameter list may be empty}
   else 
    begin
      single_obj_new_append (dst, p, obj_macro);
      with p^ do begin gp_index:= index; ptr_parameter:= mpar; ptr := macro end;
    end
end;          {!R! page; exit;}

procedure obj_add_dic_txt (var dst : obj_handle_t; index: dic_indx); var p: object_p_t; 
begin single_obj_new_append (dst, p, obj_dic_txt); p^.gp_index:= index  end; 

procedure obj_add_dic_int (var dst : obj_handle_t; index: dic_indx); var p: object_p_t;
begin single_obj_new_append (dst, p, obj_dic_int);  p^.gp_index:= index end;

procedure obj_add_dic_real(var dst : obj_handle_t; index: dic_indx); var p: object_p_t;
begin single_obj_new_append (dst, p, obj_dic_real); p^.gp_index:= index end;

procedure obj_add_dic_sym (var dst : obj_handle_t; index: dic_indx); var p: object_p_t;
begin single_obj_new_append (dst, p, obj_dic_sym); p^.gp_index:= index  end; 

procedure obj_add_dic_dat (var dst : obj_handle_t; index: dic_indx); var p: object_p_t;
begin single_obj_new_append (dst, p, obj_dic_dat); p^.gp_index:= index  end;

procedure obj_add_kw      (var dst : obj_handle_t; kw  : keyword_t);      var p: object_p_t;
begin single_obj_new_append (dst, p, obj_kw);   p^.dat_kw := kw end;

procedure obj_add_dic     (var dst : obj_handle_t; handle: dic_handle_t); var p: object_p_t;
begin single_obj_new_append (dst, p, obj_dic);  p^.ptr_dic:= handle      end;

procedure obj_add_bool    (var dst : obj_handle_t; bool: boolean);        var p: object_p_t;
begin single_obj_new_append (dst, p, obj_bool); p^.gp_index:= ord (bool) end;   

procedure obj_add_chr     (var dst : obj_handle_t; ch  : char);           var p: object_p_t;
begin single_obj_new_append (dst, p, obj_chr);  p^.gp_index:= ord (ch)  end;   

procedure obj_add_ord     (var dst : obj_handle_t; x   : dic_indx);        var p: object_p_t;
begin single_obj_new_append (dst, p, obj_id );  p^.gp_index:= x  end;  

procedure obj_add_i2      (var dst : obj_handle_t; i2  : ShortInt); var p: object_p_t; i4: integer;
begin
  if i2<0
    then begin i4:= i2; obj_add_i4 (dst, i4) end
    else begin single_obj_new_append (dst, p, obj_i2); p^.gp_index:= i2 end
end;   

procedure obj_add_i4      (var dst : obj_handle_t; i4  : integer);
var p: object_p_t; begin single_obj_new_append (dst, p, obj_i4);   p^.dat_i4:= i4  end;   

procedure obj_add_r4      (var dst : obj_handle_t; r4  : real); var p: object_p_t;
begin single_obj_new_append (dst, p, obj_r4);   p^.dat_r4:= r4  end;  

procedure obj_add_r8      (var dst : obj_handle_t; r8  : double); var p: object_p_t;
begin single_obj_new_append (dst, p, obj_r8);   p^.dat_r8:= r8  end;    {!R! page; exit;}

function  obj_sym_exists  (   dst : obj_handle_t; index: dic_indx):boolean; 
var p, p1: object_p_t;  
begin
  obj_sym_exists:= false;   
  p:= dst;  
  if p<>nil then with p^ do  
    begin 
      if obj_tag<>obj_cntl then abort ('not obj_cntl'); {test} 
      p1:= obj_first; 
      while p1<>nil do with p1^ do 
        begin if (obj_tag=obj_dic_sym) and then (gp_index=index) then break; p1:= obj_next end; 
      obj_sym_exists:= p1<>nil
    end 
end;  
 
function  obj_add_cond_ord  (var dst : obj_handle_t; list: obj_handle_t; index: dic_indx):boolean;  
var p, p1: object_p_t; n: dic_indx; 
begin
  p:= list;                           {looking for symbol index in list}
  obj_add_cond_ord:= false;           {if found appends the ordinal number to dst}
  if p<>nil then with p^ do           {remarks: ord-numbers begin with 1}
    begin
      if obj_tag<>obj_cntl then abort ('obj_add_cond_ord: not obj_cntl'); {test} 
      p1:= obj_first; n:= 1;
      while p1<>nil do with p1^ do 
        begin if obj_tag=obj_dic_sym then if gp_index=index then break else n:= n+1; p1:= obj_next end;
      if p1<>nil then begin obj_add_ord (dst, n); obj_add_cond_ord:= true end
    end
end; 

function  obj_expand_macro(var dst : obj_handle_t; m, p: obj_handle_t; index: dic_indx):boolean;  
var p1, p2, p3, p4, p5: object_p_t; i: dic_indx;
begin
  obj_expand_macro:= false;
  p1:= m; 
  if p1=nil
    then abort ('obj_expand_macro: empty ')
    else with p1^ do
      begin
        if obj_tag<>obj_cntl then abort ('obj_expand_macro: not obj_cntl'); {test}
        p2:= obj_first;
        while p2<>nil do with p2^ do
          begin if (obj_tag=obj_macro) and then (gp_index=index) then break; p2:= obj_next end;
        if p2<>nil then  {macro name pointed to by p2 is not empty (macro exists)}
          begin
            p3:= p2^.ptr ;
            if p3=nil
              then abort ('obj_expand_macro: empty macro ')
              else
                begin
                 p4:= p3^.obj_first;
                 while p4<>nil do with p4^ do
                   begin
                   if obj_tag=obj_id 
                     then single_obj_new_append_copy (dst, single_ith_obj (p, gp_index))
                     else single_obj_new_append_copy (dst, p4);
                   p4:=obj_next
                   end
                end
          end
      end 
end; 

procedure obj_reduce      (   obj : obj_handle_t);
begin not_impl ('obj_reduce') end;



procedure obj_write       (   src : obj_handle_t; var parameter: obj_param_t);
 var i: dic_indx; 

 procedure flush_output_buffer;
 begin with parameter do if length (output_buffer) <>0 then begin writeln (f, output_buffer); output_buffer:= '' end end;

 procedure app_str (s: dic_sym);
 begin
   with parameter do
     begin
       if (length (output_buffer) + length (s)) >= max_line_length then flush_output_buffer;
       output_buffer:=  output_buffer + s
     end
 end;  {!R! page; exit;}

 procedure wr_asc (var ptr: object_p_t);
 var p: object_p_t; s: dic_sym;
 begin
   p:= ptr;
   while p<>nil do with p^, parameter do
     begin
       case obj_tag of
         obj_cntl    : wr_asc (obj_first);
         obj_dic_txt : app_str (leader + DIC_SYMBOL (dic_handle_value, gp_index) + trailler);
         obj_dic_int,
         obj_dic_real: app_str (DIC_SYMBOL (dic_handle_value,  gp_index));
         obj_dic_sym : app_str (DIC_SYMBOL (dic_handle_symbol, gp_index));
         obj_dic     : begin
                         flush_output_buffer;
                         for i:= 1 to DIC_LAST_INDX (ptr_dic) do writeln (f, DIC_SYMBOL (ptr_dic, i))
                       end;
         obj_dic_dat : app_str (DIC_SYMBOL (dic_handle_data,   gp_index));
         obj_bool    : not_impl ('obj_bool');
         obj_chr     : if chr (gp_index)=newline then flush_output_buffer else app_str (chr(gp_index));
         obj_id ,
(*       obj_i2      : not_impl ('STR_OF_INTEGER');  {app_str (STR_OF_INTEGER  (gp_index, 0, 0));} *)
         obj_i2      : app_str (Int2Str (gp_index));
         obj_kw      : abort ('write_asc: illegal obj_kw');                    {      field, type decimal}                
         obj_i4      : not_impl ('STR_OF_INTEGER');  {app_str (STR_OF_INTEGER  (dat_i4,   0, 0));}
         obj_r4      : not_impl ('STR_OF_REAL');     {app_str (STR_OF_REAL     (dat_r4,   8, 2));}
         obj_r8      : not_impl ('STR_OF_REAL');     {app_str (STR_OF_DOUBLE   (dat_r8,  17, 2));}
         obj_include,
         obj_macro   : wr_asc (ptr_include);
         otherwise abort ('Fatal tag in obj_write') {test remove this line if pgm is stable}
         end;
       p:= obj_next
     end
 end;

 procedure wr_bin (var ptr: object_p_t);
 var p: object_p_t; s: dic_sym;     i, x: integer; r: real; ok: boolean;  {test: vars to be shifted into global}
 begin
   p:= ptr;
   while p<>nil do with p^, parameter do
     begin
       case obj_tag of
         obj_cntl    : wr_bin (obj_first);
         obj_dic_txt : lib_put_string     (lib_handle, DIC_SYMBOL (dic_handle_value,  gp_index));
         obj_dic_int : begin
                         x:=1; s:= DIC_SYMBOL (dic_handle_value,  gp_index); 
                         not_impl ('str_to_ShortInt');    {  i:= str_to_ShortInt (s, x, ok); test}
                         if ok 
                            then lib_put_ShortInt (lib_handle, i)
                            else abort ('wr_bin: Cant convert to int: ' + s)
                       end;
         obj_dic_real: begin
                         x:=1; s:= DIC_SYMBOL (dic_handle_value,  gp_index);
                         not_impl ('str_to_real');        {  r:= str_to_real (s, x, ok); test}
                         if ok
                           then lib_put_real     (lib_handle, r)  {test real conversion delivers 9.99}
                           else abort ('wr_bin: Cant convert to real: ' + s)
                       end;
         obj_dic_sym : not_impl ('wr_bin: obj_dic_sym');
         obj_dic     : not_impl ('wr_bin: obj_dic');
         obj_dic_dat : not_impl ('wr_bin: obj_dic_dat');
         obj_bool    : not_impl ('wr_bin: obj_bool');
         obj_chr     : begin s:= chr (gp_index); lib_put_string (lib_handle, s) end;
         obj_id      : lib_put_identifier (lib_handle, gp_index);
         obj_i2      : not_impl ('wr_bin: obj_i2');
         obj_kw      : lib_put_keyword    (lib_handle, dat_kw);
         obj_i4      : not_impl ('wr_bin: obj_i4');
         obj_r4      : not_impl ('wr_bin: obj_r4');
         obj_r8      : not_impl ('wr_bin: obj_r8');
         obj_include,
         obj_macro   : wr_bin (ptr_include);
         otherwise abort ('Fatal tag in obj_write') {test remove this line if pgm is stable}
         end;
       p:= obj_next
     end
 end;
begin if parameter.out_bin then wr_bin (src) else wr_asc (src) end;  {procedure obj_write}

begin  obj_initialize {nil the local pool} END.                      {executed once at start}