Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/PFORMAT.ZIP/PFORMAT.PAS

Pascal/Delphi Source File | 1985-01-10 | 26.1 KB | 965 lines

PROGRAM pFormat (INPUT, OUTPUT);
{
  AUTHOR:  andy j s decepida
           16 Nov 1984

  DESCRIPTION: Reads in a .PAS text file and, depending on the user's
               choice/s, generates a copy with alterations in the case of
               the contained text.
}

CONST
  Array_Size  =  177;

TYPE
  Answer_Set  =  SET OF CHAR;

  Cursor_Size =  (Full, Half, Minimum, Invisible);

  Global_Strg =  STRING[255];

  Case_Types  =  (Upper,
                 Lower,
                 AsIs);

VAR
  IO_Template,
  Work_Template,
  Proc_Label,
  Mask,
  Temp,
  Temp_String,
  In_File_Name,
  Out_File_Name : Global_Strg;

  Text_File,
  Pretty_Output : TEXT;

  Token         : ARRAY [1..Array_Size] OF STRING[20];

  Res_Case,
  Non_Res_Case  : Case_Types;

  Strt,
  Endd,
  Indx,
  Token_Locn,
  Len,
  Cnt           : INTEGER;

  CD_Char,
  Prior,
  Next          : CHAR;

  Borland_Convention,
  Interruptable,
  Comment_Active,
  Ok            : BOOLEAN;

