home *** CD-ROM | disk | FTP | other *** search
/ ftp.barnyard.co.uk / 2015.02.ftp.barnyard.co.uk.tar / ftp.barnyard.co.uk / cpm / walnut-creek-CDROM / CPM / TURBOPAS / XLIST62.LBR / XLIST62.PZS / XLIST62.PAS
Pascal/Delphi Source File  |  2000-06-30  |  16KB  |  607 lines
  1. {$I XLIST62.INC}
  2.  
  3.             Language := 'P';
  4.            IF Pos( '.CMD', FILENAME) <> 0 THEN
  5.             Language := 'D';
  6.             ASSIGN(INFILE,FILENAME);
  7.             RESET(INFILE);
  8.             OPENERRNUM := IORESULT;
  9.             OPENOK := ( OPENERRNUM = 0);
  10.             If NOT OPENOK then
  11.               Writeln(FILENAME,' NOT FOUND')
  12.             Else
  13.               FILETITLE := FILENAME;
  14.             If POS(':',FILETITLE) = 2 then
  15.                 DELETE(FILETITLE,1,2);
  16.             LTITLE := LENGTH(FILETITLE);
  17.           End;
  18.    Until OPENOK OR ABORT;
  19.  
  20.    If NOT ABORT then
  21.      Begin
  22.        Write('DESTINATION FILE OR DEVICE (CON:=SCR;<CR>=LST:): ');
  23.        if (paramcount >= 2) and (nex2time) then
  24.           begin
  25.              LSTFILENAME := paramstr(2);
  26.              writeln(LSTFILENAME);
  27.              nex2time := false
  28.           end
  29.        else
  30.           READLN(LSTFILENAME);
  31.        If LENGTH (LSTFILENAME) <= 0 then
  32.          LSTFILENAME := 'LST:' ;
  33.        For I := 1 to LENGTH(LSTFILENAME) do
  34.          LSTFILENAME[I] := UPcase(LSTFILENAME[I]) ;
  35.        ASSIGN(LST,LSTFILENAME);
  36.        Rewrite(LST);
  37.   End;
  38.    If NOT ABORT then
  39.      Begin
  40.        Repeat
  41.          Write('DO YOU WANT A <F>ull,<B>lock or <C>ross index listing (F/B/C)? ');
  42.          if (paramcount >=3) and (nex3time) then
  43.            begin
  44.               LISTOPTION := Upcase(paramstr(3));
  45.               nex3time := false
  46.            end
  47.          else
  48.            READLN( LISTOPTION );
  49.  
  50.          LISTOPTION := Upcase(LISTOPTION);
  51.        Until LISTOPTION IN ['B','C','F'];
  52.          LISTING := LISTOPTION = 'F';
  53.          BLOCK := LISTOPTION = 'B';
  54.        IF NOT LISTING AND NOT BLOCK THEN
  55.        WRITELN('WORKING: CROSS INDEX only. Please wait ! ')
  56.        ELSE WRITELN;
  57.      End;
  58. End; {open}
  59.  
  60.  
  61. Procedure PUTALFA(S:ALFA);
  62. Begin
  63.   MOVE(S[1],BUF[BUFCURSOR],16); {8}
  64.   BUFCURSOR:=BUFCURSOR+16;      {8}
  65. End;
  66.  
  67. Procedure PUTNUMBER(NUM: Integer);
  68. Var I,IPOT:Integer;
  69.     A: ALFA;
  70.     CH: Char;
  71.     ZAP:Boolean;
  72.  
  73. Begin
  74.   ZAP:=TRUE;
  75.   IPOT:=10000;
  76.   A[1]:=' ';
  77.   For I:= 2 to 6 do
  78.     Begin
  79.       CH:=CHR(NUM DIV IPOT + ORD('0'));
  80.       If I <> 6 then
  81.         If ZAP then
  82.            If CH = '0' then
  83.              CH:=' '
  84.            Else ZAP:=FALSE;
  85.       A[I]:=CH;
  86.       NUM:=NUM MOD IPOT;
  87.       IPOT:=IPOT DIV 10;
  88.     End;
  89.   A[7]:=' ';
  90.   MOVE(A,BUF[BUFCURSOR],7);
  91.   BUFCURSOR:=BUFCURSOR+7;
  92. End;
  93.  
  94.  
  95. Procedure SEARCH( ID: ALFA );               {MODULO P HASH SEARCH}
  96. {GLOBAL: T, TOP}
  97. Var
  98.     I,J,H,D  : Integer;
  99.     X         : ITEMPTR;
  100.     F         : Boolean;
  101.  
  102. Begin
  103.    J:=0;
  104.    For I:= 1 to ALFALEN do
  105.  
  106.      J:= J*10+ORD(ID[I]);
  107.    H  := ABS(J) MOD P;
  108.    F  := FALSE;
  109.    D  := 1;
  110.    Repeat
  111.       If T[H].KEY = ID
  112.          then
  113.             Begin {FOUND}
  114.                F := TRUE;
  115.                If T[H].LAST^.REFNUM = REFSPERITEM
  116.  
  117.                   then
  118.                      Begin
  119.                          NEW(X);
  120.                          X^.REFNUM := 1;
  121.                          X^.REF[1] := LINECOUNT;
  122.                          T[H].LAST^.NEXT:= X;
  123.                          T[H].LAST        := X;
  124.                      End
  125.                  Else
  126.                     WITH T[H].LAST^ do
  127.                        Begin
  128.                           REFNUM      := REFNUM + 1;
  129.                           REF[REFNUM] := LINECOUNT
  130.                        End
  131.             End
  132.          Else
  133.             If T[H].KEY = '                '
  134.                then
  135.                   Begin {NEW ENTRY}
  136.                      F := TRUE;
  137.                      NEW(X);
  138.                      X^.REFNUM := 1;
  139.                      X^.REF[1] := LINECOUNT;
  140.                      T[H].KEY := ID;
  141.                      T[H].FIRST := X;
  142.                      T[H].LAST := X;
  143.                      T[H].FOL := TOP;
  144.                      TOP := H
  145.                   End
  146.                Else
  147.                   Begin {COLLISION}
  148.                      H := H+D;
  149.                      D := D+2;
  150.                      If H >= P
  151.                         then
  152.                            H := H - P;
  153.                      If D = P
  154.                         then
  155.                            Begin
  156.                               Writeln(OUTPUT,'TBLE OVFLW');
  157.                               ERROR := TRUE
  158.                            End ;
  159.                   End
  160.    Until F OR ERROR
  161.  
  162. End {SEARCH} ;
  163.  
  164. Procedure PRINTWORD(W: WORD);
  165. Var
  166.     L,NEXTREF: Integer;
  167.     X: ITEMPTR;
  168.     THISREF: NUMREFS;
  169. Begin
  170.    PUTALFA(W.KEY);
  171.    X := W.FIRST;
  172.    L := 0;
  173.  
  174.    Repeat
  175.       If L = REFSPERLINE
  176.          then
  177.             Begin
  178.                L := 0;
  179.                LPWRITELN;
  180.                PUTALFA('                ');
  181.             End ;
  182.       L := L+1;
  183.       THISREF := (L-1) MOD REFSPERITEM + 1;
  184.       NEXTREF := X^.REF[ THISREF ];
  185.       If THISREF = X^.REFNUM
  186.          then
  187.             X := NIL
  188.          Else
  189.             If THISREF = REFSPERITEM
  190.                then
  191.                   X := X^.NEXT;
  192.       PUTNUMBER(NEXTREF);
  193.    Until X = NIL;
  194.   LPWRITELN;
  195. End {PRINTWORD} ;
  196.  
  197. Procedure PRINTTABLE;
  198. Var
  199.     I,J,M: INDEX;
  200. Begin
  201.    I := TOP;
  202.    While I <> P do
  203.       Begin {FIND MINIMAL WORD}
  204.          M := I;
  205.          J := T[I].FOL;
  206.          While J <> P do
  207.             Begin
  208.                If T[J].KEY < T[M].KEY
  209.                   then
  210.                      M := J;
  211.                J := T[J].FOL
  212.             End ;
  213.          PRINTWORD(T[M]);
  214.          If M <> I then
  215.            Begin
  216.              T[M].KEY:=T[I].KEY;
  217.  
  218.              T[M].FIRST:=T[I].FIRST;
  219.              T[M].LAST:=T[I].LAST;
  220.            End;
  221.          I := T[I].FOL
  222.       End
  223. End {PRINTTABLE} ;
  224.  
  225. Procedure OUTPUT_LINE (BUF : BUFFER) ;
  226.   Var
  227.     I : Integer ;
  228.  
  229.   Procedure PRTNEST (Var LINE : BUFFER) ;
  230.  
  231.  
  232.     Var COL : Integer ;
  233.  
  234.     Begin { PRTNEST }
  235.     For COL := 1 to NESTLVL - 1 do
  236.       Write (LST, BAR, ' ') ;
  237.     If NESTLVL > 0 then
  238.       If NESTUP OR NESTDN then
  239.         Begin
  240.         If NESTDN then
  241.           Begin
  242.           Write (LST, BAR, ' ') ;
  243.           Write (LST, 'E--') ;
  244.           For COL := NESTLVL+2 to NESTMAX do
  245.             Write (LST, '-')
  246.           End
  247.         Else
  248.           Begin
  249.           Write (LST, 'B--') ;
  250.           For COL := NESTLVL+1 to NESTMAX do
  251.             Write (LST, '-')
  252.           End ;
  253.         End
  254.       Else
  255.         Begin
  256.         Write (LST, BAR, ' ') ;
  257.         For COL := NESTLVL+1 to NESTMAX do
  258.           Write (LST,'')
  259.         End
  260.     Else
  261.       If NESTDN then
  262.         Begin
  263.         Write (LST, 'E--') ;
  264.         For COL := 2 to NESTMAX do
  265.           Write (LST, '-') ;
  266.         End
  267.       Else
  268.         For COL := 1 to NESTMAX do
  269.           Write (LST,'');
  270.         If (Language = 'D') AND (IGNORE) Then
  271.         Write(LST, Input_Line);   { modification for Ignore }
  272.     End ; { PRTNEST }
  273.  
  274.   Begin { OUTPUT_LINE }
  275.  
  276.   If ((LINECOUNT MOD PAGESIZE) = 0) OR (PAGE_NUM = 1)
  277.   then
  278.     Begin
  279.       If LISTING OR BLOCK then
  280.     If (LSTFILENAME <> 'CON:') AND (((LINECOUNT MOD PAGESIZE) = 0) OR
  281.     (EOF(INFILE)))
  282.     then
  283.     BEGIN
  284.       Writeln (OUTPUT, '< ', LINECOUNT:4, ',', MEMAVAIL:5, ' >');
  285.       IF EOF(INFILE) THEN
  286.        IF NOT BLOCK THEN
  287.        WRITELN(OUTPUT,^M^J'Working on Cross Reference Listing');
  288.     END;
  289.  
  290.     End ;
  291.   Write (LST, LINECOUNT:4, '  ') ;
  292.   PRTNEST (BUF) ;
  293.   If (Language = 'D') AND (NOT IGNORE) then
  294.   write(LST, Input_Line);
  295.   If (Language = 'P') then
  296.   For I := 1 to BUFCURSOR do
  297.     Write (LST, BUF[I]) ;
  298.   Writeln (LST) ;
  299.   If LSTFILENAME <> 'CON:' then
  300.     Write (OUTPUT, '.')
  301.   End ; { OUTPUT_LINE }
  302.  
  303. Procedure GETNEXTCHAR;
  304. Var I : Integer;
  305.  
  306. Begin { GETNEXTCHAR }
  307. If BUFCURSOR >= LENGTH (INPUT_LINE) then
  308.   Begin
  309.   EOL := TRUE ;
  310.   CH := ' ' ;
  311.   ERROR := EOF(INFILE)
  312.   End
  313. Else
  314.   Begin
  315.   BUFCURSOR := BUFCURSOR + 1 ;
  316.   CH := INPUT_LINE [BUFCURSOR] ;
  317.   BUF [BUFCURSOR] := CH ;
  318.   CH := UPcase(CH)
  319.   End
  320. End; { GETNEXTCHAR }
  321.  
  322. Procedure GETIDENTIFIER;
  323. Var
  324.     J,K,I: Integer;
  325.     ID: ALFA;
  326.  
  327. Begin { GETIDENTIFIER }
  328.    I := 0;
  329.    ID := '                ';
  330.    Repeat
  331.       If I < ALFALEN
  332.          then
  333.             Begin
  334.                I := I+1;
  335.                ID[I] := CH
  336.             End;
  337.       GETNEXTCHAR
  338.    Until ( NOT(((CH>='A') AND (CH<='Z')) OR (CH='_')
  339.                 OR ((CH>='0') AND (CH<='9')))) OR (ERROR);
  340.    I := 1;
  341.    If Upcase(Language) = 'D' then
  342.    J := 79;
  343.    If Upcase(Language) = 'P' then
  344.    J := 45;
  345.    Repeat
  346.       K := (I+J) DIV 2;      {BINARY SEARCH}
  347.       If KEY[K] <= ID
  348.          then
  349.             I := K+1;
  350.  
  351.       If KEY[K] >= ID
  352.          then
  353.             J := K-1;
  354.  
  355.    Until I > J;
  356.    If KEY[K] <> ID then
  357.      SEARCH(ID)
  358.    Else
  359.      CASE Language of
  360.      'P' : Begin {Turbo}
  361.        If (K=3) OR ((K=5) AND (LAST_KEY<>32)) OR     { Begin or CASE }
  362.           (K=32) OR (K=33) then                      { Record or Repeat }
  363.          Begin
  364.            LAST_KEY := K ;
  365.            If NESTLVL = NESTMAX then
  366.              Write (LST, '----Too many levels')
  367.            Else
  368.              Begin
  369.                NESTLVL := NESTLVL + 1 ;
  370.                NESTUP := TRUE
  371.              End
  372.          End ;
  373.        If (K=12) OR (K=40) then          { End or Until }
  374.          If (NESTLVL = 0) AND LISTING then
  375.            Write (LST, '----Nesting error  ')
  376.          Else
  377.            Begin
  378.              NESTLVL := NESTLVL - 1 ;
  379.              NESTDN := TRUE
  380.            End
  381.            End;  {Turbo}
  382.  
  383.        'D' : Begin  {DbaseII}
  384.        If (NOT IGNORE)  AND ((K=16) OR (K=34))
  385.            then     { DO or IF}
  386.          Begin
  387.            LAST_KEY := K ;
  388.            If NESTLVL = NESTMAX then
  389.              Write (LST, '----Too many levels')
  390.            Else
  391.              Begin
  392.                NESTLVL := NESTLVL + 1 ;
  393.                NESTUP := TRUE
  394.              End
  395.          End ;
  396.        If (K=20) OR (K=21) OR (K=22)
  397.        OR (K=23) OR (K=24) OR (K=25) then    { ENDDO or ENDIF or ENDCASE}
  398.          If (NESTLVL = 0) AND LISTING then
  399.            Write (LST, '----Nesting error  ')
  400.          Else
  401.            Begin
  402.              NESTLVL := NESTLVL - 1 ;
  403.              NESTDN := TRUE
  404.            End;
  405.       End;  {DbaseII}
  406.       End; {case}
  407. End; { GETIDENTIFIER }
  408.  
  409. PROCEDURE PROCESSLINE;
  410.  
  411. Begin {Processline}
  412. If Language = 'P' then
  413. BEGIN  {TURBO}
  414.       If (LENGTH (INPUT_LINE) > 0) then
  415.         Begin
  416.         EOL := FALSE ;
  417.         BUFCURSOR := BUFCURSOR + 1 ;
  418.         CH := INPUT_LINE[BUFCURSOR] ;
  419.         BUF[BUFCURSOR] := CH ;
  420.         CH := UPcase (CH)
  421.         End
  422.       Else
  423.         Begin
  424.  
  425.         EOL := TRUE ;
  426.         CH := ' '
  427.         End ;
  428.       While NOT EOL do
  429.         Begin
  430.         If ((CH >= 'A') AND (CH <= 'Z')) AND (NOT LITERAL) AND
  431.            (NOT ACOMMENT) AND (NOT BCOMMENT) then
  432.           GETIDENTIFIER
  433.         Else
  434.           If (CH = '''') OR LITERAL then
  435.             Begin
  436.               Repeat
  437.                 GETNEXTCHAR;
  438.               Until (CH = '''') OR (ERROR) OR EOL;
  439.               LITERAL := EOL ;
  440.               GETNEXTCHAR
  441.             End
  442.           Else
  443.             If (CH = '{') OR ACOMMENT then
  444.  
  445.               Begin
  446.                 While (CH <> '}') AND (NOT ERROR) AND (NOT EOL) do
  447.                   GETNEXTCHAR ;
  448.                 ACOMMENT := EOL ;
  449.                 GETNEXTCHAR
  450.               End
  451.             Else
  452.               If (CH = '(') OR BCOMMENT then
  453.                 Begin
  454.                   If NOT BCOMMENT then
  455.                     GETNEXTCHAR;
  456.                   If (CH = '*') OR BCOMMENT then
  457.                     Begin
  458.                       If NOT BCOMMENT then
  459.                         GETNEXTCHAR;
  460.                       Repeat
  461.                         While (CH <> '*') AND (NOT ERROR) AND (NOT EOL) do
  462.                           GETNEXTCHAR ;
  463.                         BCOMMENT := EOL ;
  464.                         If NOT EOL then
  465.                           GETNEXTCHAR
  466.                       Until (CH = ')') OR ERROR OR EOL ;
  467.                       If NOT EOL then
  468.                         GETNEXTCHAR
  469.                     End
  470.                 End
  471.               Else
  472.                 GETNEXTCHAR;
  473.       END;{WHILE}
  474.       EOL := FALSE ;
  475.       If LISTING OR BLOCK then
  476.       OUTPUT_LINE(BUF) ;
  477.       LINECOUNT := LINECOUNT + 1;
  478.       END; {TURBO}
  479.  
  480.  
  481. If Language = 'D' then
  482.       BEGIN {DbaseII}
  483.       If (LENGTH (INPUT_LINE) > 0) AND (NOT IGNORE)  then
  484.         Begin
  485.         EOL := FALSE ;
  486.         BUFCURSOR := BUFCURSOR + 1 ;
  487.         CH := INPUT_LINE[BUFCURSOR] ;
  488.         BUF[BUFCURSOR] := CH ;
  489.         CH := UPcase (CH)
  490.         End
  491.       Else
  492.         Begin
  493.         EOL := TRUE;
  494.         CH := ' '
  495.         End ;
  496.       While NOT EOL  do
  497.         Begin
  498.         If ((CH >= 'A') AND (CH <= 'Z')) AND (NOT LITERAL) AND
  499.            (NOT ACOMMENT) AND (NOT BCOMMENT) then
  500.           GETIDENTIFIER
  501.         Else
  502. (*          If (CH = '''') OR LITERAL then
  503.             Begin
  504.               Repeat
  505.                 GETNEXTCHAR;
  506.               Until (CH = '''') OR (ERROR) OR EOL;
  507.               LITERAL := EOL ;
  508.               GETNEXTCHAR
  509.             End
  510.           Else
  511.             If (CH = '{') OR ACOMMENT then
  512.  
  513.               Begin
  514.                 While (CH <> '}') AND (NOT ERROR) AND (NOT EOL) do
  515.                   GETNEXTCHAR ;
  516.                 ACOMMENT := EOL ;
  517.                 GETNEXTCHAR
  518.               End
  519.             Else
  520.               If (CH = '(') OR BCOMMENT then
  521.                 Begin
  522.                   If NOT BCOMMENT then
  523.                     GETNEXTCHAR;
  524.                   If (CH = '*') OR BCOMMENT then
  525.                     Begin
  526.                       If NOT BCOMMENT then
  527.                         GETNEXTCHAR;
  528.                       Repeat
  529.                         While (CH <> '*') AND (NOT ERROR) AND (NOT EOL) do
  530.                           GETNEXTCHAR ;
  531.                         BCOMMENT := EOL ;
  532.                         If NOT EOL then
  533.                           GETNEXTCHAR
  534.                       Until (CH = ')') OR ERROR OR EOL ;  *)
  535.                       If NOT EOL then
  536.                         GETNEXTCHAR
  537.                    { End }
  538.                { End }
  539.                Else
  540.                 GETNEXTCHAR;
  541.       END;{WHILE}
  542.       EOL := FALSE ;
  543.       If LISTING OR BLOCK then
  544.       OUTPUT_LINE(BUF) ;
  545.       LINECOUNT := LINECOUNT + 1;
  546.       END; {DBASEII}
  547. END;       {PROCESSLINE}
  548.  
  549.  
  550. Procedure Ignore_Line(Var Ignore: Boolean);
  551.       BEGIN
  552.       IF (LENGTH(INPUT_LINE) > 0) THEN
  553.       IF (POS('*',INPUT_LINE) = 1) OR
  554.          (POS('?',INPUT_LINE) = 1) OR
  555.          (POS('@',INPUT_LINE) = 1) OR
  556.          (POS('NOTE',INPUT_LINE) = 1) OR
  557.          (POS('Note',INPUT_LINE) = 1) OR
  558.          (POS('REMARK',INPUT_LINE) = 1) OR
  559.          (POS('Remark',INPUT_Line) = 1) OR
  560.          (POS('ACCE',INPUT_LINE) = 1) OR
  561.          (POS('Acce',INPUT_LINE) = 1) THEN IGNORE := TRUE;
  562.       END;
  563.  
  564.  
  565. Begin { CROSSREF } {AND ELIM. LEFT WHITESPACE}
  566.    nextime := true;
  567.    nex2time := true;
  568.    nex3time := true;
  569.    OPENFILES(LANGUAGE);
  570.    INITIALIZE;
  571.    IGNORE := FALSE;
  572.    While NOT EOF(INFILE) AND (NOT ABORT) do
  573.       Begin
  574.       BUFCURSOR:= 0;
  575.       NESTUP := FALSE ;
  576.       NESTDN := FALSE ;
  577.       IGNORE := FALSE;
  578.       READLN (INFILE, INPUT_LINE) ;
  579.       WHITESPACE; {rsr * added 1/13/87 to eliminate whitespace}
  580.       IF (LANGUAGE = 'D') THEN IGNORE_LINE(IGNORE);
  581.       IF INCLUDEIN(INPUT_LINE) THEN
  582.       PROCESSINCLUDEFILE(INPUT_LINE)
  583.       ELSE
  584.       PROCESSLINE;
  585.       END;
  586.  
  587.    If NOT ABORT then
  588.  
  589.      Begin
  590.      {TITLELINE;}
  591.      IF ((NOT BLOCK) OR LISTING) THEN
  592.      BEGIN
  593.      LINECOUNT := 0;
  594.      BUFCURSOR := 0;
  595.      WRITELN(LST,^M^J'CROSS REFERENCE TABLE for ',FILENAME,^M^J);
  596.      PRINTTABLE;
  597.      Writeln(LST,^M^J'END of CROSS REFERENCE TABLE for ',FILENAME,^M^J);
  598.      END;
  599.      CLOSE(LST);
  600.      If IOresult <> 0 then
  601.        Writeln('ERROR CLOSING OUTPUT FILE');
  602.      End;
  603.   WRITELN(^M^J'PROGRAM COMPLETE: Written to ',LSTFILENAME,' - EXITING ');
  604.   {FillChar(Input_Line, Sizeof(Input_Line), ' ');}
  605.   {CLRSCR}
  606.   END.
  607.