program worcha(fin,fout,worchap,output);
(* worcha: word changing program
      by patrick r. roche
      module libraries: delman, delmods *)

label 1; (* end of worcha *)

const
(* begin module version *)
   version = 2.57; (* of worcha.p 2003 Nov 17
2003 Nov 17, 2.57: increase word length buffer size
2000 jul 25, 2.56: increase line length buffer size
1996 Jul 29, 2.55: previous version
previous version: 1989 April 5
origin before 1982 aug 13 *)
(* end module version *)

(* begin module describe.worcha *)
(*
name
      worcha: word changing program

synopsis
      worcha(fin: in, fout: out, worchap: in, output: out)

files
      fin:     the file in which words need to be changed to other words.
      fout:    the file where the copy of fin with the words changed is written.
      worchap: the parameter file containing the words that need to
               be replaced and their replacements.  Worchap must be
               constructed as follows:

               a word that needs to be changed is on the first line, the
               following line contains the replacement word,
                  next line:  word to be replaced,
                  following line: replacement word,
               and so on....etc.

               so, the odd numbered lines, (1,3,5....), have the words
               from fin that will be replaced, and the even numbered
               lines, (2,4,6...), contain the replacement words.
      output:  where error messages will appear.

description
      This program was designed to go through a pascal program and
      locate and replace 'words', (pascal identifiers).

         Worcha will sort through a file and look for the words that need to be
      changed, ignoring comments and both single and double quotes.  Upon
      finding the old words, worcha will substitute the specified new words from
      worchap when copying the input file onto the specified output file.  As
      many words as necessary may be changed at one time.  Worcha produces a
      list of the changes within a comment at the end of the fout file.

documentation
      delman.assembly.worcha

author
      Patrick R. Roche

bugs
      The program will yell if word length is greater than or equal to
      wdlgthmax.

technical notes
      Worcha uses linked-lists for storing the words to be changed and their
      replacements.  Thus as many words as desired may be changed at one time.

*)
(* end module describe.worcha *)

      debug = false;          (* debugging displays on or off *)
(* 1995 dec 20.  The program bombed on a line with quotes in it:
      delman.intro.organization 'technical notes'
The trigger to bomb was a quote on the end of a line.  (A single space after it
would solve the problem.) The bug was corrected by making the routines
skip2quotes and skip1quotes be a little smarter.  They now stop putting dots
down when they exceed the end of the line and when they hit the end of the
buffer.  I am leaving the debug code in.  If it is stable it can be removed
later.  There is also debug code left by Pat.  *)

      listonoutput = false;    (* listing of changes to output *)
      listonfout = false;      (* listing of changes to fout *)
      lnlgthmax = 2000;        (* max length of a buffer line *)
      wdlgthmax = 2000;        (* max length of a word buffer *)

type
      buffer = record      (* this will hold the line of fin *)
         place: array[1..lnlgthmax] of char;
         length: integer
      end;

      buff2 = record       (* this will hold the old and new words *)
         place: array[1..wdlgthmax] of char;
         length: integer
      end;

      wordptr = ^aword;    (* a pointer to a word-record *)

      aword = record        (* these are what will make up the linked-list *)
         oldword: buff2;   (* the old word *)
         newword: buff2;   (* the new word *)
         numbchgs: integer;   (* number of times old word ---> new word *)
         next: wordptr
      end;

var
      fin,
      fout,
      worchap: text;

  first: wordptr;  (* the 'root' word pointer *)

(* begin module halt *)
procedure halt;
(* stop the program.  the procedure performs a goto to the end of the
   program.  you must have a label:
      label 1;
   declared, and also the end of the program must have this label:
      1: end.
   examples are in the module libraries.
   this is the only goto in the delila system. *)
begin
      writeln(output,' program halt.');
      goto 1
end;
(* end module halt version = 'delmod 6.51 85 apr 17 tds/gds' *)

procedure clearb(var b: buffer);
(* clear the buffer by filling with blanks *)

var i: integer;  (* counter and index *)

begin
      for i:=1 to lnlgthmax do b.place[i]:=' ';
      b.length:=0
end;

procedure clearb2(var b: buff2);
(* clear the buffer by filling with blanks *)

var i: integer;  (* counter and index *)

begin
      for i:=1 to wdlgthmax do b.place[i]:=' ';
      b.length:=0
end;

procedure writebuffer(var fout: text; b: buffer);
      (* writeln buffer b to fout *)

      var   i,   (* index of b *)
            c:   (* counter *)
             integer;

      begin
         i:=0;
         for c:=1 to b.length do begin
            i:= i+1;
            write(fout,b.place[i])
         end;
         writeln(fout)
      end;