{*****************************************************************************}

  PROCEDURE Init_Array;
  {
    initialize the reserved word array

  Warning: because the primitive parsing method employed here centred
  crucially on this array it is NOT recommended that you alter the
  contents and sequence of the entries.  My apologies non MS-DOS users
  for not including the reserved words that their TurboPascal editions do
  support.  Should you, as say as CP/M Turbo programmer, wish to alter
  this table keep in mind two things:


  ■ Do_Turbo_Extension uses the index (INDX) corresponding to the table
    entry of a found reserved word to assign the Borland type setting style
    to the output substring ... ergo, keep the new array indices in synch
    with the CASE selectors in Do_Turbo_Extension.

  ■ Since pFORMAT sequentially steps through this array to find a corresponding
    pattern occurrences in the text line currently being processed, it
    becomes important to keep the shorter reserved words that are embedded in
    other, longer reserved words as substrings towards the bottom of the
    array!
}
  BEGIN {Init_Array}
    Token [  1] := 'ABSOLUTE';
    Token [  2] := 'ARCTAN';
    Token [  3] := 'ASSIGN';
    Token [  4] := 'AUXINPTR';
    Token [  5] := 'AUXOUTPTR';
    Token [  6] := 'BLOCKREAD';
    Token [  7] := 'BLOCKWRITE';
    Token [  8] := 'BOOLEAN';
    Token [  9] := 'BUFLEN';
    Token [ 10] := 'CLREOL';
    Token [ 11] := 'CLRSCR';
    Token [ 12] := 'CONCAT';
    Token [ 13] := 'CONINPTR';
    Token [ 14] := 'CONOUTPTR';
    Token [ 15] := 'CONSTPTR';
    Token [ 16] := 'CRTEXIT';
    Token [ 17] := 'CRTINIT';
    Token [ 18] := 'DELETE';
    Token [ 19] := 'DELLINE';
    Token [ 20] := 'DOWNTO';
    Token [ 21] := 'EXECUTE';
    Token [ 22] := 'EXTERNAL';
    Token [ 23] := 'FILEPOS';
    Token [ 24] := 'FILESIZE';
    Token [ 25] := 'FILLCHAR';
    Token [ 26] := 'FORWARD';
    Token [ 27] := 'FREEMEM';
    Token [ 28] := 'FUNCTION';
    Token [ 29] := 'GETMEM';
    Token [ 30] := 'GOTOXY';
    Token [ 31] := 'GRAPHBACKGROUND';
    Token [ 32] := 'GRAPHCOLORMODE';
    Token [ 33] := 'GRAPHMODE';
    Token [ 34] := 'GRAPHWINDOW';
    Token [ 35] := 'HEAPSTR';
    Token [ 36] := 'HIRESCOLOR';
    Token [ 37] := 'INLINE';
    Token [ 38] := 'INSERT';
    Token [ 39] := 'INSLINE';
    Token [ 40] := 'INTEGER';
    Token [ 41] := 'IORESULT';
    Token [ 42] := 'KEYPRESSED';
    Token [ 43] := 'LENGTH';
    Token [ 44] := 'LONGFILEPOS';
    Token [ 45] := 'LONGFILESIZE';
    Token [ 46] := 'LONGSEEK';
    Token [ 47] := 'LOWVIDEO';
    Token [ 48] := 'LSTOUTPTR';
    Token [ 49] := 'MAXAVAIL';
    Token [ 50] := 'MAXINT';
    Token [ 51] := 'MEMAVAIL';
    Token [ 52] := 'NORMVIDEO';
    Token [ 53] := 'NOSOUND';
    Token [ 54] := 'OUTPUT';
    Token [ 55] := 'PACKED';
    Token [ 56] := 'PALETTE';
    Token [ 57] := 'PROCEDURE';
    Token [ 58] := 'PROGRAM';
    Token [ 59] := 'RANDOMIZE';
    Token [ 60] := 'RANDOM';
    Token [ 61] := 'READLN';
    Token [ 62] := 'RECORD';
    Token [ 63] := 'RELEASE';
    Token [ 64] := 'RENAME';
    Token [ 65] := 'REPEAT';
    Token [ 66] := 'REWRITE';
    Token [ 67] := 'SIZEOF';
    Token [ 68] := 'STRING';
    Token [ 69] := 'TEXTBACKGROUND';
    Token [ 70] := 'TEXTCOLOR';
    Token [ 71] := 'TEXTMODE';
    Token [ 72] := 'UPCASE';
    Token [ 73] := 'USRINPTR';
    Token [ 74] := 'USROUTPTR';
    Token [ 75] := 'WHEREX';
    Token [ 76] := 'WHEREY';
    Token [ 77] := 'WINDOW';
    Token [ 78] := 'WRITELN';
    Token [ 79] := 'ARRAY';
    Token [ 80] := 'BEGIN';
    Token [ 81] := 'CHAIN';
    Token [ 82] := 'CLOSE';
    Token [ 83] := 'CONST';
    Token [ 84] := 'DELAY';
    Token [ 85] := 'ERASE';
    Token [ 86] := 'FALSE';
    Token [ 87] := 'FLUSH';
    Token [ 88] := 'HIRES';
    Token [ 89] := 'INPUT';
    Token [ 90] := 'LABEL';
    Token [ 91] := 'MSDOS';
    Token [ 92] := 'PORTW';
    Token [ 93] := 'RESET';
    Token [ 94] := 'ROUND';
    Token [ 95] := 'SOUND';
    Token [ 96] := 'TRUNC';
    Token [ 97] := 'UNTIL';
    Token [ 98] := 'WHILE';
    Token [ 99] := 'WRITE';
    Token [100] := 'ADDR';
    Token [101] := 'BYTE';
    Token [102] := 'CASE';
    Token [103] := 'CHAR';
    Token [104] := 'COPY';
    Token [105] := 'CSEG';
    Token [106] := 'DRAW';
    Token [107] := 'DSEG';
    Token [108] := 'ELSE';
    Token [109] := 'EOLN';
    Token [110] := 'FILE';
    Token [111] := 'FRAC';
    Token [112] := 'GOTO';
    Token [113] := 'HALT';
    Token [114] := 'INTR';
    Token [115] := 'MARK';
    Token [116] := 'MEMW';
    Token [117] := 'MOVE';
    Token [118] := 'PLOT';
    Token [119] := 'PORT';
    Token [120] := 'PRED';
    Token [121] := 'READ';
    Token [122] := 'REAL';
    Token [123] := 'SEEK';
    Token [124] := 'SQRT';
    Token [125] := 'SSEG';
    Token [126] := 'SUCC';
    Token [127] := 'SWAP';
    Token [128] := 'TEXT';
    Token [129] := 'THEN';
    Token [130] := 'TRUE';
    Token [131] := 'TYPE';
    Token [132] := 'WITH';
    Token [133] := 'AND';
    Token [134] := 'AUX';
    Token [135] := 'CHR';
    Token [136] := 'CON';
    Token [137] := 'COS';
    Token [138] := 'DIV';
    Token [139] := 'END';
    Token [140] := 'EOF';
    Token [141] := 'EXP';
    Token [142] := 'FOR';
    Token [143] := 'INT';
    Token [144] := 'KBD';
    Token [145] := 'LST';
    Token [146] := 'MEM';
    Token [147] := 'MOD';
    Token [148] := 'NEW';
    Token [149] := 'NIL';
    Token [150] := 'NOT';
    Token [151] := 'ODD';
    Token [152] := 'OFS';
    Token [153] := 'ORD';
    Token [154] := 'POS';
    Token [155] := 'PTR';
    Token [156] := 'SEG';
    Token [157] := 'SET';
    Token [158] := 'SHL';
    Token [159] := 'SHR';
    Token [160] := 'SIN';
    Token [161] := 'SQR';
    Token [162] := 'STR';
    Token [163] := 'TRM';
    Token [164] := 'USR';
    Token [165] := 'VAL';
    Token [166] := 'VAR';
    Token [167] := 'XOR';
    Token [168] := 'DO';
    Token [169] := 'HI';
    Token [170] := 'IF';
    Token [171] := 'IN';
    Token [172] := 'LN';
    Token [173] := 'LO';
    Token [174] := 'OF';
    Token [175] := 'OR';
    Token [176] := 'PI';
    Token [177] := 'TO';
  END;  {Init_Array}

