PROCEDURE PAGE(VAR fx: TEXT);
BEGIN
  WRITELN(fx);
  WRITE(fx, form_feed);
END;

{ FUNCTYPE:                                                        }
{ Do binary search for keyword in 'key' list.  If found, return    }
{ TRUE, else FALSE.                                                }
Function Find_in_Reserve(var kword: alfa) : boolean;
Label Return;
Var
    low, high, mid : integer;
Begin
    low  := 1;
    high := NUMKEYS;
    while (low <= high) do begin
        mid := (low+high) div 2;
        if kword < key[mid] then
            high := mid - 1
        else if kword > key[mid] then
            low  := mid + 1
        else begin
            Find_in_Reserve := TRUE;
            goto Return;
            end;
        end;
    Find_in_Reserve := FALSE;
Return:
End;

{$W3 }
PROCEDURE BuildTree(VAR tree: treepointer; VAR INFILE: GenStr);
VAR
  CurrentWord : alfa;
  FIN : TEXT; { local input file }
  currchar,                     { Current operative character }
  nextchar      : charinfo;     { Look-ahead character }
  flushing      : (KNOT, DBL, STD, LIT, SCANFN, SCANFN2);
  fname         : string[30];
  DoInclude     : boolean; { TRUE if we discovered include file }
  fbuffer       : string[255];  { Format buffer - before final Print }
  LineIn        : string[255];
  LineInLast    : string[255];
  cp            : 0..255;
  xeof,                 { EOF status AFTER a read }
  xeoln         : BOOLEAN;      { EOLN status after a read }

   PROCEDURE Entertree(VAR subtree: treepointer;
                           Word   : alfa;
                           line   :counter);
   VAR
     nextitem : Queuepointer;
   BEGIN
     IF subtree=nil THEN
       BEGIN {create a new entry}
         NEW(subtree);
         WITH subtree^ DO BEGIN
           left := nil;
           right := nil;
           WITH entry DO BEGIN
             Wordvalue := Word;
             NEW(FirstInQueue);
             LastinQueue := FirstInQueue;
             WITH FirstInQueue^ DO BEGIN
                linenumber := line;
                NextInQueue := nil;
             END;{WITH FirstInQueue}
           END;{WITH entry}
         END;{WITH subtree}
       END {create a new entry}
     ELSE {append a list item}
       WITH subtree^, entry DO
         IF Word=Wordvalue THEN
           BEGIN
             IF lastinQueue^.linenumber <> line THEN
                BEGIN
                  NEW(nextitem);
                  WITH Nextitem^ DO BEGIN
                    linenumber := line;
                    NextInQueue := nil;
                  END;{WITH}
                  lastinQueue^.NextInQueue := Nextitem;
                  lastinQueue := nextitem;
                END;
           END
         ELSE
           IF Word < Wordvalue THEN
             Entertree(left,Word,line)
           ELSE
             Entertree(right,Word,line);
   END;{Entertree}

{$W2}

Procedure ReadC({updating} VAR nextchar : charinfo;
                {returning}VAR currchar : charinfo );
Var
  Look          : char; { Character read in from File }
