{$LINESIZE:132}
 {$PAGESIZE:57}
 {$LIST+}
 {$symtab+}
 {$WARN-} 
 {$DEBUG+} 
 {$LINE+}
 {$ENTRY+}
 {$INDEXCK-}
 {$RANGECK-}
 {$INITCK-}
 {$INDEXCK-} 
{++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{+                                                      +}
{+  PROGRAM TITLE:      Cross Reference Generator       +}
{+                                                      +}
{+  WRITTEN BY:         Peter Grogono                   +}
{+  DATE WRITTEN:       ?                               +}
{+                                                      +}
{+  SUMMARY:                                            +}
{+                                                      +}
{+      1. Output Files:                                +}
{+         default is to disk files:                    +}
{+         a. output file = file name + '.XRF'          +}
{+            all identifiers and their line #          +}
{+         b. output file = file name + '.PRN'          +}
{+            the file with all lines numbered          +}
{+      2. LISTING Device:                              +}
{+         Output may be to either the console or       +}
{+         the printer but NOT both.                    +}
{+                                                      +}
{+  MODIFICATION RECORD:                                +}
{+      12-AUG-80       -modified for Pascal/Z v3.0     +}
{+                      -by Raymond E. Penley           +}
{+      16-AUG-80       -added function ConnectFiles    +}
{+      17-AUG-80       -added GetL, ReadC, ReadWord    +}
{+      22-AUG-80       -selective use of control-c     +}
{+                                                      +}
{+                                                      +}
{++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
PROGRAM XREFG2;
{ Cross Reference Generator }
(*%P-,F-,M- [symbolic I/O OFF,
             floating point checking OFF,
             integer mult & div checking OFF]           *)
CONST
        alfa_length     =    8;
        BLANKS          = '        ';
        dflt_str_len    = 255;
        entrygap        =    0;   { # of blank lines between line numbers}
        fid_len         =   14;   { Max length CP/M file names }
        heading         = 'Cross-Reference Listing';
        headingsize     =    3;   {number of lines for heading}
        LLmax           = dflt_str_len;
{}      MaxOnLine       =   10;
        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}
        numbergap       =    2;   {number of gaps between line numbers}
{}      NumKeys         =   46;   {number of Pascal reseve words}
                                  {Read your Pascal manuals on this one!}
{}      NumKeysP1       = NumKeys + 1;
{}      NumberWidth     =    6;
        space           =  ' ';  
TYPE
{}      ALFA    = PACKED ARRAY[1..alfa_length] OF CHAR;
{}  {   BYTE    = 0..255;    }
{}      CHARNAME = (lletter, uletter, digit, blank, quote, atab,
                      EndOfLine, FileMark, otherchar );
{}      CHARINFO = RECORD
                     name : charname;
                     valu : CHAR
                   END;
        COUNTER = 1..Maxlines;
{}      dfltstr = string (dflt_str_len) ;
        FID     = string (fid_len) ;
        lineindex = 1..Maxlinelen;
{}      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;
        SZ0     = string(1);
        SZ255   = string(255);
VAR
  bell          : CHAR; 
  blankindex    : BYTE;
  currchar,                     { Current operative character }
  nextchar      : charinfo;     { Look-ahead character }
  fatal_error   : BOOLEAN;
  FILE_ID,                      { CP/M file name }
  PRN_ID,                       { basic file name + '.PRN' }
  New_ID        :  string(14) ;  { basic file name + '.XRF' }
  fbuffer     :STRING(255);     { Format buffer - before final Print }
  FIN           : TEXT;
  flushing      : (KNOT, DBL, STD, LIT);
  form_feed     : CHAR;
  Key           : ARRAY[1..NumKeysP1] OF alfa;
  letters       : SET OF CHAR;
  LISTING       : BOOLEAN;
  Look          : char; { Character read in from File }
{}{OUTPUT       : TEXT;  }      { Listing device -console or printer }
  tab           : CHAR;
  wordcount     : INTEGER;      { total # of words in file }
  WordTree      : treepointer;
  xeof,                 { EOF status AFTER a read }
  xeoln         : BOOLEAN;      { EOLN status after a read }
  GAP           : char      ;
(*%C- [Control-C OFF]***********************************************)
FUNCTION length(VAR x: STRING): INTEGER; 
VAR
    Y:   INTEGER;
    Z:   CHAR;
BEGIN
   Z := X [0] ;
   Y := ORD(Z) ;
   LENGTH := Y ;
END; {LENGTH}
PROCEDURE koncat(VAR X: STRING; VAR Y: CHAR);
 VAR LL :  INTEGER;
 BEGIN
   ll := ORD(X[0]);
   ll := ll + 1 ;
   X[ll} := Y ;
 END; {KONCAT} 
PROCEDURE setlength(VAR x: STRING; y: INTEGER);
VAR
    UL :  INTEGER; CY, CL : CHAR;
 begin
   UL := UPPER(X); CL := chr(ul);  cy := CHR(Y);
   IF Y >  ul THEN X [0]  := CL;
   ELSE X[0]  := CY ;
 END; {SETLENGTH}
FUNCTION index(VAR x: STRING; VAR y char): byte   ; EXTERNAL; 
{  PROCEDURE PAGE(VAR fx: TEXT);
BEGIN
  WRITE(fx, form_feed);
END;       }
PROCEDURE CLEAR{output};
VAR
  ix : 1..24;
BEGIN
  FOR ix:=1 TO 24 DO WRITELN;
END;
PROCEDURE BuildTree(VAR tree: treepointer);
VAR
  CurrentWord : alfa;
  Currentline: INTEGER;
  FOUT: TEXT; { local output file }
   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 );
{ revised 4 Jan 80, rep }
{ Defined the chars "^", "$", and "_" as lowercase letters }
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               }
  xeof  := EOF(FIN);
        {+++ read BYTE module +++}
  IF NOT xeof THEN
  xeoln := EOLN(FIN) ;
  IF NOT xeof THEN
        READ(FIN, Look);
        {+++ 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;
        OTHERWISE       valu := look;
    END{ case name of };
  End{ Look-ahead character name module };
END; {of ReadC}
PROCEDURE GetL( VAR fbuffer :  string      );    
{++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{+      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);               +}
{+      fbuffer = dfltstr                               +}
{+      LLmax   = 0..Max Line length;                   +}
{++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
VAR
  state : (scanning, terminal, overflow);
BEGIN { GetL }
   setlength(fbuffer,0);
   fatal_error := FALSE;
   state := scanning;
  REPEAT
    ReadC(nextchar, currchar);
{}  WRITE(FOUT, currchar.valu);
{}  IF listing THEN
       WRITE( {OUTPUT,} currchar.valu);
    IF (length(fbuffer) >= LLmax) THEN{ exceeded length of buffer }
      BEGIN{ reset EOLN }
        fatal_error := TRUE;
        state := overflow;
        setlength(fbuffer,0);
        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 }
                        KONCAT(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 }
                            koncat(fbuffer,GAP);   
                        END;
                otherwise    { END of line -or- file mark }
                        KONCAT(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:  { scanning for a closing curley  }
                  IF currchar.valu = '}' THEN
                      flushing := KNOT;
            LIT:  { scanning for a closing quote }
                  IF currchar.name = quote THEN
                    flushing := KNOT
        END{ flushing case }
      END{ ELSE }
  UNTIL (state<>scanning);
END; {of GetL}
PROCEDURE ReadWord;
{++++++++++++++++++++++++++++++++++++++++++++++++}
{+                                              +}
{+       Analyze the Line into "words"          +}
{+                                              +}
{++++++++++++++++++++++++++++++++++++++++++++++++}
LABEL   1;
CONST
  TOP = NumKeys + 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 };
{}    IF idlen=0 THEN {no word was found} GOTO 1;
      IF idlen >= blankindex THEN
        blankindex := idlen
      ELSE
        REPEAT
          CurrentWord[blankindex] := space;
          blankindex := blankindex - 1;
        UNTIL blankindex=idlen;
      WordCount := WordCount + 1;
      {++++++++++++++++++++++++++++++++++}
      {+   linear search with sentinel  +}
      {++++++++++++++++++++++++++++++++++}
          Key[TOP] := CurrentWord;
          ix := 0;
          REPEAT
            ix := ix + 1;
          UNTIL Key[ix] = CurrentWord;
      {++++++++++++++++++++++++++++++++++}
{}    IF ix=TOP THEN {CurrentWord is not a reserve word, so}
         EnterTree(tree,CurrentWord,Currentline);
      1:{Here is no word <length of word=0>};
    END; {WHILE Cpos<length(fbuffer)}
END; {of Readword}
BEGIN{BuildTree}
{}ASSIGN(FOUT,PRN_ID); REWRITE(FOUT);
  PAGE(FOUT);
  Currentline := 0;
  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;
      WRITE(FOUT, Currentline:6,': ');
      IF listing THEN WRITE({OUTPUT,} Currentline:6,': ');
      GetL(fbuffer) { attempt to read the first line };
      WRITELN(FOUT);
      IF listing THEN WRITELN{output};
      ReadWord; {Analyze the Text into single 'words' }
    END; {While}
  PAGE(FOUT);
   CLOSE(FOUT) ;
END; {of BuildTree}{CLOSE(PRN_ID);}
PROCEDURE PrintTree(tree: treepointer);
{
GLOBAL
        MaxOnLine   = max line references per line
        NumberWidth = field for each number
}
VAR
  XOUT: TEXT; { local output file }
  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);
{}              IF listing THEN
                  FOR linecounter:=1 TO newlines DO WRITELN{OUTPUT};
                Currentposition := Currentposition + newlines;
            END
          ELSE
            BEGIN
{}            PAGE(XOUT);
{}            WRITELN(XOUT,heading);
{}            FOR linecounter := 1 TO headingsize - 1 DO
                 WRITELN(XOUT);
{}            IF listing THEN
                BEGIN
                  CLEAR{OUTPUT}; {PAGE(OUTPUT);}
                  WRITELN({OUTPUT,} heading);
                  FOR linecounter := 1 TO headingsize - 1 DO
                     WRITELN{OUTPUT};
                END;
              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 MaxWordlen DO
              WRITE(XOUT, WordValue[ix]);
{}          IF listing THEN
               FOR ix:=1 TO MaxWordlen DO
                  WRITE({OUTPUT,} WordValue[ix]);
            itemcount := 0;
            itemptr := FirstInQueue;
            WHILE itemptr <> nil DO
              BEGIN
                itemcount := itemcount + 1;
                IF itemcount > MaxOnLine THEN
                  BEGIN
                    PrintLine(position,1);
{}                  WRITE(XOUT, space:MaxWordlen);
{}                  IF listing THEN 
                       WRITE({OUTPUT,} space:MaxWordlen);
                    itemcount := 1;
                  END;
{}              WRITE(XOUT, itemptr^.linenumber: numberwidth);
{}              IF listing THEN
                   WRITE({OUTPUT,}itemptr^.linenumber: numberwidth);
                itemptr := itemptr^.NextInQueue;
              END;{WHILE}
          END; {WITH entry}
          PrintEntry(right,position);
        END; {WITH subtree^}
   END; {PrintEntry}
BEGIN{PrintTree}
  READFN(input,xout);
  Rewrite(Xout) ;  
  PAGE(XOUT);
  PagePosition := MaxOnPage;
  PrintEntry(tree,PagePosition);
  PAGE(XOUT);
END; {of PrintTree}{CLOSE(New_ID);}
(*%C+ [Control-C ON]*******************************)
FUNCTION ConnectFiles: boolean;
TYPE
  Linebuffer = string(80);
VAR
  ix,jx,
  Cmllen  : BYTE;
  Cmlline : LINEBUFFER ;
BEGIN{ ConnectFiles }
  fatal_error := FALSE;
  ConnectFiles := TRUE;
   WRITELN('Enter Complete Filenames ') ;
   WRITELN ;
   WRITELN('Input File:');
   READLN(FILE_ID);
   WRITELN('Cross-Reference output:'); 
   READLN(NEW_ID); 
   WRITELN('Printed output:');
   READLN(PRN_ID);
   WRITELN;
   ASSIGN(FIN,FILE_ID);
   RESET(FIN);
   IF EOF(FIN) THEN 
      BEGIN
        WRITE(BELL);
        WRITELN('FILE  NOT  FOUND !!!!!!');
        fatal_error := TRUE;
        ConnectFiles := FALSE;
      END
   ELSE 
     writeln(FILE_ID,PRN_ID,NEW_ID); 
END{ of ConnectFiles };
(*%C- [control-c OFF]***********************************)
PROCEDURE Initialize;
VAR
  Ch: CHAR;
  con_wanted,
  tty_wanted : BOOLEAN;
BEGIN
  bell := CHR(7); GAP := ' ' ;
  IF ConnectFiles THEN
    BEGIN
      letters := ['A'..'Z','a'..'z'];
        Key[ 1] := 'AND     ';
        Key[ 2] := 'ARRAY   ';
        Key[ 3] := 'BEGIN   ';
        Key[ 4] := 'BOOLEAN '; {+++ NOT A RESERVE WORD +++}
        Key[ 5] := 'CASE    ';
        Key[ 6] := 'CHAR    '; {+++ NOT A RESERVE WORD +++}
        Key[ 7] := 'CONST   ';
        Key[ 8] := 'DIV     ';
        Key[ 9] := 'DOWNTO  ';
        Key[10] := 'DO      ';
        Key[11] := 'ELSE    ';
        Key[12] := 'END     ';
        Key[13] := 'EXIT    ';  {+++ NOT a Pascal reserve word +++}
        Key[14] := 'FILE    ';
        Key[15] := 'FOR     ';
        Key[16] := 'FUNCTION';
        Key[17] := 'GOTO    ';
        Key[18] := 'IF      ';
        Key[19] := 'IN      ';
        Key[20] := 'INPUT   '; {+++ NOT A RESERVE WORD +++}
        Key[21] := 'INTEGER '; {+++ NOT A RESERVE WORD +++}
        Key[22] := 'LABEL   ';
        Key[23] := 'MOD     ';
        Key[24] := 'NIL     ';
        Key[25] := 'NOT     ';
        Key[26] := 'OF      ';
        Key[27] := 'OR      ';
        Key[28] := 'OUTPUT  '; {+++ NOT A RESERVE WORD +++}
        Key[29] := 'PACKED  ';
        Key[30] := 'PROCEDUR';
        Key[31] := 'PROGRAM ';
        Key[32] := 'REAL    '; {+++ NOT A RESERVE WORD +++}
        Key[33] := 'RECORD  ';
        Key[34] := 'REPEAT  ';
        Key[35] := 'SET     ';
        Key[36] := 'STRING  ';  {+++ NOT a Pascal reserve word +++}
        Key[37] := 'TEXT    '; {+++ NOT A RESERVE WORD +++}
        Key[38] := 'THEN    ';
        Key[39] := 'TO      ';
        Key[40] := 'TYPE    ';
        Key[41] := 'UNTIL   ';
        Key[42] := 'VAR     ';
        Key[43] := 'WHILE   ';
        Key[44] := 'WITH    ';
        Key[45] := 'WRITE   '; {+++ NOT A RESERVE WORD +++}
        Key[46] := 'WRITELN '; {+++ NOT A RESERVE WORD +++}
        blankindex := alfa_length;
        tab     := CHR(9);  { ASCII Tab character }
        form_feed := CHR(12);  gap  := CHR(32);
        flushing := KNOT{ flushing };
        WRITELN;
        WRITELN('Output Device:');
        WRITE(  '  CONSOLE ->');
        READLN(Ch);
        con_wanted := ( (Ch='Y') OR (Ch='y') );
        WRITE(  '  PRINTER ->');
        READLN(Ch);
        tty_wanted := ( (Ch='Y') OR (Ch='y') );
        If tty_wanted THEN
           con_wanted := FALSE;
        IF NOT (con_wanted OR tty_wanted) THEN
          LISTING := FALSE
        ELSE
          BEGIN
            LISTING := TRUE;
{++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
            IF con_wanted THEN REWRITE('CON:', OUTPUT);
            IF tty_wanted THEN REWRITE('LST:', OUTPUT);
+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
          END;
        WRITELN;
    END; {IF ConnectFiles}
END; {of Initialize}
BEGIN { Cross Reference }
  CLEAR{output};
  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); 
      writeln('Pass 2 [Cross-Ref] Begins ...');PrintTree(WordTree); 
    END;
{}WRITELN;
END. { Cross Reference }