{$C-,I-,V-,R-,K-}
{++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{+                                                      +}
{+  PROGRAM TITLE:      Cross Reference Generator       +}
{+                                                      +}
{+  WRITTEN BY:         Peter Grogono                   +}
{+  DATE WRITTEN:       1978                            +}
{+                                                      +}
{+  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:                                +}
{+      19-MAR-85       -Modified for full Turbo Pascal +}
{+                       Ver2.0B command set            +}
{+                       by David W. Carroll 76011,616  +}
{+                                                      +}
{+      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         =   184;   {number of Pascal reseved 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('Print output file (.PRN): ');
   readln(prn_id);
   writeln;
   write('Cross-Reference output file (.XRF): ');
   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] := 'ARCTAN';
         key[4] := 'ARRAY';
         key[5] := 'ASSIGN';
         key[6] := 'AUX';
         key[7] := 'AUXINPTR';
         key[8] := 'AUXOUTPTR';
         key[9] := 'BEGIN';
         key[10] := 'BLACK';
         key[11] := 'BLUE';
         key[12] := 'BLOCKREAD';
         key[13] := 'BLOCKWRITE';
         key[14] := 'BOOLEAN';
         key[15] := 'BROWN';
         key[16] := 'BUFLEN';
         key[17] := 'BYTE';
         key[18] := 'CASE';
         key[19] := 'CHAIN';
         key[20] := 'CHAR';
         key[21] := 'CHR';
         key[22] := 'CLOSE';
         key[23] := 'CLREOL';
         key[24] := 'CLRSCR';
         key[25] := 'CON';
         key[26] := 'CONCAT';
         key[27] := 'CONINPTR';
         key[28] := 'CONOUTPTR';
         key[29] := 'CONST';
         key[30] := 'CONSTPTR';
         key[31] := 'COPY';
         key[32] := 'COS';
         key[33] := 'CRTEXIT';
         key[34] := 'CRTINIT';
         key[35] := 'CYAN';
         key[36] := 'DARKGRAY';
         key[37] := 'DELAY';
         key[38] := 'DELETE';
         key[39] := 'DELLINE';
         key[40] := 'DISPOSE';
         key[41] := 'DIV';
         key[42] := 'DO';
         key[43] := 'DOWNTO';
         key[44] := 'DRAW';
         key[45] := 'ELSE';
         key[46] := 'END';
         key[47] := 'EOF';
         key[48] := 'EOLN';
         key[49] := 'ERASE';
         key[50] := 'EXECUTE';
         key[51] := 'EXIT';
         key[52] := 'EXP';
         key[53] := 'EXTERNAL';
         key[54] := 'FALSE';
         key[55] := 'FILE';
         key[56] := 'FILEPOS';
         key[57] := 'FILESIZE';
         key[58] := 'FILLCHAR';
         key[59] := 'FLUSH';
         key[60] := 'FOR';
         key[61] := 'FORWARD';
         key[62] := 'FRAC';
         key[63] := 'FREEMEM';
         key[64] := 'FUNCTION';
         key[65] := 'GETMEM';
         key[66] := 'GOTO';
         key[67] := 'GOTOXY';
         key[68] := 'GRAPHBACKGROUND';
         key[69] := 'GRAPHCOLORMODE';
         key[70] := 'GRAPHMODE';
         key[71] := 'GRAPHWINDOW';
         key[72] := 'GREEN';
         key[73] := 'HALT';
         key[74] := 'HEAPPTR';
         key[75] := 'HI';
         key[76] := 'HIRES';
         key[77] := 'HIRESCOLOR';
         key[78] := 'IF';
         key[79] := 'IN';
         key[80] := 'INLINE';
         key[81] := 'INPUT';
         key[82] := 'INSERT';
         key[83] := 'INSLINE';
         key[84] := 'INT';
         key[85] := 'INTEGER';
         key[86] := 'IORESULT';
         key[87] := 'KBD';
         key[88] := 'KEYPRESSED';
         key[89] := 'LABEL';
         key[90] := 'LENGTH';
         key[91] := 'LIGHTBLUE';
         key[92] := 'LIGHTCYAN';
         key[93] := 'LIGHTGRAY';
         key[94] := 'LIGHTGREEN';
         key[95] := 'LIGHTMAGENTA';
         key[96] := 'LIGHTRED';
         key[97] := 'LN';
         key[98] := 'LO';
         key[99] := 'LOWVIDEO';
         key[100] := 'LST';
         key[101] := 'LSTOUTPTR';
         key[102] := 'MAGENTA';
         key[103] := 'MARK';
         key[104] := 'MAXAVAIL';
         key[105] := 'MAXINT';
         key[106] := 'MEM';
         key[107] := 'MEMAVAIL';
         key[108] := 'MEMW';
         key[109] := 'MOD';
         key[110] := 'MOVE';
         key[111] := 'NEW';
         key[112] := 'NIL';
         key[113] := 'NORMVIDEO';
         key[114] := 'NOSOUND';
         key[115] := 'NOT';
         key[116] := 'ODD';
         key[117] := 'OF';
         key[118] := 'OR';
         key[119] := 'ORD';
         key[120] := 'OUTPUT';
         key[121] := 'OVERLAY';
         key[122] := 'PACKED';
         key[123] := 'PALETTE';
         key[124] := 'PI';
         key[125] := 'PLOT';
         key[126] := 'PORT';
         key[127] := 'POS';
         key[128] := 'PRED';
         key[129] := 'PROCEDURE';
         key[130] := 'PROGRAM';
         key[131] := 'PTR';
         key[132] := 'RANDOM';
         key[133] := 'RANDOMIZE';
         key[134] := 'READ';
         key[135] := 'READLN';
         key[136] := 'REAL';
         key[137] := 'RECORD';
         key[138] := 'RED';
         key[139] := 'RELEASE';
         key[140] := 'RENAME';
         key[141] := 'REPEAT';
         key[142] := 'RESET';
         key[143] := 'REWRITE';
         key[144] := 'ROUND';
         key[145] := 'SEEK';
         key[146] := 'SET';
         key[147] := 'SHL';
         key[148] := 'SHR';
         key[149] := 'SIN';
         key[150] := 'SIZEOF';
         key[151] := 'SOUND';
         key[152] := 'SQR';
         key[153] := 'SQRT';
         key[154] := 'STR';
         key[155] := 'STRING';
         key[156] := 'SUCC';
         key[157] := 'SWAP';
         key[158] := 'TEXT';
         key[159] := 'TEXTBACKGROUND';
         key[160] := 'TEXTCOLOR';
         key[161] := 'TEXTMODE';
         key[162] := 'THEN';
         key[163] := 'TO';
         key[164] := 'TRM';
         key[165] := 'TRUE';
         key[166] := 'TRUNC';
         key[167] := 'TYPE';
         key[168] := 'UNTIL';
         key[169] := 'UPCASE';
         key[170] := 'USR';
         key[171] := 'USRINPTR';
         key[172] := 'USROUTPTR';
         key[173] := 'VAL';
         key[174] := 'VAR';
         key[175] := 'WHEREX';
         key[176] := 'WHEREY';
         key[177] := 'WHILE';
         key[178] := 'WHITE';
         key[179] := 'WINDOW';
         key[180] := 'WITH';
         key[181] := 'WRITE';
         key[182] := 'WRITELN';
         key[183] := 'XOR';
         key[184] := 'YELLOW';
        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 }