Program DBLIST11(input,output);

{This program produces a cross-reference listing for a
 DBASEII 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 was originally written by N. Wirth.  It was
 adapted  for  UCSD  Pascal (1.4) by Shawn Fanning  in  1978  and
 subsequently adopted for Pascal/MT+  by Mike Lehman in 1981.
 It was modified by Warren A. Smith to try to get back to ISO
 standard pascal and to add the additional features of mapping
 out the compound statements.  It was adapted for Turbo Pascal
 by Ron Finger in July 1984.  Further modified by William Mabes
 and Larry Clive in October, 1986.

 DBLIST11 developed by Ellis B. Levin -Chicago, IL
 to analyze DBASE II programs in June, 1987}

{$I-}
{$V-}
Const

      P  = 749;        {SIZE of HASHTABLE}
      NK =  82;        {NO. of KEYWORDS}
      PAGESIZE = 65;   { LINES PER PAGE}
      ALFALEN  =  16;   {  SIZE of IDENTIFIERS}
      REFSPERLINE = 8;
      REFSPERITEM =  8;
      NESTMAX = 21 ;

Type

     Str80 = string[80];
     FNAME = STRING[14];
     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 = STRING[131]{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 }
    WORKSTRING,BUF : BUFFER;
    T : ARRAY [INDEX] of WORD;   {HASH TABLE}
    KEY: ARRAY [1..NK] of ALFA; {RESERVED KEYWORD TABLE }
    ERROR,                      { ERROR FLAG }
    BLOCK,LISTING: Boolean;     { LISTING/BLOCK OPTION }
    INFILE,LST: Text;
    LSTFILENAME : String[14];
    INPUT_LINE : BUFFER{ String[120]};
    LAST_KEY,PAGE_NUM,NESTLVL:Integer;
    ABORT,LITERAL,ACOMMENT,BCOMMENT,EOL,NESTUP,NESTDN,
    NODOT,Nextime,nex2time,nex3time:Boolean;
    BAR : Char ;
    FILENAME,FILETITLE:FNAME {String[14]};
    DATE:String[20];
    LDATE,LTITLE:Byte;
    search1,search2, search3, search4: string[5];


PROCEDURE PROCESSLINE; FORWARD;

procedure WHITESPACE;  {rsr * added 1/13/87 to eliminate whitespace}
      BEGIN
      WHILE LENGTH(INPUT_LINE) > 0 DO
      BEGIN
      IF INPUT_LINE[1] IN[^I,' '] THEN DELETE(INPUT_LINE,1,1) ELSE EXIT;
      END;
      END; { Whitespace }


  Function Open(var fp:text; name: Fname): boolean;
  begin
    Assign(fp,Name);
    {$I-}
    reset(fp);
    {$I+}
    If IOresult <> 0 then
     begin
      Open := False;
      close(fp);
     end
    else
      Open := True;
  end { Open };


     Function IncludeIn(VAR CurStr: buffer): Boolean;
     Var ChkChar: char;
         column: integer;
     begin
       ChkChar := '-';
       column := pos(search1,CurStr);
       if column <> 0 then
         chkchar := CurStr[column+3]
       else
       begin
         column := Pos(search3,CurStr);
         if column <> 0 then
           chkchar := CurStr[column+4]
         else
         begin
           column := Pos(search2,CurStr);
           if column <> 0 then
             chkchar := CurStr[column+3]
           else
           begin
             column := Pos(search4,CurStr);
             if column <> 0 then
               chkchar := CurStr[column+4]
           end;
         end;
       end;
       if ChkChar in ['+','-'] then IncludeIn := False
       Else IncludeIn := True;
     end { IncludeIn };

     Procedure ProcessIncludeFile(VAR IncStr: buffer);

     var NameStart, NameEnd: integer;
         IncludeFile: text;
         IncludeFileName: Fname;

       Function Parse(IncStr: buffer): buffer;
       begin
         NameStart := pos('$I',IncStr)+2;
         while IncStr[NameStart] = ' ' do
           NameStart := Succ(NameStart);
         NameEnd := NameStart;
         while (not (IncStr[NameEnd] in [' ','}','*']))
              AND ((NameEnd - NameStart) <= 14{PathLength})
              do NameEnd := Succ(NameEnd);
         NameEnd := Pred(NameEnd);
         Parse := copy(IncStr,NameStart,(NameEnd-NameStart+1));
       end {Parse};

     begin  {Process include file}
       IncludeFileName := Parse(IncStr);
       If not Open(IncludeFile,IncludeFileName) then
       begin
         INPUT_LINE := 'ERROR -- Include file not found:  ' + IncludeFileName;
       end
       Else
       begin
       IF LISTING OR BLOCK THEN
         WRITELN(LST,^M^J'(***** Start of ',INCLUDEFILENAME,' *****)'^M^J);
         while not eof(IncludeFile) do
         begin
           BUFCURSOR:=0;
           NESTUP:= FALSE;
           NESTDN:=FALSE;
           Readln(IncludeFile,INPUT_LINE);
           WHITESPACE;
           PROCESSLINE;
         end;
         IF LISTING OR BLOCK THEN
         WRITELN(LST,^M^J'(***** End of ',INCLUDEFILENAME,' *****)'^M^J);
         close(IncludeFile);
       end;
     end {Process include file};

