Program XLIST(input,output);

{This program produces a cross-reference listing for a
Pascal program. Occurences only are listed. No distinction is
made between definitions and references. It will also give a
graphical representation of the block structure of the program.

Note: This program, originally written by N. Wirth,
uses the 'quadratic quotient' hash method. It was
adapted for UCSD Pascal (1.4 - the public domain version)
by Shawn Fanning (in 1978) and subsequently adapted for
Pascal/MT+ by Mike Lehman (in 1981). This version was then
modified be Warren A. Smith to try to get back to iso stan-
dard pascal and to add the additional feature of mapping
out the compound statements. It was adapted for Turbo Pascal
by Ron Finger in July 1984. This is a public domain program.}

{$I-}
{$V-}
Const
      P  = 749;        {SIZE of HASHTABLE}
      NK =  45;        {NO. of KEYWORDS}
      PAGESIZE = 57;   {LINES PER PAGE}
      ALFALEN  =  8;   {SIZE of IDENTIFIERS}
      REFSPERLINE = 17;
      REFSPERITEM =  5;
      NESTMAX = 10 ;
Type
     ALFA = Packed Array[1..ALFALEN] of Char;
     INDEX = 0..P;
     ITEMPTR = ^ITEM;
     WORD = Record
               KEY: ALFA;
               FIRST, LAST: ITEMPTR;
               FOL: INDEX
            End ;
     NUMREFS = 1..REFSPERITEM;
     REFTYPE = (COUNT, PTR);
     ITEM = Record
               REF   : ARRAY[NUMREFS] of Integer;
               CASE REFTYPE of
                  COUNT: (REFNUM: NUMREFS);
                  PTR: (NEXT: ITEMPTR)
            End ;
     BUFFER = Packed Array[0..131] of Char;
Var
    TOP: INDEX;  {TOP of CHAIN LINKING ALL ENTRIES IN T}
    I,LINECOUNT,BUFCURSOR: Integer; {CURRENT LINE NUMBER}
    FF,CH: Char;          {CURRENT CHAR SCANNED }
    BUF : BUFFER;
    T: ARRAY [INDEX] of WORD;   {HASH TABLE}
    KEY: ARRAY [1..NK] of ALFA; {RESERVED KEYWORD TABLE }
    ERROR,                      { ERROR FLAG }
    LISTING: Boolean;           { LISTING OPTION }
    INFILE,LST: Text;
    LSTFILENAME : String[14];
    INPUT_LINE : String[120];
    LAST_KEY,PAGE_NUM,NESTLVL:Integer;
    ABORT,LITERAL,ACOMMENT,BCOMMENT,EOL,NESTUP,NESTDN,NODOT:Boolean;
    BAR : Char ;
    FILENAME,FILETITLE:String[14];
    DATE:String[20];
    LDATE,LTITLE:Byte;

FUNCTION TAB (NUM : Integer) : Char ;
  Var
      I : Integer ;
  Begin
  For I := 1 to NUM do
    Write (LST, ' ') ;
  TAB := CHR(0)
  End ; { TAB }

Procedure TITLELINE;
Begin
  If PAGE_NUM > 1 then
    Writeln(LST,^L);
  Writeln(LST);
  Writeln(LST);
  Write(LST,'File: ',FILETITLE);
  Write(LST,TAB(15),'Cross-Reference & Block Listing',TAB(15));
  If LDATE>5 then
    Write(LST,'Date: ',DATE);
  Write(LST,TAB(50-(LDATE+LTITLE)));
  Writeln (LST,'Page ', PAGE_NUM:1);
  Writeln (LST) ;
  PAGE_NUM := PAGE_NUM + 1
End ; {TITLELINE}

Procedure LPWRITELN;
Var
  I : Integer;
Begin
  BUF[BUFCURSOR]:=CHR(13);
  BUFCURSOR:=BUFCURSOR+1;
  For I := 0 to BUFCURSOR-1 do
    Write(LST,BUF[I]);
  Writeln(LST);
  BUFCURSOR:=0;
  LINECOUNT:=LINECOUNT+1;
  If (LINECOUNT MOD PAGESIZE) = 0 then
    TITLELINE;
