home *** CD-ROM | disk | FTP | other *** search
/ ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng) / ProfitPress-MegaCDROM2.B6I / PROG / PASCAL / TPU2TPS.ZIP / TPU2TPS.PAS < prev   
Encoding:
Pascal/Delphi Source File  |  1991-07-23  |  3.8 KB  |  142 lines
  1. program TPU2TPS;
  2.  
  3. { Program to extract SYSTEM.TPS file from SYSTEM.TPU file. }
  4. { Written for the public domain by D.J. Murdoch, July 1991 }
  5.  
  6. { These declarations for a TP 6.0/ TPW 1.0 .TPU file are taken from
  7.   my INTRFC program }
  8.  
  9. type
  10.   unit_flags = set of (ieee_reals,overlays,windows,f8,moveable,f20,preload,f80,
  11.                        f100,f200,f400,f800,discardable,f2000,f4000,f8000);
  12. type
  13.   header_ptr = ^header_rec;
  14.   header_rec = record
  15.     file_id: array[0..3] of char; { 0-3 }
  16.     i4,                           { 4-5 }
  17.     i6,                           { 6-7 }
  18.     ofs_this_unit,                { 8-9 }
  19.     ofs_hashtable,                { A-B }
  20.     ofs_entry_pts,                { C-D }
  21.     ofs_code_blocks,              { E-F }
  22.     ofs_const_blocks,             {10-11}
  23.     ofs_var_blocks,               {12-13}
  24.     ofs_dll_list,                 {14-15}
  25.     ofs_unit_list,                {16-17}
  26.     ofs_src_name,                 {18-19}
  27.     ofs_line_lengths,             {1A-1B}
  28.     sym_size,                     {1C-1D}
  29.     code_size,                    {1E-1F}
  30.     const_size,                   {20-21}
  31.     reloc_size,                   {22-23}
  32.     vmt_size,                     {24-25}
  33.     var_size,                     {26-27}
  34.     ofs_full_hash: word;          {28-29}
  35.     flags : unit_flags;           {2A-2B}
  36.     other : array[$2C..$3F] of byte; {2C-3F}
  37.   end;
  38.  
  39. var
  40.   buffer : array[0..32767] of byte;
  41.   header : header_rec absolute buffer;
  42.  
  43. function word_at(offset:word):word;
  44. { Return the word at a given offset in the buffer }
  45. begin
  46.   word_at := buffer[offset] + buffer[offset+1] shl 8;
  47. end;
  48.  
  49. procedure set_word(offset,value:word);
  50. { Set the word at a given offset to a new value }
  51. begin
  52.   move(value,buffer[offset],sizeof(word));
  53. end;
  54.  
  55. procedure trim_hash;
  56. { Trim hash references that point too far out in the .TPU }
  57. var
  58.   start : word;
  59.   current,next : word;
  60. begin
  61.   with header do
  62.   begin
  63.     start := 0;
  64.     while start <= word_at(ofs_hashtable) do
  65.     begin
  66.       next := ofs_hashtable + start + 2;
  67.       repeat
  68.         current := next;
  69.         next := word_at(current);
  70.       until next < sym_size;
  71.       set_word(ofs_hashtable + start + 2, next);
  72.       inc(start,2);
  73.     end;
  74.   end;
  75. end;
  76.  
  77. var
  78.   tpu,tps: file;
  79.   actual : word;
  80. begin
  81.   writeln('TPU2TPS - Reads SYSTEM.TPU and extracts SYSTEM.TPS from it.');
  82.   assign(tpu,'SYSTEM.TPU');
  83.   {$i-} reset(tpu,1); {$i+}
  84.   if ioresult <> 0 then
  85.   begin
  86.     writeln('SYSTEM.TPU not found.  Use TPUMOVER to extract it from TURBO.TPL');
  87.     writeln(' or TPW.TPL.');
  88.     halt(99);
  89.   end;
  90.   blockread(tpu,buffer,sizeof(buffer),actual);
  91.   close(tpu);
  92.  
  93.   assign(tps,'SYSTEM.TPS');
  94.   {$i-} rewrite(tps,1); {$i+}
  95.   if ioresult <> 0 then
  96.   begin
  97.     writeln('Unable to open SYSTEM.TPS for writing!');
  98.     halt(98);
  99.   end;
  100.  
  101.   with header do
  102.   begin
  103.     if file_id <> 'TPU9' then
  104.     begin
  105.       writeln('SYSTEM.TPU is from an incorrect version.  Sorry!');
  106.       halt(97);
  107.     end;
  108.  
  109.     { Save the reduced size first }
  110.     sym_size := ofs_this_unit;
  111.     if sym_size > sizeof(buffer) then
  112.     begin
  113.       writeln('Internal error!  We''ve run out of space.');
  114.       halt(96);
  115.     end;
  116.  
  117.     { Change the header to drop all the extras }
  118.     ofs_this_unit   := 0;
  119.     ofs_entry_pts   := 0;
  120.     ofs_code_blocks := 0;
  121.     ofs_const_blocks:= 0;
  122.     ofs_var_blocks  := 0;
  123.     ofs_dll_list    := 0;
  124.     ofs_unit_list   := 0;
  125.     ofs_src_name    := 0;
  126.     ofs_line_lengths:= 0;
  127.     code_size       := 0;
  128.     const_size      := 0;
  129.     reloc_size      := 0;
  130.     vmt_size        := 0;
  131.     var_size        := 0;
  132.     flags           := [];
  133.   end;
  134.  
  135.   trim_hash;
  136.  
  137.   blockwrite(tps,buffer,header.sym_size);
  138.   close(tps);
  139.   writeln('SYSTEM.TPS created!');
  140. end.
  141.  
  142.