function ConstStr(C : Char; N : Integer) : Str80;
var
  S : string[80];
begin
  if N < 0 then
    N := 0;
  S[0] := Chr(N);
  FillChar(S[1],N,C);
  ConstStr := S;
end;

procedure BigDash;
var
  I : integer;
begin
  For I := 1 to 79 do
     begin
       Write('-');
      end;
   writeln;
 end;

Function Centered(TheString:Str80):Str80;
begin
  Centered := ConstStr(' ',((80 - Length(TheString)) Div 2)) +
  TheString;
end;


Function Space(Spaces : Integer) : Str80;
Var
  Column : Integer;
  Temp   : Str80;
begin
  Temp :='';
  For Column := 1 to Spaces do
  begin
    Temp := Temp + ' ';
    Space := Temp;
  end;
end;


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] := 'ACCE            ';
   KEY[ 2] := 'ACCCEPT         ';
   KEY[ 3] := 'ADD             ';
   KEY[ 4] := 'ALL             ';
   KEY[ 5] := 'AND             ';
   KEY[ 6] := 'APPEND          ';
   KEY[ 7] := 'ASCENDING       ';
   KEY[ 8] := 'BLANK           ';
   KEY[ 9] := 'BROWSE          ';
   KEY[10] := 'CANCEL          ';
   KEY[11] := 'CHANGE          ';
   KEY[12] := 'CLEAR           ';
   KEY[13] := 'CONTINUE        ';
   KEY[14] := 'COPY            ';
   KEY[15] := 'COUNT           ';
   KEY[16] := 'CREATE          ';
   KEY[17] := 'DELETE          ';
   KEY[18] := 'DELIMITED       ';
   KEY[19] := 'DESCENDING      ';
   KEY[20] := 'DISPLAY         ';
   KEY[21] := 'DO              ';
   KEY[22] := 'EDIT            ';
   KEY[23] := 'EOF             ';
   KEY[24] := 'EJECT           ';
   KEY[25] := 'ELSE            ';
   KEY[26] := 'ENDCASE         ';
   KEY[27] := 'ENDDO           ';
   KEY[28] := 'ENDIF           ';
   KEY[29] := 'ERASE           ';
   KEY[30] := 'FIELD           ';
   KEY[31] := 'FILE            ';
   KEY[32] := 'FILES           ';
   KEY[33] := 'FIND            ';
   KEY[34] := 'FOR             ';
   KEY[35] := 'GET             ';
   KEY[36] := 'GO              ';
   KEY[37] := 'IF              ';
   KEY[38] := 'INDEX           ';
   KEY[39] := 'INPUT           ';
   KEY[40] := 'INSERT          ';
   KEY[41] := 'JOIN            ';
   KEY[42] := 'LEN             ';
   KEY[43] := 'LIST            ';
   KEY[44] := 'LOCATE          ';
   KEY[45] := 'LOOP            ';
   KEY[46] := 'NOT             ';
   KEY[47] := 'NOTE            ';
   KEY[48] := 'MODIFY          ';
   KEY[49] := 'OFF             ';
   KEY[50] := 'ON              ';
   KEY[51] := 'OR              ';
   KEY[52] := 'PACK            ';
   KEY[53] := 'PICTURE         ';
   KEY[54] := 'POKE            ';
   KEY[55] := 'QUIT            ';
   KEY[56] := 'READ            ';
   KEY[57] := 'RECALL          ';
   KEY[58] := 'RELEASE         ';
   KEY[59] := 'REMARK          ';
   KEY[60] := 'RENAME          ';
   KEY[61] := 'REPLACE         ';
   KEY[62] := 'REPORT          ';
   KEY[63] := 'RESET           ';
   KEY[64] := 'RESTORE         ';
   KEY[65] := 'RETURN          ';
   KEY[66] := 'SAVE            ';
   KEY[67] := 'SAY             ';
   KEY[68] := 'SELECT          ';
   KEY[69] := 'SET             ';
   KEY[70] := 'SDF             ';
   KEY[71] := 'SKIP            ';
   KEY[72] := 'SORT            ';
   KEY[73] := 'STORE           ';
   KEY[74] := 'STRUCTURE       ';
   KEY[75] := 'SUM             ';
   KEY[76] := 'TO              ';
   KEY[77] := 'TOTAL           ';
   KEY[78] := 'UPDATE          ';
   KEY[79] := 'USE             ';
   KEY[80] := 'USING           ';
   KEY[81] := 'WAIT            ';
   KEY[82] := 'WITH            ';

   LINECOUNT:= 1;
   TOP := P;
   PAGE_NUM := 1 ;
   LITERAL := FALSE ;
   ACOMMENT := FALSE ;
   BCOMMENT := FALSE ;
   NESTLVL := 0 ;
   LAST_KEY := 0 ;
   BAR := '|' ;
   CH  := ' ';
    search1 := '{$'+'I';  { So LISTER can list itself! }
    search2 := '{$'+'i';
    search3 := '(*$'+'I';
    search4 := '(*$'+'i';

