Crawly Crypt Collection 2/crawlyvol2.bin/program/pascal/forest2/forest2.pas

Pascal/Delphi Source File | 1989-01-16 | 23.1 KB | 696 lines

PROGRAM Forest2;   {Tab size = 2}
{A program to indicate the overall structure of a Pascal program.
 AUTHOR      : Merlin L. Hanson
 VERSION     : 2.0             DATE  : 1/15/89
 COMPILED BY : Personal Pascal Version 2.00
}

  {$I GEMSUBS.PAS}
  CONST
    TAB      = 9;    ESC     =   27;
    NoBorder = 0;    MyBlack = $180;
  TYPE
    PathChars = PACKED ARRAY [1..80] OF char;
  VAR
    MyInFile      : {FILE OF} text;           {Pascal source file}
    CRT           : {FILE OF} text;           {OUTPUT file may be redirected}
    TextLine      : ARRAY [1..170] OF char;   {The current line}
    TextUpperCase : ARRAY [1..170] OF char;   {and its' equivalent}
    FileName      : Path_Name;                {Used for both files}
    Path          : Path_Name;                {Used for both files}
    NbrCharInLine : integer;                  {length of text line}
    ch            : char;                     {A general purpose character}
    LineNbr       : integer;                  {The line number, 1..n}
    Choice        : (Monitor,Printer,FileX);  {possible destinations}
    NbrTab        : integer;                  {Change each tab char to number tab spaces}
    PrinterModeChanged : boolean;             {Remember to reset the printer}
    ReservedWord  : ARRAY[1..10]OF string;    {These are the 'magic' words}
    TextStrUpper  : string[255];              {An upper case string version of current line}
  (*$I AUXSUBS.PAS (some of the VT-52 stuff is used)*)

  FUNCTION GetSkipFlag:long_integer;
    {Return the value of a constant encoded here. If the value is
    $AAAAAAAA then set skip perforations on the printer.  If it is
    any other value, the printer settings will not be changed for
    this purpose alone. Since this function is early in the program
    it is relatively easy to find and change the value with
    a sector editor.}
    BEGIN
      GetSkipFlag := $AAAAAAAA;
    END {marker};

  PROCEDURE DisplayExitBox;
    VAR  Box : dialog_ptr;  OK : integer;
    BEGIN
      Box := New_Dialog(2,  70,21,8,3);
      OK  := Add_DItem(Box,G_Button,
                       Selectable |Exit_Btn | Default,
                       2,1,4,1,   NoBorder,MyBlack);
      Set_DText(Box,OK,' OK ',System_Font,TE_Left);
      OK := Do_Dialog(Box,0);
      End_Dialog(Box);
      ClrScr;
    END {displayexitbox};

    PROCEDURE SetUp;

    PROCEDURE DisplayCoverSheet;
      CONST
        w = 39;
        h = 16;
      VAR
        s   : ARRAY [1..12] OF string[35];
        Box : dialog_ptr;
        OK  : integer;

      PROCEDURE MakeText
                  (Box : dialog_ptr;
                     X : integer;
                     Y : integer;
                 NChar : integer;
                     S : string);
        VAR  junk : integer;
        BEGIN {maketext}
          junk := Add_DItem(Box,G_String,None,
                            X,Y,NChar,1,    NoBorder,MyBlack);
          Set_DText(Box,junk,S,System_Font,TE_Left);
        END {maketext};

      PROCEDURE DrawBox;
        VAR
          i, x, y : integer;
        BEGIN
        s[1] := '              FOREST     ';
        s[2] := '           Version 2.0   ';
        s[3] := '               by        ';
        s[4] := '         Merlin L. Hanson';
        s[5] := '          Genie Address: ';
        s[6] := '            M.L.HANSON   ';
        s[7] := '                         ';
        s[8] := '                         ';
        s[9] := '  Portions of this product are';
        s[10] := 'Copyright  1986, 1987 OSS and CCD.';
        INSERT    (CHR(189),s[10],11           );
        s[11] := '   Used by Permission of OSS.';
        s[12] :=             ' OK ';
        Box := New_Dialog(12,    0,0,w,h);
        x := 3;  y := 1;
        FOR i := 1 TO 11 DO
          MakeText(Box,x,y + i, 34,    s[i]);
        OK := Add_DItem(Box,G_Button,
                  Selectable | Exit_Btn | Default,
                  17,14,4,1,     NoBorder,MyBlack);
        Set_DText(Box,OK,s[12],System_Font,TE_Left);
        END {drawbox};

      begin  {displaycoversheet}
        Clear_Screen;
        DrawBox;
        Center_Dialog(Box);
        OK := Do_Dialog(Box,0);
        End_Dialog(Box);
        Delete_Dialog(Box);
        Clear_Screen;
      END {displaycoversheet};

      PROCEDURE OfferHelp;
        VAR Choice : integer;

        PROCEDURE DisplayHelpScreen;
          BEGIN
            Hide_Mouse;
          CRTExit; {reset the CRT}
          CRTInit; {automatic word wrap on.}
            ClrScr;
                GoToXY(1,36);
            WriteLn('FOREST.PRG');
            GoToXY(2,35);
            WriteLn('June 20,1988');
                GoToXY(3,14);
            WriteLn('A program to show the structure of a Pascal program.');
                WriteLn;
            Write('The INPUT file should be a file that would be acceptible to a Pascal compiler,');
                WriteLn('  although it does not need a file extension of .PAS.');
                WriteLn;
            Write('Text lines that declare PROCEDUREs, FUNCTIONs,');
            Write(' Includes ( {$I, (*$I  ), and mostlines that have');
            Write(' BEGIN followed by a comment will be displayed ');
                WriteLn('along with the    line number in the file.');
                WriteLn;
                WriteLn('Key words can be upper or lower case. The comment delimiter can be { or (*.');
                WriteLn;
            WriteLn('The construct: ''BEGIN {\ comment}'' will NOT be printed.');
                WriteLn;
                Write('You will be asked for a tab setting.');
            Write('  If your file doesn''t use tabs, the answer');
            WriteLn(' must be a digit; but its'' value is immaterial.');
            Show_Mouse;
                DisplayExitBox;
                ClrScr;
          END {displayhelpscreen};

        BEGIN {offerhelp}
          Choice := Do_Alert(
             '[2][  Do you want help?  ][ HELP | Who, ME? ]',2);
          IF Choice = 1 THEN
            DisplayHelpScreen;
        END {offerhelp};

    PROCEDURE GetInputFile;

      PROCEDURE GetDriveAndPath(VAR S:string);
        {A procedure that returns a Pascal string containing the current drive,
        current path and all punctuation.  Simply append a raw file name.}
        VAR
          i : integer;
          T : string;
          Path : string;
          DriveString : string;

        FUNCTION CurrentDisk:integer;
          {Returns an integer specifying the current drive. 0 specifies A, etc.}
          GEMDOS($19);

        PROCEDURE GetDir(VAR Ptr:string; DriveID:integer);
          {Puts a C string defining the folders currently open on DriveID
          into S.  DriveID of 0 specifies the current drive.}
          GEMDOS($47);

        BEGIN {getdriveandpath}
          DriveString := CONCAT(CHR(ORD('A')+CurrentDisk),':');
          GetDir(Path,0);
          {Convert from C to Pascal.}
          i := 0;
          WHILE Path[i] <> CHR(0) DO
            BEGIN
              T[i+1] := Path[i];
              i := i+1;
            END;
          {Set the length}
          T[0] := CHR(i);
          S := CONCAT(DriveString,T,'\');
        END {getdriveandpath};

      BEGIN
        GoToXY(3,34);
        InverseVideo;
        WriteLn('  Input File ');
        NormVideo;
        GetDriveAndPath(Path);
        FileName := CONCAT('________.PAS',CHR(0));
        IF Get_In_File(Path,FileName)
          THEN RESET(MyInFile,FileName)
          ELSE HALT; {user cancel}
        ClrScr;
      END {getinputfile};

        PROCEDURE GetDestinationChoice;
      VAR
        Box            : dialog_ptr;
        Pushed         : Tree_Index;
        S              : string[20];
        Index, BoxText : integer;
        Item           : ARRAY [1..3] OF integer;
        ObjectFlag     : ARRAY [1..3] OF integer;

      procedure IdentifyTheButton;
        {returns with Pushed in the range 1..3}
        VAR i : integer;
          Find : boolean;
        BEGIN
          i := 1;
          Find := FALSE;
          REPEAT
            IF Item[i] = Pushed
              THEN Find := TRUE
              ELSE i    := i+1;
          UNTIL Find;
          Pushed := i;
        END {identifythebutton};

      BEGIN {getdestinationchoice};
        ClrScr;
        Box     := New_Dialog(5,0,0,40,14);
        BoxText := Add_DItem(Box,G_String,None,
                             5,3,40,1,
                             NoBorder,MyBlack);
        Set_DText(Box,BoxText,
                  'Where do you want the output?',
                  System_Font,TE_Center);
        ObjectFlag[1] := Radio_Btn|Selectable|Exit_Btn;
        ObjectFlag[2] := ObjectFlag[1] + Default;
        ObjectFlag[3] := ObjectFlag[1];
        FOR Index := 1 TO 3 DO
          BEGIN
            Item[Index] := Add_DItem(Box,G_Button,
                                     ObjectFlag[Index],
                                     5 + 11 * (Index - 1),7,    9,1,
                                     NoBorder,MyBlack);
            CASE Index OF
              1 : S := 'Monitor';
              2 : S := 'Printer';
              3 : S := 'File';
            END {case};
            Set_DText(Box,Item[Index],S,System_Font,TE_Center);
          END {do};
        Center_Dialog(Box);
        Pushed := Do_Dialog(Box,0);
        IdentifyTheButton;
        End_Dialog(Box);
        CASE Pushed OF
          1 : Choice := Monitor;
          2 : Choice := Printer;
          3 : Choice := FileX;
        END {case};
        ClrScr;
      END {getdestinationchoice};

    PROCEDURE DrawEmptyBox;
      VAR  Box : dialog_ptr;
      BEGIN
        Box := New_Dialog(1,0,0,30,4);
        Center_Dialog(Box);
        Show_Dialog(Box,0);
        GoTOXY(13,32);
        Write(CRT,'Line Number:');
      END {drawemptybox};

      PROCEDURE GetTabSetting;
        LABEL 100;
        VAR
          Box : dialog_ptr;
          S   : str255;
          junk,OK,TabN,Choice : integer;
        BEGIN
100:
          Hide_Mouse;
          Clear_Screen;
          Box := New_Dialog(3,0,0,30,7);
 {LINE 1}
          junk := Add_DItem(Box,G_Text,None,2,2,28,1,
                             NoBorder,MyBlack);
          Set_DText(Box,junk,'What is the Tab Size?',
                    System_font,TE_Center);
 {LINE 2}
          TabN := Add_DItem(Box,G_FText,
                            Editable,
                            15,3,   1,1,  NoBorder,MyBlack);
          Set_DEdit(Box,TabN,'_','9','2',System_Font,TE_Center);
 {LINE 3}
          OK := Add_DItem(Box,G_Button,
                            Default|Selectable|Exit_Btn,
                            13,5,  4,1,   NoBorder,MyBlack);
          Set_DText(Box,OK,' OK ', System_Font,TE_Center);

          Center_Dialog(Box);
          Show_Mouse;
          junk := Do_Dialog(Box,TabN);
          Get_DEdit(Box,TabN,S);
          {convert digit to Binary}
          NbrTab := ORD(S[1]) - 48;
          {GEM allows invalid exit, e.g., <Backspace> or <Esc>.
          Have to trap this case.}
          IF (NbrTab < 0) OR (NbrTab > 9) THEN
            GoTo 100;
       END {gettabsetting};

    PROCEDURE SetUpPrinter;
      VAR PrinterStatus, Choice : integer;

      function PtrStatus : integer;
        GEMDOS($11);

      BEGIN {setupprinter}
        PrinterStatus := PtrStatus;
        WHILE PrinterStatus = 0 DO
          BEGIN
            Choice := Do_Alert(
             '[0][   Please turn the   |     printer on][ Abort | OK ]',2);
            PrinterStatus := PtrStatus;
            IF Choice = 1 THEN
              HALT;
          END;
        {Printer is ready to go.}
        Choice := Do_Alert(
            '[2][Change pitch on Epson|    printer?][ Yes | No ]',2);
        IF Choice = 1 THEN
          BEGIN   {\change the pitch}
            {Note suppression on printing of above line by '\'}
            Choice := Do_Alert(
              '[0][ Characters per line ][ 80 | 132 | 160 ]',0);
            WriteLn(CHR(ESC),'@');               {reset printer}
            CASE Choice OF
              1 :                 ;              {Pica draft}
              2 : WriteLn(CHR(15));              {compressed}
              3 : WriteLn(CHR(ESC),'M',CHR(15)); {compressed Elite}
            END {case};
            PrinterModeChanged := TRUE;
          END {choice = 1};
        IF (Choice = 1) OR (GetSkipFlag = $AAAAAAAA)
          THEN
            BEGIN
              {Set form length to 11 inches.}
              WriteLn(CHR(ESC),'C',CHR(0),CHR(11));
              {Skip 6 line at the perforations.}
              WriteLn(CHR(ESC),'N',CHR(6));
            END;
      END {setupprinter};

    PROCEDURE InitializeReservedWords;
      BEGIN
        ReservedWord[1] := 'PROGRAM';
        ReservedWord[2] := 'PROCEDURE';
        ReservedWord[3] := 'FUNCTION';
        ReservedWord[4] := '(*$I';
        ReservedWord[5] := '(*$i';
        ReservedWord[6] := '{$I';
        ReservedWord[7] := '{$i';
        ReservedWord[8] := 'BEGIN';
      END {initializereservedwords};

    PROCEDURE PrintDate;
      {The file name has already been put on this line.  Add the date
      at the right side of the paper and do a physical print.}
      VAR m,d,y:integer;
      BEGIN
        Get_Date(m,d,y);
        WriteLn(m:80-(LENGTH(FileName)+12), '/',d:2, '/',y:4);
        WriteLn;
      END {printdate};

    BEGIN {setup}
      LineNbr := 0;
      PrinterModeChanged := FALSE;
      Init_Mouse;
      DisplayCoverSheet;
      OfferHelp;
      GetInputFile;
      GetTabSetting;
      GetDestinationChoice;
      {Process the choice.}
      CASE Choice OF
        Monitor : BEGIN
                    Hide_Mouse;
                    ClrScr;
                  END;
        Printer : BEGIN
                    Rewrite(OUTPUT,'PRN:');
                    SetUpPrinter;
                    Write(FileName);
                    PrintDate;
                  END;
        FileX   : BEGIN
                    GoToXY(3,35);
                    InverseVideo;
                    WriteLn(' Output File ');
                    NormVideo;
                    FileName := CONCAT('STRUCT  .TXT',CHR(0));
                    {Bad procedure name, actually getting an output file.}
                    IF Get_In_File(Path,FileName)
                      THEN Rewrite(OUTPUT,FileName)
                      ELSE HALT;
                    ClrScr;
                    REWRITE(CRT,'CON:');
                    DrawEmptyBox;  {Will hold line numbers}
                  END;
      END {case};
      InitializeReservedWords;
    END {setup};

  PROCEDURE Compute;

    PROCEDURE GetLine;
      LABEL  100;
      VAR
        i, j : integer;    TextString : string[170];
        ch : char;    Done : boolean;

      FUNCTION UpperCase(ch : char) : char;
        BEGIN
          IF (ch >= 'a') AND (ch <= 'z')
            THEN UpperCase := CHR(ORD(ch) - 32{'a' - 'A'})
            ELSE UpperCase := ch;
        END {uppercase};

      PROCEDURE ChangeTabToSpaces;
        VAR  k : integer;
        BEGIN
          {NbrCharInLine will be used by the WriteLine procedure.}
          NbrCharInLine := NbrCharInLine + (NbrTab - 1);
          FOR k := 1 TO NbrTab DO
            BEGIN
              TextLine[j] := ' ';
              TextUpperCase[j] := ' ';
              j := j + 1;
            END {do};
        END {changetabtospaces};


      BEGIN {getline}
        Done := FALSE;
        REPEAT
          IF EOF(MyInFile)
            THEN GoTo 100;
          ReadLn(MyInFile,TextString);
          IF LENGTH(TextString) = 0
            THEN LineNbr := LineNbr + 1
            ELSE    Done := TRUE;
        UNTIL Done;
        NbrCharInLine := LENGTH(TextString);
        j := 1;
        FOR i := 1 TO NbrCharInLine DO
          BEGIN
            IF TextString[i] = CHR(Tab)
              THEN ChangeTabToSpaces
              ELSE
                BEGIN
                  TextLine[j] := TextString[i];
                  TextUpperCase[j] := UpperCase(TextLine[j]);
                  j := j + 1;
                END;
          END;
        (*FOR i := 1 TO NbrCharInLine DO
          Write(TextUpperCase[i]);
        WriteLn;*)
        LineNbr := LineNbr + 1;
100:
      END {getline};

    PROCEDURE AnalyzeLine;
      VAR  i : integer; Token : integer;

      PROCEDURE WriteLine;
        VAR  i : integer;  AllBlank : boolean;

        PROCEDURE PrintBar;
          BEGIN
            IF i MOD 2 <> 0
              THEN Write('|')
              ELSE Write(' ');
          END {printbar};

        PROCEDURE MeldStrings;
          VAR i, j : integer;
          BEGIN
            i := 1;
            WHILE TextLine[i] = ' ' DO
              BEGIN
                IF i MOD 2 = 0 THEN
                  TextLine[i] := '|';
                i := i + 1;
              END;
          END {meldstrings};

        BEGIN    {writeline}
          Write(LineNbr:5,' ');
          MeldStrings;
          FOR i := 1 TO NbrCharInLine DO
            Write(TextLine[i]);
          WriteLn;
        END {writeline};

      FUNCTION ReservedIsFirst(Index:integer):boolean;
        {The reserved word at Index is on the line, but it's not
        necessarily the first token on the line.  Return TRUE if it
        is the first, otherwise return FALSE.  All reserved words
        have at least three characters, base the decision on that.}
        VAR i,j:integer; Match:boolean; S:string[255];
        BEGIN
          i := 1;
          WHILE TextUpperCase[i] = ' ' DO
            i := i+1;
          {Assert: i points at the first non-blank.}
          S := ReservedWord[Index];
          Match := TRUE;
          FOR j := 1 TO 3 DO
            BEGIN
              IF S[j] <> TextUpperCase[i]
                THEN Match := FALSE;
              i := i+1;
            END;
          ReservedIsFirst := Match;
        END {reservedisfirst};

        FUNCTION PrintBegin:boolean;
          {We know that 'begin' is on the line as the first text.
          See if it is followed by a comment.  If it is and the printing
          of the comment is not suppressed, return TRUE, otherwise
          return FALSE.}
          VAR
            i,j :integer;
            Find:boolean;
            S   : string;
          BEGIN
            i := POS('N',TextStrUpper);
            i := i+1;
            WHILE (TextStrUpper[i] = ' ')
            AND (i < LENGTH(TextStrUpper)) DO
              i := i+1;
            Find := FALSE;
            {Assert: i points at the first non-blank after BEGIN.}
            IF (LENGTH(TextStrUpper) - 5) < 0
              THEN {get out of here. not enuf room for a comment}
              ELSE
                BEGIN
                  {Printing is suppressed iff '{\' or '(*\'}
                  S := COPY(TextStrUpper,i,4);
                  i := POS('{',S);
                  j := POS('(*',S);
                  IF (i > 0) AND (S[i+1] <> '\')
                  OR
                  ( (j > 0) AND (S[j+2] <> '\'))
                        THEN Find := TRUE;
                END;
            PrintBegin := Find;
          END {printbegin};

      BEGIN {analyzeline}
        IF NbrCharInLine > 0
          THEN
            BEGIN
              FOR i := 1 TO NbrCharInLine DO
                TextStrUpper[i+1] :=  TextUpperCase[i];
              TextStrUpper[0] := CHR(NbrCharInLine);
              (*WriteLn(TextStrUpper);*)
              FOR Token := 1 TO 8 DO
                IF POS(ReservedWord[Token],TextStrUpper) <> 0
                  THEN
                    IF ReservedIsFirst(Token)
                      THEN
                        IF (Token < 8)
                        OR ((Token = 8) AND (PrintBegin))
                          THEN WriteLine;
            END;
      END {analyzeline};

    PROCEDURE DisplayLineNbr;
      BEGIN
        IF Choice = FileX
          THEN
            BEGIN   (*\ Don't print this line.*)
              GoToXY(13,44);
              Write(CRT,LineNbr:5);
            END;
      END {displaylinenbr};

    BEGIN {compute}
      GetLine;
      WHILE NOT EOF(MyInFile) DO
        BEGIN
          AnalyzeLine;
          DisplayLineNbr;
          GetLine;
        END;
    END {compute};

  PROCEDURE CleanUp;
    BEGIN {cleanup}
      IF Choice = FileX THEN
        BEGIN
          CLOSE(Output);
          REWRITE(OUTPUT,'CON:');
          GoToXY(17,20);
          WriteLn('Output file sucessfully written and closed.');
          ReadLn;
        END;
      Hide_Mouse;
      Init_Mouse;
      IF Choice = Monitor
        THEN
          DisplayExitBox;
      ClrScr;
      IF PrinterModeChanged THEN
        WriteLn(CHR(ESC),'@');        {reset the printer}
      {Next line logically shouldn't be needed; but mouse
      handling is a black art on the ST.}
      Show_Mouse;
    END {cleanup};

  BEGIN             {main}
    ClrScr;
    IF Init_Gem >= 0 THEN
      BEGIN
        NbrTab := 2;
        SetUp;
        Set_Mouse(M_Bee);
        Compute;
        CleanUp;
        Exit_Gem;
      END {GEM block};
  END {program}.
(*                         TABLE OF CONTENTS

    4 PROGRAM Forest2;   {Tab size = 2}
   11  |{$I GEMSUBS.PAS}
   32  |(*$I AUXSUBS.PAS (some of the VT-52 stuff is used)*)
   34  |FUNCTION GetSkipFlag:long_integer;
   45  |PROCEDURE DisplayExitBox;
   58  |PROCEDURE SetUp;
   60  | |PROCEDURE DisplayCoverSheet;
   69  | | |PROCEDURE MakeText
   76  | | | |BEGIN {maketext}
   82  | | |PROCEDURE DrawBox;
  109  | | |begin  {displaycoversheet}
  119  | |PROCEDURE OfferHelp;
  122  | | |PROCEDURE DisplayHelpScreen;
  155  | | |BEGIN {offerhelp}
  162  | |PROCEDURE GetInputFile;
  164  | | |PROCEDURE GetDriveAndPath(VAR S:string);
  173  | | | |FUNCTION CurrentDisk:integer;
  177  | | | |PROCEDURE GetDir(VAR Ptr:string; DriveID:integer);
  182  | | | |BEGIN {getdriveandpath}
  210  | |PROCEDURE GetDestinationChoice;
  219  | | |procedure IdentifyTheButton;
  234  | | |BEGIN {getdestinationchoice};
  271  | |PROCEDURE DrawEmptyBox;
  281  | | |PROCEDURE GetTabSetting;
  320  | |PROCEDURE SetUpPrinter;
  323  | | |function PtrStatus : integer;
  326  | | |BEGIN {setupprinter}
  362  | |PROCEDURE InitializeReservedWords;
  374  | |PROCEDURE PrintDate;
  384  | |BEGIN {setup}
  423  |PROCEDURE Compute;
  425  | |PROCEDURE GetLine;
  431  | | |FUNCTION UpperCase(ch : char) : char;
  438  | | |PROCEDURE ChangeTabToSpaces;
  452  | | |BEGIN {getline}
  482  | |PROCEDURE AnalyzeLine;
  485  | | |PROCEDURE WriteLine;
  488  | | | |PROCEDURE PrintBar;
  495  | | | |PROCEDURE MeldStrings;
  507  | | | |BEGIN    {writeline}
  515  | | |FUNCTION ReservedIsFirst(Index:integer):boolean;
  537  | | | |FUNCTION PrintBegin:boolean;
  570  | | |BEGIN {analyzeline}
  589  | |PROCEDURE DisplayLineNbr;
  599  | |BEGIN {compute}
  609  |PROCEDURE CleanUp;
  610  | |BEGIN {cleanup}
  632  |BEGIN             {main}
                                  *)