End;

Procedure INITIALIZE;
Var
  I : Integer;
Begin { INITIALIZE }
   FF:=CHR(12);
   ERROR := FALSE;
   For I := 0 to P do
      T[I].KEY := '        ';
   KEY[ 1] := 'AND     ';
   KEY[ 2] := 'ARRAY   ';
   KEY[ 3] := 'BEGIN   ';
   KEY[ 4] := 'BOOLEAN ';
   KEY[ 5] := 'CASE    ';
   KEY[ 6] := 'CHAR    ';
   KEY[ 7] := 'CONST   ';
   KEY[ 8] := 'DIV     ';
   KEY[ 9] := 'DOWNTO  ';
   KEY[10] := 'DO      ';
   KEY[11] := 'ELSE    ';
   KEY[12] := 'END     ';
   KEY[13] := 'EXIT    ';
   KEY[14] := 'FILE    ';
   KEY[15] := 'FOR     ';
   KEY[16] := 'FUNCTION';
   KEY[17] := 'GOTO    ';
   KEY[18] := 'IF      ';
   KEY[19] := 'IN      ';
   KEY[20] := 'INPUT   ';
   KEY[21] := 'INTEGER ';
   KEY[22] := 'MOD     ';
   KEY[23] := 'NIL     ';
   KEY[24] := 'NOT     ';
   KEY[25] := 'OF      ';
   KEY[26] := 'OR      ';
   KEY[27] := 'OUTPUT  ';
   KEY[28] := 'PACKED  ';
   KEY[29] := 'PROCEDUR';
   KEY[30] := 'PROGRAM ';
   KEY[31] := 'REAL    ';
   KEY[32] := 'RECORD  ';
   KEY[33] := 'REPEAT  ';
   KEY[34] := 'SET     ';
   KEY[35] := 'STRING  ';
   KEY[36] := 'TEXT    ';
   KEY[37] := 'THEN    ';
   KEY[38] := 'TO      ';
   KEY[39] := 'TYPE    ';
   KEY[40] := 'UNTIL   ';
   KEY[41] := 'VAR     ';
   KEY[42] := 'WHILE   ';
   KEY[43] := 'WITH    ';
   KEY[44] := 'WRITE   ';
   KEY[45] := 'WRITELN ';

   LINECOUNT:= 1;
   TOP := P;
   PAGE_NUM := 1 ;
   LITERAL := FALSE ;
   ACOMMENT := FALSE ;
   BCOMMENT := FALSE ;
   NESTLVL := 0 ;
   LAST_KEY := 0 ;
   BAR := '|' ;
   CH  := ' '
End; { INITIALIZE }

Procedure OPENFILES;
Var
    I,NUMBLOCKS,OPENERRNUM: Integer;
    OPENOK: Boolean;
    LISTOPTION: Char;
Begin { OPEN }
   Writeln;
   ABORT := FALSE ;
   Repeat
      NODOT := TRUE;
      Write('Filename: ( CR to quit): ');
      READLN( FILENAME );
        ABORT := Length(FILENAME) <= 0;
        If NOT ABORT then
          Begin
            For I := 1 to LENGTH(FILENAME) do
              Begin
                FILENAME[I] := UPcase(FILENAME[I]) ;
                If FILENAME[I] = '.' then
                  NODOT := False
              End;
            If NODOT then
              FILENAME := FILENAME + '.PAS';
            ASSIGN(INFILE,FILENAME);
            RESET(INFILE);
            OPENERRNUM := IORESULT;
            OPENOK := ( OPENERRNUM = 0);
            If NOT OPENOK then
              Writeln(FILENAME,' not found')
            Else
              FILETITLE := FILENAME;
              If POS(':',FILETITLE) = 2 then
                DELETE(FILETITLE,1,2);
              LTITLE := LENGTH(FILETITLE);
        End;
   Until OPENOK OR ABORT;

   If NOT ABORT then
     Begin
       Write('Destination file or device (CR for LST:): ');
       READLN(LSTFILENAME);
       If LENGTH (LSTFILENAME) <= 0 then
         LSTFILENAME := 'LST:' ;
       For I := 1 to LENGTH(LSTFILENAME) do
         LSTFILENAME[I] := UPcase(LSTFILENAME[I]) ;
       ASSIGN(LST,LSTFILENAME);
       Rewrite(LST);
  End;
   If NOT ABORT then
     Begin
       Repeat
         Write('Do you want a listing (Y/N)? ');
         READLN( LISTOPTION );
         LISTOPTION := UPcase(LISTOPTION);
       Until LISTOPTION IN ['Y','N'];
         LISTING := LISTOPTION = 'Y';
         If LDATE=5 then
           Begin
             Write('Date: ');
             READLN(DATE);
             LDATE:=LENGTH(DATE)+5
           End;
     End
