Programmer 7500/MAX_PROGRAMMERS.iso/INFO/TURBOPAS/TPF.ZIP/TPF.PAS

Pascal/Delphi Source File | 1985-05-27 | 38.5 KB | 1,159 lines

{[B+,O=78]}
{$R-}

{program TPF(Input, Output, Source, Result);
!
! TPF: A Turbo Pascal Text Formatter.
!
! TPF is a program which formats a Pascal program (or fragment)
! according to standardized formatting rules.  It also converts the case
! of the identifiers and reserved words to your specification.
!
! A series of directives allow control over various aspects of the
! formatting.  Many of these are the result of strong differences of
! opinion amoung potential users of the formatter.
!
! Anyone studying this program should have a copy of the TPF users
! manual.
!
! The formatter does an (almost) complete syntactic check of the program
! as it formats, and if it gets confused as to where it is, aborts and
! does not create an output element.  This avoids a problem which the
! previous formatter had of losing track of its parsing and producing
! complete garbage as an output element.  This would sometimes get
! substituted for the original element, and made recovery very
! difficult.  The extra checking costs a bit of time and code space,
! but seems worth it overall.  It also allows a very flexible formatting
! policy.
!
! There is a delayed output buffer to allow conditional modification of
! formatting decisions. This allows the user to make tentative
! decisions and modify them later.  For instance, the user can note
! potential break points in a line and go back and use them when
! the line fills.  This facility is also used to allow short statements
! to follow case labels directly.  The statement is put on the next
! line, then if it would have fit can be moved back up to the line with
! the label.
!
! Comments are always difficult to handle in a Pascal formatter, and
! TPF attempts to handle them in a way which provides the user with
! some control of their formatting.  The comment handling is completly
! separate from the normal formatting, and can be changed without
! affecting other areas.
!
! Revision History:
!
! SW, 9/30/84
!     The WHILE and WITH statements now do not force a blank line before and
!     and after.
!
!     The block header does not emit extra blank lines. Note the programmer
!     must insert a blank line before the BEGIN if so desired.
!
!     The lexical scanner was changed to handle Turbo's hex constants.
!
!     Turbo's FILE type was implemented.
!
! SW, 5/11/85
!     Handles the OVERLAY keyword.
!     Handles the INLINE statement.
!     Allow for nested comments.
!     Handle Turbo's style of external routines.
!
! SW, 5/20/85
!     Changed the logic for formatting statement comments. Comments in CONST,
!     TYPE, and VAR declarations are aligned to the "remark" column, whose
!     initial value is 40. All other statement comments are formatted as
!     before.
}

const
    Max_Line_Len = 127;                 {max output line length}
    Buf_Size = 129;                     {output buffer size, > max_line_len}
    Buf_Size_P1 = 130;                  {buffer size +- 1}
    Buf_Size_M1 = 128;
    Max_Word_Len = 9;                   {reserved words char size}
    No_Res_Words = 44;                  {number of reserved words}
    Default_Out_Line = 78;              {default output line length}
    Default_Tab_Spaces = 4;             {logical indentation increments}
    Default_Comment_Spaces = 1;         {spacing before and after comments}
    Max_Break_Level = 4;                {max number of break levels}
    Ff = 12;                            {ascii form feed character}
    Ht = 9;                             {ascii tab character}

    {identifier spelling constants}

    Hash_Max = 64;                      {size of hash table}
    Hash_Lim = 63;                      {top entry in hash table}
    String_Block_Size = 512;            {size of a block of the string table}
    String_Block_Max = 511;             {max entry in a string block}
    String_Index_Max = 63;              {max entry in the string index}
    Tab_Interval = 8;                   {standard tab interval}

