Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/CONCUR.ZIP/VERSION.PAS

Pascal/Delphi Source File | 1986-12-16 | 5.6 KB | 264 lines

program version;

(***********************************************

  VERSION.PAS  : FIND COMPILER VERSION SPECIFIC
                   LIBRARY LOCATIONS.

  AUTHOR       : J.F.J. PASSANT
  VERSION      : 1.00
  DATE         : 16-DEC-86

************************************************)

{$i libdec.pas}


type hexstring = string [79];

{$v-}
function hex1 (b : byte) : char;
begin
  if b > 9 then b := b + 7;
  hex1 := chr (b + ord ('0'));
end;

function hex2 (b : integer) : hexstring;
begin
  hex2 := hex1 (b div 16) + hex1 (b mod 16);
end;

function hex4 (b : integer) : hexstring;
var mask, shft, i, a : integer;
    s : hexstring;
begin
  mask := $f000;
  shft := 12;
  s [0] := #0;
  for i := 1 to 4 do
    begin
      a := (b and mask) shr shft;
      s := s + hex1 (a);
      mask := mask shr 4;
      shft := shft - 4;
    end;
  hex4 := s;
end;

{$v+}


type  addrptr  = ^integer;
      byteptr  = ^byte;
      vstring  = string [79];


var addrnormvideo  : integer;
    addrlowvideo   : integer;
    addrappend     : integer;
    addrreadln     : integer;
    addrioresult   : integer;
    changeflag     : boolean;



procedure dummy;
{Declares standard procedures to find their addresses}
var dummyf : text;
    dummyi : integer;

begin
  normvideo;
  lowvideo;
  append (dummyf);
  readln;
  dummyi := ioresult;
end;


procedure findaddresses;
{Finds the addresses of the procedures declared in <dummy>}
var addrdummy : integer;
    p         : addrptr;

begin
  addrdummy := ofs (dummy);
  p := ptr (cseg, addrdummy+12);
  addrnormvideo := p^ + addrdummy+14;
  p := ptr (cseg, addrdummy+15);
  addrlowvideo  := p^ + addrdummy+17;
  p := ptr (cseg, addrdummy+26);
  addrappend    := p^ + addrdummy+28;
  p := ptr (cseg, addrdummy+32);
  addrreadln    := p^ + addrdummy+34;
  p := ptr (cseg, addrdummy+38);
  addrioresult  := p^ + addrdummy+40;
end;



procedure change (id : vstring; addr : integer);
{Gives a change notification}
begin
  writeln ('Change constant value of "', id:11, '" to $', hex4 (addr));
  changeflag := true;
end;


procedure finderror (id : vstring);
{Gives an error message}
begin
  writeln ('Cannot find address for ', id);
  changeflag := true;
end;


procedure checkattr;
{Finds address of attribute bytes in library data segment}
var p : addrptr;

begin
  p := ptr (cseg, addrnormvideo + 2);
  if p^ <> normattr then change ('normattr', p^);
  p := ptr (cseg, addrlowvideo + 2);
  if p^ <> lowattr then change ('lowattr', p^);
end;


procedure checkscreen;
{Checks wheter the screen layout variables can be found}
var row, col : integer;

begin
  col := nrofcols;
  row := nrofrows;
  if col mod 20 <> 0 then writeln ('Address for "nrofcols" incorrect');
  if (row <> 24) and (row <> 25) then
    writeln ('Address for "nrofrows" incorrect');
end;


procedure checkctrlcjump;
{Checks control-c jump address}
var pb : byteptr;
    pa : integer;

begin
  pa := addrioresult - 5;
  pb := ptr (cseg, pa);
  if pb^ <> $BA
    then finderror ('ctrlcjump')
    else if pa <> ctrlcjump then change ('ctrlcjump', pa);
end;


procedure checkinitialstack;
{Checks the initial SP variable address}
var pb : byteptr;
    pa : addrptr;
    a  : integer;

begin
  pa := ptr (cseg, $101);    {Find program init start address}
  a  := pa^ + $103;
  pa := ptr (cseg, a+1);     {Find call to init code}
  a  := pa^ + a+3;
  pb := ptr (cseg, a+$55);   {Pointer to 'initialstack' reference}
  pa := ptr (cseg, a+$56);
  if pb^ <> $A3
    then finderror ('initialstack')
    else if pa^ <> initialstack then change ('initialstack', pa^);
end;


procedure checkliberror;
{Checks the library error variable location}
var pb : byteptr;
    pa : addrptr;

begin
  pb := ptr (cseg, addrioresult + 2);
  pa := ptr (cseg, addrioresult + 4);
  if pb^ <> $86
    then finderror ('liberror')
    else if pa^ <> liberror then change ('liberror', pa^);
end;


procedure checkconinvar;
{Checks the variable locations used by conin}
var pb : byteptr;
    pa : addrptr;

begin
  pb := ptr (cseg, coninptr);
  pa := ptr (cseg, coninptr+1);
  if pb^ <> $A0
    then finderror ('secondchar')
    else if pa^ <> secondchar then change ('secondchar', pa^);
  pb := ptr (cseg, coninptr + $20);
  pa := ptr (cseg, coninptr + $22);
  if pb^ <> $80
    then finderror ('ctrlcflag')
    else if pa^ <> ctrlcflag then change ('ctrlcflag', pa^);
end;


procedure checkretaddr;
{Checks the location of retaddr}
var pb : byteptr;
    pa : addrptr;

begin
  pb := ptr (cseg, addrioresult - 10);
  pa := ptr (cseg, addrioresult - 8);
  if pb^ <> $83
    then finderror ('retaddr')
    else if pa^ <> retaddr then change ('retaddr', pa^);
end;


procedure checkfileptr;
{Checks the location of the default file pointer}
var pb : byteptr;
    pa : addrptr;

begin
  pb := ptr (cseg, addrreadln + 10);
  pa := ptr (cseg, addrreadln + 12);
  if pb^ <> $C7
    then finderror ('fileptr')
    else if pa^ <> fileptr then change ('fileptr', pa^);
end;


procedure checkfilescratch;
{Checks the location of the filescratch variable}
var pb : byteptr;
    pa : addrptr;

begin
  pb := ptr (cseg, addrappend + 2);
  pa := ptr (cseg, addrappend + 3);
  if pb^ <> $A2
    then finderror ('filescratch')
    else if pa^ <> filescratch then change ('filescratch', pa^);
end;



begin
  findaddresses;
  changeflag := false;
  checkattr;
  checkscreen;
  checkctrlcjump;
  checkinitialstack;
  checkliberror;
  checkconinvar;
  checkretaddr;
  checkfileptr;
  checkfilescratch;
  if not changeflag then writeln ('No changes needed !!');
end.