home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / cobol / library / xref / xref1.inc < prev   
Text File  |  1994-04-30  |  13KB  |  396 lines
  1. PROCEDURE PAGE(VAR fx: TEXT);
  2. BEGIN
  3.   WRITELN(fx);
  4.   WRITE(fx, form_feed);
  5. END;
  6.  
  7.  
  8. FUNCTION Just_A_Cobol_Number(VAR CurrentWord:Alfa):Boolean;
  9.  
  10. (* Identifies character strings composed entirely of digits, including
  11.    the special COBOL case entirely of 9's.  Trims leading and trailing
  12.    gadgets from the word, except for parentheses.  No text on a COBOL
  13.    comment line ever enters here.  Returns TRUE if the string is all
  14.    digits, but FALSE if 9's are presumably a PICTURE, FALSE if any non-
  15.    digit is embedded in the string.  Call this from Find_In_Reserve,
  16.    because chopping removes the trailing dot from many reserved words
  17.    which would not otherwise be detected.
  18.  
  19.    This function was added to ensure that words in significant literals,
  20.    such as in the VALUE OF FILE-ID IS 'B:FILENAME.DAT' sentence, get xreffed.
  21.    This method also points up embarassing misspellings in SCREEN SECTIONs,
  22.    such as "PASWORD", and allows numeric PICTUREs to be xreffed.
  23.    *)
  24.  
  25. label chop, wombat;
  26. var Result: Boolean; i: Integer;
  27. begin
  28.    chop:
  29.    Result := Length(CurrentWord) = 0;       (* if TRUE, ignore null entry  *)
  30.    if not Result then begin
  31.  
  32.    (* return TRUE if word is a number, but not PICTURE 999... *)
  33.  
  34.          i := Length(CurrentWord);
  35.          if i > 0 then begin
  36.  
  37.             (* By the way, this elegant little string chopper is an example
  38.                of some fairly sophisticated Pascal coding, but I don't have
  39.                time to explain it to you.  Your koan for today:  Why goto?
  40.                What unwritten law REQUIRES the use of goto in this case?
  41.                If you solve THIS one, you can call yourself a systems analyst!
  42.                The answer is not in the books, but everyone who knows the
  43.                answer wonders what in the world Wirth was thinking of.  Homer
  44.                sometimes nods, very true.  But obviously, Homer knocked
  45.                himself unconscious with this one.  -dco,9/30/86
  46.                *)
  47.  
  48.             (* leading buffalo? *)
  49.  
  50.             if not (CurrentWord[1] in ['(','0'..'9','A'..'Z']) then begin
  51.                Delete(CurrentWord,1,1);
  52.                goto chop
  53.                end;
  54.  
  55.             (* trailing buffalo? *)
  56.  
  57.             if i > 1 then
  58.             if not (CurrentWord[i] in [')','0'..'9','A'..'Z']) then begin
  59.                Delete(CurrentWord,i,1);
  60.                goto chop
  61.                end;
  62.  
  63.             end;
  64.  
  65.  
  66.          (* anything not a digit? if so, can't be a number *)
  67.          for i := 1 to Length(CurrentWord) do begin
  68.             Result := CurrentWord[i] in ['0'..'9'];
  69.             if not Result then goto wombat;
  70.             end;
  71.  
  72.          (* test for PICTURE -- all 9's? *)
  73.          for i := 1 to Length(CurrentWord) do begin
  74.             Result := CurrentWord[i] <> '9';
  75.             if Result then goto wombat
  76.             end
  77.  
  78.       end;
  79.  
  80.    wombat:  Just_A_Cobol_Number := Result
  81.  
  82. end; {of Just_A_Cobol_Number}
  83.  
  84.  
  85.  
  86. { FUNCTYPE:                                                        }
  87. { Do binary search for keyword in 'key' list.  If found, return    }
  88. { TRUE, else FALSE.                                                }
  89. Function Find_in_Reserve(var kword: alfa) : boolean;
  90. Label Return;
  91. Var
  92.     low, high, mid : integer;  Result:Boolean;
  93. Begin
  94.     Result := Just_A_Cobol_Number(kword);
  95.     if not Result then begin
  96.        low  := 1;
  97.        high := NUMKEYS;
  98.        while (low <= high) do begin
  99.            mid := (low+high) div 2;
  100.            if kword < key[mid] then
  101.                high := mid - 1
  102.            else if kword > key[mid] then
  103.                low  := mid + 1
  104.            else begin
  105.                Result := TRUE;
  106.                goto Return;
  107.                end;
  108.            end;
  109.        Result := FALSE;
  110.     end;
  111.     Return: Find_in_Reserve := Result
  112. End;
  113.  
  114. {$W3 }
  115. PROCEDURE BuildTree(VAR tree: treepointer; VAR INFILE: GenStr);
  116. label chop;
  117. VAR
  118.   i:Integer;
  119.   CurrentWord : alfa;
  120.   FIN : TEXT; { local input file }
  121.   currchar,                     { Current operative character }
  122.   nextchar      : charinfo;     { Look-ahead character }
  123.   flushing      : (KNOT, DBL, STD, LIT, SCANFN, SCANFN2);
  124.   fname         : string[30];
  125.   DoInclude     : boolean; { TRUE if we discovered include file }
  126.   fbuffer       : string[255];  { Format buffer - before final Print }
  127.   LineIn        : string[255];
  128.   LineInLast    : string[255];
  129.   cp            : 0..255;
  130.   xeof,                 { EOF status AFTER a read }
  131.   xeoln         : BOOLEAN;      { EOLN status after a read }
  132.  
  133.    PROCEDURE Entertree(VAR subtree: treepointer;
  134.                            Word   : alfa;
  135.                            line   :counter);
  136.    VAR
  137.      nextitem : Queuepointer;
  138.    BEGIN
  139.      IF subtree=nil THEN
  140.        BEGIN {create a new entry}
  141.          NEW(subtree);
  142.          WITH subtree^ DO BEGIN
  143.            left := nil;
  144.            right := nil;
  145.            WITH entry DO BEGIN
  146.              Wordvalue := Word;
  147.              NEW(FirstInQueue);
  148.              LastinQueue := FirstInQueue;
  149.              WITH FirstInQueue^ DO BEGIN
  150.                 linenumber := line;
  151.                 NextInQueue := nil;
  152.              END;{WITH FirstInQueue}
  153.            END;{WITH entry}
  154.          END;{WITH subtree}
  155.        END {create a new entry}
  156.      ELSE {append a list item}
  157.        WITH subtree^, entry DO
  158.          IF Word=Wordvalue THEN
  159.            BEGIN
  160.              IF lastinQueue^.linenumber <> line THEN
  161.                 BEGIN
  162.                   NEW(nextitem);
  163.                   WITH Nextitem^ DO BEGIN
  164.                     linenumber := line;
  165.                     NextInQueue := nil;
  166.                   END;{WITH}
  167.                   lastinQueue^.NextInQueue := Nextitem;
  168.                   lastinQueue := nextitem;
  169.                 END;
  170.            END
  171.          ELSE
  172.            IF Word < Wordvalue THEN
  173.              Entertree(left,Word,line)
  174.            ELSE
  175.              Entertree(right,Word,line);
  176.    END;{Entertree}
  177.  
  178. {$W2}
  179.  
  180. Procedure ReadC({updating} VAR nextchar : charinfo;
  181.                 {returning}VAR currchar : charinfo );
  182. Var
  183.   Look          : char; { Character read in from File }
  184. BEGIN   {+++ File status module. +++
  185.    Stores file status "AFTER" a read.
  186.    NOTE this play on words - after one char is
  187.    actually "PRIOR TO" the next character               }
  188.   if xeoln then begin
  189.      LineInLast := LineIn;
  190.      if (not EOF(FIN)) then begin
  191.         readln(FIN, LineIn);
  192.         cp := 0;
  193.         xeoln := FALSE;
  194.         end
  195.       else
  196.         xeof := TRUE;
  197.       end;
  198.   if cp >= length(LineIn) then begin
  199.      xeoln := TRUE;
  200.      xeof  := EOF(FIN);
  201.      Look  := ' ';
  202.      end
  203.   else begin
  204.      cp := cp + 1;
  205.      Look := LineIn[cp];
  206.      End;
  207.         {+++ current operative character module +++}
  208.   currchar := nextchar;
  209.         {+++ Classify the character just read +++}
  210.  
  211.   WITH nextchar DO BEGIN{ Look-ahead character name module }
  212.     IF xeof THEN
  213.         name := FileMark
  214.     ELSE IF xeoln THEN
  215.         name := EndOfLine
  216.     ELSE IF Look = TAB THEN
  217.         name := atab
  218.     ELSE IF Look = space THEN
  219.         name := blank
  220.  
  221.     ELSE IF Look = ',' THEN
  222.         name := otherchar
  223.  
  224.     ELSE IF Look IN ['a'..'z'] THEN {lower case plus}
  225.         name := lletter
  226.  
  227.     ELSE IF Look in ['!'..'_'] THEN (* anything printable goes!! *)
  228.         name := uletter
  229.  
  230.     ELSE
  231.         name := otherchar;
  232.  
  233.     CASE name of{ store character value module }
  234.         EndOfLine,
  235.         FileMark:       Valu := space;
  236.         lletter:        Valu := upcase(look);       { Cnvrt to uppcase }
  237.         ELSE            valu := look;
  238.     END{ case name of };
  239.  
  240.   End{ Look-ahead character name module };
  241.  
  242. END; {of ReadC}
  243.  
  244. PROCEDURE GetL( VAR fbuffer :  GenStr      );
  245. {++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
  246. {+      Get a line of text into users buffer.           +}
  247. {+      Flushes comment lines:                          +}
  248. {+      Flushes lines of Literals:  'this is it'        +}
  249. {+      Ignores special characters & tabs:              +}
  250. {+      Recognizes End of File and End of Line.         +}
  251. {+                                                      +}
  252. {+GLOBAL                                                +}
  253. {+      flushing : (KNOT, DBL, STD, LIT, SCANFN);       +}
  254. {+      LLmax   = 0..Max Line length;                   +}
  255. {++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
  256. VAR
  257.   state : (scanning, terminal, overflow);
  258.   sawdot : boolean;
  259. BEGIN { GetL }
  260.    fbuffer := '';
  261.    fname := '';
  262.    fatal_error := FALSE;
  263.    state := scanning;
  264.   REPEAT
  265.     ReadC(nextchar, currchar);
  266.     IF (length(fbuffer) >= LLmax) THEN{ exceeded length of buffer }
  267.       BEGIN{ reset EOLN }
  268.         fatal_error := TRUE;
  269.         state := overflow;
  270.         fbuffer := '';
  271.         WRITE(bell);
  272.         WRITELN(xrefver,': error: exceeded length of input buffer');
  273.       END
  274.     ELSE
  275.       BEGIN
  276.         IF (currchar.name IN [FileMark,EndOfLine]) THEN
  277.           state:=terminal{ END of line or END of file };
  278.         CASE flushing of
  279.             DBL: ;
  280.             STD: ;
  281.             LIT: ;
  282.             SCANFN: ;
  283.             SCANFN2:;  (* all above are meaningless for COBOL *)
  284.             KNOT:
  285.                 CASE currchar.name of
  286.                 lletter, uletter, digit, blank:
  287.                         BEGIN{ store }
  288.                         fbuffer := concat(FBUFFER,CURRCHAR.VALU) ;
  289.                         END;
  290.                 atab, quote, otherchar:
  291.                         BEGIN  { convert to a space }
  292.                            fbuffer := concat(fbuffer,GAP);
  293.                         END;
  294.                 ELSE         { END of line -or- file mark }
  295.                         fbuffer := concat(fbuffer,currchar.valu)
  296.                 END{ case currchar name of };
  297.         END{ flushing case }
  298.       END{ ELSE }
  299.   UNTIL (state<>scanning);
  300. END; {of GetL}
  301.  
  302.  
  303.  
  304. PROCEDURE ReadWord;
  305. {++++++++++++++++++++++++++++++++++++++++++++++++}
  306. {+                                              +}
  307. {+       Analyze the Line into "words"          +}
  308. {+                                              +}
  309. {++++++++++++++++++++++++++++++++++++++++++++++++}
  310. LABEL   1;
  311. VAR
  312.   ix,           {temp indexer}
  313.   idlen,        {length of the word}
  314.   Cpos : BYTE; { Current Position pointer }
  315. BEGIN{ ReadWord }
  316.   Cpos := 1; { start at the beginning of a line }
  317.   WHILE Cpos < length(fbuffer) DO
  318.     BEGIN {Cpos<length(fbuffer)}
  319.       WHILE (Cpos < length(fbuffer)) AND (fbuffer[Cpos]=space) DO
  320.         Cpos:=Cpos + 1;    {--- skip spaces ---}
  321.       idlen := 0;
  322.       WHILE (Cpos < length(fbuffer)) AND (fbuffer[Cpos ] <> space) DO
  323.         BEGIN{ accept only non-spaces }
  324.           IF idlen < MaxWordlen THEN
  325.             BEGIN
  326.               idlen := idlen + 1;
  327.               CurrentWord[idlen] := fbuffer[Cpos];
  328.             END;
  329.           Cpos := Cpos +1;
  330.         END{ WHILE };
  331.       CurrentWord[0] := chr(idlen);
  332.       IF length(CurrentWord)=0 THEN {no word was found} GOTO 1;
  333.  
  334.       IF (not Find_in_Reserve(CurrentWord))        {check if reserved word}
  335.       THEN
  336.          EnterTree(tree,CurrentWord,Currentline);
  337.  
  338.       1:{Here is no word <length of word=0>};
  339.     END; {WHILE Cpos<length(fbuffer)}
  340. END; {of Readword}
  341.  
  342.  
  343. BEGIN{BuildTree}
  344.    flushing := KNOT{ flushing };
  345.    DoInclude := FALSE;
  346.    xeoln := TRUE;
  347.    xeof  := FALSE;
  348.    LineIn := '';
  349.    ASSIGN(FIN,INFILE);
  350.    RESET(FIN);
  351.    IF IOresult <> 0 THEN
  352.       BEGIN
  353.         WRITE(BELL);
  354.         WRITELN(xrefver,': error: file ',INFILE,' not found');
  355.         fatal_error := TRUE;
  356.       END;
  357.      nextchar.name := blank;       { Initialize next char to a space }
  358.      nextchar.valu := space;
  359.      ReadC({update}    nextchar,   { Initialize current char to space }
  360.            {returning} currchar);  { First char from file in nextchar }
  361.  
  362.      if not listing then write ('.'); (* first dot *)
  363.  
  364.      WHILE ((currchar.name<>filemark) AND (NOT fatal_error)) DO
  365.        BEGIN
  366.          Currentline := Currentline + 1;
  367.          GetL(fbuffer) { attempt to read the first line };
  368.  
  369.  
  370.          Writeln(Fout, Currentline:6,': ',LineInLast);
  371.  
  372.          (* also listing to console? *)
  373.  
  374.          IF listing THEN Writeln(Currentline:6,': ',LineInLast)
  375.          else BEGIN
  376.             if (CurrentLine mod 50) = 0 then
  377.                writeln(Currentline:5,' lines read');
  378.             write ('.');
  379.             END;
  380.  
  381.          (* don't xref COBOL comment lines when found *)
  382.  
  383.          if Length(fbuffer) >= 7 then begin
  384.             if fbuffer[7] in ['*','/'] then begin
  385.                (* ignore comment line *)
  386.                end
  387.             else begin
  388.                ReadWord  {Analyze the Text into single 'words' }
  389.                end
  390.             end;
  391.  
  392.        END; {While}
  393.        close(FIN);
  394.        writeln (' ',Currentline:0,' total lines read');
  395. END; {of BuildTree}{CLOSE(PRN_ID);}
  396.