type
    Symbols = (Absolute_Sym, And_Sym, Array_Sym, Begin_Sym, Case_Sym,
               Const_sym, Div_Sym, Do_Sym, Downto_sym, Else_Sym, End_Sym,
               Extern_Sym, File_Sym, For_Sym, Forward_Sym, Function_Sym,
               Goto_Sym, If_Sym, In_Sym, Inline_Sym, Label_Sym, Mod_Sym,
               Nil_Sym, Not_Sym, Of_Sym, Or_Sym, Overlay_Sym, Packed_Sym,
               Procedure_Sym, Program_Sym, Record_Sym, Repeat_Sym, Set_Sym,
               Shl_Sym, Shr_Sym, String_Sym, Then_Sym, To_Sym, Type_Sym,
               Until_Sym, Var_Sym, While_Sym, With_Sym, Xor_Sym, Plus, Minus,
               Mult, Divide, Becomes, Period, Comma, Semicolon, Colon, Equal,
               Rel_Op, Pointer, Subrange, Apostrophy, Open_Paren, Close_Paren,
               Open_Brack, Close_Brack, Identifier, Number, Str_Const,
               Comment, Text_End);
    {basic symbol enumeration}

    Set_Of_Syms = set of Symbols;       {set ops on basic symbols}
    StringType = packed array [1..12] of Char; {identifier type for sirtag}
    Word_Type = packed array [1..Max_Word_Len] of Char; {reserved}
    Len_Table_Type =                    {index into reserved word table by
                                        length}
        record
            Low_Index, Hi_Index: 1..No_Res_Words;
        end;

    Line_Index = 0..Max_Line_Len;
    Actions = (Graphic, Spaces, Begin_Line);
    Buffer_Index = 0..Buf_Size_M1;      {output buffer index}
    Char_Buffer = array [Buffer_Index] of
            record
                case Action_Is: Actions of
                    Spaces, Begin_Line: (Spacing: Line_Index);
                    Graphic: (Character: Char)
            end;

    Col_Log =
        record
            Log_Char: Integer;          {char_count at time of log}
            Log_Col: Line_Index;        {write_col at time of log}
            Log_Line: Integer;          {current_line at time of log}
        end;

    Break_Lev = 0..Max_Break_Level;     {expression break priorities}
    Abort_Kind = (Syntax, Nesting, Com_Format); {error types}
    Hash_Value = 0..Hash_Max;           {possible hash values}

    {string table description}

    String_Block_Index = 0..String_Index_Max; {index table index}
    String_Piece_Index = 0..String_Block_Max; {index to chars in a piece}
    String_Block = packed array [String_Piece_Index] of Char;

    {identifier spelling bookkeeping}

    Id_Ptr = ^Id_Descr;

    Id_Descr =
        packed record
            Next: Id_Ptr;               {next id with this hash entry}
            Start: Integer;             {start of identifier spelling in
                                        string table}
            Len: Line_Index;            {length of identifier}
        end;