End; {open}

Procedure PUTALFA(S:ALFA);
Begin
  MOVE(S[1],BUF[BUFCURSOR],8);
  BUFCURSOR:=BUFCURSOR+8;
End;

Procedure PUTNUMBER(NUM: Integer);
Var I,IPOT:Integer;
    A: ALFA;
    CH: Char;
    ZAP:Boolean;
    
Begin
  ZAP:=TRUE;
  IPOT:=10000;
  A[1]:=' ';
  For I:= 2 to 6 do
    Begin
      CH:=CHR(NUM DIV IPOT + ORD('0'));
      If I <> 6 then
        If ZAP then
           If CH = '0' then
             CH:=' '
           Else ZAP:=FALSE;
      A[I]:=CH;
      NUM:=NUM MOD IPOT;
      IPOT:=IPOT DIV 10;
    End;
  A[7]:=' ';
  MOVE(A,BUF[BUFCURSOR],7);
  BUFCURSOR:=BUFCURSOR+7;
End;

Procedure SEARCH( ID: ALFA );               {MODULO P HASH SEARCH}
{GLOBAL: T, TOP}
Var
    I,J,H,D  : Integer;
    X         : ITEMPTR;
    F         : Boolean;

Begin
   J:=0;
   For I:= 1 to ALFALEN do
     J:= J*10+ORD(ID[I]);
   H  := ABS(J) MOD P;
   F  := FALSE;
   D  := 1;
   Repeat
      If T[H].KEY = ID
         then
            Begin {FOUND}
               F := TRUE;
               If T[H].LAST^.REFNUM = REFSPERITEM
                  then
                     Begin
                         NEW(X);
                         X^.REFNUM := 1;
                         X^.REF[1] := LINECOUNT;
                         T[H].LAST^.NEXT:= X;
                         T[H].LAST        := X;
                     End
                 Else
                    WITH T[H].LAST^ do
                       Begin
                          REFNUM      := REFNUM + 1;
                          REF[REFNUM] := LINECOUNT
                       End
            End
         Else
            If T[H].KEY = '        '
               then
                  Begin {NEW ENTRY}
                     F := TRUE;
                     NEW(X);
                     X^.REFNUM := 1;
                     X^.REF[1] := LINECOUNT;
                     T[H].KEY := ID;
                     T[H].FIRST := X;
                     T[H].LAST := X;
                     T[H].FOL := TOP;
                     TOP := H
                  End
               Else
                  Begin {COLLISION}
                     H := H+D;
                     D := D+2;
                     If H >= P
                        then
                           H := H - P;
                     If D = P
                        then
                           Begin
                              Writeln(OUTPUT,'TBLE OVFLW');
                              ERROR := TRUE
                           End ;
                  End
   Until F OR ERROR
End {SEARCH} ;



Procedure PRINTWORD(W: WORD);
Var
    L,NEXTREF: Integer;
    X: ITEMPTR;
    THISREF: NUMREFS;
Begin
   PUTALFA(W.KEY);
   X := W.FIRST;
   L := 0;
   Repeat
      If L = REFSPERLINE
         then
            Begin
               L := 0;
               LPWRITELN;
               PUTALFA('        ');
            End ;
      L := L+1;
      THISREF := (L-1) MOD REFSPERITEM + 1;
      NEXTREF := X^.REF[ THISREF ];
      If THISREF = X^.REFNUM
         then
            X := NIL
         Else
            If THISREF = REFSPERITEM
               then
                  X := X^.NEXT;
      PUTNUMBER(NEXTREF);
   Until X = NIL;
  LPWRITELN;
