Power-Programmierung/CD1.mdf/cobol/library/xref/xref1.inc

Text File | 1994-04-30 | 12.7 KB | 396 lines

PROCEDURE PAGE(VAR fx: TEXT);
BEGIN
  WRITELN(fx);
  WRITE(fx, form_feed);
END;


FUNCTION Just_A_Cobol_Number(VAR CurrentWord:Alfa):Boolean;

(* Identifies character strings composed entirely of digits, including
   the special COBOL case entirely of 9's.  Trims leading and trailing
   gadgets from the word, except for parentheses.  No text on a COBOL
   comment line ever enters here.  Returns TRUE if the string is all
   digits, but FALSE if 9's are presumably a PICTURE, FALSE if any non-
   digit is embedded in the string.  Call this from Find_In_Reserve,
   because chopping removes the trailing dot from many reserved words
   which would not otherwise be detected.

   This function was added to ensure that words in significant literals,
   such as in the VALUE OF FILE-ID IS 'B:FILENAME.DAT' sentence, get xreffed.
   This method also points up embarassing misspellings in SCREEN SECTIONs,
   such as "PASWORD", and allows numeric PICTUREs to be xreffed.
   *)

label chop, wombat;
var Result: Boolean; i: Integer;
begin
   chop:
   Result := Length(CurrentWord) = 0;       (* if TRUE, ignore null entry  *)
   if not Result then begin

   (* return TRUE if word is a number, but not PICTURE 999... *)

         i := Length(CurrentWord);
         if i > 0 then begin

            (* By the way, this elegant little string chopper is an example
               of some fairly sophisticated Pascal coding, but I don't have
               time to explain it to you.  Your koan for today:  Why goto?
               What unwritten law REQUIRES the use of goto in this case?
               If you solve THIS one, you can call yourself a systems analyst!
               The answer is not in the books, but everyone who knows the
               answer wonders what in the world Wirth was thinking of.  Homer
               sometimes nods, very true.  But obviously, Homer knocked
               himself unconscious with this one.  -dco,9/30/86
               *)

            (* leading buffalo? *)

            if not (CurrentWord[1] in ['(','0'..'9','A'..'Z']) then begin
               Delete(CurrentWord,1,1);
               goto chop
               end;

            (* trailing buffalo? *)

            if i > 1 then
            if not (CurrentWord[i] in [')','0'..'9','A'..'Z']) then begin
               Delete(CurrentWord,i,1);
               goto chop
               end;

            end;


         (* anything not a digit? if so, can't be a number *)
         for i := 1 to Length(CurrentWord) do begin
            Result := CurrentWord[i] in ['0'..'9'];
            if not Result then goto wombat;
            end;

         (* test for PICTURE -- all 9's? *)
         for i := 1 to Length(CurrentWord) do begin
            Result := CurrentWord[i] <> '9';
            if Result then goto wombat
            end

      end;

   wombat:  Just_A_Cobol_Number := Result

end; {of Just_A_Cobol_Number}



{ FUNCTYPE:                                                        }
{ Do binary search for keyword in 'key' list.  If found, return    }
{ TRUE, else FALSE.                                                }
Function Find_in_Reserve(var kword: alfa) : boolean;
Label Return;
Var
    low, high, mid : integer;  Result:Boolean;
Begin
    Result := Just_A_Cobol_Number(kword);
    if not Result then begin
       low  := 1;
       high := NUMKEYS;
       while (low <= high) do begin
           mid := (low+high) div 2;
           if kword < key[mid] then
               high := mid - 1
           else if kword > key[mid] then
               low  := mid + 1
           else begin
               Result := TRUE;
               goto Return;
               end;
           end;
       Result := FALSE;
    end;
    Return: Find_in_Reserve := Result
End;

{$W3 }
PROCEDURE BuildTree(VAR tree: treepointer; VAR INFILE: GenStr);
label chop;
VAR
  i:Integer;
  CurrentWord : alfa;
  FIN : TEXT; { local input file }
  currchar,                     { Current operative character }
  nextchar      : charinfo;     { Look-ahead character }
  flushing      : (KNOT, DBL, STD, LIT, SCANFN, SCANFN2);
  fname         : string[30];
  DoInclude     : boolean; { TRUE if we discovered include file }
  fbuffer       : string[255];  { Format buffer - before final Print }
  LineIn        : string[255];
  LineInLast    : string[255];
  cp            : 0..255;
  xeof,                 { EOF status AFTER a read }
  xeoln         : BOOLEAN;      { EOLN status after a read }

   PROCEDURE Entertree(VAR subtree: treepointer;
                           Word   : alfa;
                           line   :counter);
   VAR
     nextitem : Queuepointer;
   BEGIN
     IF subtree=nil THEN
       BEGIN {create a new entry}
         NEW(subtree);
         WITH subtree^ DO BEGIN
           left := nil;
           right := nil;
           WITH entry DO BEGIN
             Wordvalue := Word;
             NEW(FirstInQueue);
             LastinQueue := FirstInQueue;
             WITH FirstInQueue^ DO BEGIN
                linenumber := line;
                NextInQueue := nil;
             END;{WITH FirstInQueue}
           END;{WITH entry}
         END;{WITH subtree}
       END {create a new entry}
     ELSE {append a list item}
       WITH subtree^, entry DO
         IF Word=Wordvalue THEN
           BEGIN
             IF lastinQueue^.linenumber <> line THEN
                BEGIN
                  NEW(nextitem);
                  WITH Nextitem^ DO BEGIN
                    linenumber := line;
                    NextInQueue := nil;
                  END;{WITH}
                  lastinQueue^.NextInQueue := Nextitem;
                  lastinQueue := nextitem;
                END;
           END
         ELSE
           IF Word < Wordvalue THEN
             Entertree(left,Word,line)
           ELSE
             Entertree(right,Word,line);
   END;{Entertree}

{$W2}

Procedure ReadC({updating} VAR nextchar : charinfo;
                {returning}VAR currchar : charinfo );
Var
  Look          : char; { Character read in from File }
BEGIN   {+++ File status module. +++
   Stores file status "AFTER" a read.
   NOTE this play on words - after one char is
   actually "PRIOR TO" the next character               }
  if xeoln then begin
     LineInLast := LineIn;
     if (not EOF(FIN)) then begin
        readln(FIN, LineIn);
        cp := 0;
        xeoln := FALSE;
        end
      else
        xeof := TRUE;
      end;
  if cp >= length(LineIn) then begin
     xeoln := TRUE;
     xeof  := EOF(FIN);
     Look  := ' ';
     end
  else begin
     cp := cp + 1;
     Look := LineIn[cp];
     End;
        {+++ current operative character module +++}
  currchar := nextchar;
        {+++ Classify the character just read +++}

  WITH nextchar DO BEGIN{ Look-ahead character name module }
    IF xeof THEN
        name := FileMark
    ELSE IF xeoln THEN
        name := EndOfLine
    ELSE IF Look = TAB THEN
        name := atab
    ELSE IF Look = space THEN
        name := blank

    ELSE IF Look = ',' THEN
        name := otherchar

    ELSE IF Look IN ['a'..'z'] THEN {lower case plus}
        name := lletter

    ELSE IF Look in ['!'..'_'] THEN (* anything printable goes!! *)
        name := uletter

    ELSE
        name := otherchar;

    CASE name of{ store character value module }
        EndOfLine,
        FileMark:       Valu := space;
        lletter:        Valu := upcase(look);       { Cnvrt to uppcase }
        ELSE            valu := look;
    END{ case name of };

  End{ Look-ahead character name module };

END; {of ReadC}

PROCEDURE GetL( VAR fbuffer :  GenStr      );
{++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{+      Get a line of text into users buffer.           +}
{+      Flushes comment lines:                          +}
{+      Flushes lines of Literals:  'this is it'        +}
{+      Ignores special characters & tabs:              +}
{+      Recognizes End of File and End of Line.         +}
{+                                                      +}
{+GLOBAL                                                +}
{+      flushing : (KNOT, DBL, STD, LIT, SCANFN);       +}
{+      LLmax   = 0..Max Line length;                   +}
{++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
VAR
  state : (scanning, terminal, overflow);
  sawdot : boolean;
BEGIN { GetL }
   fbuffer := '';
   fname := '';
   fatal_error := FALSE;
   state := scanning;
  REPEAT
    ReadC(nextchar, currchar);
    IF (length(fbuffer) >= LLmax) THEN{ exceeded length of buffer }
      BEGIN{ reset EOLN }
        fatal_error := TRUE;
        state := overflow;
        fbuffer := '';
        WRITE(bell);
        WRITELN(xrefver,': error: exceeded length of input buffer');
      END
    ELSE
      BEGIN
        IF (currchar.name IN [FileMark,EndOfLine]) THEN
          state:=terminal{ END of line or END of file };
        CASE flushing of
            DBL: ;
            STD: ;
            LIT: ;
            SCANFN: ;
            SCANFN2:;  (* all above are meaningless for COBOL *)
            KNOT:
                CASE currchar.name of
                lletter, uletter, digit, blank:
                        BEGIN{ store }
                        fbuffer := concat(FBUFFER,CURRCHAR.VALU) ;
                        END;
                atab, quote, otherchar:
                        BEGIN  { convert to a space }
                           fbuffer := concat(fbuffer,GAP);
                        END;
                ELSE         { END of line -or- file mark }
                        fbuffer := concat(fbuffer,currchar.valu)
                END{ case currchar name of };
        END{ flushing case }
      END{ ELSE }
  UNTIL (state<>scanning);
END; {of GetL}



PROCEDURE ReadWord;
{++++++++++++++++++++++++++++++++++++++++++++++++}
{+                                              +}
{+       Analyze the Line into "words"          +}
{+                                              +}
{++++++++++++++++++++++++++++++++++++++++++++++++}
LABEL   1;
VAR
  ix,           {temp indexer}
  idlen,        {length of the word}
  Cpos : BYTE; { Current Position pointer }
BEGIN{ ReadWord }
  Cpos := 1; { start at the beginning of a line }
  WHILE Cpos < length(fbuffer) DO
    BEGIN {Cpos<length(fbuffer)}
      WHILE (Cpos < length(fbuffer)) AND (fbuffer[Cpos]=space) DO
        Cpos:=Cpos + 1;    {--- skip spaces ---}
      idlen := 0;
      WHILE (Cpos < length(fbuffer)) AND (fbuffer[Cpos ] <> space) DO
        BEGIN{ accept only non-spaces }
          IF idlen < MaxWordlen THEN
            BEGIN
              idlen := idlen + 1;
              CurrentWord[idlen] := fbuffer[Cpos];
            END;
          Cpos := Cpos +1;
        END{ WHILE };
      CurrentWord[0] := chr(idlen);
      IF length(CurrentWord)=0 THEN {no word was found} GOTO 1;

      IF (not Find_in_Reserve(CurrentWord))        {check if reserved word}
      THEN
         EnterTree(tree,CurrentWord,Currentline);

      1:{Here is no word <length of word=0>};
    END; {WHILE Cpos<length(fbuffer)}
END; {of Readword}


BEGIN{BuildTree}
   flushing := KNOT{ flushing };
   DoInclude := FALSE;
   xeoln := TRUE;
   xeof  := FALSE;
   LineIn := '';
   ASSIGN(FIN,INFILE);
   RESET(FIN);
   IF IOresult <> 0 THEN
      BEGIN
        WRITE(BELL);
        WRITELN(xrefver,': error: file ',INFILE,' not found');
        fatal_error := TRUE;
      END;
     nextchar.name := blank;       { Initialize next char to a space }
     nextchar.valu := space;
     ReadC({update}    nextchar,   { Initialize current char to space }
           {returning} currchar);  { First char from file in nextchar }

     if not listing then write ('.'); (* first dot *)

     WHILE ((currchar.name<>filemark) AND (NOT fatal_error)) DO
       BEGIN
         Currentline := Currentline + 1;
         GetL(fbuffer) { attempt to read the first line };


         Writeln(Fout, Currentline:6,': ',LineInLast);

         (* also listing to console? *)

         IF listing THEN Writeln(Currentline:6,': ',LineInLast)
         else BEGIN
            if (CurrentLine mod 50) = 0 then
               writeln(Currentline:5,' lines read');
            write ('.');
            END;

         (* don't xref COBOL comment lines when found *)

         if Length(fbuffer) >= 7 then begin
            if fbuffer[7] in ['*','/'] then begin
               (* ignore comment line *)
               end
            else begin
               ReadWord  {Analyze the Text into single 'words' }
               end
            end;

       END; {While}
       close(FIN);
       writeln (' ',Currentline:0,' total lines read');
END; {of BuildTree}{CLOSE(PRN_ID);}