program TPU2TPS;

{ Program to extract SYSTEM.TPS file from SYSTEM.TPU file. }
{ Written for the public domain by D.J. Murdoch, July 1991 }

{ These declarations for a TP 6.0/ TPW 1.0 .TPU file are taken from
  my INTRFC program }

type
  unit_flags = set of (ieee_reals,overlays,windows,f8,moveable,f20,preload,f80,
                       f100,f200,f400,f800,discardable,f2000,f4000,f8000);
type
  header_ptr = ^header_rec;
  header_rec = record
    file_id: array[0..3] of char; { 0-3 }
    i4,                           { 4-5 }
    i6,                           { 6-7 }
    ofs_this_unit,                { 8-9 }
    ofs_hashtable,                { A-B }
    ofs_entry_pts,                { C-D }
    ofs_code_blocks,              { E-F }
    ofs_const_blocks,             {10-11}
    ofs_var_blocks,               {12-13}
    ofs_dll_list,                 {14-15}
    ofs_unit_list,                {16-17}
    ofs_src_name,                 {18-19}
    ofs_line_lengths,             {1A-1B}
    sym_size,                     {1C-1D}
    code_size,                    {1E-1F}
    const_size,                   {20-21}
    reloc_size,                   {22-23}
    vmt_size,                     {24-25}
    var_size,                     {26-27}
    ofs_full_hash: word;          {28-29}
    flags : unit_flags;           {2A-2B}
    other : array[$2C..$3F] of byte; {2C-3F}
  end;

var
  buffer : array[0..32767] of byte;
  header : header_rec absolute buffer;

function word_at(offset:word):word;
{ Return the word at a given offset in the buffer }
begin
  word_at := buffer[offset] + buffer[offset+1] shl 8;
end;

procedure set_word(offset,value:word);
{ Set the word at a given offset to a new value }
begin
  move(value,buffer[offset],sizeof(word));
end;

procedure trim_hash;
{ Trim hash references that point too far out in the .TPU }
var
  start : word;
  current,next : word;
begin
  with header do
  begin
    start := 0;
    while start <= word_at(ofs_hashtable) do
    begin
      next := ofs_hashtable + start + 2;
      repeat
        current := next;
        next := word_at(current);
      until next < sym_size;
      set_word(ofs_hashtable + start + 2, next);
      inc(start,2);
    end;
  end;
end;

var
  tpu,tps: file;
  actual : word;
begin
  writeln('TPU2TPS - Reads SYSTEM.TPU and extracts SYSTEM.TPS from it.');
  assign(tpu,'SYSTEM.TPU');
  {$i-} reset(tpu,1); {$i+}
  if ioresult <> 0 then
  begin
    writeln('SYSTEM.TPU not found.  Use TPUMOVER to extract it from TURBO.TPL');
    writeln(' or TPW.TPL.');
    halt(99);
  end;
  blockread(tpu,buffer,sizeof(buffer),actual);
  close(tpu);

  assign(tps,'SYSTEM.TPS');
  {$i-} rewrite(tps,1); {$i+}
  if ioresult <> 0 then
  begin
    writeln('Unable to open SYSTEM.TPS for writing!');
    halt(98);
  end;

  with header do
  begin
    if file_id <> 'TPU9' then
    begin
      writeln('SYSTEM.TPU is from an incorrect version.  Sorry!');
      halt(97);
    end;

    { Save the reduced size first }
    sym_size := ofs_this_unit;
    if sym_size > sizeof(buffer) then
    begin
      writeln('Internal error!  We''ve run out of space.');
      halt(96);
    end;

    { Change the header to drop all the extras }
    ofs_this_unit   := 0;
    ofs_entry_pts   := 0;
    ofs_code_blocks := 0;
    ofs_const_blocks:= 0;
    ofs_var_blocks  := 0;
    ofs_dll_list    := 0;
    ofs_unit_list   := 0;
    ofs_src_name    := 0;
    ofs_line_lengths:= 0;
    code_size       := 0;
    const_size      := 0;
    reloc_size      := 0;
    vmt_size        := 0;
    var_size        := 0;
    flags           := [];
  end;

  trim_hash;

  blockwrite(tps,buffer,header.sym_size);
  close(tps);
  writeln('SYSTEM.TPS created!');
end.