End {PRINTWORD} ;

Procedure PRINTTABLE;
Var
    I,J,M: INDEX;
Begin
   I := TOP;
   While I <> P do
      Begin {FIND MINIMAL WORD}
         M := I;
         J := T[I].FOL;
         While J <> P do
            Begin
               If T[J].KEY < T[M].KEY
                  then
                     M := J;
               J := T[J].FOL
            End ;
         PRINTWORD(T[M]);
         If M <> I then 
           Begin
             T[M].KEY:=T[I].KEY;
             T[M].FIRST:=T[I].FIRST;
             T[M].LAST:=T[I].LAST;
           End;
         I := T[I].FOL
      End
End {PRINTTABLE} ;

Procedure OUTPUT_LINE (BUF : BUFFER) ;
  Var
    I : Integer ;
  Procedure FILL_LINE (Var LINE : BUFFER) ;
    Var
      I : Integer ;
    Begin { FILL_LINE }
    I := 1 ;
    While (LINE[I] = ' ') do
      Begin
      LINE[I] := '-' ;
      I := I + 1
      End
    End ; { FILL_LINE }

  Procedure PRTNEST (Var LINE : BUFFER) ;

    Var COL : Integer ;

    Begin { PRTNEST }
    For COL := 1 to NESTLVL - 1 do
      Write (LST, BAR, '  ') ;
    If NESTLVL > 0 then
      If NESTUP OR NESTDN then
        Begin
        If NESTDN then
          Begin
          Write (LST, BAR, '  ') ;
          Write (LST, 'E--') ;
          For COL := NESTLVL+2 to NESTMAX do
            Write (LST, '---')
          End
        Else
          Begin
          Write (LST, 'B--') ;
          For COL := NESTLVL+1 to NESTMAX do
            Write (LST, '---')
          End ;
        FILL_LINE (LINE)
        End
      Else
        Begin
        Write (LST, BAR, '  ') ;
        For COL := NESTLVL+1 to NESTMAX do
          Write (LST, '   ')
        End
    Else
      If NESTDN then
        Begin
        Write (LST, 'E--') ;
        For COL := 2 to NESTMAX do
          Write (LST, '---') ;
        FILL_LINE (LINE)
        End
      Else
        For COL := 1 to NESTMAX do
          Write (LST, '   ')
    End ; { PRTNEST }
        
  Begin { OUTPUT_LINE }
  If ((LINECOUNT MOD PAGESIZE) = 0) OR (PAGE_NUM = 1) then
    Begin
      If LISTING then
        TITLELINE;
    If (LSTFILENAME <> 'CON:') AND ((LINECOUNT MOD PAGESIZE) = 0) then
      Writeln (OUTPUT, '< ', LINECOUNT:4, ',', MEMAVAIL:5, ' >')
    End ;
  Write (LST, LINECOUNT:4, '  ') ;
  PRTNEST (BUF) ;
  For I := 1 to BUFCURSOR do
    Write (LST, BUF[I]) ;
  Writeln (LST) ;
  If LSTFILENAME <> 'CON:' then
    Write (OUTPUT, '.')
  End ; { OUTPUT_LINE }

Procedure GETNEXTCHAR;
Var I : Integer;

Begin { GETNEXTCHAR }
If BUFCURSOR >= LENGTH (INPUT_LINE) then
  Begin
  EOL := TRUE ;
  CH := ' ' ;
  ERROR := EOF(INFILE)
  End
Else
  Begin
  BUFCURSOR := BUFCURSOR + 1 ;
  CH := INPUT_LINE [BUFCURSOR] ;
  BUF [BUFCURSOR] := CH ;
  CH := UPcase(CH)
  End
End; { GETNEXTCHAR }

Procedure GETIDENTIFIER;
Var
    J,K,I: Integer;
    ID: ALFA;

