{$C-,I-,V-,R-,K-}
{++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{+                                                      +}
{+  PROGRAM TITLE:      Cross Reference Generator       +}
{+                                                      +}
{+  WRITTEN BY:         Peter Grogono                   +}
{+  DATE WRITTEN:       ?                               +}
{+                                                      +}
{+  SUMMARY:                                            +}
{+      1. Output Files:                                +}
{+         a. first output file is a numbered listing   +}
{+            of the input source                       +}
{+         b. second output file is cross reference     +}
{+            with each identifier followed by the      +}
{+            line numbers on which it appears.         +}
{+      2. Listing Device:                              +}
{+         The numbered source listing may optionally   +}
{+         be routed to the screen or printer (but not  +}
{+         both).                                       +}
{+                                                      +}
{+  MODIFICATION RECORD:                                +}
{+      17-APR-84       -Modified for Turbo Pascal so   +}
{+                       $ includes are supported       +}
{+                                                      +}
{+                                                      +}
{++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
PROGRAM XREFG2;
{ Cross Reference Generator }
CONST
        alfa_length     =  15;
        dflt_str_len    = 255;
        entrygap        =    0;   { # of blank lines between line numbers}
        heading         : string[23] = 'Cross-Reference Listing';
        headingsize     =    3;   {number of lines for heading}
        LLmax           = dflt_str_len;
        MaxOnLine       =   8;
        Maxlines        = MAXINT; {longest document permitted}
        MaxWordlen      = alfa_length;{longest word read without truncation}
        Maxlinelen      =   80;   {length of output line}
        MaxOnPage       =   60;   {size of output page}
        NumKeys         =   70;   {number of Pascal reseve words}
                                  {Read your Pascal manuals on this one!}
        NumberWidth     =    6;
        space           : char = ' ';
TYPE
        ALFA    = string[alfa_length];
        CHARNAME = (lletter, uletter, digit, blank, quote, atab,
                      EndOfLine, FileMark, otherchar );
        CHARINFO = RECORD
                     name : charname;
                     valu : CHAR
                   END;
        COUNTER = 1..Maxlines;
        pageindex = BYTE;
        Wordindex = 1..MaxWordlen;
        Queuepointer = ^Queueitem;
        Queueitem = RECORD
                        linenumber : counter;
                        NextInQueue: Queuepointer
                    END;
        EntryType = RECORD
                        Wordvalue : alfa;
                        FirstInQueue,
                        lastinQueue: Queuepointer
                     END;
        treepointer = ^node;
        node = RECORD
                 entry : EntryType;
                 left,
                 right : treepointer
               END;
        GenStr  = string[255];
VAR
  bell          : CHAR;
  fatal_error   : BOOLEAN;
  FILE_ID,                      { Input file name }
  PRN_ID,                       { basic file name + '.PRN' }
  New_ID        : string[20];   { basic file name + '.XRF' }
  form_feed     : CHAR;
  Key           : ARRAY[1..NumKeys] OF alfa;
  LISTING       : BOOLEAN;
  tab           : CHAR;
  WordTree      : treepointer;
  GAP           : char      ;
  Currentline: INTEGER;
  FOUT: TEXT; { print output file }
  XOUT: TEXT; { xref  output file }


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;

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}

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 }
     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 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);

END; {of BuildTree}{CLOSE(PRN_ID);}

PROCEDURE PrintTree(tree: treepointer);
{
GLOBAL
        MaxOnLine   = max line references per line
        NumberWidth = field for each number
}
VAR
  pageposition: pageindex;
   PROCEDURE PrintEntry(subtree: treepointer;
                        VAR position: pageindex);
   VAR  ix: Wordindex;
        itemcount : 0..Maxlinelen;
        itemptr : Queuepointer;
        PROCEDURE PrintLine(VAR Currentposition: pageindex;
                                newlines: pageindex);
        VAR
          linecounter: pageindex;
        BEGIN
          IF (Currentposition + newlines) < MaxOnPage THEN
            BEGIN
                FOR linecounter:=1 TO newlines DO WRITELN(XOUT);
                Currentposition := Currentposition + newlines;
            END
          ELSE
            BEGIN
              PAGE(XOUT);
              WRITELN(XOUT,heading);
              FOR linecounter := 1 TO headingsize - 1 DO
                 WRITELN(XOUT);
              Currentposition := headingsize + 1;
            END
        END;{PrintLine}

   BEGIN{PrintEntry}
     IF subtree<>nil THEN
        WITH subtree^ DO BEGIN
          PrintEntry(left,position);
          PrintLine(position,entrygap + 1);
          WITH entry DO BEGIN
            FOR ix := 1 to length(WordValue) do WRITE(XOUT, WordValue[ix]);
            WRITE(XOUT, space:(MaxWordLen-length(WordValue)));
            itemcount := 0;
            itemptr := FirstInQueue;
            WHILE itemptr <> nil DO
              BEGIN
                itemcount := itemcount + 1;
                IF itemcount > MaxOnLine THEN
                  BEGIN
                    PrintLine(position,1);
                    WRITE(XOUT, space:MaxWordlen);
                    itemcount := 1;
                  END;
                WRITE(XOUT, itemptr^.linenumber: numberwidth);
                itemptr := itemptr^.NextInQueue;
              END;{WHILE}
          END; {WITH entry}
          PrintEntry(right,position);
        END; {WITH subtree^}
   END; {PrintEntry}

