home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / pascal / utility / unittool / turbo4 / intrfac4 / objstuff.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1988-09-04  |  10.8 KB  |  393 lines
  1. unit objstuff;
  2. { These are the object oriented routines }
  3.  
  4. interface
  5.  
  6. uses
  7.   util,globals,hash;
  8.  
  9. procedure print_obj_list;
  10. procedure print_obj(obj:obj_ptr);
  11. procedure write_type_def(def:type_def_ptr);
  12. procedure write_type_info(name:string; info:type_info_ptr);
  13. function find_type(unit_rec:unit_list_ptr;def_ofs:word):obj_ptr;
  14. procedure write_var_type(type_unit,type_def_ofs:word);
  15. procedure write_var_info(name:string; info:var_info_ptr);
  16. procedure write_args(info:func_info_ptr);
  17. procedure write_func_info(name:string; info:func_info_ptr);
  18. procedure write_proc_info(name:string; info:func_info_ptr);
  19. procedure write_const_info(name:string; info:const_info_ptr);
  20.  
  21. implementation
  22.  
  23. procedure write_type_def(def:type_def_ptr);
  24. var
  25.   i : integer;
  26.   l : longint;
  27.   hash_table : hash_ptr;
  28.   save_kind : byte;
  29.   field_list : list_ptr;
  30.   current : list_ptr;
  31.   obj : obj_ptr;
  32. begin
  33.   with def^ do
  34.     case type_type of
  35.       0 : write('untyped');
  36.       1 : begin                  {Array}
  37.             write('array[');
  38.             write_var_type(index_unit,index_ofs);
  39.             write('] of ');
  40.             write_var_type(element_unit,element_ofs);
  41.           end;
  42.       2 : begin                  {Record}
  43.             save_kind := last_kind;
  44.             last_kind := record_id;
  45.             writeln ('Record ');
  46.             hash_table := add_offset(buffer,table_ofs);
  47.  
  48.             build_list(field_list,buffer,hash_table);
  49.  
  50.             current := field_list;
  51.             while current^.offset < $ffff do
  52.             begin
  53.               obj := add_offset(buffer,current^.offset);
  54.               write(^I);
  55.               print_obj(obj);
  56.               current := current^.next;
  57.             end;
  58.  
  59.             write(^I,'end');
  60.             last_kind := save_kind;
  61.           end;
  62.       3 : begin                  {File}
  63.             write('file');
  64.             if base_unit <> 0 then
  65.             begin
  66.               write(' of ');
  67.               write_var_type(base_unit,base_ofs);
  68.             end;
  69.           end;
  70.       4 : write('built-in text file');    {Text}
  71.       5 : begin                  {Set}
  72.             write('set of ');
  73.             write_var_type(base_unit,base_ofs);
  74.           end;
  75.       6 : begin                  {Pointer}
  76.             write('^',string(add_offset(def,16)^));
  77.           end;
  78.  
  79.       7 : begin                  {String}
  80.             write('string[',size-1,']');
  81.             {N.B. actually record is like array of char, but "string" with
  82.                   no length is different.}
  83.           end;
  84.       8 : write('built-in 8087 type');    {8087}
  85.       9 : write('built-in 6 byte real');  {Real}
  86.      10 : begin                  {Range}
  87.             write(lower,'..',upper);
  88.           end;
  89.      11 : write('built-in boolean');
  90.      12 : write('built-in char');
  91.      13 : begin                  {Enumeration}
  92.             write('(');
  93.             {  Assume following records are constant declarations  }
  94.             obj := add_offset(def,16);
  95.             for l:=lower to upper-1 do
  96.             begin
  97.               write(obj^.name,',');
  98.               obj:=add_offset(obj,12+length(obj^.name));
  99.             end;
  100.             write(obj^.name,')');
  101.           end;
  102.  
  103.      else
  104.           begin
  105.             writeln('Type definition of type ',type_type, 'otherbyte=',
  106.                     other_byte,'size=',size);
  107.             write(' junk=');
  108.             for i:=3 to 8 do
  109.               write(who_knows[i]:6);
  110.             writeln;
  111.           end;
  112.     end;
  113. end;
  114.  
  115. procedure write_type_info(name:string; info:type_info_ptr);
  116. begin
  117.   if (last_kind <> record_id) and (last_kind <> type_id) then
  118.   begin
  119.     writeln('type');
  120.     last_kind := type_id;
  121.   end;
  122.   write(^I,name,'=',^I);
  123.   with info^,unit_list[info^.type_unit]^ do
  124.   begin
  125.     if buffer <> nil then
  126.       write_type_def(add_offset(buffer,type_def_ofs))
  127.     else
  128.       write(name,'.ofs',type_def_ofs);
  129.     writeln(';');
  130.   end;
  131. end;
  132.  
  133. function find_type(unit_rec:unit_list_ptr;def_ofs:word):obj_ptr;
  134. var
  135.   current:list_ptr;
  136.   obj : obj_ptr;
  137.   obj_info : type_info_ptr;
  138. begin
  139.   with unit_rec^ do
  140.   begin
  141.     if obj_list = nil then
  142.       build_list(obj_list,buffer,add_offset(buffer,header_ptr(buffer)^.ofs_hashtable));
  143.     current := obj_list;
  144.     while current^.offset < $ffff do
  145.     begin
  146.       obj := add_offset(buffer,current^.offset);
  147.       obj_info := add_offset(obj,3+length(obj^.name));
  148.       if     (obj_info^.id = type_id)
  149.          and (obj_info^.type_def_ofs = def_ofs)
  150.          and (obj_info^.type_unit = 64) then
  151.       begin
  152.         find_type := obj;
  153.         exit;
  154.       end;
  155.       current := current^.next;
  156.     end;
  157.     find_type := nil;
  158.   end;
  159. end;
  160.  
  161. procedure write_var_type(type_unit,type_def_ofs:word);
  162. var
  163.   type_obj : obj_ptr;
  164. begin
  165.   with unit_list[type_unit]^ do
  166.   begin
  167.     if buffer <> nil then
  168.     begin
  169.       type_obj := find_type(unit_list[type_unit],type_def_ofs);
  170.       if type_obj <> nil then
  171.         write(type_obj^.name)
  172.       else
  173.         write_type_def(add_offset(buffer,type_def_ofs));
  174.     end
  175.     else
  176.       write(name,'.ofs',type_def_ofs);
  177.   end;
  178. end;
  179.  
  180. procedure write_var_info(name:string; info:var_info_ptr);
  181. begin
  182.   with info^ do
  183.   begin
  184.     if last_kind <> record_id then
  185.       case c_or_v of
  186.         0 : begin
  187.               if last_kind <> var_id then
  188.               begin
  189.                 writeln('Var');
  190.                 last_kind := var_id;
  191.               end;
  192.             end;
  193.  
  194.         255: if last_kind <> const_id then
  195.              begin
  196.                writeln('Const');
  197.                last_kind := const_id;
  198.              end;
  199.         else writeln('C_or_V=',c_or_v,' ');
  200.       end;
  201.     write(^I,name,':',^I);
  202.     write_var_type(type_unit,type_def_ofs);
  203.     if c_or_v = 255 then
  204.       write('=',^I,'?');
  205.     write(';',^I,'{ofs ',offset);
  206.     if in_unit > 64 then              { Records use 0; this unit is 64}
  207.       write(' in ',unit_list[in_unit]^.name,' unit');
  208.     writeln('}');
  209.   end;
  210. end;
  211.  
  212. procedure write_args(info:func_info_ptr);
  213. var
  214.   i:word;
  215.   arg : arg_ptr;
  216. begin
  217.   writeln('(');
  218.   arg := add_offset(info,sizeof(func_info_rec));
  219.   for i:=1 to info^.num_args do
  220.   begin
  221.     with arg^ do
  222.     begin
  223.       write(^I);
  224.       case var_or_val of
  225.       0 : write('    ');
  226.       1 : write('var ');
  227.       else
  228.         writeln('var_or_val=',var_or_val,', not 0 or 1!');
  229.       end;
  230.       write(name,':',^I);
  231.       write_var_type(type_unit,type_def_ofs);
  232.       writeln(';');
  233.     end;
  234.     arg := add_offset(arg,6+length(arg^.name));
  235.   end;
  236.   write(^I,^I,')');
  237. end;
  238.  
  239. procedure write_func_info(name:string; info:func_info_ptr);
  240. begin
  241.   write('function',^I,name);
  242.   if info^.num_args > 0 then
  243.     write_args(info);
  244.   write(':',^I);
  245.   write_var_type(info^.type_unit,info^.type_def_ofs);
  246.   writeln(';');
  247. end;
  248.  
  249. procedure write_proc_info(name:string; info:func_info_ptr);
  250. begin
  251.   write('procedure',^I,name);
  252.   if info^.num_args > 0 then
  253.     write_args(info);
  254.   writeln(';');
  255. end;
  256.  
  257. procedure write_const_info(name:string; info:const_info_ptr);
  258. var
  259.   type_obj : obj_ptr;
  260. begin
  261.   if (last_kind <> record_id) and (last_kind <> const_id) then
  262.   begin
  263.     writeln('Const');
  264.     last_kind := const_id;
  265.   end;
  266.   write(^I,name,'=',^I);
  267.   with info^,unit_list[type_unit]^ do
  268.   begin
  269.     if buffer <> nil then
  270.     begin
  271.       type_obj := find_type(unit_list[type_unit],type_def_ofs);
  272.       if type_obj <> nil then
  273.       begin
  274.         with type_obj^ do
  275.         begin
  276.           if name = 'LONGINT' then
  277.             write(intval)
  278.           else if name = 'REAL' then
  279.             write(realval)
  280. {         else if name = 'EXTENDED' then  } {put this in only if compiled with}
  281. {           write(extendval)              } { N+ option }
  282.           else
  283.             write(name,' value ',intval); {Don't know correct way to print}
  284.         end;
  285.       end
  286.       else
  287.       begin
  288.         if (type_def_ofs = 164)   { Risky to fix this, but can't see any
  289.                                   other way to detect string constants }
  290.            and (unit_list[type_unit]^.name = 'SYSTEM') then
  291.            write('''',stringval,'''')
  292.         else
  293.           write('?');
  294.       end;
  295.     end
  296.     else
  297.       write('?');
  298.   end;
  299.   writeln(';');
  300. end;
  301.  
  302. procedure print_obj(obj:obj_ptr);
  303. var
  304.   j:word;
  305.   obj_info : ^byte_array;
  306.   new_entry : list_ptr;
  307.   info_len,info_ofs : word;
  308. begin
  309.   info_ofs := 3+length(obj^.name);
  310.   obj_info := add_offset(obj,info_ofs);
  311.  
  312.   if obj_info^[0] = unit_id then
  313.     add_unit(obj,unit_ptr(obj_info));
  314.  
  315.   case obj_info^[0] of
  316.      const_id : write_const_info(obj^.name,pointer(obj_info));
  317.      type_id : write_type_info(obj^.name,pointer(obj_info));
  318.  
  319.      var_id  : write_var_info(obj^.name,pointer(obj_info));
  320.  
  321.      proc_id : begin
  322.                  write_proc_info(obj^.name,pointer(obj_info));
  323.                  last_kind := proc_id;
  324.                end;
  325.      func_id : begin
  326.                  write_func_info(obj^.name,pointer(obj_info));
  327.                  last_kind := func_id;
  328.                end;
  329.  
  330.      sys_proc_id : begin
  331.                  writeln('built-in procedure ',word_at(obj_info^[1]),
  332.                          ^I,obj^.name,';');
  333.                  last_kind := sys_proc_id;
  334.                end;
  335.  
  336.      sys_fn_id : begin
  337.                  writeln('built-in function ',word_at(obj_info^[1]),
  338.                          ^I,obj^.name,';');
  339.                  last_kind := sys_fn_id;
  340.                end;
  341.  
  342.      sys_port_id : begin
  343.                    writeln('Port array',^I,obj^.name,';');
  344.                    last_kind := sys_port_id;
  345.                  end;
  346.  
  347.      sys_mem_id : begin
  348.                     writeln('Memory array',^I,obj^.name,';');
  349.                     last_kind := sys_mem_id;
  350.                   end;
  351.  
  352.      unit_id :   if unit_ptr(obj_info)^.unit_number = 64 then
  353.                  begin
  354.                    writeln('Unit',^I,obj^.name,';');
  355.                    last_kind := init_id;
  356.                  end
  357.                  else
  358.                    case last_kind of
  359.                    unit_id : writeln(^I,',',obj^.name);
  360.                    else      begin
  361.                                writeln('Uses',^I,obj^.name);
  362.                                last_kind := unit_id;
  363.                              end;
  364.                    end;
  365.      else
  366.                begin
  367.                  writeln('Unknown kind ',obj_info^[0],^I,obj^.name);
  368.                  for j:=0 to 15 do
  369.                    write(obj_info^[j]:5);
  370.                  writeln;
  371.                  last_kind := obj_info^[0];
  372.                end;
  373.   end;
  374. end;
  375.  
  376. procedure print_obj_list;
  377. var
  378.   obj : obj_ptr;
  379.   current : list_ptr;
  380.   bytes : ^byte_array;
  381.   j : integer;
  382. begin
  383.   last_kind := init_id;
  384.   current := obj_list;
  385.   while current^.offset < $ffff do
  386.   begin
  387.     obj := add_offset(buffer,current^.offset);
  388.     print_obj(obj);
  389.     current := current^.next;
  390.   end;
  391. end;
  392.  
  393. end.