{*****************************************************************************}

  PROCEDURE Set_Cursor (Size : Cursor_Size);
  {
    cursor is set according to the passed Size ... IBM-PC specific!
  }

  TYPE
    Reg_Pack    =  RECORD
                    AX, BX, CX, DX, BP, SI, DI, ES, Flags : INTEGER;
    END; {of Reg_Pack}

  VAR
    Rec_Pack    :  Reg_Pack;

  BEGIN
    Rec_Pack.AX := $0100;     {set cursor type service code ... cf A-47 of
                              Hardware Technical Reference Manual}
    CASE Size OF
      Full     : Rec_Pack.CX := $000D;
      Half     : Rec_Pack.CX := $070C;
      Minimum  : Rec_Pack.CX := $0B0C;
      Invisible: Rec_Pack.CX := $2000;
    END; {CASE Size OF}

    Intr ($10, Rec_Pack)      {call video I/O ROM call}
  END;

{*****************************************************************************}

  FUNCTION Is_Special_Char (Ch : CHAR) : BOOLEAN;
  {
    TRUE if Ch is a special char
  }

  BEGIN
    Is_Special_Char := (ORD(Ch) IN [32, 39..47, 58..62, 91, 93, 123, 125])
  END;

{*****************************************************************************}

  FUNCTION Lo_Case (Ch : CHAR) : CHAR;
  {
    returns lower case of an alpha char
  }

  BEGIN
    IF (Ch IN ['A'..'Z']) THEN
      Ch := CHR (ORD(Ch) - ORD('A') + ORD('a'));
    Lo_Case := Ch
  END;

{*****************************************************************************}

  PROCEDURE Up_Strg (VAR Strg : Global_Strg);

  VAR
    Slot : INTEGER;

  BEGIN
    IF (LENGTH(Strg) > 0) THEN
      FOR Slot := 1 TO LENGTH(Strg) DO
        Strg[Slot] := UpCase(Strg[Slot])
  END;

