program f77patch;

imports        Perq_string from Perq_string;
imports        Fileutils from Fileutils;
imports        Filesystem from Filesystem;
imports        Code from Code;
imports        filetypes from filetypes;
        
        
label 10,11,20,30,90,99,100,101,900,905,910,912,915,920,925,930,935,940,945,950,
      960,990,999;
      
type dbleword=record msw,lsw:integer end;
     altrec=record
            oval,disp,blkno:integer;
            nval:array[0..17] of integer
            end;
            
var cfile,lfile:text;
    cline,cname,lname,mname,segname,fullname,tname,nostr:string;
    ok,applyma:boolean;
    pno,segfileid,tmpid,blks,bits,ind:integer;
    alter:array[1..20] of altrec;
    segbuff:pdirblk;
    blkbuff:psegblock;
    cs:long;
    csdble:dbleword;
    che,cl,i,tlen:integer;
    pdata:ptrfsdataentry;
    
function lstoi(var str:string;var num:integer):boolean;

{ Converts hex or decimal string, str, up to terminating character into an
  integer in num. Returns rest of string in str.                           }
  
label 10;
var len,i,dig,base,start:integer;
begin
num:=0;
lstoi:=false;
len:=length(str);
if len=0 then exit(lstoi);
if (str[1]='X') then
  begin
  base:=16;
  start:=2;
  end else
  begin
  base:=10;
  start:=1;
  end;
for i:=start to len do
  begin
  case str[i] of
  ',',')':goto 10;
  '0'..'9':dig:=ord(str[i])-ord('0');
  'A'..'F':begin
           if base=10 then exit(lstoi);
           dig:=ord(str[i])-ord('A')+10;
           end;
  otherwise:exit(lstoi);
  end;
  num:=num*base+dig;
  end;
10:
if i+1>len then str:='' else str:=substr(str,i+1,len-i);
lstoi:=true;
end; {lstoi}

function hxtoi(var xstr:string;var xnum:integer):boolean;

{ Converts 1st 4 characters of hex string, xstr, into an integer in xnum.
  Returns remaining characters in xstr.                                   }                                           
var i,dig:integer;
begin
xnum:=0;
hxtoi:=false;
for i:=1 to 4 do
  begin
  case xstr[i] of
    '0'..'9':dig:=ord(xstr[i])-ord('0');
    'A'..'F':dig:=ord(xstr[i])-ord('A') + 10;
    otherwise:exit(hxtoi);
    end;
  xnum:=xnum*16 + dig;
  end;
hxtoi:=true;
if length(xstr)>4 then xstr:=substr(xstr,5,length(xstr)-4) else xstr:='';
end; { hxtoi }

function ma(alter:altrec):boolean;

{ Applies  1 alter line to seg file }

var i:integer;
begin
ma:=false;
WRITELN('reading block ',alter.blkno,' at displacemet ',alter.disp);
fsblkread(tmpid,alter.blkno,segbuff);
if segbuff^.buffer[alter.disp]<>alter.oval then exit(ma);
for i:=1 to alter.nval[0] do segbuff^.buffer[alter.disp+i-1]:=alter.nval[i];
fsblkwrite(tmpid,alter.blkno,segbuff);
ma:=true;
writeln(lfile);
writeln(lfile,'Block ',alter.blkno:1,' at word displacement ',alter.disp:3);
writeln(lfile,'old value',alter.oval:6:-16,'  <hex>');
writeln(lfile,'         ',alter.oval:6:-10,'  <dec>');
write(lfile,'new value');
for i:=1 to alter.nval[0] do write(lfile,alter.nval[i]:6:-16);
writeln(lfile,'  <hex>');
write(lfile,'         ');
for i:=1 to alter.nval[0] do write(lfile,alter.nval[i]:6:-10);
writeln(lfile,'  <dec>');
end; { ma }

{ f77patch }
begin
writeln;
writeln('          FORTRAN Patch Utility Version 1.0');
writeln;

{ Get commandfile and listing file names }
write('commandfilename:');
readln(cname);
write('listfilename:');
readln(lname);
reset(cfile,cname);

{ Initialise listing file }
rewrite(lfile,lname);
writeln(lfile,'          FORTRAN Patch Utility Version 1.0');

10:
if eof(cfile) then goto 900;
11:
{ Read mod amend line of command file }
writeln(lfile);
readln(cfile,cline);
if length(cline)=0 then goto 10;
cs:=0;  applyma:=true;  cl:=0;
convupper(cline);
writeln(lfile,cline);
for i:=1 to length(cline) do cs:=cs+ord(cline[i]);
if cline[1]<>'M' then goto 905;
if length(cline)<3 then goto 905;
if cline[2]<>'(' then goto 905;
ind:=pos(cline,',');
if ind=0 then goto 905;
mname:=substr(cline,3,ind-3);
segname:=concat(mname,'.seg');
tname:=concat(mname,'.tmp');
fullname:=segname;
segfileid:=fssearch(fssyssearchlist,fullname,blks,bits);
if segfileid=0 then goto 910;

{ Check that fullname is a seg file }
{ new(pdata);
fsgetfsdata(segfileid,pdata);
if pdata^.filetype<>segfile then goto 912; }

nostr:=substr(cline,ind+1,length(cline)-ind-1);
if length(nostr)>2 then goto 915;
ok:=lstoi(nostr,pno);
if not ok then goto 915;
if pno>40 then goto 915;

