(*====================================================================*)
(*  PROGRAM TITLE: PASCAL CROSS-REFERENCING PROGRAM                   *)
(*                                                                    *)
(*  PROGRAM FILE: XREF.SRC                                            *)
(*                                                                    *)
(*  LAST UPDATE:  09-MAR-81 by Mike Lehman                            *)
(*								      *)
(*	NOTE: THIS PROGRAM WAS ORIGINALLY WRITTEN BY N. WIRTH AND     *)
(*	ADAPTED FOR UCSD PASCAL (I.4 - THE PUBLIC DOMAIN VERSION)     *)
(*	BY SHAWN FANNING (IN 1978) AND SUBSEQUENTLY ADAPTED FOR	      *)
(*	PASCAL/MT+ BY MIKE LEHMAN (IN 1981) AND IS A PUBLIC DOMAIN    *)
(*	PROGRAM.  IF YOU MAKE REVISIONS, ETC. PLEASE LEAVE THE AUTHOR *)
(*	AND MODIFIERS NAME IN THE SOURCE FILE.  THANK YOU.	      *)
(*                                                                    *)
(*  PROGRAM SUMMARY:                                                  *)
(*                                                                    *)
(*     THIS PROGRAM PRODUCES A CROSS-REFERENCE LISTING FOR ANY        *)
(*   PASCAL PROGRAM.  OCCURENCES ONLY ARE LISTED.  NO DISTINCTION IS  *)
(*   MADE BETWEEN DEFINITIONS AND REFERENCES.                         *)
(*====================================================================*)



PROGRAM XREF;

(*CROSS REFERENCE GENERATOR FOR PASCAL PROGRAMS.  N.WIRTH, 7.5.74*)
(*'QUADRATIC QUOTIENT' HASH METHOD*)

CONST
      P  = 749;           (*SIZE OF HASHTABLE*)
      NK =  45;             (*NO. OF KEYWORDS*)
      ALFALEN  =  8;
      REFSPERLINE = 15;
      REFSPERITEM =  5;


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,BUF1,BUF2: ^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: TEXT;
    LST : TEXT;			
    LSTFILENAME : STRING;
    INPUT_LINE : STRING;

PROCEDURE INITIALIZE;
VAR
  I : INTEGER;

PROCEDURE FIRSTHALF;
BEGIN
   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';
END;

PROCEDURE SECONDHALF;
BEGIN
   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 ';
END;

BEGIN (* INITIALIZE *)
   WRITELN;
   WRITELN('Pascal/MT+ Program Xref Utility -- Release 5.2');
   WRITELN('This program is public domain');
   WRITELN;
   FF:=CHR(12);
   NEW(BUF1);
   NEW(BUF2);
   BUF:=BUF1;
   ERROR   := FALSE;
   FOR I := 0 TO P DO
      T[I].KEY := '        ';
   FIRSTHALF;
   SECONDHALF;
   LINECOUNT:= 0;
   BUFCURSOR:= 0;
   TOP := P;
   CH  := ' '
END; (* INITIALIZE *)



PROCEDURE OPENFILES;
VAR
    NUMBLOCKS: INTEGER;
    OPENOK: BOOLEAN;
    OPENERRNUM : INTEGER;
    LISTOPTION: CHAR;
    FILENAME: STRING;

BEGIN (* OPEN *)
   REPEAT
      WRITELN;
      WRITE( 'Input file ? ' );
      READLN( FILENAME );
      IF LENGTH(FILENAME) >0 THEN
	BEGIN
          ASSIGN(INFILE, FILENAME );
	  RESET(INFILE)
	END;
      OPENERRNUM := IORESULT;
      OPENOK     := ( OPENERRNUM <> 255 );
      IF NOT OPENOK THEN
        WRITELN( '*** INPUT OPEN ERROR #', OPENERRNUM );
   UNTIL OPENOK;

   WRITE('Output file name? ');
   READLN(LSTFILENAME);
   ASSIGN(LST,LSTFILENAME);
   REWRITE(LST);

   WRITE( 'Do you want a listing ? ' );
   READ( LISTOPTION );
   LISTING := NOT(LISTOPTION = 'N');
   IF LISTING THEN PUTNUMBER(0);
   READLN(INFILE,INPUT_LINE);
   WRITELN;
END; (* OPEN *)


PROCEDURE LPWRITELN;
VAR
  I : INTEGER;