Begin { GETIDENTIFIER }
   I := 0;
   ID := '        ';
   Repeat
      If I < ALFALEN
         then
            Begin
               I := I+1;
               ID[I] := CH
            End;
      GETNEXTCHAR
   Until ( NOT(((CH>='A') AND (CH<='Z')) OR (CH='_')
                OR ((CH>='0') AND (CH<='9')))) OR (ERROR);
   I := 1;
   J := NK;
   Repeat
      K := (I+J) DIV 2;      {BINARY SEARCH}
      If KEY[K] <= ID
         then
            I := K+1;

      If KEY[K] >= ID
         then
            J := K-1;

   Until I > J;
   If KEY[K] <> ID then
     SEARCH(ID)
   Else
     Begin
       If (K=3) OR ((K=5) AND (LAST_KEY<>32)) OR     { Begin or CASE }
          (K=32) OR (K=33) then                      { Record or Repeat }
         Begin
           LAST_KEY := K ;
           If NESTLVL = NESTMAX then
             Write (LST, '----Too many levels')
           Else
             Begin
               NESTLVL := NESTLVL + 1 ;
               NESTUP := TRUE
             End
         End ;
       If (K=12) OR (K=40) then          { End or Until }
         If NESTLVL = 0 then
           Write (LST, '----Nesting error  ')
         Else
           Begin
             NESTLVL := NESTLVL - 1 ;
             NESTDN := TRUE
           End
     End

End; { GETIDENTIFIER }

Begin { CROSSREF }
   LDATE:=5;
   Repeat
   INITIALIZE;
   OPENFILES;
   While NOT EOF(INFILE) AND (NOT ABORT) do
      Begin
      BUFCURSOR:= 0;
      NESTUP := FALSE ;
      NESTDN := FALSE ;
      READLN (INFILE, INPUT_LINE) ;
      If LENGTH (INPUT_LINE) > 0 then
        Begin
        EOL := FALSE ;
        BUFCURSOR := BUFCURSOR + 1 ;
        CH := INPUT_LINE [BUFCURSOR] ;
        BUF [BUFCURSOR] := CH ;
        CH := UPcase (CH)
        End
      Else
        Begin
        EOL := TRUE ;
        CH := ' '
        End ;
      While NOT EOL do
        Begin
        If ((CH >= 'A') AND (CH <= 'Z')) AND (NOT LITERAL) AND
           (NOT ACOMMENT) AND (NOT BCOMMENT) then
          GETIDENTIFIER
        Else
          If (CH = '''') OR LITERAL then
            Begin
              Repeat
                GETNEXTCHAR;
              Until (CH = '''') OR (ERROR) OR EOL;
              LITERAL := EOL ;
              GETNEXTCHAR
            End
          Else
            If (CH = '{') OR ACOMMENT then
              Begin
                While (CH <> '}') AND (NOT ERROR) AND (NOT EOL) do
                  GETNEXTCHAR ;
                ACOMMENT := EOL ;
                GETNEXTCHAR
              End
            Else
              If (CH = '(') OR BCOMMENT then
                Begin
                  If NOT BCOMMENT then
                    GETNEXTCHAR;
                  If (CH = '*') OR BCOMMENT then
                    Begin
                      If NOT BCOMMENT then
                        GETNEXTCHAR;
                      Repeat
                        While (CH <> '*') AND (NOT ERROR) AND (NOT EOL) do
                          GETNEXTCHAR ;
                        BCOMMENT := EOL ;
                        If NOT EOL then
                          GETNEXTCHAR
                      Until (CH = ')') OR ERROR OR EOL ;
                      If NOT EOL then
                        GETNEXTCHAR
                    End
                End
              Else
                GETNEXTCHAR;

        End; { While }
      EOL := FALSE ;
      If LISTING then
        OUTPUT_LINE (BUF) ;
      LINECOUNT := LINECOUNT + 1
      End ;
   If NOT ABORT then
     Begin
     TITLELINE;
     LINECOUNT := 0;
     BUFCURSOR := 0;
     PRINTTABLE;
     Writeln(LST,^L);
     CLOSE(LST);
     If IOresult <> 0 then
       Writeln('Error closing output file')
     End;
  Until LENGTH(FILENAME) <= 0
End.