20:
{ Read first alter line of command file }
if eof(cfile) then goto 99;
readln(cfile,cline);
if length(cline)=0 then goto 20;
while (cline[1]<>'c') and (cline[1]<>'C') do
  begin
  cl:=cl+1;
  convupper(cline);
  writeln(lfile,cline);
  for i:=1 to length(cline) do cs:=cs+ord(cline[i]);
  if cline[1]<>'A' then goto 920;
  if length(cline)<3 then goto 920;
  nostr:=substr(cline,3,length(cline)-2);
  ok:=lstoi(nostr,i);
  if not ok then goto 925;
  if i>=blks then goto 925 else alter[cl].blkno:=i;
  ok:=lstoi(nostr,i);
  if not ok then goto 930;
  if i>255 then goto 930 else alter[cl].disp:=i;
  ok:=lstoi(nostr,alter[cl].oval);
  if not ok then goto 935;
  if nostr[1]<>'X' then goto 940;
  nostr:=substr(nostr,2,length(nostr)-2);
  tlen:=length(nostr);
  if tlen mod 4<>0 then goto 940;
  for i:=1 to tlen div 4 do
    begin
    ok:=hxtoi(nostr,alter[cl].nval[i]);
    if not ok then goto 940;
    end;
  alter[cl].nval[0]:=tlen div 4;

  90:
  { Read next line of command file }
  if eof(cfile) then goto 99;
  readln(cfile,cline);
  if length(cline)=0 then goto 90;
  end;

{ Analyse checksum line }
convupper(cline);
writeln(lfile,cline);
ind:=pos(cline,'(');
if ind=0 then goto 945;
if cline[length(cline)]<>')' then goto 945;
csdble:=recast(cs,dbleword);
if ind+1<length(cline) then
  begin
  if cline[ind+1]<>'X' then goto 945;
  nostr:=substr(cline,ind+2,length(cline)-ind-2);
  if length(nostr)<>4 then goto 945;
  ok:=hxtoi(nostr,che);
  if not ok then goto 945;
  if che<>csdble.lsw then goto 950;
  end;
writeln(lfile,'Checksum is X',csdble.lsw:1:-16);
if not applyma then goto 99;
writeln(lfile);

30:
{ Check if temporary file exists }
tmpid:=fsinternallookup(tname,i,i);
if tmpid<>0 then
  begin
  tname:=concat(tname,'$');
  goto 30;
  end;

{ Copy segfile to temporary file }
WRITELN('copy segfile to temp. file ',tname);
tmpid:=fsenter(tname);
new(segbuff);
for i:=0 to blks-1 do
  begin
  fsblkread(segfileid,i,segbuff);
  fsblkwrite(tmpid,i,segbuff);
  end;
fsclose(segfileid,blks,bits);

{ Read block 0 of file }
fsblkread(tmpid,0,segbuff);
blkbuff:=recast(segbuff,psegblock);
if blkbuff^.version[pno+40]=chr(pno) then
  begin
  writeln(lfile,'patch no.',pno:4,' already applied to module ',fullname);
  WRITELN('deleteing temp. file ',tname);
  fsdelete(tname);
  end else
  begin
  writeln(lfile,'Module ',fullname,' being updated with patch no.',pno:4);
  for i:=1 to cl do
    begin
    ok:=ma(alter[i]);
    if not ok then goto 960;
    end;
  fsblkread(tmpid,0,segbuff);
  blkbuff:=recast(segbuff,psegblock);
  blkbuff^.version[pno+40]:=chr(pno);
  fsblkwrite(tmpid,0,segbuff);
  fsclose(tmpid,blks,bits);
  writeln(lfile);
  writeln(lfile,'changes written to file ',fullname);
WRITELN('deleting file ',fullname);
  fsdelete(fullname);
WRITELN('renaming tempfile to ',fullname);
  fsrename(tname,fullname);
  end;

99:
{ Repeat if not end of file }
if not eof(cfile) then goto 11;

101:
{ Finished }
close(lfile);
exit(f77patch);

900:
writeln(lfile,' ** ',cname,' empty'); goto 101;
905:
writeln(lfile,' ** Mod Amend line invalid'); applyma:=false; goto 20;
910:
writeln(lfile,' ** ',segname,' does not exist'); applyma:=false; goto 20;
912:
writeln(lfile,' ** ',fullname,' is not a SEG file'); applyma:=false; goto 20;
915:
writeln(lfile,' ** Patch number invalid'); applyma:=false; goto 20;
920:
writeln(lfile,' ** Alter line invalid'); applyma:=false; goto 90;
925:
writeln(lfile,' ** Block no. invalid'); applyma:=false; goto 90;
930:
writeln(lfile,' ** Displacement invalid'); applyma:=false; goto 90;
935:
writeln(lfile,' ** Old valuse invalid'); applyma:=false; goto 90;
940:
writeln(lfile,' ** New value invalid'); applyma:=false; goto 90;
945:
writeln(lfile,' ** Checksum line invalid'); goto 99;
950:
writeln(lfile,' ** Checksum invalid'); goto 99;
960:
writeln(lfile,' ** alter fails'); fsclose(tmpid,blks,bits);
WRITELN('deleteing file ',tname);
fsdelete(tname); goto 99;
990:
writeln(lfile,' ** Premature end of command file'); goto 101;

end. {f77patch }