BEGIN
  BUF^[BUFCURSOR]:=CHR(13);
  BUFCURSOR:=BUFCURSOR+1;
  FOR I := 0 TO BUFCURSOR-1 DO
    WRITE(LST,BUF^[I]);
  IF BUF = BUF1 THEN BUF:=BUF2 ELSE BUF:=BUF1;
  BUFCURSOR:=0;
  LINECOUNT:=LINECOUNT+1;
  IF (LINECOUNT MOD 60) = 0 THEN
    PAGE(LST);
END;

PROCEDURE PUTALFA(S:ALFA);
BEGIN
  MOVELEFT(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]:=' ';
  MOVELEFT(A,BUF^[BUFCURSOR],7);
  BUFCURSOR:=BUFCURSOR+7;
END;


PROCEDURE GETNEXTCHAR;
VAR I : INTEGER;
BEGIN

    IF LENGTH(INPUT_LINE) = 0 THEN
      READLN(INFILE,INPUT_LINE);

    IF LENGTH(INPUT_LINE) = 0 THEN
      CH := ' '
    ELSE
      BEGIN
	CH:=INPUT_LINE[1];
        DELETE(INPUT_LINE,1,1)
      END;

    IF EOF(INFILE) THEN ERROR:=TRUE
    ELSE
      BEGIN
        BUF^[BUFCURSOR]:=CH;
        BUFCURSOR:=BUFCURSOR+1;
        IF LENGTH(INPUT_LINE) = 0 THEN
          BEGIN
            BUF^[BUFCURSOR]:=CHR(13);
            BUFCURSOR:=BUFCURSOR+1;
            LINECOUNT:= LINECOUNT +1;
            IF LISTING THEN
              BEGIN
		IF LSTFILENAME <> 'CON:' THEN
		  WRITE('.');
		FOR I := 0 TO BUFCURSOR-1 DO
                  WRITE(LST,BUF^[I]);
                IF BUF = BUF2 THEN BUF:=BUF1 ELSE BUF:=BUF2;
                BUFCURSOR:=0;
                PUTNUMBER(LINECOUNT);
              END
            ELSE
	      BEGIN
		BUFCURSOR:=0;
		WRITE('.')
	      END;

            IF (LINECOUNT MOD 60) = 0 THEN
              BEGIN
                IF LISTING THEN PAGE(LST);
                WRITELN(OUTPUT,'< ',LINECOUNT:4,',',MEMAVAIL:5,' >');
              END;
           END;
       END;
 END; (* GETNEXTCHAR *)


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: INTEGER;
    X: ITEMPTR;
    NEXTREF : INTEGER;
    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 GETIDENTIFIER;
VAR
    J,K,I: INTEGER;
    ID: ALFA;

BEGIN (* GETIDENTIFIER *)
   I := 0;
   ID := '        ';
   REPEAT
      IF I < ALFALEN
         THEN
            BEGIN
               I := I+1;
               IF ('a' <= CH) AND (CH <= 'z')
                  THEN
                     ID[I] := CHR( ORD(CH) - ORD('a') + ORD('A') )
                  ELSE
                     ID[I] := CH
            END;
      GETNEXTCHAR
   UNTIL ( NOT(((CH>='A') AND (CH<='Z')) OR ((CH>='a') AND (CH<='z'))
                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);
END; (* GETIDENTIFIER *)

BEGIN (* CROSSREF *)
   INITIALIZE;

   OPENFILES;
   WHILE (NOT(EOF(INFILE))) AND (NOT( ERROR)) DO
      BEGIN
        IF ((CH>='A') AND (CH<='Z')) THEN
          GETIDENTIFIER
        ELSE
          IF (CH = '''') THEN
            BEGIN
              REPEAT
                GETNEXTCHAR;
              UNTIL (CH = '''') OR (ERROR);
              GETNEXTCHAR;
            END
          ELSE
            IF CH = '(' THEN
              BEGIN
                GETNEXTCHAR;
                IF CH = '*' THEN
                  BEGIN
                    GETNEXTCHAR;
                    WHILE (CH <> ')') AND (NOT(ERROR)) DO
                      BEGIN
                        WHILE (CH <> '*') AND (NOT(ERROR)) DO
                          GETNEXTCHAR;
                        GETNEXTCHAR;
                      END;
                    GETNEXTCHAR;
                  END;
              END
            ELSE
              GETNEXTCHAR;

      END; (* WHILE *)
   PAGE(LST);
   LINECOUNT := 0;
   BUFCURSOR := 0;
   PRINTTABLE;
   PAGE(LST);
   CLOSE(LST,I);
   IF I = 255 THEN
     WRITELN('Error closing output file')
END.