Programmer 7500/MAX_PROGRAMMERS.iso/INFO/TURBOPAS/COMP.ZIP/COMP.PAS

Pascal/Delphi Source File | 1985-12-28 | 10.1 KB | 547 lines

program comp;

{ source file comparator:
  after an article in Dr. Dobb's Journal No. 94 by D.E. Cortesi

  Turbo 3.0 implementation and changes by
  Paul van der Eijk   [phone]  }

{$p32  allows output redirection }
{$r- disable range checking}
{$k- disable stack checking}

const
   trace   = false;

   maxfile = 2000;         {largest old/new file}
   maxover = 2001;         {maxfile+1 sentinel value}
   maxchar = 255;          {longest line}
   maxsym  = 4023;         {prime > 2*maxfile}
   topsym  = 4022;         {maxsym-1 max index }


type
   symnum  = 0..topsym;
   linenum = 1..maxover;
   linecnt = 0..maxover;

   ltext   = string[maxchar];
   linerec = record
      matched: boolean;  {true when matched in other file}
      index  : integer;  {index to symbtab or other file}
   end;

   symrec  = record
      hashval: integer;   {neg = unused entry}
      lineval: ^ltext;    {address of text string}
      oline  : linenum;   {index to line in old file}
      ocount : 0..2;      {occurrences in old file}
      ncount : 0..2;      {occurrences in new file}
   end;

var
   oldmax,
   newmax: linecnt;
   oldfile,
   newfile: text;
   difname,
   oldname,
   newname: string[20];
   oa     ,
   na     : array[linenum] of linerec;
   st     : array[symnum] of symrec;
   supbl  : boolean;  {suppress multiple blanks}


function store(var t: ltext): symnum;
label
   1,
   2,
   3,
   4;

var
   s: symnum;
   h: integer;
   l: 0..maxchar;

   procedure removebl;
   var
      xl,
      xr : 0..maxchar;
   begin
   xl := 1;
   for xr := 2 to length(t)
   do if (t[xr] <> ' ') or (t[xl] <> ' ')
      then
         begin
         xl := succ(xl);
         t[xl] := t[xr]
         end;
   t[0] := chr(xl)
   end;

begin {store}
{strip trailing blanks}
l := length(t);
while t[l] = ' '
do l := l - 1;
t[0] := chr(l);

{optional suppress multiple blanks}
if supbl and (l > 0)
then
   removebl;

{get hash value}
h := 0;
for l := length(t) downto 1
do h := h + h + ord(t[l]);  {ignores overflow}
h := h and $7FFF;

s := h mod maxsym;

{find duplicate line or vacant symbol starting at st[s] }
1: if st[s].hashval < 0
   then
      goto 3;   {free entry}

   if st[s].hashval <> h
   then
      goto 2;   {fast not equal}

   if st[s].lineval^ = t
   then
      goto 4;   {expensive equal}

2: {next entry}
   s := (s + 1) mod maxsym;
   goto 1;

3: {install new line}
   with st[s]
   do begin
      hashval := h;
      getmem(lineval,length(t) + 1);
      lineval^ := t;
      end;
4: {line exists}
   store := s
end;

procedure pass1;
{read old file}
var
   o: linecnt;
   s: symnum;
   t: ltext;
begin
o := 0;
repeat
   readln(oldfile,t);
   o := o + 1;
   s := store(t);
   with st[s]
   do begin
      oline := o;
      if ocount < 2
      then
         ocount := ocount + 1
      end;
   with oa[o]
   do begin
      matched := false;
      index := s
      end;
until eof(oldfile) or (o >= maxfile);
{create stopper}
with oa[o + 1]
do begin
   matched := true;
   index := maxover
   end;
oldmax := o
end;

procedure pass2;
{read the new file}
var
   n: linecnt;
   s: symnum;
   t: ltext;
begin
n := 0;
repeat
   readln(newfile,t);
   n := n + 1;
   s := store(t);
   with st[s]
   do if ncount < 2
      then
         ncount := ncount + 1;
   with na[n]
   do begin
      matched := false;
      index   := s
      end
until eof(newfile) or (n >= maxfile);
{create stopper}
with na[n + 1]
do begin
   matched := true;
   index   := maxover
   end;
newmax := n
end;


procedure matchup(o,n: linenum);
{store indices for matching lines}
begin
with oa[o]
do begin
   matched := true;
   index   := n
   end;
with na[n]
do begin
   matched := true;
   index := o
   end
end;

procedure pass3;
{when a line appears exactly once in each file, it
 is the same line in a possible different position}
var
   o,
   n: linenum;
begin
for n := 1 to newmax
do begin
   with st[na[n].index]
   do if (ocount = 1) and (ncount = 1)
      then
         matchup(oline,n)
   end
end;

procedure pass4a;
{if two lines are equal and directly follow two matched lines
 then they match}
var
   o,
   o1,
   n,
   n1: linenum;
begin
for n := 1 to newmax - 1
do if na[n].matched
   then
      begin
      n1 := n + 1;
      if not na[n1].matched
      then
         begin
         o := na[n].index;
         if o < oldmax
         then
            begin
            o1 := o + 1;
            if not oa[o1].matched
            then
               if oa[o1].index = na[n1].index
               then
                  matchup(o1,n1)
            end
         end
      end
end;

procedure pass4b;
{if two lines are equal and preceed two matched lines
 then they match}
var
   o ,
   o1,
   n ,
   n1: linenum;