{*****************************************************************************}

  PROCEDURE Lo_Strg (VAR Strg : Global_Strg);

  VAR
    Slot : INTEGER;

  BEGIN
    IF (LENGTH(Strg) > 0) THEN
      FOR Slot := 1 TO LENGTH(Strg) DO
        Strg[Slot] := Lo_Case(Strg[Slot])
  END;

{*****************************************************************************}

  FUNCTION Get_Char (Legal_Commands : Answer_Set) : CHAR;
  {
    waits for a CHAR input belonging in Legal_Commands
  }

  CONST
    Bks = 8;

  VAR
    Ch_In : CHAR;

  BEGIN
    WRITE ('[ ]');
    WRITE (CHR(Bks), CHR(Bks), ' ',CHR(Bks));
    REPEAT
      Set_Cursor (Full);
      READ (KBD, Ch_In);
      Ch_In := UpCase (Ch_In);
      IF NOT (Ch_In IN Legal_Commands) THEN
        BEGIN
          Sound (8900);
          Delay (10);
          NoSound;
          Sound (90);
          Delay (30);
          NoSound;
        END;
    UNTIL (Ch_In IN Legal_Commands);
    Set_Cursor (Minimum);
    Get_Char := Ch_In;
  END;

{*****************************************************************************}

  FUNCTION User_Says_YES : BOOLEAN;
  {
    waits for a y/Y or n/N CHAR input
  }

  VAR
    Reply : CHAR;

  BEGIN
    WRITE (' [y/n] ■ ');
    User_Says_YES := (Get_Char(['Y','N']) = 'Y')
  END;

{*****************************************************************************}

  PROCEDURE Trim_Off (VAR TempStr : Global_Strg);

  BEGIN
    WHILE POS(' ', TempStr) = 1 DO
      DELETE (TempStr, 1, 1);
  END;

{*****************************************************************************}

  PROCEDURE User_Quits;

  BEGIN
    Set_Cursor (Minimum);
    CrtExit;
    ClrScr;
    HALT;
  END;

{*****************************************************************************}

  PROCEDURE Evaluate_User_Choice (ConfirmationTail : Global_Strg;
                                          Reserved : BOOLEAN);
  BEGIN {Evaluate_User_Choice}
    WRITELN;
    WRITE (' You chose ');
    TextColor (8); TextBackGround (7);
    CASE CD_Char OF
      'U' : BEGIN
              WRITE ('Upper-case');
              IF Reserved THEN
                Res_Case := Upper
              ELSE
                Non_Res_Case := Upper
            END;
      'L' : BEGIN
              WRITE ('Lower-case');
              IF Reserved THEN
                Res_Case := Lower
              ELSE
                Non_Res_Case := Lower
             END;
      'A' : BEGIN
              WRITE ('As-Is');
              IF Reserved THEN
                Res_Case := AsIs
              ELSE
                Non_Res_Case := AsIs
            END;
      'B' : BEGIN
              WRITE ('Borland type setting');
              Borland_Convention := TRUE;
            END;
      'Q' : User_Quits;
    END;
    LowVideo;
    WRITELN (' ',ConfirmationTail);
    WRITE   (' Is this correct? ');
  END; {Evaluate_User_Choice}

{*****************************************************************************}

   PROCEDURE Change_Defaults;

    BEGIN {Change_Defaults}
      WRITELN;
      REPEAT
        WRITELN;
        WRITELN;
        WRITELN (' ■ PASCAL reserved words.');
        WRITE   ('   Options are : U(pper-case, L(ower-case, A(s-Is, Q(uit');
        CD_Char := Get_Char (['U','L','A','Q']);
        Evaluate_User_Choice ('for the RESERVED words.', TRUE);
      UNTIL User_Says_YES;

      WRITELN;
      REPEAT
        WRITELN;
        WRITELN;
        WRITELN (' ■ Turbo Pascal Extensions.');
        WRITE   ('   Options are : U(pper, L(ower, As-Is, B(o',
                 'rland type setting, Q(uit');
        CD_Char := Get_Char (['U','L','A','B','Q']);
        Evaluate_User_Choice ('for the Turbo Pascal Extensions.', TRUE);
      UNTIL User_Says_Yes;

      WRITELN;
      REPEAT
        WRITELN;
        WRITELN;
        WRITELN (' ■ Non-Reserved Words.');
        WRITE   ('   Options are : U(pper-case, L(ower-case, A(s-is, Q(uit');
        CD_Char := Get_Char (['U','L','A','Q']);
        Evaluate_User_Choice (' for the user defined identifiers.',
                           FALSE);
      UNTIL User_Says_YES;
    END; {Change_Defaults}