procedure writetrigger(var fout: text; b: buffer);
      (* writeln buffer b to fout within quotes *)

      var   i,   (* index of b *)
            c:   (* counter *)
             integer;

      begin
         write(fout,' ''');
         i:=0;
         for c:=1 to b.length do begin
            i:= i+1;
            write(fout,b.place[i])
         end;
         write(fout,'''');
         writeln(fout)
      end;

procedure write2trigger(var fout: text; b: buff2);
      (* writeln buff2 b to fout within quotes *)

      var   i,   (* index of b *)
            c:   (* counter *)
             integer;

      begin
         write(fout,' ''');
         i:=0;
         for c:=1 to b.length do begin
            i:= i+1;
            write(fout,b.place[i])
         end;
         write(fout,'''');
         writeln(fout)
      end;

procedure writeword(var fout: text; b: buff2);
      (* write buff2 b to fout *)

      var   i,   (* index of b *)
            c:   (* counter *)
             integer;

      begin
         i:=0;
{zzz}
{writeln(output,'b.length = ',b.length:1);}
         for c:=1 to b.length do begin
            i:= i+1;
{write(output,'i = ',i:1,' "');}
            write(fout,b.place[i])
{;writeln(output,'"');}
         end
      end;

procedure removeblanks(var b: buff2);
         (* remove blanks from the end of a buff2 *)

      begin
         if b.place[b.length]=' '   (* if the last place is blank *)
         then begin   (* remove the blank and check next place etc. *)
            repeat
               b.length:= b.length-1
            until (b.place[b.length]<>' ')
         end
      end;

procedure readintobuffer(var fin: text; var b: buffer);
      (* read a line from fin into buffer b *)

      var i: integer;   (* index for b.place[i] and counter *)

      begin
         clearb(b);     (* clear the buffer *)
         i:=0;          (* starting at begining of the line *)

         while ( i<lnlgthmax ) and not (eoln(fin) or eof(fin) ) do begin
         (* keeping line length below max and going to end of line *)
            i:= i+1 ;               (* next character *)
            read(fin, b.place[i]);   (* read in next character to buffer *)
            b.length := i           (* keeping track of length of the buffer *)
         end;
         if i=lnlgthmax   (* if the input line is more
                       than the buffer can handle *)
         then begin
            writeln(output,' input to buffer is too big');
            writebuffer(output,b);
            halt
         end;
         if not eof(fin) then readln(fin)    (* go to beginning of next line *)
      end;

procedure readinword(var fin: text; var b: buff2);
      (* read a line from fin into wordbuffer b *)

      var i: integer;   (* index for b.place[i] and counter *)

      begin
         clearb2(b);    (* clear the buffer *)
         i:=1;          (* necessary because of leading-blanks routine *)

         (* routine to get rid of leading blanks *)
         while (fin^ = ' ') and (not eoln(fin)) do get(fin);
         if eoln(fin)
         then begin
            writeln(output,' there are blank lines in worchap.');
            halt   (* stop program and notify user *)
         end;

         while ( i<=wdlgthmax ) and not (eoln(fin) or eof(fin) ) do begin
         (* keeping word length below wdlgthmax and going to end of line
          no words are allowed to be longer than wdlgthmax char *)

            read(fin, b.place[i]); (* read in next character to buffer *)
            b.length := i;         (* keeping track of length of the buffer *)
            i:= i+1                (* next character *)
         end;


         if i=wdlgthmax+1   (* if the word is longer then wdlgthmax,
                      longer than any allowed word, then
                      notify the user of the problem, write
                      the word, and halt the program *)
         then begin
            writeln(output,' oldword is more than allowed characters');
            write2trigger(output,b);
            halt
         end;
         if not eof(fin) then readln(fin)    (* go to beginning of next line *)

      end;

procedure readintempword(temp: buffer; var tempword: buff2;
                              var i: integer; var nomatch: boolean);
      (* this will read in a word from . to . in temp
         into tempword. if the word being read is longer than
         wdlgthmax, and therefore cannot match any word in the list,
         then nomatch will indicate this.(saves time) *)

      var c: integer;   (* index for tempword *)

      begin
         clearb2(tempword); (* clear the buffer *)
         nomatch:= false;   (* we do not know yet.. *)
         c:=1;  (* start at the beginning of tempword *)
         while (temp.place[i]<>'.') and (c<=wdlgthmax)
                and (i<=temp.length)do begin
                   (* read in the tempword till its end or the end of temp *)

            tempword.place[c]:= temp.place[i];
            tempword.length:=c;
            i:=i+1;
            c:=c+1
         end;
         if (c>wdlgthmax) and (temp.place[i]<>'.')
            (* if the tempword is longer than any word in the list *)
         then nomatch:= true   (* then no match is possible *)
      end;

procedure skipcomments(var commentpasteol: boolean; var i: integer;
                            var b, finline: buffer);
      (* translating comments from fin to '.' in temp.  see changewords *)

      begin  (* skipcomments *)
         if (finline.place[i] ='(') and (finline.place[i+1]='*')
         (* if this current place is the beginning of a comment *)
         then begin    (* move to end of comment assigning '.' to temp *)
            repeat
               b.place[i]:='.';
               i:= i+1
            until ((finline.place[i]=')') and
                  (finline.place[i-1]='*')) or
                  (i=finline.length);
               (* until you get to the end of the comment or
                  the end of the line *)

            if (finline.place[i]=')') and  (* if end of comment *)
               (finline.place[i-1]='*')
            then begin
               b.place[i]:='.';  (* change the ')' to '.' *)
               b.length:= i;   (* keep accurate track of the length of b *)
               i:=i+1;   (* leaves us on the next char of finline
                            or finline.length+1 if end of line *)
               commentpasteol := false
            end
            else if (i=finline.length) and   (* if end of line but
                                                 not end of comment *)
                    ((finline.place[i]<>')') or
                    (finline.place[i-1]<>'*'))
                 then begin
                    commentpasteol := true;
                    b.place[i]:='.';   (* assign the last place *)
                    b.length:= i   (* keep track of the length of b *)
                 end
                 else begin
                         writeln(output,' skipcomments is ending weird....');
                         halt
                      end
         end
      end;

procedure skip2quotes(var quote2pasteol: boolean; var i: integer;
                           var b, finline: buffer);
      (* translating quotes from fin to '.' in temp.  see changewords *)

      begin
{zzzqqq}
(* clean halt; *)
if debug then writeln(output,'BEGIN skip2quotes (cleanhalt)');
         if finline.place[i]=''''   (* if current place is the beginning of
                                       a quote *)
         then begin   (* move to end of quote assigning '.' to temp *)