End; { INITIALIZE }

{$I DLSTOVER.INC}

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 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 ;
        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, '-') ;
        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 OR BLOCK then
    If (LSTFILENAME <> 'CON:') AND (((LINECOUNT MOD PAGESIZE) = 0) OR
    (EOF(INFILE)))
    then
    BEGIN
      Writeln (OUTPUT, '< ', LINECOUNT:4, ',', MEMAVAIL:5, ' >');
      IF EOF(INFILE) THEN
       IF NOT BLOCK THEN
       WRITELN(OUTPUT,^M^J'Working on Cross Reference Listing');
    END;
    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=21) OR (K=37)  then     { DO or IF}
         Begin
           LAST_KEY := K ;
           If NESTLVL = NESTMAX then
             Write (LST, '----Too many levels')
           Else
             Begin
               NESTLVL := NESTLVL + 1 ;
               NESTUP := TRUE
             End
         End ;

       If (K=26) OR (K=27) OR (K= 28) then    { ENDDO or ENDIF or ENDCASE}
         If (NESTLVL = 0) AND LISTING then
           Write (LST, '----Nesting error  ')
         Else
           Begin
             NESTLVL := NESTLVL - 1 ;
             NESTDN := TRUE
           End
     End

End; { GETIDENTIFIER }

PROCEDURE PROCESSLINE;
BEGIN
      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 OR BLOCK then
      OUTPUT_LINE(BUF) ;
      LINECOUNT := LINECOUNT + 1;
      END; {PROCESSLINE}

Begin { CROSSREF } {AND ELIM. LEFT WHITESPACE}
   nextime := true;
   nex2time := true;
   nex3time := true;
   INITIALIZE;
   OPENFILES;
   While NOT EOF(INFILE) AND (NOT ABORT) do
      Begin
      BUFCURSOR:= 0;
      NESTUP := FALSE ;
      NESTDN := FALSE ;
      READLN (INFILE, INPUT_LINE) ;
      WHITESPACE; {rsr * added 1/13/87 to eliminate whitespace}
      IF INCLUDEIN(INPUT_LINE) THEN
      PROCESSINCLUDEFILE(INPUT_LINE)
      ELSE
      PROCESSLINE;
      END;

   If NOT ABORT then
     Begin
     {TITLELINE;}
     IF ((NOT BLOCK) OR LISTING) THEN
     BEGIN
     LINECOUNT := 0;
     BUFCURSOR := 0;
     WRITELN(LST,^M^J'CROSS REFERENCE TABLE for ',FILENAME,^M^J);
     PRINTTABLE;
     Writeln(LST,^M^J'END of CROSS REFERENCE TABLE for ',FILENAME,^M^J);
     END;
     CLOSE(LST);
     If IOresult <> 0 then
     Writeln('ERROR CLOSING OUTPUT FILE')
     End;
  WRITELN(^M^J'PROGRAM COMPLETE: Written to ',LSTFILENAME,' - EXITING ');
  {CLRSCR}
  END.