{*****************************************************************************}

  FUNCTION Is_A_Token : BOOLEAN;
  {
    returns TRUE if the pattern found is properly delimited
  }
  BEGIN {Is_A_Token}
    IF (Token_Locn + LENGTH(Token[Indx])) < Len THEN
      Next := COPY (Work_Template,
                  (Token_Locn + (LENGTH(Token[Indx]))), 1)
    ELSE
      Next := '.';

    IF Token_Locn > 1 THEN
      BEGIN
        Prior := COPY (Work_Template, Token_Locn - 1, 1);
        Is_A_Token := ((Is_Special_Char(Prior)) AND (Is_Special_Char(Next)));
      END
    ELSE
      IF Token_Locn = 1 THEN
        Is_A_Token := (Is_Special_Char (Next));
  END; {Is_A_Token}

{*****************************************************************************}

  PROCEDURE Mask_Out (KeyWord : Global_Strg);
  {
    mask out a pattern match ... to enable multi-occurrences
  }
  VAR
    Slot : INTEGER;

  BEGIN {Mask_Out}
    DELETE (Work_Template, Token_Locn, LENGTH(Token[Indx]));
    Mask := KeyWord;
    FOR Slot := 1 TO LENGTH(KeyWord) DO
      Mask[Slot] := '\';
    INSERT (Mask, Work_Template, Token_Locn)
  END;  {Mask_Out}