BEGIN{PrintTree}
  PagePosition := MaxOnPage;
  PrintEntry(tree,PagePosition);
END; {of PrintTree}{CLOSE(New_ID);}

FUNCTION ConnectFiles: boolean;
TYPE
  Linebuffer = string[80];
VAR
  ix  : BYTE;
BEGIN{ ConnectFiles }
  fatal_error := FALSE;
  ConnectFiles := TRUE;
   WRITELN('Enter Complete Filenames') ;
   WRITELN ;
   WRITE('Input File: ');
   READLN(FILE_ID);
   WRITELN;
   WRITE('Printed output: ');
   READLN(PRN_ID);
   WRITELN;
   WRITE('Cross-Reference output: ');
   READLN(NEW_ID);
   WRITELN;
   Assign(fout,PRN_ID);
   Rewrite(FOUT);
   if IOresult <> 0 then begin
      writeln('Could not open ',PRN_ID,' (print output file).');
      ConnectFiles := FALSE;
      fatal_error  := TRUE;
      end;
  assign(xout,NEW_ID);
  Rewrite(Xout) ;
  if IOresult <> 0 then begin
     writeln('Could not open ',NEW_ID,' (xref output file).');
     ConnectFiles := FALSE;
     fatal_error := TRUE;
     end;
END{ of ConnectFiles };

PROCEDURE Initialize;
VAR
  Ch: CHAR;
BEGIN
  bell := ^G; GAP := ' ' ;
  Currentline := 0;
  IF ConnectFiles THEN
    BEGIN
        Key[ 1] := 'ABSOLUTE';
        Key[ 2] := 'AND';
        Key[ 3] := 'ARRAY';
        Key[ 4] := 'ASSIGN';
        Key[ 5] := 'BEGIN';
        Key[ 6] := 'BOOLEAN';
        Key[ 7] := 'BYTE';
        Key[ 8] := 'CASE';
        Key[ 9] := 'CHAIN';
        Key[10] := 'CHAR';
        Key[11] := 'CHR';
        Key[12] := 'CLOSE';
        Key[13] := 'CONCAT';
        Key[14] := 'CONST';
        Key[15] := 'COPY';
        Key[16] := 'DELETE';
        Key[17] := 'DIV';
        Key[18] := 'DO';
        Key[19] := 'DOWNTO';
        Key[20] := 'ELSE';
        Key[21] := 'END';
        Key[22] := 'EOF';
        Key[23] := 'EOLN';
        Key[24] := 'EXECUTE';
        Key[25] := 'EXIT';
        Key[26] := 'EXTERNAL';
        Key[27] := 'FALSE';
        Key[28] := 'FILE';
        Key[29] := 'FILLCHAR';
        Key[30] := 'FOR';
        Key[31] := 'FORWARD';
        Key[32] := 'FUNCTION';
        Key[33] := 'GOTO';
        Key[34] := 'IF';
        Key[35] := 'IN';
        Key[36] := 'INLINE';
        Key[37] := 'INPUT';
        Key[38] := 'INTEGER';
        Key[39] := 'LABEL';
        Key[40] := 'LENGTH';
        Key[41] := 'MOD';
        Key[42] := 'NIL';
        Key[43] := 'NOT';
        Key[44] := 'OF';
        Key[45] := 'OR';
        Key[46] := 'ORD';
        Key[47] := 'OUTPUT';
        Key[48] := 'PACKED';
        Key[49] := 'PROCEDURE';
        Key[50] := 'PROGRAM';
        Key[51] := 'REAL';
        Key[52] := 'RECORD';
        Key[53] := 'REPEAT';
        Key[54] := 'SET';
        Key[55] := 'SHL';
        Key[56] := 'SHR';
        Key[57] := 'STRING';
        Key[58] := 'SUCC';
        Key[59] := 'TEXT';
        Key[60] := 'THEN';
        Key[61] := 'TO';
        Key[62] := 'TRUE';
        Key[63] := 'TYPE';
        Key[64] := 'UNTIL';
        Key[65] := 'VAR';
        Key[66] := 'WHILE';
        Key[67] := 'WITH';
        Key[68] := 'WRITE';
        Key[69] := 'WRITELN';
        Key[70] := 'XOR';
        tab     := CHR(9);  { ASCII Tab character }
        form_feed := CHR(12);  gap  := CHR(32);
        WRITE('List file to console (Y/N)?: ');
        READ(kbd,Ch);
        LISTING := ( (Ch='Y') OR (Ch='y') );
        WRITELN; WRITELN;
    END; {IF ConnectFiles}
END; {of Initialize}

BEGIN { Cross Reference }
  CLRSCR;
  WRITELN(' ':22, 'CROSS REFERENCE GENERATOR');
  WRITELN;WRITELN;WRITELN;WRITELN;
  Initialize;
  IF NOT fatal_error THEN
    BEGIN
      WordTree := NIL;          {Make the Tree empty}
      writeln('Pass 1 [Listing] Begins ...');BuildTree(WordTree, FILE_ID);
      close(FOUT) ;
      writeln('Pass 2 [Cross-Ref] Begins ...');PrintTree(WordTree);
      close(XOUT);
    END;
  WRITELN;
END. { Cross Reference }