begin
for n := newmax downto 2
do if na[n].matched
   then
      begin
      n1 := n - 1;
      if not na[n1].matched
      then
         begin
         o := na[n].index;
         if o > 1
         then
            begin
            o1 := o - 1;
            if not oa[o1].matched
            then
               if oa[o1].index = na[n1].index
               then
                  matchup(o1,n1)
            end
         end
      end
end;


procedure pass5;
{translate block moves into deletes and inserts}
var
   o,
   n: linenum;
   done: boolean;

   procedure resolve(var o,n: linenum);
   var
      xo,
      xn,
      first,
      last : linenum;
      t    : integer;
      s: symnum;
   begin
   xo := o;
   repeat
      t := 1 + oa[xo].index;
      xo := xo + 1
   until (t <> oa[xo].index) or not oa[xo].matched;
   xn := n;
   repeat
      t := 1 + na[xn].index;
      xn := xn + 1
   until (t <> na[xn].index) or not na[xn].matched;
   if xo - o < xn - n
   then
      begin
      first := o;
      last := xo - 1;
      o := xo
      end
   else
      begin
      first := na[n].index;
      last := first + xn - n - 1;
      n := xn
      end;

   s := 0;
   for t := first to last
   do begin
      while (st[s].oline < first) or (st[s].oline > last)
      do s := s + 1;
      xo := st[s].oline;
      xn := oa[xo].index;
      with oa[xo]
      do begin
         matched := false;
         index := s
         end;
      with na[xn]
      do begin
         matched := false;
         index := s
         end;
      s := s + 1
      end
   end;

begin {pass5}
o := 1;  n := 1;  done := false;
repeat
   while not oa[o].matched
   do o := o + 1;
   while not na[n].matched
   do n := n + 1;

   if (n > newmax) or (o > oldmax)
   then
      done := true
   else
      if oa[o].index = n
      then
         begin
         o := o + 1;
         n := n + 1
         end
      else
         resolve(o,n)
until done
end;


procedure pass6;
var
   xo,
   xn,
   o,
   n,
   i: linenum;
   delcnt,
   inscnt: integer;

begin {pass6}
o := 1;  n := 1;
repeat

   delcnt := 0;
   if not oa[o].matched
   then
      begin {deleting}
      xo := o;
      repeat
         delcnt := delcnt + 1;
         o := o + 1
      until oa[o].matched
      end;

   inscnt := 0;
   if not na[n].matched
   then
      begin
      xn := n;
      repeat
         inscnt := inscnt + 1;
         n := n + 1
      until na[n].matched;
      end;


   if (delcnt > 0) and (inscnt > 0)
   then
      begin
      writeln('-----Replace at ',xo:0);
      for i := xo to xo + delcnt - 1
      do writeln(st[oa[i].index].lineval^);
      writeln('-----with');
      for i := xn to xn + inscnt - 1
      do writeln(st[na[i].index].lineval^)
      end
   else
      if delcnt > 0
      then
         begin
         writeln('-----Delete at ',xo:0);
         for i := xo to xo + delcnt - 1
         do writeln(st[oa[i].index].lineval^)
         end
      else
         if inscnt > 0
         then
            begin
            writeln('-----Insert at ',xn:0);
            for i := xn to xn + inscnt - 1
            do writeln(st[na[i].index].lineval^)
            end;

   while oa[o].matched and na[n].matched and (o <= oldmax)
   do begin
      o := o + 1;
      n := n + 1
      end;


until (oa[o].index = maxover) and (na[n].index = maxover);
end;


procedure setup;
var
   j: symnum;
begin
for j := 0 to topsym
do with st[j]
   do begin
      hashval := -1;
      oline := maxover;
      ocount := 0;
      ncount := 0
      end;
oldmax := 0;
newmax := 0;

end;


procedure dump(t: ltext);
var
   i: linenum;
begin
if trace
then
   begin
   writeln('OLD FILE ',t);
   for i := 1 to oldmax
   do with oa[i],st[index]
      do begin
         write(i:5,index:8,matched:7,oline:8,ocount:3,ncount:3);
         if not matched
         then
            write('   ',lineval^);
         writeln
         end;
   writeln('NEW FILE ',t);
   for i := 1 to newmax
   do with na[i],st[index]
      do begin
         write(i:5,index:8,matched:7,oline:8,ocount:3,ncount:3);
         if not matched
         then
            write('    ',lineval^);
         writeln
         end
   end
end;



begin
if paramcount < 2
then
   begin
   writeln('usage: comp oldfile newfile');
   writeln('       optional switches /s : to suppress multiple blanks');
   writeln('       diffile is written to output')
   end
else
   begin
   assign(oldfile,paramstr(1));
   reset(oldfile);
   assign(newfile,paramstr(2));
   reset(newfile);
   supbl := false;
   if paramcount > 2
   then
      begin
      if (paramstr(3) = '/s') or (paramstr(3) = '/S')
      then
         supbl := true
      end;

   if eof(oldfile)
   then
      writeln('OLD FILE IS EMPTY')
   else
      if eof(newfile)
      then
         writeln('NEW FILE IS EMPTY')
      else
         begin
         setup;
         pass1;
         pass2;  dump('AFTER PASS2');
         pass3;  dump('AFTER PASS3');
         pass5;  dump('AFTER PASS5');
         pass4a;
         pass4b; dump('AFTER PASS4');
         pass6;
         end
   end
end.