{*****************************************************************************}

 PROCEDURE Do_Turbo_Extension (VAR Extension : Global_Strg);

 BEGIN {Do_Turbo_Extension}
   CASE Indx OF
      1 : Extension := 'Absolute';
      3 : Extension := 'Assign';
      4 : Extension := 'AuxInPtr';
      5 : Extension := 'AuxOutPtr';
      9 : Extension := 'BufLen';
     10 : Extension := 'ClrEol';
     11 : Extension := 'ClrScr';
     13 : Extension := 'ConInPtr';
     14 : Extension := 'ConOutPtr';
     15 : Extension := 'ConstPtr';
     16 : Extension := 'CrtExit';
     17 : Extension := 'CrtInit';
     19 : Extension := 'DelLine';
     21 : Extension := 'Execute';
     23 : Extension := 'FilePos';
     24 : Extension := 'FileSize';
     25 : Extension := 'FillChar';
     27 : Extension := 'FreeMem';
     29 : Extension := 'GetMem';
     30 : Extension := 'GotoXY';
     31 : Extension := 'GraphBackGround';
     32 : Extension := 'GraphColorMode';
     33 : Extension := 'GraphMode';
     34 : Extension := 'GraphWindow';
     35 : Extension := 'HeapStr';
     36 : Extension := 'HiResColor';
     37 : Extension := 'InLine';
     39 : Extension := 'InsLine';
     41 : Extension := 'IOResult';
     42 : Extension := 'KeyPressed';
     44 : Extension := 'LongFilePos';
     45 : Extension := 'LongFileSize';
     46 : Extension := 'LongSeek';
     47 : Extension := 'LowVideo';
     48 : Extension := 'LstOutPtr';
     49 : Extension := 'MaxAvail';
     52 : Extension := 'NormVideo';
     53 : Extension := 'NoSound';
     56 : Extension := 'Palette';
     59 : Extension := 'Randomize';
     60 : Extension := 'Random';
     64 : Extension := 'Rename';
     69 : Extension := 'TextBackGround';
     70 : Extension := 'TextColor';
     71 : Extension := 'TextMode';
     72 : Extension := 'UpCase';
     73 : Extension := 'UsrInPtr';
     74 : Extension := 'UsrOutPtr';
     75 : Extension := 'WhereX';
     76 : Extension := 'WhereY';
     77 : Extension := 'Window';
     81 : Extension := 'Chain';
     84 : Extension := 'Delay';
     85 : Extension := 'Erase';
     87 : Extension := 'Flush';
     88 : Extension := 'HiRes';
     91 : Extension := 'MSDos';
     92 : Extension := 'PortW';
     95 : Extension := 'Sound';
    100 : Extension := 'Addr';
    101 : Extension := 'Byte';
    105 : Extension := 'CSeg';
    106 : Extension := 'Draw';
    107 : Extension := 'DSeg';
    111 : Extension := 'Frac';
    114 : Extension := 'Intr';
    116 : Extension := 'MemW';
    117 : Extension := 'Move';
    118 : Extension := 'Plot';
    119 : Extension := 'Port';
    123 : Extension := 'Seek';
    124 : Extension := 'Sqrt';
    125 : Extension := 'SSeg';
    127 : Extension := 'Swap';
    134 : Extension := 'Aux';
    136 : Extension := 'Con';
    144 : Extension := 'Kbd';
    145 : Extension := 'Lst';
    146 : Extension := 'Mem';
    152 : Extension := 'Ofs';
    155 : Extension := 'Ptr';
    156 : Extension := 'Seg';
    158 : Extension := 'ShL';
    159 : Extension := 'ShR';
    163 : Extension := 'Trm';
    164 : Extension := 'Usr';
    167 : Extension := 'XOr';
    169 : Extension := 'Hi';
    173 : Extension := 'Lo';
    176 : Extension := 'Pi';
   END; {CASE Indx OF}
 END;  {Do_Turbo_Extension}

{*****************************************************************************}

   PROCEDURE Do_Reserved_Word;

   BEGIN
     Temp := Token [Indx];
     DELETE (IO_Template, Token_Locn, LENGTH(Token[Indx]));
     IF Res_Case = Lower THEN
       Lo_Strg (Temp);
     IF Borland_Convention THEN
       Do_Turbo_Extension (Temp);
     INSERT (Temp, IO_Template, Token_Locn);
   END;

{*****************************************************************************}

   PROCEDURE TableSearch;

   BEGIN
     Indx := 1;
     REPEAT
       Token_Locn := POS (Token[Indx], Work_Template);
       IF (Token_Locn <> 0) AND Is_A_Token THEN
         BEGIN                    {pattern match is reserved word}
           IF Res_Case <> AsIs THEN
             Do_Reserved_Word;
           Mask_Out (Token[Indx]);
           TableSearch            {recurse!!!}
         END;
       IF Token_Locn <> 0 THEN    {pattern match NOT reserved}
         Mask_Out (Token[Indx]);
       IF Token_Locn = 0 THEN     {no pattern match}
         Indx := Indx + 1;
     UNTIL ( (Indx > Array_Size) AND (Token_Locn = 0) );
   END;

{*****************************************************************************}

   PROCEDURE Find_Token_Match;

   BEGIN {Find_Token_Match}
     REPEAT      {exhaust all keyword occurrences in a line of text}
       TableSearch;
       IF Interruptable THEN
         IF KeyPressed THEN
           BEGIN
             TextColor (24); TextBackGround (1);
             WRITELN;
             WRITE ('Abort pFORMAT of ',In_File_Name,'? ');
             IF User_Says_YES THEN
               User_Quits
             ELSE
               DelLine;
             LowVideo;
           END;
     UNTIL Token_Locn = 0;
   END;  {Find_Token_Match}

