{$I XLIST62.INC}

            Language := 'P';
           IF Pos( '.CMD', FILENAME) <> 0 THEN
            Language := 'D';
            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 (CON:=SCR;<CR>=LST:): ');
       if (paramcount >= 2) and (nex2time) then
          begin
             LSTFILENAME := paramstr(2);
             writeln(LSTFILENAME);
             nex2time := false
          end
       else
          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 <F>ull,<B>lock or <C>ross index listing (F/B/C)? ');
         if (paramcount >=3) and (nex3time) then
           begin
              LISTOPTION := Upcase(paramstr(3));
              nex3time := false
           end
         else
           READLN( LISTOPTION );

         LISTOPTION := Upcase(LISTOPTION);
       Until LISTOPTION IN ['B','C','F'];
         LISTING := LISTOPTION = 'F';
         BLOCK := LISTOPTION = 'B';
       IF NOT LISTING AND NOT BLOCK THEN
       WRITELN('WORKING: CROSS INDEX only. Please wait ! ')
       ELSE WRITELN;
     End;
End; {open}


Procedure PUTALFA(S:ALFA);
Begin
  MOVE(S[1],BUF[BUFCURSOR],16); {8}
  BUFCURSOR:=BUFCURSOR+16;      {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 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,'');
        If (Language = 'D') AND (IGNORE) Then
        Write(LST, Input_Line);   { modification for Ignore }
    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) ;
  If (Language = 'D') AND (NOT IGNORE) then
  write(LST, Input_Line);
  If (Language = 'P') then
  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;
   If Upcase(Language) = 'D' then
   J := 79;
   If Upcase(Language) = 'P' then
   J := 45;
   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
     CASE Language of
     'P' : Begin {Turbo}
       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) AND LISTING then
           Write (LST, '----Nesting error  ')
         Else
           Begin
             NESTLVL := NESTLVL - 1 ;
             NESTDN := TRUE
           End
           End;  {Turbo}

       'D' : Begin  {DbaseII}
       If (NOT IGNORE)  AND ((K=16) OR (K=34))
           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=20) OR (K=21) OR (K=22)
       OR (K=23) OR (K=24) OR (K=25) 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;  {DbaseII}
      End; {case}
End; { GETIDENTIFIER }

PROCEDURE PROCESSLINE;

Begin {Processline}
If Language = 'P' then
BEGIN  {TURBO}
      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; {TURBO}


If Language = 'D' then
      BEGIN {DbaseII}
      If (LENGTH (INPUT_LINE) > 0) AND (NOT IGNORE)  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; {DBASEII}
END;       {PROCESSLINE}


Procedure Ignore_Line(Var Ignore: Boolean);
      BEGIN
      IF (LENGTH(INPUT_LINE) > 0) THEN
      IF (POS('*',INPUT_LINE) = 1) OR
         (POS('?',INPUT_LINE) = 1) OR
         (POS('@',INPUT_LINE) = 1) OR
         (POS('NOTE',INPUT_LINE) = 1) OR
         (POS('Note',INPUT_LINE) = 1) OR
         (POS('REMARK',INPUT_LINE) = 1) OR
         (POS('Remark',INPUT_Line) = 1) OR
         (POS('ACCE',INPUT_LINE) = 1) OR
         (POS('Acce',INPUT_LINE) = 1) THEN IGNORE := TRUE;
      END;


Begin { CROSSREF } {AND ELIM. LEFT WHITESPACE}
   nextime := true;
   nex2time := true;
   nex3time := true;
   OPENFILES(LANGUAGE);
   INITIALIZE;
   IGNORE := FALSE;
   While NOT EOF(INFILE) AND (NOT ABORT) do
      Begin
      BUFCURSOR:= 0;
      NESTUP := FALSE ;
      NESTDN := FALSE ;
      IGNORE := FALSE;
      READLN (INFILE, INPUT_LINE) ;
      WHITESPACE; {rsr * added 1/13/87 to eliminate whitespace}
      IF (LANGUAGE = 'D') THEN IGNORE_LINE(IGNORE);
      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 ');
  {FillChar(Input_Line, Sizeof(Input_Line), ' ');}
  {CLRSCR}
  END.