if debug then writebuffer(output,finline);
if debug then writeln(output,'finline.length:',finline.length:1);
if debug then writeln(output,' place ',i:3,' is a single( was dbl) quote ');
            repeat
               b.place[i]:='.';
               i:= i+1;
if debug
 then writeln(output,' finline.place[',i:1,'] is: "',finline.place[i],'"')
{
original:
            until (finline.place[i]='''') or (i=finline.length);
}
{THE FOLLOWING FIXED THE PROBLEM - it made the next halt CLEAN
also, it is always better to test for > than = for the length!! }
            until (finline.place[i]='''') or (i>=finline.length)
                  or (i = lnlgthmax);
               (* until the end of the comment or the end of the line *)
{halt; (* dirty *) CONVERTED TO CLEAN}

(* the problem is that the logic of the until is wrong.
since the first character is a single quote,
it never finds a second quote and i will never equal
finlinelength.  so it keeps running up memory until
it hits a segment limit. *)

            (* this is a hack patch to make the thing work
               correctly if it overshot *)
            if i > finline.length
            then i := finline.length;

            if finline.place[i]=''''      (* if end of quote *)
            then begin
               b.place[i]:='.';  (* change the ' to . *)
               b.length:= i;  (* keep track of the length of b *)
               i:=i+1; (* leaves us on the next char of finline
                          or on finline.length+1 if end of line *)
               quote2pasteol:= false
{;writeln(output,'quote2pasteol is false');}
            end
            else if (finline.place[i]<>'''') and (* end of line but
                                                    not end of quote *)
                    (i>=finline.length)
               then begin
                  quote2pasteol:= true;
{writeln(output,'quote2pasteol is true');}
                  b.place[i]:='.';   (* assign the last place *)
                  b.length:= i   (* keep track of the length of b *)
               end
               else begin
                  writeln(output,' skip2quotes is ending weird....');
                  halt
               end

         end
      end;

procedure skip1quotes(var quote1pasteol: boolean; var i: integer;
                           var b, finline: buffer);
      (* translating quotes from fin to '.' in temp.  see changewords *)

      begin
         if finline.place[i]='"'    (* if current place is the
                                       beginning of a quote *)
         then begin   (* move to end of quote assigning '.' to temp *)
            repeat
               b.place[i]:='.';
               i:= i+1
{ original:
            until (finline.place[i]='"') or (i=finline.length);
}
{add the following protection, as in skip2quotes}
            until (finline.place[i]='"') or (i>=finline.length)
                  or (i = lnlgthmax);
               (* until end of quote or end of line *)

            (* this is a hack patch to make the thing work
               correctly if it overshot *)
            if i > finline.length
            then i := finline.length;

            if finline.place[i]='"'      (* if end of quote *)
            then begin
               b.place[i]:='.';  (* change the " to . *)
               b.length:= i;  (* keep track of the length of b *)
               i:=i+1; (* leaves us on the next char of finline
                         or on finline.length+1 if end of line *)
               quote1pasteol:= false
            end
            else if (finline.place[i]<>'"') and (* end of line but
                                                   not end of quote *)
                    (i>=finline.length)
                 then begin
                    quote1pasteol:= true;
                    b.place[i]:='.';   (* assign the last place *)
                    b.length:= i   (* keep track of the length of b *)
                 end
                 else begin
                    writeln(output,' skip1quotes is ending weird....');
                    halt
                 end
         end
      end;

procedure endcomment(var commentpasteol: boolean; var i: integer;
                          var b, finline: buffer);
      (* if the last line had a comment that did not end on that line,
      search this line for the end to that comment.  see changewords and
      skipcomments *)

      begin
         if finline.length>=2 then begin  (* see last else in this proced. *)
            i:=1;
            b.place[1]:='.';  (* these two steps are necessary because
                                 of the way the loop is constructed below
                                 if you do not start on position 2, then
                                 the program will bomb because of the
                                 testing of finline.place[i-1] which
                                 would be out of the range if i=1. *)
               repeat        (* move to end of comment assigning '.' to temp *)
                  i:= i+1;
                  b.place[i]:='.'
               until (((finline.place[i]=')') and
               (finline.place[i-1]='*')) or (i=finline.length));
                  (* until you get to the end of the comment or
                     the end of the line *)

(*if debug then writeln(output,' i= ',i);
if debug then writeln(output,' finline.place[i-1]= ',finline.place[i-1]);
if debug then writeln(output,' finline.place[i]= ',finline.place[i]);
if debug then writeln(output,' finline.length= ',finline.length); *)

               if (finline.place[i]=')') and  (* if end of comment *)
                  (finline.place[i-1]='*')
               then begin
                  i:=i+1;   (* leaves us on the next char of finline
                               or on finline.length+1 if end of line *)
                  commentpasteol := false
               end
               else if (i=finline.length) and     (* if end of line but
                                                      not end of comment *)
                       ((finline.place[i]<>')') or
                       (finline.place[i-1]<>'*'))
                    then commentpasteol := true
                       else begin
                          writeln(output,' endcomment is ending weird....');
                          halt
                       end
         end
         else commentpasteol:= true (* if filnine is shorter than 2, it cannot
                                       contain the end-of-comment marks and
                                       therefor the comment must not end on
                                       this line *)
      end;

procedure end2quote(var quote2pasteol: boolean; var i: integer;
                          var b, finline: buffer);
      (* if the last line had a quote that did not end on that line,
      search this line for the end to that quote.  see changewords and
      skip2quotes *)

      begin
         if finline.length>=1 then begin  (* see last else in this proced. *)
            i:=0;
            repeat   (* move to the end of the quote assigning '.' to temp *)
               i:=i+1;
               b.place[i]:='.'
            until (finline.place[i]='''') or (i=finline.length);
               (* until the end of the quote or the end of the line *)

            if finline.place[i]=''''   (* if end of quote *)
            then begin
               quote2pasteol:= false;
               i:=i+1   (* leaves us on the next char
                           or on finline.length+1 if end of line *)
            end
            else if (i=finline.length) and  (* if end of line, but
                                               not end of quote *)
                    (finline.place[i]<>'''')
                 then quote2pasteol:= true
                 else begin
                    writeln(output,' end2quote is ending weird....');
                    halt
                 end
         end
         else quote2pasteol:= true  (* if finline.length is less than
                                       1, it cannot contain the end-
                                       of-quote mark and therefor
                                       the quote will not end on this
                                       line *)
      end;

procedure end1quote(var quote1pasteol: boolean; var i: integer;
                          var b, finline: buffer);
      (* if the last line had a quote that did not end on that line,
      search this line for the end to that quote.  see changewords and
      skip1quotes *)

      begin
         if finline.length>=1 then begin  (* see last else in this proced. *)
            i:=0;
            repeat   (* move to the end of the quote assigning '.' to temp *)
               i:=i+1;
               b.place[i]:='.'
            until (finline.place[i]='"') or (i=finline.length);
               (* until the end of the quote or the end of the line *)

            if finline.place[i]='"'   (* if end of quote *)
            then begin
               quote1pasteol:= false;
               i:=i+1   (* leaves us on the next char or on
                           finline.length+1 if end of line *)
            end
            else if (i=finline.length) and  (* if end of line, but
                                               not end of quote *)
                    (finline.place[i]<>'"')
                 then quote1pasteol:= true
                 else begin
                    writeln(output,' end1quote is ending weird....');
                    halt
                 end
         end
         else quote1pasteol:= true  (* if finline.length is less than
                                       1, it cannot contain the end-
                                       of-quote mark and therefor
                                       the quote will not end on this
                                       line *)
      end;

procedure assigntemp(finline: buffer; var b: buffer; var commentpasteol,
                          quote2pasteol, quote1pasteol: boolean);
         (* assign temp.place[i] values.  see changewords *)

      var i: integer;   (* index of finline and temp *)

      begin

         clearb(b);   (* clear the buffer *)
         i:=1;        (* start at the beginning *)
         if commentpasteol then endcomment(commentpasteol,i,b,finline);
         if quote2pasteol then end2quote(quote2pasteol,i,b,finline);
         if quote1pasteol then end1quote(quote1pasteol,i,b,finline);

         while i <= finline.length do begin
(*clean halt;*)
            (* assign finline to temp buffer that will
               only contain the identifiers which are
               not in comments or quotes. everything
               else will be translated into '.' in temp *)

          if i<=finline.length then skipcomments(commentpasteol,i,b,finline);
(*clean halt;*)
          if i<=finline.length then skip2quotes(quote2pasteol,i,b,finline);
{halt; NEUTRALIZE}
(* dirty halt;*)
          if i<=finline.length then skip1quotes(quote1pasteol,i,b,finline);

(* dirty halt;*)

          if (finline.place[i]<>'''') and  (* if a quote ends right away
                                              do not want to do the subst.
                                              below b/c it will mess up
                                              our ability to detect the
                                              end of the quote by advancing
                                              finline.place to the next
                                              position before we check for
                                              the end of the quote. *)
               (finline.place[i]<>'"')
            then
               if i<=finline.length then begin  (* only want to continue
                                                   if there is anything left *)
            (* There was a bug here!  We now need both smalls AND caps! *)
                  if finline.place[i] in ['a'..'z','A'..'Z','0'..'9']
                     (* only want letters and numbers in temp *)
                  then b.place[i]:=finline.place[i]
                  else b.place[i]:='.';
                  b.length:=i;   (* keeping track of the length of temp *)
                  i:=i+1
               end
         end;


if debug then write  (output,'             |0        1         2         3');
if debug then writeln(output,'         4         5         6');
if debug then write  (output,'             |123456789012345678901234567890');
if debug then writeln(output,'1234567890123456789012345678901234');
if debug then write(output,' finline:    |');
if debug then writebuffer(output,finline);
if debug then write(output,' temp:       |');
if debug then writebuffer(output,b);

if debug then writeln(output,' commentpasteol: ',commentpasteol);
if debug then writeln(output,' quote2pasteol: ',quote2pasteol);
if debug then writeln(output,' quote1pasteol: ',quote1pasteol);

      end;

procedure assignwords(var p: wordptr);
      (* assign the values to the word-records *)

      begin
         if eof(worchap) then begin
            writeln(output,' unexpected end of worchap encountered.');
            halt
         end;
         with p^ do begin
            readinword(worchap,oldword);
            removeblanks(oldword);
            if eof(worchap) then begin
            (* if no new word for a corresponding old word *)
               writeln(output,' odd number of words in worchap.');
               writeln(output,' must have old-new pairs of words.');
               halt
            end;
            readinword(worchap,newword);
            removeblanks(newword);
            numbchgs:=0;
            next:= nil   (* make sure that all ptr"s initialy are nil *)
         end
      end;

function afteryou(p: wordptr): boolean;
      (* answers the question 'do i belong after you?' or more accurately,
         does p^.old belong after p^.next^.old in this list. *)

      var  n: integer;
         done: boolean;

      begin
         n:=1;   (* start with first letters of words *)
         done:= false;
(*
*)
if debug then write2trigger(output,p^.oldword);
         while not done do begin
            if p^.next= nil   (* if we are at the end of the list *)
            then begin
               afteryou:= false;
               done:= true
            end
            else if p^.oldword.place[n] < p^.next^.oldword.place[n]
            (* we belong before you *)
               then begin
                  afteryou:= false;
                  done:= true;
               end
               else if p^.oldword.place[n] > p^.next^.oldword.place[n]
               (* we belong after you *)
                  then begin
                     afteryou:= true;
                     done:= true
                  end
                  else if (n=p^.oldword.length) and (n<p^.next^.oldword.length)
                  (* we match to my length but you are longer
                  therefore i belong before you *)
                     then begin
                        afteryou:= false;
                        done:= true
                     end
                     else if (n=p^.next^.oldword.length) and (n<p^.oldword.length)
                     (* we match to your length but i am longer
                     so i belong after you *)
                        then begin
                           afteryou:= true;
                           done:= true
                        end
                        else if (n=p^.oldword.length) and (n=p^.next^.oldword.length)
                        (* we match so notify user and stop *)
                           then begin
                              writeln(output,' word repeated in worchap.');
                              halt
                           end
                           else begin
                              done:= false;
                              n:= n+1  (* go to next letter of words *)
                           end
         end
      end;

procedure makelist(var worchap: text; var first: wordptr);
      (* makes an alphabetical linked list of records which contain
         old words and their corresponding newwords and the number
         of changes of the oldwords into their newwords *)


      var
         newptr,         (* the ptr to the newly created word record *)
         lookptr: wordptr;     (* a pointer used to look through the list*)
         inlist: boolean;   (* wether or not the memb has been inserted *)
         listlength: integer;

      begin
         new(newptr);  (* make first member by hand *)
         first:= newptr;
         assignwords(first);
         listlength:=1;
         while not eof(worchap) do begin   (* make rest of list *)
            inlist:= false;
            new(newptr);
            assignwords(newptr);
            listlength:= listlength+1;  (* keep track of list-length *)
            lookptr:= first;   (* start at beginning of list *)
            newptr^.next:= first;
            if not afteryou(newptr)  (* see 'function afteryou' *)
            then begin  (* insert new member if it belongs as first memb *)
               first:= newptr;
               inlist:= true
            end
            else begin
               newptr^.next:= first^.next; (* move to next memb of list *)
               while afteryou(newptr) do begin
               (* move thru list till find right spot for insertion *)
                  lookptr:= lookptr^.next;
                  newptr^.next:= newptr^.next^.next
               end;
               lookptr^.next:= newptr;  (* insert new member *)
               inlist:= true
            end
         end
      end;

function wordmatch(aword,bword: buff2): boolean;
      (* does aword match bword??? *)
      var
         n,                    (* index of buff2"s *)
         level: integer;       (* matching level *)
         fail: boolean;        (* indicates mismatch,(speeds up funct.) *)
      begin
if debug then writeln(output,'BEGIN wordmatch');
         n:= 1;
         level:= 0;
         if (aword.length = bword.length)   (* if not same length no match *)
         then if aword.place[1] = bword.place[1]
             (* quick check of the first letters of each, if they do not
                match, then the words do not match.  since the lists are
                in alphabetical order, this will aid in the speed of the
                search of the list *)
            then  begin
               level:= level+1;      (* indicate match *)
               fail:= false;         (* has not failed yet ... *)
               while (n < aword.length) and (not fail) do begin
               (* check the rest of the word *)
                  n:= n+1;
                  if aword.place[n] = bword.place[n]
                  then level:= level+1
                  else fail:= true
               end;
               if level= aword.length   (* if words match *)
               then wordmatch:= true
               else wordmatch:= false
            end
            else wordmatch:= false
         else wordmatch:= false
;if debug then writeln(output,'END wordmatch');
      end;

function matchptr(first: wordptr;  tempword: buff2): wordptr;
      (* take tempword (given from proced. changeword) and look
         through the linked list of oldwords looking for a match.
         if a match is found, matchptr will point to the matching
         oldword, and since the newword is on the same record,
         matchptr will also point to the newword. same for numbchgs.
         if no match is found, matchptr will be left pointing to nil *)
      var
         p: wordptr;      (* pointer to look thru list with *)
         done: boolean;   (* wether or not finished looking thru list *)
         n: integer;   (* number of memb of the list now looking at *)
      begin
if debug then writeln(output,'BEGIN matchptr');
         n:=1;
         p:= first;
if debug then if p = nil then writeln(output,'p=nil!')
                         else writeln(output,'p<>nil');
         repeat               (* look thru the list *)
if debug then writeln(output,'HERE 1 zzz');
if debug then writeln(output,'p^.old:');
(* at this call, one never gets to writeword because the pointer p
is pointing out into far space.
This implies that first is bad - not set for example.  *)
if debug then writeword(output,p^.oldword);
if debug then writeln(output,'HERE 1.5 zzz');
{halt; NEUTRALIZE}
            if not wordmatch(p^.oldword,tempword)
            then begin  (* go to next memb of list *)
if debug then writeln(output,'HERE 2 zzz');
               p:= p^.next;
               n:=n+1;
               done:= false
            end
            else done:= true;
if debug then writeln(output,'HERE 3 zzz');
            if p = nil   (* if we get to the end of the list *)
            then done:= true
         until done;
         matchptr:= p;
if debug then writeln(output,'END matchptr');
      end;

procedure printlist(first: wordptr; var place: text);
      (* this proced. will print out an alphabetical listing of
         the words, old and new, and the number of times that each
         oldword was replace by its newword, all in a table, with
         totals added at the bottom. *)

      const
         tablewidth = 80;   (* maximum width of the table *)
         minwordsize = 12;   (* minimum size of the word field *)

      var
         p: wordptr;    (* pointer to search through the list *)
         maxwordsize,   (* maximum size of the word field *)
         wordsize,      (* size of the word field *)
         numwords,      (* keeps track of the number of words for totals *)
         total,         (* keeps the total number of changes *)
         i:  integer;   (* counter *)
         shortened: boolean; (* true if a word was shortened in the table *)

      begin
         maxwordsize:=trunc((tablewidth-17)/2);
         wordsize:=0;
         numwords:=0;
         total:=0;
         shortened:=false;
         (* get the wordsize from the list**********************************)
         p:= first;   (* start at the beginning of the list *)
         repeat
            if p^.oldword.length > wordsize
            then wordsize:=p^.oldword.length;
            if p^.newword.length > wordsize
            then wordsize:=p^.newword.length;
            p:=p^.next
         until p = nil;

         if wordsize > maxwordsize
         then wordsize:= maxwordsize;
         if wordsize < minwordsize
         then wordsize:= minwordsize;

         (* write the headings of the table ********************************)
         for i:=1 to ((2*wordsize)+13) do write(place,' ');
         writeln(place,'number');
         for i:=1 to ((2*wordsize)+15) do write(place,' ');
         writeln(place,'of');
         for i:=1 to 8 do write(place,' ');
         write(place,'old word');
         for i:=1 to (wordsize-6) do write(place,' ');
         write(place,'new word');
         for i:=1 to (wordsize-5) do write(place,' ');
         writeln(place,'changes');

         (* underline headings of the table ********************************)
         for i:=1 to 8 do write(place,' ');
         for i:=1 to 8 do write(place,'-');
         for i:=1 to (wordsize-6) do write(place,' ');
         for i:=1 to 8 do write(place,'-');
         for i:=1 to (wordsize-5) do write(place,' ');
         for i:=1 to 7 do write(place,'-');
         writeln(place);
         writeln(place);

         (* write the contents of the table ********************************)
         p:=first; (* start at the beginning of the list again *)
         while p<>nil do begin
            for i:=1 to 8 do write(place,' ');   (* initial spaces *)
            if p^.oldword.length<=wordsize
            then begin  (* word will fit so write word *)
               writeword(place,p^.oldword);
               for i:=(p^.oldword.length+1) to (wordsize+1) do write(place,' ')
            end
            else begin
            (* word will not fit so shorten and write with a / at the end *)
               for i:=1 to wordsize do write(place,p^.oldword.place[i]);
               write(place,'/');
               shortened := true;
            end;
            write(place,' ');  (* word separator blank *)
            if p^.newword.length<=wordsize
            then begin  (* word will fit so write word *)
               writeword(place,p^.newword);
               for i:=(p^.newword.length+1) to (wordsize+1) do write(place,' ')
            end
            else begin
            (* word will not fit so shorten and write with a / at the end *)
               for i:=1 to wordsize do write(place,p^.newword.place[i]);
               write(place,'/');
               shortened := true;
            end;
            write(place,'  '); (* word-numbchgs separator blanks *)
            writeln(place,p^.numbchgs:4);
            total:= total+ p^.numbchgs; (* keep track of total of numbchgs *)
            numwords:= numwords+ 1;  (* keep track of total number of words *)
            p:=p^.next  (* point to next memb of list *)
         end;

         (* underline end of table for totals ******************************)
         for i:=1 to 8 do write(place,' ');  (* first spaces *)
         for i:=1 to ((2*wordsize)+9) do write(place,'-');
         writeln(place);

         (* write the totals at the bottom of the table ********************)
         write(place,' totals: ');
         write(place,numwords:5);
         for i:=1 to (wordsize-3) do write(place,' ');
         write(place,numwords:5);
         for i:=1 to (wordsize-3) do write(place,' ');
         writeln(place,total:4);
         if shortened then begin
            writeln(place);
            write  (place,' a "/" indicates the word was shortened for');
            writeln(place,' printing in the table.')
         end;
      end;  (* printlist *)

procedure changewords(var fin, fout: text);
      (* this is what does all of the changing of words.  it uses all
      of the previous proced and funct. *)

      var
         p,                (* to use the matchptr function value *)
         first: wordptr;   (* pointer to the first memb of a linked list
                              of the old and new words from worchap *)
         temp,             (* the buffer made from finline that will hold only
                              pascal "words" *)
         finline: buffer;  (* a line from file fin *)
         tempword: buff2;  (* the current word we are looking at in
                              the temp buffer and the word we are using
                              to look for a match with the oldwords *)
         i,                (* index of buffers *)
         c,                (* counter for for loop *)
         numline,          (* number of the input line *)
         oldbeg: integer;  (* the place of the beginning of the oldword
                              in finline *)

         commentpasteol,   (* whether or not the comment runs past
                              the end of the line *)
         quote1pasteol,    (* whether or not the quote runs past the
                              end of the line *)
         quote2pasteol,    (* whether or not the quote runs past
                              the end of the line *)
         nomatch: boolean; (* can there be a match?  see proced. readinwords *)

      begin
         i:=1;
         numline:=0;
         oldbeg:=0;
         commentpasteol:=false;
         quote1pasteol:=false;
         quote2pasteol:=false;

{zzz}
if debug then writeln(output, 'here is where the first is generated:');
            makelist(worchap,first);
if debug then begin
   writeln(output, 'past makelist');
   write(output, '"');
   writeword(output,first^.oldword);
   writeln(output, '"');
   write(output, '"');
   writeword(output,first^.newword);
   writeln(output, '"');
   writeln(output,first^.numbchgs:1);
end;
(* if halt; here, clean ending => problem is below *)

         while not eof(fin) do begin
            readintobuffer(fin,finline);   (* pick up a line of fin *)
(* if halt; here, clean ending => problem is below *)

            numline := numline+1;   (* keeping track of finline number *)
if debug then writeln(output);
if debug then writeln(output);
if debug then writeln(output,' numline is:',numline:5);

(* if halt; here, clean ending => problem is below *)
           assigntemp(finline,temp,commentpasteol,quote2pasteol,quote1pasteol);
(* if halt; is here it ends clean but gives bus error! *)

            (* go through temp and fin writing to fout and
               replacing oldwords encountered with their
               newwords *)

            i:= 1;
            while i<=finline.length do begin  (* search line *)
(*
*)
if debug then writeln(output,' searching line ',numline:5);
(* if halt; is here it ends clean but gives bus error! *)

if debug then writeln(output,'finline.length=',finline.length:1);
               if temp.place[i]='.'
               then begin   (* skip dots *)
if debug then writeln(output,'skipping dots');
                  repeat
if debug then writeln(output,'i=',i:1);
if debug then writeln(output,'finline.place[i]="',finline.place[i],'"');
{zzz}
if debug then writeln(output,'HERE 4');
if debug then write(output,finline.place[i]);
{halt; (* dirty *) NEUTRALIZE}
                     write(fout,finline.place[i]);
if debug then writeln(output,'HERE 5');
                     i:=i+1
;if debug then writeln(output,'HERE 6');
                  until (temp.place[i]<>'.') or (i=finline.length+1);
{halt; (* dirty *) NEUTRALIZE}
if debug then writeln(output,'HERE 7');
               end;

if debug then writeln(output,'HERE 8');
{halt; (* dirty *) NEUTRALIZE}

               if i<=temp.length then begin  (* found a word *)

(*
*)
if debug then writeln(output,' found a word at position ',i);
                  oldbeg:= i;
                  readintempword(temp,tempword,i,nomatch);
if debug then writeln(output,'passed readintempword');

                  if not nomatch   (* a match is not impossible *)
                  then begin
if debug then writeln(output,'about to matchptr');
                     p:= matchptr(first,tempword);
if debug then writeln(output,'passed matchptr');
                     if p<> nil
                     then begin  (* found a match *)

(*
*)
if debug then write(output,' found a match: ');
if debug then writeword(output,p^.oldword);
if debug then writeln(output);
                        writeword(fout,p^.newword);
                        p^.numbchgs:= p^.numbchgs+1
                     end   (* we are at the '.' after tempword in temp *)

                     else begin  (* did not find a match *)
(*
*)
if debug then writeln(output,' looked and no match found.');
                        if i<=temp.length
                        then
                        for c:=oldbeg to i-1 do write(fout,finline.place[c])
                           (* no substitution so write to fout up to after
                              end of tempword *)
                        else for c:=oldbeg to temp.length do
                             write(fout,finline.place[c])
                             (* no substitution and i is temp.length+1 probably
                                from readintempword going to the end of temp *)
                     end
                  end
                  else begin
(*
*)
if debug then writeln(output,' no match is possible with this word.');
                     i:= oldbeg;
                     while (temp.place[i]<>'.') and (i<=finline.length) do begin

                        write(fout,finline.place[i]);
                        i:=i+1
                     end
                  end
               end
            end;
if debug then writeln(output,' line number: ',numline,' transfered to fout.');
            writeln(fout)
         end;

         if listonfout
         then begin   (* show user list in fout *)
            for i:=1 to 5 do writeln(fout);  (* spacing before list *)
            writeln(fout,'(*');  (* putting list in comment *)
            printlist(first,fout);  (* write out list *)
            writeln(fout,'*)');  (* putting list in comment *)
         end;

         if listonoutput
         then begin   (* show user list on screen *)
            printlist(first,output);
            writeln(output);

            writeln(output,' p.s.  fout also has this list at the end.');
            writeln(output,'       the list is within comments so the');
            writeln(output,'       program will compile.')
         end
      end;

begin  (* worcha *)
      writeln(output,' worcha ',version:4:2);
      reset(fin);
      reset(worchap);
      rewrite(fout);

      changewords(fin,fout);

(* makelist(worchap,first);  *)
(* printlist(first,output);   *)

1: end. (* worcha *)