{*****************************************************************************}

  PROCEDURE Fix_Comment_Strings;
  {
    mask out comments & strings so as-is chars can be restored from
    Temp_String onto IO_Template
  }

    PROCEDURE Mask_String (Len_Comment : INTEGER);

    VAR
      Slot : INTEGER;

    BEGIN
      Temp_String := COPY (Work_Template, Strt, Len_Comment);
      FOR Slot := 1 TO LENGTH(Temp_String) DO
        Temp_String[Slot] := ' ';
      DELETE (Work_Template, Strt, Len_Comment);
      INSERT (Temp_String, Work_Template, Strt);
    END;

  BEGIN {Fix_Comment_Strings}
    {do strings}
    REPEAT
      Strt := POS('''', Work_Template);
      IF Strt <> 0 THEN
        Work_Template[Strt] := ' ';
      Endd := POS ('''', Work_Template);
      IF Endd <> 0 THEN
        Work_Template[Endd] := ' ';
      IF ((Endd <> 0) AND (Strt <> 0)) THEN
        Mask_String (Endd - Strt + 1);
    UNTIL ((Endd = 0) OR (Strt = 0));

    Strt := POS('{', Work_Template);
    IF Strt = 0 THEN {check again for alternative delimiter}
      Strt := POS ('(*', Work_Template);

    Endd := POS('}', Work_Template);
    IF Endd = 0 THEN {check again for alternate delimiter}
      Endd := POS('*)', Work_Template);

    IF Strt <> 0 THEN
      Comment_Active := TRUE;

    IF Endd <> 0 THEN
      Comment_Active := FALSE;

    IF Strt = 0 THEN
      IF Endd = 0 THEN
        IF Comment_Active THEN
          BEGIN
            Strt := 1;
            Mask_String (Len - Strt + 1)
          END
        ELSE {no active comment}
          BEGIN
            {do nothing}
          END
      ELSE  {endd <> 0}
        BEGIN
          Strt := 1;
          Mask_String (Endd - Strt + 1)
        END
    ELSE    {strt <> 0}
      IF Endd <> 0 THEN
        Mask_String (Endd - Strt + 1)
      ELSE
        Mask_String (Len - Strt + 1);
  END; {Fix_Comment_Strings}

{*****************************************************************************}

  PROCEDURE Parse;

  VAR
    Slot : INTEGER;

  BEGIN
    Work_Template := IO_Template;
    Len := LENGTH (IO_Template);

    Fix_Comment_Strings;

    Up_Strg (Work_Template);

    Temp_String := IO_Template;

    IF Non_Res_Case = Upper THEN
      Up_Strg (IO_Template)
    ELSE
      IF Non_Res_Case = Lower THEN
        Lo_Strg (IO_Template);

    FOR Slot := 1 TO LENGTH(IO_Template) DO
      IF Work_Template[Slot] = ' ' THEN
        IO_Template[Slot] := Temp_String[Slot];

    Find_Token_Match;
  END;

{*****************************************************************************}

  PROCEDURE Verify_Default_Settings;

  BEGIN
    GotoXY (1,3);
    WRITELN;
    TextColor (1); TextBackGround (1);
    WRITELN ('Output File ',Out_File_Name,'''','s default attributes are :');
    LowVideo;
    WRITELN (' ■ TurboPASCAL key/reserved words are in UPPER-case letters and');
    WRITELN (' ■ Other alphabetic characters are written as is.');
    WRITELN;
    WRITE   ('Would you like to change these defaults ? ');
    IF User_Says_YES THEN
      Change_Defaults
    ELSE
      BEGIN
        Res_Case := Upper;
        Non_Res_Case := Lower;
      END;
  END;

{*****************************************************************************}

  PROCEDURE Banner;

  BEGIN
    ClrScr;
    TextColor (8); TextBackGround (7);
    WRITELN (
  '                  Turbo Format [1.01] - @ndyjsdecepid@ 1984 Nov 16              '
            );
  END;

{*****************************************************************************}

  PROCEDURE Get_Input_Name;

  BEGIN {Get_Input_Name}
    REPEAT
      WRITELN;
      WRITE  ('Name of TurboPASCAL source text file  » ');
      READLN (In_File_Name);
      Trim_Off (In_File_Name);
      Up_Strg (In_File_Name);

      IF LENGTH(In_File_Name) < 1 THEN
        User_Quits;

      ASSIGN (Text_File, In_File_Name);
      {$I-} RESET (Text_File) {$I+};
      Ok := (IOResult = 0);
      IF NOT Ok THEN
        BEGIN
          Sound (6099);
          Delay (500);
          Sound (600);
          NoSound;
          WRITE ('Cannot find file ');
          NormVideo;
          WRITE (In_File_Name);
          LowVideo;
        END
    UNTIL Ok;
  END; {Get_Input_Name}

{*****************************************************************************}

  PROCEDURE Get_Output_Name;

  BEGIN {Get_Output_Name};
    REPEAT
      WRITELN;
      WRITE  ('Name of pFORMAT generated file        » ');
      READLN (Out_File_Name);
      Trim_Off (Out_File_Name);
      Up_Strg (Out_File_Name);

      IF LENGTH (Out_File_Name) < 1 THEN
        User_Quits;

      ASSIGN  (Pretty_Output, Out_File_Name);
      {$I-} REWRITE (Pretty_Output) {$I+};

      Ok := (IOResult = 0);

      IF NOT Ok THEN
        BEGIN
          WRITELN;
          Sound (6099);
          Delay (500);
          Sound (600);
          NoSound;
          WRITE ('Unable to open file ');
          NormVideo;
          WRITE (Out_File_Name);
          LowVideo;
        END;
    UNTIL Ok;
  END; {Get_Input_Name}

{*****************************************************************************}

BEGIN {--------------------------------------------------------------- pFormat}
  Init_Array;

  REPEAT
    Window (1, 1, 80, 25);
    GotoXY (1,1);
    ClrScr;
    Borland_Convention := FALSE;
    Comment_Active     := FALSE;

    Banner;

    Window (1, 2, 80, 24);
    ClrScr;
    LowVideo;
    WRITELN;
    WRITE   ('■ To quit, press a lone ',CHR(17),'┘ in response to the prompts');
    WRITELN (' for file names.');
    WRITELN;

    Get_Input_Name;
    Get_Output_Name;

    Window (1, 1, 80, 24);
    GotoXY (1,1);
    Banner;

    Window (1, 2, 80, 24);
    Verify_Default_Settings;
    NormVideo;
    WRITELN;
    WRITELN;
    WRITE ('Would you like to be able to abort this run with a keypress?');
    Interruptable := User_Says_YES;
    LowVideo;
    Window (1, 1, 80, 24);
    GotoXY (1,1);
    Banner;

    GotoXY (1,3);
    TextColor (16); TextBackGround (1);
    Proc_Label := CONCAT ('Reading ',In_File_Name,' & generating ',
                                   Out_File_Name);

    IF (LENGTH (Proc_Label) <= 80) THEN {centre if it fits 80-char line}
      WRITE (Proc_Label:((80 + LENGTH(Proc_Label)) DIV 2))
    ELSE
      WRITE (Proc_Label);
    GotoXY (1,5);
    NormVideo;
    FOR Cnt  := 1 TO 80 DO
      WRITE ('═');

    LowVideo;
    Window (1, 6, 80, 23);
    ClrScr;
    Set_Cursor (Invisible);

    WHILE NOT (EOF(Text_File)) DO
      BEGIN
        READLN  (Text_File, IO_Template);
        Parse;
        WRITELN (IO_Template);
        WRITELN (Pretty_Output, IO_Template);
      END;
    Set_Cursor (Minimum);
    CLOSE (Text_File);
    CLOSE (Pretty_Output);
    ClrScr;
    WRITELN;
    WRITE ('Quit pFORMAT');
  UNTIL User_Says_YES;
END.  {---------------------------------------------------------------pFormat}