BEGIN   {+++ File status module. +++
   Stores file status "AFTER" a read.
   NOTE this play on words - after one char is
   actually "PRIOR TO" the next character               }
  if xeoln then begin
     LineInLast := LineIn;
     if (not EOF(FIN)) then begin
        readln(FIN, LineIn);
        cp := 0;
        xeoln := FALSE;
        end
      else
        xeof := TRUE;
      end;
  if cp >= length(LineIn) then begin
     xeoln := TRUE;
     xeof  := EOF(FIN);
     Look  := ' ';
     end
  else begin
     cp := cp + 1;
     Look := LineIn[cp];
     End;
        {+++ current operative character module +++}
  currchar := nextchar;
        {+++ Classify the character just read +++}
  WITH nextchar DO BEGIN{ Look-ahead character name module }
    IF xeof THEN
        name := FileMark
    ELSE IF xeoln THEN
        name := EndOfLine
    ELSE IF Look IN ['a'..'z'] THEN {lower case plus}
        name := lletter
    ELSE IF Look IN ['^','$','_','A'..'Z'] THEN {upper case}
        name := uletter
    ELSE IF Look IN ['0'..'9'] THEN {digit}
        name := digit
    ELSE IF Look = '''' THEN
        name := quote
    ELSE IF Look = TAB THEN
        name := atab
    ELSE IF Look = space THEN
        name := blank
    ELSE
        name := otherchar;
    CASE name of{ store character value module }
        EndOfLine,
        FileMark:       Valu := space;
        lletter:        Valu := upcase(look);       { Cnvrt to uppcase }
        ELSE            valu := look;
    END{ case name of };
  End{ Look-ahead character name module };
END; {of ReadC}

PROCEDURE GetL( VAR fbuffer :  GenStr      );
{++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{+      Get a line of text into users buffer.           +}
{+      Flushes comment lines:                          +}
{+      Flushes lines of Literals:  'this is it'        +}
{+      Ignores special characters & tabs:              +}
{+      Recognizes End of File and End of Line.         +}
{+                                                      +}
{+GLOBAL                                                +}
{+      flushing : (KNOT, DBL, STD, LIT, SCANFN);       +}
{+      LLmax   = 0..Max Line length;                   +}
{++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
VAR
  state : (scanning, terminal, overflow);
  sawdot : boolean;
BEGIN { GetL }
   fbuffer := '';
   fname := '';
   fatal_error := FALSE;
   state := scanning;
  REPEAT
    ReadC(nextchar, currchar);
    IF (length(fbuffer) >= LLmax) THEN{ exceeded length of buffer }
      BEGIN{ reset EOLN }
        fatal_error := TRUE;
        state := overflow;
        fbuffer := '';
        WRITE(bell);
        WRITELN('EXCEEDED LENGTH OF INPUT BUFFER');
      END
    ELSE
      BEGIN
        IF (currchar.name IN [FileMark,EndOfLine]) THEN
          state:=terminal{ END of line or END of file };
        CASE flushing of
            KNOT:
                CASE currchar.name of
                lletter, uletter, digit, blank:
                        BEGIN{ store }
                        fbuffer := concat(FBUFFER,CURRCHAR.VALU) ;
                        END;
                atab, quote, otherchar:
                        BEGIN{   Flush comments -convert
                                 tabs & other chars to spaces }
                        IF (currchar.valu='(') and (nextchar.valu='*')
                          THEN flushing := DBL
                        ELSE IF (currchar.valu='{') THEN
                           flushing := STD
                        ELSE IF currchar.name=quote THEN
                           flushing := LIT;
                        { convert to a space }
                           fbuffer := concat(fbuffer,GAP);
                        END;
                ELSE         { END of line -or- file mark }
                        fbuffer := concat(fbuffer,currchar.valu)
                END{ case currchar name of };
            DBL:  { scanning for a closing  - double comment }
                IF (currchar.valu ='*') and (nextchar.valu =')')
                  THEN flushing := KNOT;
            STD:  begin { scanning for a closing curley  }
                  IF currchar.valu = '}' THEN
                      flushing := KNOT;
{ Check if incl } if (currchar.valu = '$') and (nextchar.valu = 'I') then
                      flushing := SCANFN;
                  end;
            LIT:  { scanning for a closing quote }
                  IF currchar.name = quote THEN
                    flushing := KNOT;
            SCANFN: if (nextchar.valu<>' ') and (nextchar.valu<>TAB) then
                    begin
                    flushing := SCANFN2;
                    SAWDOT := FALSE;
                    end;
            SCANFN2: if (currchar.valu in ['A'..'Z','0'..'9','.'])
                     then begin
                        fname := concat(fname, currchar.valu);
                        if currchar.valu = '.' then SAWDOT := TRUE;
                        end
                     else begin
                        if length(fname) = 0 then  { Make sure we ignore $I-}
                           DoInclude := FALSE      { compiler directive }
                        else begin
                           if not SAWDOT then fname := Concat(fname, '.PAS');
                           DoInclude := TRUE;
                           end;
                        flushing := STD;
                        end;
        END{ flushing case }
      END{ ELSE }
  UNTIL (state<>scanning);
END; {of GetL}

PROCEDURE ReadWord;
{++++++++++++++++++++++++++++++++++++++++++++++++}
{+                                              +}
{+       Analyze the Line into "words"          +}
{+                                              +}
{++++++++++++++++++++++++++++++++++++++++++++++++}
LABEL   1;
VAR
  ix,           {temp indexer}
  idlen,        {length of the word}
  Cpos : BYTE; { Current Position pointer }
BEGIN{ ReadWord }
  Cpos := 1; { start at the beginning of a line }
  WHILE Cpos < length(fbuffer) DO
    BEGIN {Cpos<length(fbuffer)}
      WHILE (Cpos < length(fbuffer)) AND (fbuffer[Cpos]=space) DO
        Cpos:=Cpos + 1;    {--- skip spaces ---}
      idlen := 0;
      WHILE (Cpos < length(fbuffer)) AND (fbuffer[Cpos ] <> space) DO
        BEGIN{ accept only non-spaces }
          IF idlen < MaxWordlen THEN
            BEGIN
              idlen := idlen + 1;
              CurrentWord[idlen] := fbuffer[Cpos];
            END;
          Cpos := Cpos +1;
        END{ WHILE };
      CurrentWord[0] := chr(idlen);
      IF length(CurrentWord)=0 THEN {no word was found} GOTO 1;

      IF (not Find_in_Reserve(CurrentWord)) and    {check if reserved word}
         (not (CurrentWord[1] in ['0'..'9'])) then {or numeric constant}
         EnterTree(tree,CurrentWord,Currentline);

      1:{Here is no word <length of word=0>};
    END; {WHILE Cpos<length(fbuffer)}
END; {of Readword}

BEGIN{BuildTree}
   flushing := KNOT{ flushing };
   DoInclude := FALSE;
   xeoln := TRUE;
   xeof  := FALSE;
   LineIn := '';
   ASSIGN(FIN,INFILE);
   RESET(FIN);
   IF IOresult <> 0 THEN
      BEGIN
        WRITE(BELL);
        WRITELN('File ',INFILE,' not found !!!!!!');
        fatal_error := TRUE;
      END;
     nextchar.name := blank;       { Initialize next char to a space }
     nextchar.valu := space;
     ReadC({update}    nextchar,   { Initialize current char to space }
           {returning} currchar);  { First char from file in nextchar }
     write ('.');
     WHILE ((currchar.name<>filemark) AND (NOT fatal_error)) DO
       BEGIN
         Currentline := Currentline + 1;
         GetL(fbuffer) { attempt to read the first line };
         Writeln(Fout, Currentline:6,': ',LineInLast);
         IF listing THEN Writeln(Currentline:6,': ',LineInLast)
         else BEGIN
            if (CurrentLine mod 50) = 0 then
               writeln(' ',Currentline:0,' lines read');
            write ('.');
            END;

{         else if (Currentline mod 100) = 0 then
           writeln('ON LINE : ',Currentline:0);        }

         ReadWord; {Analyze the Text into single 'words' }
         if DoInclude then Begin
            BuildTree(tree, fname);  { recursively do include }
            DoInclude := FALSE;
            end;
       END; {While}
       close(FIN);
       writeln (' ',Currentline:0,' total lines read');
END; {of BuildTree}{CLOSE(PRN_ID);}