home *** CD-ROM | disk | FTP | other *** search
/ ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng) / ProfitPress-MegaCDROM2.B6I / PROG / PASCAL / INTRFC62.ZIP / RELOC.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1991-05-02  |  4.3 KB  |  168 lines
  1. unit reloc;
  2. { unit to print relocation records }
  3.  
  4. interface
  5. uses dump,util,globals,loader,nametype,head;
  6.  
  7. type
  8.   reloc_ptr = ^reloc_rec;
  9.   reloc_rec = record
  10.     unit_num,            { offset to unit in unit block }
  11.     rtype : byte;
  12.     rblock,roffset,offset : word;
  13.   end;
  14.  
  15. const
  16.   code_seg  = 0;
  17.   code_data = 1;
  18.   var_seg   = 2;
  19.   const_seg = 3;
  20.  
  21. procedure print_reloc(seg:byte);
  22. procedure write_reloc_type(rtype:byte);
  23.  
  24. implementation
  25.  
  26. uses
  27.   blocks;
  28.  
  29. function ref_type(rtype:byte):byte;
  30. begin
  31.   ref_type := (rtype shr 4) and 3;
  32. end;
  33.  
  34. function target_type(rtype:byte):byte;
  35. begin
  36.   target_type := rtype shr 6;
  37. end;
  38.  
  39. procedure print_reloc(seg:byte);
  40. var
  41.   codebase,codeofs,codelimit,
  42.   base,ofs,limit : word;
  43.   block : reloc_ptr;
  44.   code_block : block_ptr;
  45.   target_unit : unit_list_ptr;
  46.   entry_pt : entry_pt_ptr;
  47.   target_unit_name : string;
  48.   fake_unit_info : unit_ptr;
  49. begin
  50.   writeln;
  51.   case seg of
  52.   code_seg : begin
  53.         writeln('Code segment relocation records');
  54.         if header^.reloc_size = 0 then
  55.         begin
  56.           writeln('(none)');
  57.           exit;
  58.         end;
  59.         codebase :=header^.ofs_code_blocks;
  60.         codelimit := header^.ofs_const_blocks-codebase;
  61.      end;
  62.  
  63.   const_seg : begin
  64.         writeln('Const segment relocation records');
  65.         if header^.vmt_size = 0 then
  66.         begin
  67.           writeln('(none)');
  68.           exit;
  69.         end;
  70.         codebase :=header^.ofs_const_blocks;
  71.         codelimit := header^.ofs_var_blocks-codebase;
  72.      end;
  73.   end;
  74.   writeln('  Reloc');
  75.   writeln('  Offset  Fixup Type    Unit       Block:Offset');
  76.   base := 0;
  77.   codeofs := 0;
  78.   while codeofs < codelimit do
  79.   begin
  80.     code_block := add_offset(buffer,codebase+codeofs);
  81.     write('---');
  82.     case seg of
  83.       code_seg:  write_code_block_name(code_block^.owner);
  84.       const_seg: write_const_block_name(code_block^.owner);
  85.     end;
  86.     writeln('---');
  87.     ofs := 0;
  88.     limit := code_block^.relocbytes;
  89.     while ofs < limit do
  90.     begin
  91.       block := add_offset(reloc_buf,base+ofs);
  92.       with block^ do
  93.       begin
  94.         write(hexword2(codeofs),':',hexword(offset),' ');
  95.         if (rtype = $FF) and (unit_num = $FF) then
  96.         begin
  97.           write('Coproc   ');
  98.           case rblock of
  99.           1 : write('DS override');
  100.           2 : write('SS override');
  101.           3 : write('CS override');
  102.           4 : write('ES override');
  103.           5 : write('Standard');
  104.           6 : write('FWAIT');
  105.           else
  106.             write('Unrecognized fixup type ',hexword(rblock));
  107.           end;
  108.           if roffset <> 0 then
  109.             write(' ROffset = ',hexword(Roffset));
  110.         end
  111.         else
  112.         begin
  113.           write_reloc_type(rtype);
  114.           target_unit_name := unit_name(unit_num);
  115.           write(target_unit_name:10);
  116.  
  117.           if target_type(rtype) = 0 then  { This doesn't catch Coproc fixups }
  118.           begin
  119.             { It might be a good idea to try to add the unit to the unit_list
  120.               here, but I don't think so.  Let it fail if it wants to. }
  121.  
  122.             target_unit := get_unit_by_name(target_unit_name);
  123.  
  124.             if (target_unit <> nil) and (target_unit^.buffer <> nil) then
  125.               with target_unit^ do
  126.               begin
  127.                 entry_pt := add_offset(buffer,
  128.                              header_ptr(buffer)^.ofs_entry_pts+rblock);
  129.                 write(' ',hexword2(entry_pt^.code_block),':',
  130.                       hexword(entry_pt^.offset));
  131.               end
  132.             else
  133.               write(' entry',hexword(rblock));
  134.           end
  135.           else
  136.             write(' ',hexword2(rblock),':',hexword(roffset));
  137.         end;
  138.         writeln;
  139.       end;
  140.       inc(ofs,sizeof(reloc_rec));
  141.     end;
  142.     inc(base,ofs);
  143.     inc(codeofs,sizeof(block_rec));
  144.   end;
  145. end;
  146.  
  147. procedure write_reloc_type(rtype:byte);
  148. begin
  149.   if (rtype and $0F) <> 0 then
  150.     write  ('Unknown type ',hexbyte(rtype):4);
  151.  
  152.   case ref_type(rtype) of
  153.   0 : write('Relative ');
  154.   1 : write('Offset   ');
  155.   2 : write('Segment  ');
  156.   3 : write('Pointer  ');
  157.   end;
  158.  
  159.   case target_type(rtype) of
  160.   code_seg  : write('Code    ');
  161.   code_data : write('CS Const');
  162.   var_seg   : write('Var     ');
  163.   const_seg : write('DS Const');
  164.   end;
  165. end;
  166.  
  167. end.
  168.