home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / INTRFC.ZIP / OBJSTUFF.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1988-05-08  |  10.5 KB  |  385 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.     writeln(';',^I,'{ofs ',offset,'}');
  206.   end;
  207. end;
  208.  
  209. procedure write_args(info:func_info_ptr);
  210. var
  211.   i:word;
  212.   arg : arg_ptr;
  213. begin
  214.   writeln('(');
  215.   arg := add_offset(info,sizeof(func_info_rec));
  216.   for i:=1 to info^.num_args do
  217.   begin
  218.     with arg^ do
  219.     begin
  220.       write(^I);
  221.       case var_or_val of
  222.       0 : write('    ');
  223.       1 : write('var ');
  224.       else
  225.         writeln('var_or_val=',var_or_val,', not 0 or 1!');
  226.       end;
  227.       write(name,':',^I);
  228.       write_var_type(type_unit,type_def_ofs);
  229.       writeln(';');
  230.     end;
  231.     arg := add_offset(arg,6+length(arg^.name));
  232.   end;
  233.   write(^I,^I,')');
  234. end;
  235.  
  236. procedure write_func_info(name:string; info:func_info_ptr);
  237. begin
  238.   write('function',^I,name);
  239.   if info^.num_args > 0 then
  240.     write_args(info);
  241.   write(':',^I);
  242.   write_var_type(info^.type_unit,info^.type_def_ofs);
  243.   writeln(';');
  244. end;
  245.  
  246. procedure write_proc_info(name:string; info:func_info_ptr);
  247. begin
  248.   write('procedure',^I,name);
  249.   if info^.num_args > 0 then
  250.     write_args(info);
  251.   writeln(';');
  252. end;
  253.  
  254. procedure write_const_info(name:string; info:const_info_ptr);
  255. var
  256.   type_obj : obj_ptr;
  257. begin
  258.   if (last_kind <> record_id) and (last_kind <> const_id) then
  259.   begin
  260.     writeln('Const');
  261.     last_kind := const_id;
  262.   end;
  263.   write(^I,name,'=',^I);
  264.   with info^,unit_list[type_unit]^ do
  265.   begin
  266.     if buffer <> nil then
  267.     begin
  268.       type_obj := find_type(unit_list[type_unit],type_def_ofs);
  269.       if type_obj <> nil then
  270.       begin
  271.         with type_obj^ do
  272.         begin
  273.           if name = 'LONGINT' then
  274.             write(intval)
  275.           else if name = 'REAL' then
  276.             write(realval)
  277. {         else if name = 'EXTENDED' then  } {put this in only if compiled with}
  278. {           write(extendval)              } { N+ option }
  279.           else
  280.             write(name,' value ',intval); {Don't know correct way to print}
  281.         end;
  282.       end
  283.       else
  284.       begin
  285.         if (type_def_ofs = 164)   { Risky to fix this, but can't see any
  286.                                   other way to detect string constants }
  287.            and (unit_list[type_unit]^.name = 'SYSTEM') then
  288.            write('''',stringval,'''')
  289.         else
  290.           write('?');
  291.       end;
  292.     end
  293.     else
  294.       write('?');
  295.   end;
  296.   writeln(';');
  297. end;
  298.  
  299. procedure print_obj(obj:obj_ptr);
  300. var
  301.   j:word;
  302.   obj_info : ^byte_array;
  303.   new_entry : list_ptr;
  304.   info_len,info_ofs : word;
  305. begin
  306.   info_ofs := 3+length(obj^.name);
  307.   obj_info := add_offset(obj,info_ofs);
  308.  
  309.   if obj_info^[0] = unit_id then
  310.     add_unit(obj,unit_ptr(obj_info));
  311.  
  312.   case obj_info^[0] of
  313.      const_id : write_const_info(obj^.name,pointer(obj_info));
  314.      type_id : write_type_info(obj^.name,pointer(obj_info));
  315.  
  316.      var_id  : write_var_info(obj^.name,pointer(obj_info));
  317.  
  318.      proc_id : begin
  319.                  write_proc_info(obj^.name,pointer(obj_info));
  320.                  last_kind := proc_id;
  321.                end;
  322.      func_id : begin
  323.                  write_func_info(obj^.name,pointer(obj_info));
  324.                  last_kind := func_id;
  325.                end;
  326.  
  327.      sys_proc_id : begin
  328.                  writeln('built-in procedure',^I,obj^.name,';');
  329.                  last_kind := sys_proc_id;
  330.                end;
  331.  
  332.      sys_fn_id : begin
  333.                  writeln('built-in function',^I,obj^.name,';');
  334.                  last_kind := sys_fn_id;
  335.                end;
  336.  
  337.      sys_port_id : begin
  338.                    writeln('Port array',^I,obj^.name,';');
  339.                    last_kind := sys_port_id;
  340.                  end;
  341.  
  342.      sys_mem_id : begin
  343.                     writeln('Memory array',^I,obj^.name,';');
  344.                     last_kind := sys_mem_id;
  345.                   end;
  346.  
  347.      unit_id :   if unit_ptr(obj_info)^.unit_number = 64 then
  348.                  begin
  349.                    writeln('Unit',^I,obj^.name,';');
  350.                    last_kind := init_id;
  351.                  end
  352.                  else
  353.                    case last_kind of
  354.                    unit_id : writeln(^I,',',obj^.name);
  355.                    else      begin
  356.                                writeln('Uses',^I,obj^.name);
  357.                                last_kind := unit_id;
  358.                              end;
  359.                    end;
  360.      else
  361.                begin
  362.                  writeln('Unknown kind ',obj_info^[0],^I,obj^.name);
  363.                  last_kind := obj_info^[0];
  364.                end;
  365.   end;
  366. end;
  367.  
  368. procedure print_obj_list;
  369. var
  370.   obj : obj_ptr;
  371.   current : list_ptr;
  372.   bytes : ^byte_array;
  373.   j : integer;
  374. begin
  375.   last_kind := init_id;
  376.   current := obj_list;
  377.   while current^.offset < $ffff do
  378.   begin
  379.     obj := add_offset(buffer,current^.offset);
  380.     print_obj(obj);
  381.     current := current^.next;
  382.   end;
  383. end;
  384.  
  385. end.