var
    {Structured Constants}

    Space_Before, Space_After: Set_Of_Syms; {individual symbol spacing}
    Alphanumerics: Set_Of_Syms;         {alpha symbols}
    Resv_Wrd: array [1..No_Res_Words] of Word_Type; {reserved word table}
    Res_Symbol: array [1..No_Res_Words] of Symbols; {symbols for resv_wrd}
    Res_Len: array [2..Max_Word_Len] of Len_Table_Type; {length index}
    UpperCase: array [Char] of Char;
    LowerCase: array [Char] of Char;    {case conversion tables}
    Prog_Set, Block_Beg_Sys, Stat_Set: Set_Of_Syms; {syntactic symbol types}
    Constants: Set_Of_Syms;             {symbols which can be constants}
    Heading_Beg_Sys: Set_Of_Syms;       {symbols which begin a block heading}
    Type_Beg_Sys: Set_Of_Syms;          {type beginning symbols}
    Expr_Beg_Sys: Set_Of_Syms;          {expression beginning symbols}
    Rel_Ops: Set_Of_Syms;               {relational operators}
    Arith_Ops: Set_Of_Syms;             {arithmetic operators}

    {Formatting variables}

    Indent: Integer;                    {current number of indentation spaces}
    Stat_Indent: Integer;               {indentation for major statement}
    Write_Col: Integer;                 {current output column}
    Remark_Col: Integer;
    Symbol_Break: array [Break_Lev] of
            record
                Buf_Char: Integer;      {character in buffer}
                Break_Col: Line_Index;  {output column}
            end;
    Last_Sym: Symbols;                  {last symbol processed}
    Sym_Written: Boolean;               {last symbol was written}
    Indent_State: array [Line_Index] of Line_Index;
    Indent_Level: Line_Index;           {these make a stack of indent levels}
    End_Line: Boolean;                  {last symbol ends the line}

    {miscellaneous}

    Result: Text;                       {output file}
    Source: Text;                       {input file}
    Output_Line: Integer;               {line numbers for output}
    Current_Line: Integer;              {line number being written}
    Input_Line: Integer;                {input line number}

    {Formatting Control Values}

    Out_Line_Len: Integer;              {current output line length}
    One_Half_Line: Integer;             {significant point upon line}
    Five_Eighth_Line: Integer;          {"}
    Three_Fourth_Line: Integer;         {"}

    Tab_Spaces: Integer;                {spaces to indent for each level}
    Continue_Spaces: Integer;           {spaces to indent continuation line}
    Comment_Spaces: Integer;            {spaces before statement comment}
    Stats_Per_Line: Integer;            {statements per line}

    {flags to direct formatting}

    Uc_Res_Words: Boolean;              {convert reserved words to UC}
    Lc_Res_Words: Boolean;              {convert reserved words to LC}
    Uc_Idents: Boolean;                 {convert identifiers to UC}
    Lc_Idents: Boolean;                 {convert identifiers to LC}
    Portability_Mode: Boolean;          {eliminate underscores}
    Formatting: Boolean;                {do formatting (otherwise, copy)}
    New_Formatting: Boolean;            {start formatting at end of comment}
    Bunching: Boolean;                  {bunch statements on one line}
    Convert_To_Tabs: Boolean;           {convert leading spaces to tabs}
    First_Spelling: Boolean;            {convert equivalent ids to first
                                        spelling}

    {lexical scanner variables}

    Symbol_Found: Boolean;              {success from lexical analysis}
    New_Input_Line: Boolean;            {true when no chars as yet on new
                                        line}
    Blank_Lines: Integer;               {Count of blank lines read but not
                                        printed}
    End_File: Boolean;                  {eof read}
    Ch: Char;                           {current character for lexical
                                        analysis}
    Double_Period: Boolean;             {set if double period found}
    Column: Integer;                    {input column for last char input}
    Tab_Column: Integer;                {column at end of tab, for conversion
                                        to spaces}
    Sym: Symbols;                       {current basic symbol from lex}
    Symbol: array [Line_Index] of Char; {workspace for lex analysis}
    Sym_Len: 0..Max_Line_Len;           {index into WINDOW array}
    In_Type_Or_Var_Dcl: Boolean;        {true if parsing the TYPE or VAR
                                        declaration}
    In_Declaration: Boolean;            {true if parsing a CONST, TYPE, or VAR
                                        declaration }

    {output character buffering}

    Unwritten: Char_Buffer;             {unwritten characters}
    Char_Count: Integer;                {characters written so far}
    Oldest: Buffer_Index;               {oldest char in buffer}
    Initial_Blanks: Integer;            {initial blanks on a line}
    Saving_Blanks: Boolean;             {true if saving blanks to convert to
                                        tabs}

    {error handling variables}

    Overflows: 0..Maxint;               {number of line overflows}
    First_Overflow: 0..Maxint;          {line where first overflow occured}
    Com_Overflows: 0..Maxint;           {number of comment overflows}
    First_Com_Overflow: 0..Maxint;      {line of first comment overflow}

    {identifier spelling variables}

    Hash_Table: array [Hash_Value] of Id_Ptr; {main hash table}
    String_Index: array [String_Block_Index] of ^String_Block;

    {string table base array}

    String_Top: Integer;                {last character in string table}

{*---------------------------------*
 | Read and Process Command String |
 *---------------------------------*}

const
    Default_Ext = 'PAS';                {default filename extension}
    CSI_Prompt = 'TPF>';                {prompt to use if necessary}

var
    {Operating system interface variables}

    Cmd_String: string [80] absolute CSeg: $0080;
    Cmd_Line: string [80];
    Source_Filename: string [8];
    Source_Extension: string [3];


procedure CSI;
{
! Read and process command line.
}

    var
        I: Integer;

    begin

    if Length(Cmd_String) > 0 then
        Cmd_Line := Copy(Cmd_String, 2, Length(Cmd_String) - 1)
    else
        repeat
            Write(CSI_Prompt);
            ReadLn(Cmd_Line);
        until Length(Cmd_Line) > 0;

    I := Pos('.', Cmd_Line);

    if I = 0 then
        begin
        Source_Filename := Cmd_Line;
        Source_Extension := Default_Ext;
        end
    else
        begin
        Source_Filename := Copy(Cmd_Line, 1, I - 1);
        Source_Extension := Copy(Cmd_Line, I + 1, 3);
        end;

    Assign(Source, Source_Filename + '.' + Source_Extension);
    {$I-}
    Reset(Source);
    {$I+}

    if IoResult <> 0 then
        begin
        WriteLn(Output);
        WriteLn('Cannot open input file');
        Halt;
        end;

    Assign(Result, 'TEMP.TMP');
    Rewrite(Result);
    end; {csi}

{*--------------------------*
 | Initialize Set Constants |
 *--------------------------*}


procedure Init_Sets; {initialize set constants}
    begin
    Space_Before := [Absolute_Sym, And_Sym, Div_Sym, Do_Sym, Downto_sym,
                    In_Sym, Mod_Sym, Of_Sym, Or_Sym, Shl_Sym, Shr_Sym,
                    Then_Sym, To_Sym, Xor_Sym, Plus, Minus, Mult, Divide,
                    Becomes, Equal, Rel_Op];

    Space_After := [Absolute_Sym, And_Sym, Array_Sym, Case_Sym, Div_Sym,
                   Downto_Sym, Extern_Sym, For_Sym, Function_Sym, Goto_Sym,
                   If_Sym, In_Sym, Inline_Sym, Mod_Sym, Not_Sym, Of_Sym,
                   Or_Sym, Overlay_Sym, Packed_Sym, Procedure_Sym,
                   Program_Sym, Shl_Sym, Shr_Sym, String_Sym, To_Sym,
                   Until_Sym, While_Sym, With_Sym, Xor_Sym, Plus, Minus, Mult,
                   Divide, Becomes, Comma, Semicolon, Colon, Equal, Rel_Op,
                   Comment];

    Alphanumerics := [Absolute_Sym..Xor_Sym, Identifier, Number];

    Heading_Beg_Sys := [Label_Sym, Const_sym, Type_Sym, Var_Sym, Overlay_Sym,
                       Procedure_Sym, Function_Sym];

    Block_Beg_Sys := Heading_Beg_Sys + [Begin_Sym];

    Stat_Set := [Begin_Sym, If_Sym, Case_Sym, While_Sym, Repeat_Sym, For_Sym,
                With_Sym, Inline_Sym, Goto_Sym, Number, Identifier];

    Constants := [Number, Identifier, Str_Const, Plus, Minus, Nil_Sym];

    Expr_Beg_Sys := Constants + [Pointer, Not_Sym, Nil_Sym, Open_Brack,
                    Open_Paren];

    Arith_Ops := [Plus, Minus, Mult, Divide, Div_Sym, Mod_Sym];
    Rel_Ops := [Equal, Rel_Op, In_Sym];

    Type_Beg_Sys := Constants + [Pointer, Set_Sym, Record_Sym, File_Sym,
                    Array_Sym, Open_Paren, String_Sym] - [Nil_Sym];
    end {init_sets} ;


procedure Init_Resv_Wrd;
{
! Initialize reserved word array and length indices into reserved word
! array for length keyed search
}
    begin {[s=2]}
    Res_Len[2].Low_Index := 1;           Res_Len[2].Hi_Index := 6;
    Res_Len[3].Low_Index := 7;           Res_Len[3].Hi_Index := 18;
    Res_Len[4].Low_Index := 19;          Res_Len[4].Hi_Index := 25;
    Res_Len[5].Low_Index := 26;          Res_Len[5].Hi_Index := 31;
    Res_Len[6].Low_Index := 32;          Res_Len[6].Hi_Index := 37;
    Res_Len[7].Low_Index := 38;          Res_Len[7].Hi_Index := 40;
    Res_Len[8].Low_Index := 41;          Res_Len[8].Hi_Index := 43;
    Res_Len[9].Low_Index := 44;          Res_Len[9].Hi_Index := 44;
    Resv_Wrd[1] := 'do       ';          Res_Symbol[1] := Do_Sym;
    Resv_Wrd[2] := 'if       ';          Res_Symbol[2] := If_Sym;
    Resv_Wrd[3] := 'in       ';          Res_Symbol[3] := In_Sym;
    Resv_Wrd[4] := 'of       ';          Res_Symbol[4] := Of_Sym;
    Resv_Wrd[5] := 'or       ';          Res_Symbol[5] := Or_Sym;
    Resv_Wrd[6] := 'to       ';          Res_Symbol[6] := To_Sym;
    Resv_Wrd[7] := 'and      ';          Res_Symbol[7] := And_Sym;
    Resv_Wrd[8] := 'div      ';          Res_Symbol[8] := Div_Sym;
    Resv_Wrd[9] := 'end      ';          Res_Symbol[9] := End_Sym;
    Resv_Wrd[10] := 'for      ';         Res_Symbol[10] := For_Sym;
    Resv_Wrd[11] := 'mod      ';         Res_Symbol[11] := Mod_Sym;
    Resv_Wrd[12] := 'nil      ';         Res_Symbol[12] := Nil_Sym;
    Resv_Wrd[13] := 'not      ';         Res_Symbol[13] := Not_Sym;
    Resv_Wrd[14] := 'set      ';         Res_Symbol[14] := Set_Sym;
    Resv_Wrd[15] := 'shl      ';         Res_Symbol[15] := Shl_Sym;
    Resv_Wrd[16] := 'shr      ';         Res_Symbol[16] := Shr_Sym;
    Resv_Wrd[17] := 'var      ';         Res_Symbol[17] := Var_Sym;
    Resv_Wrd[18] := 'xor      ';         Res_Symbol[18] := Xor_Sym;
    Resv_Wrd[19] := 'case     ';         Res_Symbol[19] := Case_Sym;
    Resv_Wrd[20] := 'else     ';         Res_Symbol[20] := Else_Sym;
    Resv_Wrd[21] := 'file     ';         Res_Symbol[21] := File_Sym;
    Resv_Wrd[22] := 'goto     ';         Res_Symbol[22] := Goto_Sym;
    Resv_Wrd[23] := 'then     ';         Res_Symbol[23] := Then_Sym;
    Resv_Wrd[24] := 'type     ';         Res_Symbol[24] := Type_Sym;
    Resv_Wrd[25] := 'with     ';         Res_Symbol[25] := With_Sym;
    Resv_Wrd[26] := 'array    ';         Res_Symbol[26] := Array_Sym;
    Resv_Wrd[27] := 'begin    ';         Res_Symbol[27] := Begin_Sym;
    Resv_Wrd[28] := 'const    ';         Res_Symbol[28] := Const_sym;
    Resv_Wrd[29] := 'label    ';         Res_Symbol[29] := Label_Sym;
    Resv_Wrd[30] := 'until    ';         Res_Symbol[30] := Until_Sym;
    Resv_Wrd[31] := 'while    ';         Res_Symbol[31] := While_Sym;
    Resv_Wrd[32] := 'downto   ';         Res_Symbol[32] := Downto_sym;
    Resv_Wrd[33] := 'inline   ';         Res_Symbol[33] := Inline_Sym;
    Resv_Wrd[34] := 'packed   ';         Res_Symbol[34] := Packed_Sym;
    Resv_Wrd[35] := 'record   ';         Res_Symbol[35] := Record_Sym;
    Resv_Wrd[36] := 'repeat   ';         Res_Symbol[36] := Repeat_Sym;
    Resv_Wrd[37] := 'string   ';         Res_Symbol[37] := String_Sym;
    Resv_Wrd[38] := 'forward  ';         Res_Symbol[38] := Forward_Sym;
    Resv_Wrd[39] := 'overlay  ';         Res_Symbol[39] := Overlay_Sym;
    Resv_Wrd[40] := 'program  ';         Res_Symbol[40] := Program_Sym;
    Resv_Wrd[41] := 'absolute ';         Res_Symbol[41] := Absolute_Sym;
    Resv_Wrd[42] := 'external ';         Res_Symbol[42] := Extern_Sym;
    Resv_Wrd[43] := 'function ';         Res_Symbol[43] := Function_Sym;
    Resv_Wrd[44] := 'procedure';         Res_Symbol[44] := Procedure_Sym;
    end {[s=1] init_resv_wrd} ;


procedure Initialize;

    var
        P: Integer;
        C: Char;                        {induction var}
        H: Hash_Value;                  {induction var}
        S: String_Block_Index;          {induction var}

    begin {initialize all global variables}
    Init_Sets;

    for C := Chr(0) to Chr(127) do
        begin
        LowerCase[C] := C;
        UpperCase[C] := C;
        end;

    for C := 'A' to 'Z' do
        begin
        LowerCase[C] := Chr(Ord(C) + Ord('a') - Ord('A'));
        UpperCase[Chr(Ord(C) + Ord('a') - Ord('A'))] := C;
        end;

    Char_Count := 0;
    Out_Line_Len := Default_Out_Line;
    Tab_Spaces := Default_Tab_Spaces;
    Continue_Spaces := (Tab_Spaces + 1) div 2;
    Comment_Spaces := Default_Comment_Spaces;
    Indent_Level := 0;
    One_Half_Line := Out_Line_Len div 2;
    Five_Eighth_Line := 5 * Out_Line_Len div 8;
    Three_Fourth_Line := 3 * Out_Line_Len div 4;
    Stats_Per_Line := 1;
    for P := 1 to Out_Line_Len do Symbol[P] := ' ';
    Sym_Len := 0;
    Indent := 0;
    Stat_Indent := 0;
    Write_Col := 0;
    Remark_Col := 40;
    Saving_Blanks := false;
    Column := 0;
    Tab_Column := 0;
    Output_Line := 1;
    Current_Line := 0;
    Input_Line := 1;
    New_Input_Line := true;
    Blank_Lines := 0;
    Sym := Period;
    End_Line := false;
    End_File := false;
    Last_Sym := Period;
    Sym_Written := false;
    Ch := ' ';
    In_Type_Or_Var_Dcl := false;
    In_Declaration := false;
    Double_Period := false;
    Formatting := true;
    New_Formatting := true;
    Uc_Res_Words := false;
    Lc_Res_Words := false;
    Uc_Idents := false;
    Lc_Idents := false;
    Portability_Mode := false;
    Bunching := false;
    Convert_To_Tabs := false;
    First_Spelling := false;
    Overflows := 0;
    Com_Overflows := 0;
    Init_Resv_Wrd;
    for H := 0 to Hash_Max do Hash_Table[H] := nil;
    for S := 0 to String_Index_Max do String_Index[S] := nil;
    String_Top := 0;
    end {initialize} ;

{*-----------------------------*
 | Terminate and Print Message |
 *-----------------------------*}


procedure Backup_Source;

    var
        F: Text;

    begin
    Assign(F, Source_Filename + '.TPF');
    {$I-}
    Reset(F);
    {$I+}

    if IoResult = 0 then {Backup file already exist}
        begin
        Close(F);
        Erase(F);
        end;

    Rename(Source, Source_Filename + '.TPF');
    end; {Backup_Source}


procedure Final_Data; {print summary data}
    begin
    Close(Source);
    Close(Result);
    Backup_Source;
    Rename(Result, Source_Filename + '.' + Source_Extension);

    if Overflows > 0 then
        begin
        write(Output, 'Token too wide for output at ', Overflows: 1,
              ' place');
        if Overflows > 1 then write(Output, 's, first error');
        writeln(Output, ' on line ', First_Overflow: 1, '.');
        end;

    if Com_Overflows > 0 then
        begin
        write(Output, 'Comment too wide for output at ', Com_Overflows: 1,
              ' place');
        if Com_Overflows > 1 then write(Output, 's, first');
        writeln(Output, ' on line ', First_Com_Overflow: 1, '.');
        end;
    write(Output, ' Formatting complete, ', Output_Line - 1: 1, ' line');
    if Output_Line > 2 then write('s');
    writeln(Output, ' output.');
    end; {final_data}

{*------------------*
 | Character output |
 *------------------*}


procedure Clear_Breaks; {clear out all symbol breaks}

    var
        i: Break_Lev;                   {induction var}

    begin
    for i := 0 to Max_Break_Level do Symbol_Break[i].Buf_Char := 0;
    end; {clear_breaks}


procedure Reset_Char_Count;
{
! Reset the output character count to avoid overflow, taking care to
! preserve the actual buffer loc
}
    begin
    if Char_Count > Buf_Size_P1 then
        Char_Count := Char_Count mod Buf_Size + 2 * Buf_Size;
    Clear_Breaks;
    end; {reset_char_count}


procedure Write_A(Ch: Char);
{
! Write a character to the output buffer. If necessary (which it
! always is after the buffer is filled), write the previous contents
! of the buffer)
}

    var
        i: Line_Index;

    begin
    Char_Count := Char_Count + 1;
    Oldest := Char_Count mod Buf_Size;

    with Unwritten[Oldest] do
        begin
        if Char_Count >= Buf_Size_P1 then
            if Action_Is = Graphic then
                begin
                if Saving_Blanks then
                    if Character = ' ' then
                        Initial_Blanks := Initial_Blanks + 1
                    else
                        begin

                        while Convert_To_Tabs and
                              (Initial_Blanks >= Tab_Interval) do
                            begin
                            write(Result, Chr(Ht));
                            Initial_Blanks := Initial_Blanks - Tab_Interval;
                            end;

                        while Initial_Blanks > 0 do
                            begin
                            write(Result, ' ');
                            Initial_Blanks := Initial_Blanks - 1;
                            end;

                        Saving_Blanks := false;
                        write(Result, Character)
                        end
                else write(Result, Character);
                end
            else if Action_Is = Spaces then
                begin
                if Saving_Blanks then
                    Initial_Blanks := Initial_Blanks + Spacing
                else
                    for i := 1 to Spacing do write(Result, ' ');
                end
            else {action_is = begin_line}
                begin
                if Char_Count > Buf_Size_P1 then writeln(Result);
                Saving_Blanks := true;
                Initial_Blanks := Spacing;
                Output_Line := Output_Line + 1;
                end;
        Action_Is := Graphic;
        Character := Ch;
        if Ch = Chr(Ht) then
            Write_Col := ((Write_Col + Tab_Interval) div Tab_Interval) *
                         Tab_Interval
        else Write_Col := Write_Col + 1;
        end; {with}
    end; {write_a}


procedure New_Line(Indent: Line_Index);

  {start a new line and indent it as specified}

    begin
    {fake a character, then change it}
    End_Line := false;
    Write_A(' ');

    with Unwritten[Oldest] do
        begin
        Action_Is := Begin_Line;
        Spacing := Indent;
        end;

    Write_Col := Indent;
    Current_Line := Current_Line + 1;
    end; {new_line}


procedure Print_Line(Indent: Integer);
{
! Print a line for formatting
}
    begin

    if Formatting then
        begin

        while (Blank_Lines > 0) and (Current_Line > 0) do
            begin
            New_Line(0);
            Blank_Lines := 0;
            end;

        New_Line(Indent);
        end;
    Blank_Lines := 0;
    Clear_Breaks;
    end; {print_line}


procedure Space(N: Integer); {space n characters}
    begin
    if Formatting then
        begin
        Write_A(' ');

        with Unwritten[Oldest] do
            begin
            Action_Is := Spaces;
            if N >= 0 then Spacing := N
            else Spacing := 0;
            end;

        Write_Col := Write_Col + N - 1;
        end;
    end; {space}


procedure Flush_Buffer; {flush any unwritten buffer}

    var
        i: 0..Buf_Size_M1;

    begin
    for i := 0 to Buf_Size_M1 do Write_A(' ');
    writeln(Result);
    end; {flush_buffer}


procedure Flush_Symbol;

    var
        P: Line_Index;                  {induction var}

    begin {flush any accumulated characters in the buffer}
    if not Sym_Written then for P := 1 to Sym_Len do Write_A(Symbol[P]);
    end; {flush_symbol}


procedure throwaway(Ch: Char);
    begin {dummy procedure to throw away an output character}
    end; {throwaway}


procedure Get_Char;

  {read next character from input file}

    begin
    if Column < Tab_Column then
        begin
        Column := Column + 1;
        Ch := ' ';
        if not Formatting then Write_A(' ');
        end
    else if not Eof(Source) then
        if not eoln(Source) then
            begin {normal}
            Read(Source, Ch);
            if Ch = Chr(Ht) then
                begin {kluge in input tabs}
                Tab_Column := ((Column + Tab_Interval) div Tab_Interval) *
                              Tab_Interval;
                Ch := ' ';
                end;
            if not Formatting then Write_A(Ch);
            Column := Column + 1;
            end {normal}
        else
            begin {eoln}
            if New_Input_Line then Blank_Lines := Blank_Lines + 1
            else New_Input_Line := true;
            Column := 0;
            Tab_Column := 0;
            Input_Line := Input_Line + 1;
            readln(Source);
            if not Formatting then
                begin
                New_Line(0);
                Reset_Char_Count;
                end;
            Ch := ' ';
            end {eoln}
    else
        begin {eof}
        End_File := true;
        Ch := ' ';
        end {eof}
    end {get_char} ;

{*----------------*
 | Error Handling |
 *----------------*}


procedure Line_Overflow;

  {token too long for output line, note it}

    begin
    Overflows := Overflows + 1;
    if Overflows = 1 then First_Overflow := Current_Line + 1;
    end; {line_overflow}


procedure Comment_Overflow;
{
! Block comment too long for output line, note it
}
    begin
    Com_Overflows := Com_Overflows + 1;
    if Com_Overflows = 1 then First_Com_Overflow := Current_Line;
    end; {comment_overflow}


procedure Abort(Kind: Abort_Kind);
{
! Abort processing and do not create output element
}
    begin
    Flush_Symbol;
    Write_A(Ch);
    writeln(Output);
    if Kind = Syntax then write(Output, 'Syntax error detected, ')
    else if Kind = Nesting then
        write(Output, 'Too many indentation levels, ')
    else write(Output, 'Could not format comment, ');
    WriteLn(Output, 'processing aborted at input line ', Input_Line: 1);
    Close(Result);
    {       Erase(Result); }
    Halt;
    end; {abort}

{*---------------------*
 | Indentation Control |
 *---------------------*}


procedure Indent_Plus(Delta: Integer);
{
! Increment indentation and check for overflow
}
    begin
    if Indent_Level > Max_Line_Len then Abort(Nesting);
    Indent_Level := Indent_Level + 1;
    Indent_State[Indent_Level] := Indent;
    Indent := Indent + Delta;
    if Indent > Out_Line_Len then Indent := Out_Line_Len
    else if Indent < 0 then Indent := 0;
    end; {indent_plus}


procedure Undent;
{
! Reset indent to the last value
}
    begin
    Indent := Indent_State[Indent_Level];
    Indent_Level := Indent_Level - 1;
    end; {undent}


procedure Set_Symbol_Break(Level: Break_Lev);
{
! Mark a good spot to break a line
}
    begin
    Space(0);

    with Symbol_Break[Level] do
        begin
        Buf_Char := Char_Count;
        Break_Col := Write_Col;
        end;

    end; {set_symbol_break}


procedure Format_Line(Indent: Integer);
{
! Make a newline if allowed, otherwise mark this as a good break
! point.
}
    begin
    Print_Line(Indent);
    end;


procedure Make_White;
{
! Force a blank line if allowed
}
    begin
    if Formatting and (Blank_Lines = 0) then Blank_Lines := 1;
    end; {Make_White}


procedure Put_Sym;
{
! Put the current symbol to the output, taking care of spaces before
! the symbol. This also handles full lines, and tries to break lines
! at a convenient place
}

    var
        Before: Line_Index;             {spaces before this character}
        Sym_Indent: Integer;            {indentation before this symbol}
        i: Line_Index;                  {induction var}
        L: Break_Lev;                   {induction var}
        Last_Break: Integer;            {last break character}


    function Spaces_Before(ThisSym, OldSym: Symbols): Line_Index;
    {
    ! Determine the number of spaces before a symbol
    }
        begin
        if ((ThisSym in Alphanumerics) and (OldSym in Alphanumerics)) or
           (ThisSym in Space_Before) or (OldSym in Space_After) then
            Spaces_Before := 1
        else Spaces_Before := 0;
        end; {spaces_before}

    begin
    Before := Spaces_Before(Sym, Last_Sym);
    if End_Line or (Before + Sym_Len + Write_Col > Out_Line_Len) then
        begin {must handle an end of line}
        L := Max_Break_Level;

        while (L > 0) and (Symbol_Break[L].Buf_Char = 0) do L := L - 1;

        with Symbol_Break[L] do
            if not End_Line and Formatting and (Buf_Char > 0) and
               (Char_Count - Buf_Char < Buf_Size) and
               (Before + Sym_Len + Indent + Write_Col - Break_Col <=
               Out_Line_Len) then
                begin

                with Unwritten[Buf_Char mod Buf_Size] do
                    begin
                    Action_Is := Begin_Line;
                    Spacing := Indent
                    end;

                Write_Col := Write_Col - Break_Col + Indent;
                Current_Line := Current_Line + 1;
                Last_Break := Buf_Char;
                end
            else
                begin {no good break spot, break it here}
                Sym_Indent := Out_Line_Len - Sym_Len;
                if Sym_Indent > Indent then Sym_Indent := Indent
                else if Sym_Indent < 0 then
                    begin
                    Sym_Indent := 0;
                    Line_Overflow
                    end;
                Print_Line(Sym_Indent);
                Last_Break := Char_Count;
                end;

        for L := 0 to Max_Break_Level do

            with Symbol_Break[L] do
                if Buf_Char <= Last_Break then Buf_Char := 0;

        end; {if line overflow}
    if Unwritten[Oldest].Action_Is = Begin_Line then Before := 0;
    if Before > 0 then

        with Unwritten[Char_Count mod Buf_Size] do
            if Formatting and (Action_Is = Spaces) then
                begin
                Write_Col := Write_Col - Spacing + Before;
                Spacing := Before;
                end
            else Space(Before);

    if Formatting then for i := 1 to Sym_Len do Write_A(Symbol[i]);
    Last_Sym := Sym;
    Sym_Written := true;
    End_Line := false;
    end; {put_sym}


procedure Block_Com_Char(Character: Char);
    forward;


procedure Stat_Com_Char(Character: Char);
    forward;


procedure Do_Formatter_Directives(Put_Ch_Idx: Integer);
{
! Read a formatter directive and set flags and value appropriately
}

    var
        Temp_Flag: Boolean;
        Opt_char: Char;                 {which option specified}


    procedure Copy_A_Char;
        begin {copy a character and get a new one}
        case Put_Ch_Idx of
            1: Block_Com_Char(Ch);
            2: Stat_Com_Char(Ch);
            end;
        Get_Char;
        end; {copy_a_char}


    procedure Switch_Dir(var Switch: Boolean);
        begin {read and set a switch directive, if char is not + or -, the
                                        value is unchanged}

        if Ch = '+' then
            begin
            Switch := true;
            Copy_A_Char
            end
        else if Ch = '-' then
            begin
            Switch := false;
            Copy_A_Char
            end;
        end; {switch_dir}


    procedure Num_Dir(var Value: Integer;
                      Min, Max: Integer {limits} );
    {
    ! Read a numeric directive and set value. If the value is out
    ! of bounds it is set to the limit value
    }

        var
            Temp_Val: Integer;          {value being accumulated}

        begin
        if Ch = '=' then Copy_A_Char;
        if (Ch >= '0') and (Ch <= '9') then
            begin
            Temp_Val := 0;

            while (Ch >= '0') and (Ch <= '9') do
                begin
                if Temp_Val <= (Maxint - 9) div 10 then
                    Temp_Val := Temp_Val * 10 + (Ord(Ch) - Ord('0'));
                Copy_A_Char;
                end;

            if Temp_Val < Min then Temp_Val := Min;
            if Temp_Val > Max then Temp_Val := Max;
            Value := Temp_Val;
            end;
        end; {num_dir}

    begin
    Copy_A_Char;
    repeat
        if (Ch <> ']') and (Ch <> '}') and (Ch <> '*') then
            begin
            Opt_char := Ch;
            Copy_A_Char;
            case Opt_char of
                'a', 'A': Switch_Dir(First_Spelling);
                'b', 'B': Switch_Dir(Bunching);
                'c', 'C': Switch_Dir(Convert_To_Tabs);
                'f', 'F': Switch_Dir(New_Formatting);

                'o', 'O':
                    begin
                    Num_Dir(Out_Line_Len, 1, Max_Line_Len);
                    One_Half_Line := Out_Line_Len div 2;
                    Five_Eighth_Line := (5 * Out_Line_Len) div 8;
                    Three_Fourth_Line := (3 * Out_Line_Len) div 4;
                    end;

                'p', 'P': Switch_Dir(Portability_Mode);

                'r', 'R':
                    begin
                    Switch_Dir(Temp_Flag);
                    if Temp_Flag then
                        begin
                        Uc_Res_Words := true;
                        Lc_Res_Words := false;
                        end
                    else
                        begin
                        Uc_Res_Words := false;
                        Lc_Res_Words := true;
                        end;
                    end;

                's', 'S': Num_Dir(Stats_Per_Line, 1, Max_Line_Len);

                't', 'T':
                    begin
                    Num_Dir(Tab_Spaces, 0, Max_Line_Len);
                    Continue_Spaces := (Tab_Spaces + 1) div 2;
                    end;

                'u', 'U':
                    begin
                    Switch_Dir(Temp_Flag);
                    if Temp_Flag then
                        begin
                        Uc_Idents := true;
                        LC_Idents := false;
                        end
                    else
                        begin
                        Uc_Idents := false;
                        Lc_Idents := true;
                        end;
                    end;
                else;
                end; {case}
            end;
    until (Ch = ']') or (Ch = '}') or (Ch = '*');
    if Ch = ']' then Copy_A_Char;
    end; {do_formatter_directives}

{$I TPFCOM.PAS}
{$I TPFSCN.PAS}
{$I TPFSTM.PAS}
{$I TPFDCL.PAS}


procedure Process_Text;
    begin
    Clear_Breaks;
    if Sym = Program_Sym then Do_Program
    else if Sym in Block_Beg_Sys then
        begin
        Do_Block;
        if Sym = Semicolon then Next_Sym;
        if Sym = Period then Next_Sym; {set of external procs}
        end
    else if Sym in Stat_Set then Stat_List;
    check([Text_End]);
    Flush_Buffer;
    end {Process_Text} ;

begin {TPF}
Initialize;
csi;
Get_Char; {lead one char}
Get_Sym; {lead one symbol}
Process_Text;
Final_Data;
end {TPF} .