fpc/utils/ptopu.pp

{$mode objfpc}
{$h+}
Unit PtoPu;
{
    This file is part of the Free Pascal run time library.
    Copyright (c) 1999-2000 by Michael Van Canneyt, member of
    the Free Pascal development team

    Pascal Pretty-Printer object implementation

    See the file COPYING.FPC, included in this distribution,
    for details about the copyright.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.

 **********************************************************************}

{
 This unit is based heavily on the code by

 Author:  Peter Grogono
   This program is based on a Pascal pretty-printer written by Ledgard,
   Hueras, and Singer.  See SIGPLAN Notices, Vol. 12, No. 7, July 1977,
   pages 101-105, and PP.DOC/HLP.
   This version of PP developed under Pascal/Z V4.0 or later.
   Very minor modifications for Turbo Pascal made by Willett Kempton
   March 1984 and Oct 84.  Runs under 8-bit Turbo or 16-bit Turbo.
   Toad Hall tweak, rewrite for TP 5, 28 Nov 89

The following was changed :
 - Object oriented
 - Uses streams
 - Run-time customizable.
}
{ $define debug}
Interface

uses Classes,Sysutils;

Const

  MAXSYMBOLSIZE = 65500;
  MAXSHOWSIZE = 40;
  MAXSTACKSIZE = 100;
  MAXKEYLENGTH = 15;     { The longest keywords are IMPLEMENTATION INITIALIZATION }
  DEFLINESIZE = 100;
  DEFINDENT = 2;
  
TYPE
  Token    = AnsiString;
  FileName = STRING;

  TTokenScope = (tsInterface,tsImplementation);

  { Keysymbols }
  { If you add keysyms, adjust the definition of lastkey }
  keysymbol =  { keywords }
              (endsym,beginsym,ifsym,thensym,elsesym,procsym,varsym,ofsym,
               whilesym,dosym,casesym,withsym,forsym,repeatsym,untilsym,
               funcsym,labelsym,constsym,typesym,recordsym,stringsym,progsym,
               { TP and Delphi keywords}
               asmsym, trysym, finallysym,exceptsym,raisesym,classsym,objectsym,
               constructorsym,destructorsym,inheritedsym,propertysym,
               privatesym,publicsym,protectedsym,publishedsym,
               initializationsym,finalizationsym,
               inlinesym,librarysym,interfacesym,implementationsym,
               readsym,writesym,unitsym,
               { Not used for formatting }
               andsym,arrsym,divsym,downsym,filesym,gotosym,insym,modsym,
               notsym,nilsym,orsym,setsym,tosym,virtualsym,usessym,
               casevarsym,ofobjectsym,
               { other symbols }
               becomes,notequal,lessorequal,greaterorequal,delphicomment,dopencomment,dclosecomment,opencomment,closecomment,semicolon,colon,equals,
               openparen,closeparen,period,endoffile,othersym);

  { Formatting options }
  { If you add options, adjust the definition of lastopt }
  options = (crsupp,crbefore,blinbefore,
             dindonkey,dindent,spbef,
             spaft,gobsym,inbytab,inbyindent,crafter,upper,lower,capital);

  optionset = SET OF options;
  keysymset = SET OF keysymbol;

  tableentry = RECORD
                 selected : optionset;
                 dindsym : keysymset;
                 terminators : keysymset
               END;

  { Character identification }

  charname = (letter,digit,space,quote,endofline,
              filemark,otherchar);

  charinfo = RECORD
               name : charname;
               Value : CHAR
             END;

  symbol = RECORD
             name : keysymbol;
             Value : Token;
             IsKeyWord : BOOLEAN;
             length, spacesbefore, crsbefore : INTEGER;
           END;

  symbolinfo = ^ symbol;

  stackentry = RECORD
                 indentsymbol : keysymbol;
                 prevmargin : INTEGER;
               END;

  symbolstack = ARRAY [1..MAXSTACKSIZE] OF stackentry;

Const FirstOpt = crsupp;
      LastOpt = capital; { Adjust this if you add options }
      FirstKey = endsym;
      LastKey = othersym; { Adjust this if you add options }
      LastFormatsym = usessym;

Type
  tableptr = ^tableentry;
  optiontable = ARRAY [Ttokenscope,keysymbol] OF tableptr;
  OEntriesTable = Array [keysymbol] OF String[15];
  ONamesTable = Array [Options] of String[15];
  KeywordTable = ARRAY [endsym..lastFormatsym] OF String[MAXKEYLENGTH];
  SpecialChar = ARRAY [1..2] OF CHAR;
  dblcharset = SET OF endsym..othersym;
  DblCharTable = ARRAY [becomes..dclosecomment] OF SpecialChar;
  SglCharTable = ARRAY [opencomment..period] OF CHAR;
  
  TVerboseEvent = Procedure (Sender : TObject; Const Msg : String) of Object;

  { TPrettyPrinter }

  TPrettyPrinter=Class(TObject)
  Private
    FTokenScope: TTokenScope;
{$ifdef debug}
    GobbleLevel : Integer;
{$endif debug}
    PreviousSymbol : keysymbol;
    RecordLevel : Integer;
    ClassSeen,ObjectSeen : Boolean;
    LastStruct : KeySymbol;
    CRPending : BOOLEAN;
    currchar,nextchar : charinfo;
    currsym,nextsym : symbolinfo;
    inlines,outlines : INTEGER;
    stack   : symbolstack;
    top,startpos,currlinepos,currmargin : Integer;
    option : OptionTable;
    FOnVerbose :  TVerboseEvent;
    FirstWordStackPos,
    FirstWordPos,
    FLineSize,
    FIndent : Integer;
    ins,outs,cfgs : TStream;
    Procedure Verbose (Const Msg : String);
    Procedure GetChar;
    Procedure StoreNextChar(Var lngth: INTEGER;
                            var Value: Token);
    Procedure SkipBlanks(Out spacesbefore, crsbefore: INTEGER);
    Procedure GetComment(sym: symbolinfo);
    Procedure GetDoubleComment(sym: symbolinfo);
    Procedure GetDelphiComment(sym: symbolinfo);
    Procedure GetNumber(sym: symbolinfo);
    Procedure GetCharLiteral(sym: symbolinfo);
    Function  char_Type: keysymbol;
    Procedure GetSpecialChar(sym: symbolinfo);
    Procedure GetNextSymbol(sym: symbolinfo);
    Procedure GetIdentifier(sym: symbolinfo);
    Procedure GetSymbol;
    Procedure PopStack(Out indentsymbol: keysymbol;
                       Out prevmargin: INTEGER);
    Procedure PushStack(indentsymbol: keysymbol;
                        prevmargin: INTEGER );
    Procedure WriteCRs(numberofcrs: INTEGER);
    Procedure InsertCR;
    Procedure InsertBlankLine;
    Procedure LShiftOn(dindsym: keysymset);
    Procedure LShift;
    Procedure InsertSpace(VAR symbol: symbolinfo);
    Procedure MoveLinePos(newlinepos: INTEGER);
    Procedure PrintSymbol;
    Procedure PPSymbol;
    Procedure Gobble(terminators: keysymset);
    Procedure RShift(currmsym: keysymbol);
    Procedure RShiftIndent(currmsym: keysymbol);
    Function ReadConfigFile: Boolean;
  Public
    Constructor Create;
    Function PrettyPrint : Boolean;
    Property OnVerbose : TVerboseEvent Read FOnVerbose Write FOnVerbose;
    Property LineSize : Integer Read FLineSize Write FLineSize;
    Property Indent : Integer Read FIndent Write FIndent;    { How many characters to indent ? }
    Property Source : TStream Read Ins Write Ins;
    Property Dest : TStream Read OutS Write Outs;
    Property Config : Tstream Read cfgS Write cfgs;
    Property CurrentScope : TTokenScope Read FTokenScope Write FTokenScope;
  end;

Procedure GenerateCfgFile(S: TStream);

Implementation

Const
  Blank = ' ';


VAR
  sets : tableptr;
  dblch   : dblcharset;

CONST
  Keyword : KeywordTable =
     ('END', 'BEGIN', 'IF', 'THEN',
      'ELSE', 'PROCEDURE', 'VAR', 'OF',
      'WHILE', 'DO', 'CASE', 'WITH',
      'FOR', 'REPEAT', 'UNTIL', 'FUNCTION',
      'LABEL', 'CONST', 'TYPE', 'RECORD',
      'STRING', 'PROGRAM',
      'ASM','TRY','FINALLY','EXCEPT','RAISE','CLASS','OBJECT',
      'CONSTRUCTOR','DESTRUCTOR','INHERITED','PROPERTY',
      'PRIVATE','PUBLIC','PROTECTED','PUBLISHED',
      'INITIALIZATION','FINALIZATION',
      'INLINE','LIBRARY','INTERFACE','IMPLEMENTATION',
      'READ','WRITE','UNIT',
      {keywords not used for formatting }
      'AND', 'ARRAY', 'DIV', 'DOWNTO',
      'FILE', 'GOTO', 'IN', 'MOD',
      'NOT', 'NIL', 'OR', 'SET','TO','VIRTUAL','USES'
     );


  EntryNames : OEntriesTable =
              ('end','begin','if','then','else','proc','var',
               'of','while','do','case','with','for','repeat','until',
               'func','label','const','type','record','string',
               'prog',
               'asm','try','finally','except','raise','class','object',
               'constructor','destructor','inherited','property',
               'private','public','protected','published',
               'initialization','finalization',
               'inline','library','interface','implementation',
               'read','write','unit',

               'and','arr','div','down','file','goto',
               'in','mod','not','nil','or','set','to','virtual','uses',
               'casevar','ofobject',
               'becomes','notequal','lessorequal','greaterorequal','delphicomment','dopencomment','dclosecomment',
               'opencomment','closecomment','semicolon',
               'colon','equals',
               'openparen','closeparen','period','endoffile','other');

  OptionNames : ONamesTable =
       ('crsupp','crbefore','blinbefore',
        'dindonkey','dindent','spbef','spaft',
        'gobsym','inbytab','inbyindent','crafter','upper',
        'lower','capital');


  DblChar : DblCharTable =
     ( ':=', '<>', '<=', '>=',  '//','(*','*)' );

  SglChar : SglCharTable =
    ('{', '}', ';', ':', '=', '(', ')', '.' );

{ ---------------------------------------------------------------------
    General functions, not part of the object.
  ---------------------------------------------------------------------}

  function upperStr(const s : string) : string;
  var
    i  : longint;
  begin
     setLength(upperStr,length(s));
     for i:=1 to length(s) do
      if s[i] in ['a'..'z'] then
       upperStr[i]:=char(byte(s[i])-32)
      else
       upperStr[i]:=s[i];
  end;

  function LowerStr(const s : string) : string;
  var
    i  : longint;
  begin
     setLength(LowerStr,length(s));
     for i:=1 to length(s) do
      if s[i] in ['A'..'Z'] then
       LowerStr[i]:=char(byte(s[i])+32)
      else
       LowerStr[i]:=s[i];
  end;



Function IntToStr(I : LongInt) : String;

var
 s : string;
begin
  str(I,s);
  IntToStr := s;
end;

Function StrToInt(Const S : String) : Integer;

Var Code : integer;
    Res : Integer;

begin
  Val(S, Res, Code);
  StrToInt := Res;
  If Code<>0 then StrToInt:=0;
end;

Procedure Strip (Var S : String);

Const WhiteSpace =  [#32,#9,#10,#13];

Var I,J : Longint;

begin
  If length(s)=0 then exit;
  I:=1;
  While (S[I] in whitespace) and (I<Length(S)) do inc(i);
  J:=length(S);
  While (S[J] in whitespace) and (J>1) do dec(j);
  If I<=J then
    S:=Copy(S,i,j-i+1)
  else
    S:='';
end;

Procedure ClassID(Value: Token;
                  lngth: INTEGER;
                  VAR idtype: keysymbol;
                  VAR IsKeyWord: BOOLEAN);
  { Classify an identifier.  We are only interested
    in it if it is a keyword, so we use the hash table. }
  VAR
    Keyvalue: String[MAXKEYLENGTH];
    Sym : keysymbol;
    
  BEGIN
    IF lngth > MAXKEYLENGTH THEN BEGIN
      idtype := othersym;
      IsKeyWord := FALSE
    END
    ELSE
      BEGIN
      IsKeyWord := FALSE;
      KeyValue:= UpperStr(Value);
      sym:=endsym;
      While (Not IsKeyword) and (sym<=lastformatsym) DO
         begin
         iskeyword:=(KeyValue=Keyword[sym]);
         if not iskeyword then
           Sym:=Succ(sym);
         end;
      if IsKeyWord then
        idtype:=sym
      ELSE
        idtype := othersym;
      END
  END; { of ClassID }

{ ---------------------------------------------------------------------
    Functions to create options and set defaults.
  ---------------------------------------------------------------------}

Procedure CreateOptions (Out Option : OptionTable);

Var Sym : KeySymbol;
    T : TTokenScope;

begin
  FOR sym := endsym TO othersym DO
    For T:=Low(TTokenScope) to High(TTokenScope) do
      begin
      NEW(option[T,sym]);
      option[T,sym]^.selected := [];
      option[T,sym]^.dindsym := [];
      option[T,sym]^.terminators := []
      END;
end;

Procedure SetTerminators(Var Option : OptionTable);

Var
  T : TTokenScope;
  
begin
  For T:=Low(TTokenScope) to High(TTokenScope) do
    begin
    option[t,casesym]^.terminators    := [ofsym];
    option[t,casevarsym]^.terminators := [ofsym];
    option[t,forsym]^.terminators     := [dosym];
    option[t,whilesym]^.terminators   := [dosym];
    option[t,withsym]^.terminators    := [dosym];
    option[t,ifsym]^.terminators      := [thensym];
    option[t,untilsym]^.terminators   := [endsym, untilsym, elsesym, semicolon];
    option[t,becomes]^.terminators    := [endsym, untilsym, elsesym, semicolon];
    option[t,openparen]^.terminators  := [closeparen];
    option[t,usessym]^.terminators    := [semicolon];
    end;
end;

Procedure SetDefaultIndents (Var Option : OptionTable);

Var
  T : TTokenScope;

begin
  For T:=Low(TTokenScope) to High(TTokenScope) do
    begin
    option[t,recordsym]^.dindsym    := [endsym];
    option[t,funcsym]^.dindsym      := [labelsym, constsym, typesym, varsym];
    option[t,procsym]^.dindsym      := [labelsym, constsym, typesym, varsym];
    option[t,constsym]^.dindsym     := [labelsym, constsym, typesym, varsym];
    option[t,typesym]^.dindsym      := [labelsym, constsym, typesym, varsym];
    option[t,varsym]^.dindsym       := [labelsym, constsym, typesym, varsym];
    option[t,beginsym]^.dindsym     := [labelsym, constsym, typesym, varsym];
    option[t,publicsym]^.dindsym    := [endsym,protectedsym,privatesym,publicsym,publishedsym];
    option[t,privatesym]^.dindsym   := [endsym,protectedsym,privatesym,publicsym,publishedsym];
    option[t,protectedsym]^.dindsym := [endsym,protectedsym,privatesym,publicsym,publishedsym];
    option[t,publishedsym]^.dindsym := [endsym,protectedsym,privatesym,publicsym,publishedsym];
    option[t,finallysym]^.dindsym   := [trysym];
    option[t,exceptsym]^.dindsym   := [trysym];
    option[t,elsesym]^.dindsym      := [ifsym, thensym, elsesym];
    option[t,untilsym]^.dindsym     := [ifsym, thensym, elsesym, forsym, whilesym,
                                      withsym, colon, equals];
    option[t,endsym]^.dindsym       := [ifsym, thensym, elsesym, forsym, whilesym,
                                      withsym, casevarsym, colon, equals, recordsym,
                                      trysym,classsym,objectsym,protectedsym,privatesym,
                                      publicsym,publishedsym,finallysym,exceptsym];
    option[t,semicolon]^.dindsym    := [ifsym, thensym, elsesym, forsym,
                                      whilesym, withsym, colon, equals];
    option[t,implementationsym]^.dindsym    := [labelsym, varsym, typesym, constsym,
                                      endsym,propertysym];
    end;
end;

Procedure SetDefaults (Var Option : OptionTable);

{ Sets default values for the formatting rules. }

Var
  T : TTokenScope;

begin
  For T:=Low(TTokenScope) to High(TTokenScope) do
    begin
    option[t,progsym]^.selected         := [capital,blinbefore, spaft];
    option[t,unitsym]^.selected         := [capital,blinbefore, spaft];
    option[t,librarysym]^.selected      := [capital,blinbefore, spaft];
    option[t,funcsym]^.selected         := [capital,blinbefore, dindonkey, spaft];
    option[t,procsym]^.selected         := [capital,blinbefore, dindonkey, spaft];
    option[t,labelsym]^.selected        := [capital,blinbefore, spaft, inbytab];
    option[t,constsym]^.selected        := [capital,blinbefore, dindonkey, spaft, inbytab];
    option[t,typesym]^.selected         := [capital,blinbefore, dindonkey, spaft, inbytab];
    option[t,varsym]^.selected          := [capital,blinbefore, dindonkey, spaft, inbytab];
    option[t,beginsym]^.selected        := [capital,dindonkey, crbefore, crafter, inbytab];
    option[t,repeatsym]^.selected       := [capital,inbytab, crafter];
    option[t,recordsym]^.selected       := [capital,inbyIndent, crafter];
    option[t,objectsym]^.selected       := [capital,inbyIndent];
    option[t,classsym]^.selected        := [capital,inbyIndent];
    option[t,publicsym]^.selected       := [capital,crbefore, dindonkey, spaft,inbytab];
    option[t,publishedsym]^.selected    := [capital,crbefore, dindonkey, spaft,inbytab];
    option[t,protectedsym]^.selected    := [capital,crbefore, dindonkey, spaft,inbytab];
    option[t,privatesym]^.selected      := [capital,crbefore, dindonkey, spaft,inbytab];
    option[t,trysym]^.Selected          := [capital,crbefore,crafter,inbytab];
    option[t,finallysym]^.selected      := [capital,crbefore,dindent,crafter,inbytab];
    option[t,exceptsym]^.selected       := [capital,crbefore,dindent,crafter,inbytab];
    option[t,casesym]^.selected         := [capital,spaft, inbytab, gobsym, crafter];
    option[t,casevarsym]^.selected      := [capital,spaft, inbytab, gobsym, crafter];
    option[t,ofsym]^.selected           := [capital,crsupp, spbef, spaft];
    option[t,forsym]^.selected          := [capital,spaft, inbytab, gobsym, crafter];
    option[t,whilesym]^.selected        := [capital,spaft, inbytab, gobsym, crafter];
    option[t,withsym]^.selected         := [capital,spaft, inbytab, gobsym, crafter];
    option[t,dosym]^.selected           := [capital,crsupp, spbef];
    option[t,ifsym]^.selected           := [capital,spaft, inbytab, gobsym];
    option[t,implementationsym]^.selected := [capital,blinbefore,crafter,dindonkey];
    option[t,interfacesym]^.selected    := [capital,blinbefore,crafter];
    option[t,usessym]^.selected         := [capital,blinbefore,spaft];
    option[t,thensym]^.selected         := [capital];
    option[t,elsesym]^.selected         := [capital,crbefore, dindonkey, inbytab];
    option[t,endsym]^.selected          := [capital,crbefore, crafter,dindonkey,dindent];
    option[t,untilsym]^.selected        := [capital,crbefore, dindonkey, dindent, spaft,
                                          gobsym, crafter];
    option[t,becomes]^.selected         := [capital,spbef, spaft, gobsym];
    option[t,Delphicomment]^.Selected   := [crafter];
    option[t,opencomment]^.selected     := [capital,crsupp];
    option[t,closecomment]^.selected    := [capital,crsupp];
    option[t,semicolon]^.selected       := [capital,crsupp, dindonkey, crafter];
    option[t,colon]^.selected           := [capital,inbytab];
    option[t,equals]^.selected          := [capital,spbef, spaft, inbytab];
    option[t,openparen]^.selected       := [capital,gobsym];
    option[t,period]^.selected          := [capital,crsupp];
    end;
  option[tsInterface,funcsym]^.selected         := [capital, dindonkey, spaft];
  option[tsInterface,procsym]^.selected         := [capital, dindonkey, spaft];
end;

{ ---------------------------------------------------------------------
    Stream handling routines
  ---------------------------------------------------------------------}

Function ReadChar (S : TStream) : Char;

Var C : Char;

begin
  repeat
    if S.Position=S.Size then
      C:=#0
    else
      S.Read(C,1);
  Until (C<>#13);
  ReadChar:=C;
end;

Function EoSLn (S : TStream) : Char;

Const WhiteSpace = [' ', #9, #13 ];

Var C : Char;

begin
  Repeat
    if S.Position = S.Size then
      C:=#0
    else
      S.Read(C,1);
  Until (Not (C in WhiteSpace)) or ((C=#10));
  EoSln:=C;
end;

Function ReadString (S: TStream): String;

Var
  I : Byte;
  Count : Integer;
    
begin
  Result:='';
  I:=0;
  Repeat
    If ((I+1)>Length(Result)) then
      SetLength(Result,Length(Result)+255);
    Count:=S.Read(Result[I+1],1);
    If Count>0 then
      Inc(I);
  until (Result[I]=#10) or (Count=0);
  If Result[i]=#10 Then Dec(I);
  If Result[I]=#13 then Dec(I);
  SetLength(Result,I);
end;

Procedure WriteString (S : TStream; ST : String);

begin
  S.Write(St[1],length(St));
end;

Procedure WriteAnsiString (S : TStream; ST : AnsiString);

begin
  S.Write(St[1],length(St));
end;


Procedure WriteCR (S: TStream);

Const
  Newline = System.LineEnding;

begin
  WriteString(S,Newline);
end;


Procedure WriteLnString (S : TStream; ST : String);

begin
  WriteString(S,ST);
  WriteCR(S);
end;


{ ---------------------------------------------------------------------
    TPrettyPrinter object
  ---------------------------------------------------------------------}

Procedure TPrettyPrinter.Verbose (Const Msg : String);

begin
  If Assigned (FOnVerbose) then
    FOnVerbose(Self,Msg);
end;

Procedure TPrettyPrinter.GetChar;
{ Read the next character and classify it }
  VAR  Ch: CHAR;
  BEGIN
    currchar := nextchar;
    WITH nextchar DO
      begin
      Ch:=ReadCHar(Ins);
      If Ch=#0 then
        BEGIN
        name := filemark;
        Value := Blank
        END
      ELSE If (Ch=#10) THEN
        BEGIN
        name := endofline;
        Value := Ch;
        Inc(inlines);
        END
      ELSE
        BEGIN
        Value := Ch;
        IF Ch IN ['a'..'z', 'A'..'Z', '_'] THEN name := letter
        ELSE IF Ch IN ['0'..'9'] THEN name := digit
        ELSE IF Ch = '''' THEN name := quote
        ELSE IF Ch in [#13,' ',#9] THEN name := space
        ELSE name := otherchar
        END
      end;
  END; { of GetChar }


Procedure TPrettyPrinter.StoreNextChar(VAR lngth: INTEGER;
                        VAR Value: Token);
  { Store a character in the current symbol }
  BEGIN
    GetChar;
    IF lngth < MAXSYMBOLSIZE THEN BEGIN {XXX - should there be a limit at all?}
      Inc(lngth);
      setlength(Value,lngth);
      Value[lngth] := currchar.Value;
    END;
  END; { of StoreNextChar }


Procedure TPrettyPrinter.SkipBlanks(out spacesbefore, crsbefore: INTEGER);
  { Count the spaces between symbols }
  BEGIN
    spacesbefore := 0;
    crsbefore := 0;
    WHILE nextchar.name IN [space, endofline] DO BEGIN
      GetChar;
      CASE currchar.name OF
        space:      Inc(spacesbefore);
        endofline:  BEGIN
                      Inc(crsbefore);
                      spacesbefore := 0;
                    END;
      END;  {case}
    END;
  END; { of SkipBlanks }


Procedure TPrettyPrinter.GetComment(sym: symbolinfo);
  { Process comments using brace notation }
  BEGIN
    sym^.name := opencomment;
    WHILE NOT ((currchar.Value = '}') 
    OR (nextchar.name = filemark)) DO
      StoreNextChar(sym^.length, sym^.Value);
    IF currchar.Value = '}' THEN sym^.name := closecomment;
  END; { of GetCommment }

Procedure TPrettyPrinter.GetDoubleComment(sym: symbolinfo);
  { Process comments using parenthesis notation }
  BEGIN
    sym^.name := dopencomment;
    WHILE NOT (((currchar.Value = '*') AND (nextchar.Value = ')'))
    OR (nextchar.name = filemark)) DO
      StoreNextChar(sym^.length, sym^.Value);
    IF (currchar.Value = '*') AND (nextchar.Value = ')') THEN BEGIN
      StoreNextChar(sym^.length, sym^.Value);
      sym^.name := dclosecomment;
    END;
  END; { of GetDoubleCommment }

Procedure TPrettyPrinter.GetDelphiComment(sym: symbolinfo);
  { Process comments using either brace or parenthesis notation }
  BEGIN
    sym^.name := Delphicomment;
    WHILE NOT ((nextchar.name = endofline) OR (nextchar.name = filemark)) DO
      StoreNextChar(sym^.length, sym^.Value);

  END; { of GetDelphiCommment }



Procedure TPrettyPrinter.GetIdentifier(sym: symbolinfo);
  { Read an identifier and classify it }
  BEGIN
    WHILE nextchar.name IN [letter, digit] DO
      StoreNextChar(sym^.length, sym^.Value);
    ClassID(sym^.Value, sym^.length, sym^.name, sym^.IsKeyWord);
    IF sym^.name IN [recordsym, objectsym,classsym, casesym, endsym] THEN
      begin
      if sym^.name=implementationsym then
        FTokenScope:=tsImplementation;
      if sym^.name in [recordsym,objectsym,classsym] then
        LastStruct:=sym^.name;
      CASE sym^.name OF
        RecordSym : Inc(RecordLevel);
        ClassSym : ClassSeen:=True;
        objectsym : begin
                    if (PreviousSymbol=Ofsym) then
                      sym^.name:=ofobjectsym
                    else
                      ObjectSeen:=True;
                    end;
        casesym   : IF (RecordLevel>0) and (LastStruct=recordsym) THEN sym^.name := casevarsym;
        endsym    : If (LastStruct=recordsym) then
                      Dec(Recordlevel);
                    else
                      begin
                      ClassSeen:=False;
                      ObjectSeen:=False;
                      end
      END;  {case}
      end;
     If (PreviousSymbol=ClassSym) and (sym^.Name=ofsym) then
       ClassSeen:=False;
     PreviousSymbol:=sym^.Name;
  END; { of GetIdentifier }


{ Read a number and store it as a string }
Procedure TPrettyPrinter.GetNumber(sym: symbolinfo);
  BEGIN
    WHILE nextchar.name = digit DO StoreNextChar(sym^.length, sym^.Value);
    sym^.name := othersym;
  END; { of GetNumber }


PROCEDURE TPrettyPrinter.GetCharLiteral(sym: symbolinfo);
  { Read a quoted string }
  BEGIN
    WHILE nextchar.name = quote DO BEGIN
      StoreNextChar(sym^.length, sym^.Value);
      WHILE NOT (nextchar.name IN [quote, endofline, filemark]) DO
        StoreNextChar(sym^.length, sym^.Value);
      IF nextchar.name = quote THEN StoreNextChar(sym^.length, sym^.Value);
    END;
    sym^.name := othersym;
  END; { of GetCharLiteral }


FUNCTION TPrettyPrinter.char_Type: keysymbol;

  { Classify a character pair }

  VAR
    NextTwoChars: SpecialChar;
    Hit: BOOLEAN;
    thischar: keysymbol;
  BEGIN
    NextTwoChars[1] := currchar.Value;
    NextTwoChars[2] := nextchar.Value;
    thischar := becomes;
    Hit := FALSE;
    WHILE NOT (Hit OR (thischar = opencomment)) DO BEGIN
      IF NextTwoChars = DblChar[thischar] THEN Hit := TRUE
      ELSE Inc(thischar);
    END;
    IF NOT Hit THEN BEGIN
      thischar := opencomment;
      WHILE NOT (Hit OR (PRED(thischar) = period)) DO BEGIN
        IF currchar.Value = SglChar[thischar] THEN Hit := TRUE
        ELSE Inc(thischar);
      END;
    END;
    IF Hit THEN char_Type := thischar
    ELSE char_Type := othersym;
  END; { of char_Type }


Procedure TPrettyPrinter.GetSpecialChar(sym: symbolinfo);
   { Read special characters }
  BEGIN
    StoreNextChar(sym^.length, sym^.Value);
    sym^.name := char_Type;
    IF sym^.name IN dblch THEN StoreNextChar(sym^.length, sym^.Value)
  END; { of GetSpecialChar }


Procedure TPrettyPrinter.GetNextSymbol(sym: symbolinfo);
  { Read a symbol using the appropriate procedure }
  BEGIN
    CASE nextchar.name OF
      letter:     GetIdentifier(sym);
      digit:      GetNumber(sym);
      quote:      GetCharLiteral(sym);
      otherchar:  BEGIN
                    GetSpecialChar(sym);
                    IF sym^.name = opencomment THEN GetComment(sym)
                    else IF sym^.name = dopencomment THEN GetDoubleComment(sym)
                    else IF sym^.name= DelphiComment then GetDelphiComment(Sym)
                  END;
      filemark:   sym^.name := endoffile;
      ELSE {:} {Turbo}
        WRITELN('Unknown character type: ', ORD(nextchar.name));
    END;  {case}
  END; { of GetNextSymbol }


Procedure TprettyPrinter.GetSymbol;
{ Store the next symbol in NEXTSYM }
  VAR
    dummy: symbolinfo;
  BEGIN
    dummy := currsym;
    currsym := nextsym;
    nextsym := dummy;
    SkipBlanks(nextsym^.spacesbefore, nextsym^.crsbefore);
    nextsym^.length := 0;
    nextsym^.IsKeyWord := FALSE;
    IF currsym^.name = opencomment THEN GetComment(nextsym)
    ELSE IF currsym^.name = dopencomment THEN GetDoubleComment(nextsym)
    ELSE GetNextSymbol(nextsym);
  END;  {of GetSymbol}


Procedure TprettyPrinter.PopStack(Out indentsymbol: keysymbol;
                                  Out prevmargin: INTEGER);
  { Manage stack of indentation symbols and margins }
  BEGIN
    IF top > 0 THEN BEGIN
      indentsymbol := stack[top].indentsymbol;
      prevmargin := stack[top].prevmargin;
      Dec(top);
    END
    ELSE BEGIN
      indentsymbol := othersym;
      prevmargin := 0;
    END;
  END; { of PopStack }


Procedure TPrettyPrinter.PushStack(indentsymbol: keysymbol;
                                   prevmargin: INTEGER );
  BEGIN
    Inc(top);
    stack[top].indentsymbol := indentsymbol;
    stack[top].prevmargin := prevmargin;
  END; { of PushStack }


Procedure TPrettyPrinter.WriteCRs(numberofcrs: INTEGER);
  VAR
    i: INTEGER;
  BEGIN
    IF numberofcrs > 0 THEN BEGIN
      FOR i := 1 TO numberofcrs DO
        WriteCr(OutS);
      Inc(outlines,numberofcrs);
      Currlinepos := 0;
      FirstWordStackPos:=-1;
    END;
  END; { of WriteCRs }


Procedure TPrettyPrinter.InsertCR;
  BEGIN
    IF currsym^.crsbefore = 0 THEN BEGIN
      WriteCRs(1);
      currsym^.spacesbefore := 0;
    END;
  END; { of InsertCR }


Procedure TPrettyPrinter.InsertBlankLine;
BEGIN
  IF currsym^.crsbefore = 0 THEN 
    BEGIN
    IF currlinepos = 0 THEN 
      WriteCRs(1)
    ELSE 
      WriteCRs(2);
      currsym^.spacesbefore := 0;
    END
  ELSE 
    IF currsym^.crsbefore = 1 THEN
      IF currlinepos > 0 THEN 
        begin
        WriteCRs(1);
        currsym^.spacesbefore := 0;
        end;
END; { of InsertBlankLine }


Procedure TPrettyPrinter.LShiftOn(dindsym: keysymset);
  { Move margin left according to stack configuration and current symbol }
  VAR
    indentsymbol: keysymbol;
    prevmargin: INTEGER;
  BEGIN
{$ifdef debug}
    Write('LShiftOn ',EntryNames[currsym^.name],' : ',FirstWordPos,'/',CurrMargin);
{$endif debug}
    IF top > 0 THEN BEGIN
      REPEAT
        PopStack(indentsymbol, prevmargin);
        IF indentsymbol IN dindsym THEN currmargin := prevmargin;
      UNTIL NOT (indentsymbol IN dindsym) OR (top = 0);
      IF NOT (indentsymbol IN dindsym) THEN
        PushStack(indentsymbol, prevmargin);
    END;
{$ifdef debug}
    Writeln('-> ',CurrMargin);
{$endif debug}
  END; { of LShiftOn }


Procedure TprettyPrinter.LShift;
{ Move margin left according to stack top }
  VAR
    indentsymbol: keysymbol;
    prevmargin: INTEGER;
  BEGIN
{$ifdef debug}
    Write('LShift ',EntryNames[currsym^.name],' : ',FirstWordPos,'/',CurrMargin);
{$endif debug}
    IF top > 0 THEN BEGIN
      PopStack(indentsymbol, prevmargin);
      currmargin := prevmargin;
(* maybe PopStack(indentsymbol,currmargin); *)
    END;
{$ifdef debug}
    Writeln('-> ',CurrMargin);
{$endif debug}
  END; { of LShift }

Procedure TprettyPrinter.RShift(currmsym: keysymbol);
  { Move right, stacking margin positions }
  BEGIN
{$ifdef debug}
    Write('RShift ',EntryNames[currmsym],' : ',FirstWordPos,'/',Currmargin);
{$endif debug}
    IF top < MAXSTACKSIZE THEN PushStack(currmsym, currmargin);
    IF startpos > currmargin THEN currmargin := startpos;
    Inc(currmargin,INDENT);
{$ifdef debug}
    Writeln(' -> ',Currmargin)
{$endif debug}
  END; { of RShift }

Procedure TprettyPrinter.RShiftIndent(currmsym: keysymbol);
  { Move right, stacking margin positions }
  BEGIN
{$ifdef debug}
    Write('RShiftIndent ',EntryNames[currmsym],' : ',FirstWordPos,'/',Currmargin);
{$endif debug}
    If (FirstWordStackPos>=0) then
      Top:=FirstWordStackPos
    else
      Top:=0;
{$ifdef debug}
    If (Top>0) then
      Write(' Stackpos ',Top,' Item: ',EntryNames[Stack[Top].IndentSymbol],' Pos: ',Stack[Top].Prevmargin)
    else
      Write(' no item on stack');
{$endif debug}
    IF top < MAXSTACKSIZE THEN PushStack(othersym, FirstWordPos);
//    IF top < MAXSTACKSIZE THEN PushStack(currmsym, currmargin);
    CurrMargin:=FirstWordPos+Indent;
{$ifdef debug}
    Writeln(' -> ',Currmargin)
{$endif debug}
  END; { of RShift }


Procedure TPrettyPrinter.InsertSpace(VAR symbol: symbolinfo);
  { Insert space if room on line }
  BEGIN
    IF currlinepos < LineSize THEN BEGIN
      WriteString(OutS, Blank);
      Inc(currlinepos);
      IF (symbol^.crsbefore = 0) AND (symbol^.spacesbefore > 0)
      THEN Dec(symbol^.spacesbefore);
    END;
  END; { of InsertSpace }


Procedure TPrettyPrinter.MoveLinePos(newlinepos: INTEGER);
  { Insert spaces until correct line position reached }
  VAR  i: INTEGER;
  BEGIN
    FOR i := SUCC(currlinepos) TO newlinepos DO
      WriteString(OutS, Blank);
    currlinepos := newlinepos;
  END; { of MoveLinePos }


Procedure TPrettyPrinter.PrintSymbol;

  BEGIN
    IF (currsym^.IsKeyWord) then
      begin
      If upper in sets^.selected Then
        WriteString (OutS,UpperStr(currsym^.value))
      else if lower in sets^.selected then
        WriteString (OutS,LowerStr(currsym^.value))
      else if capital in sets^.selected then
        begin
        WriteString(OutS,UpCase(CurrSym^.Value[1]));
        WriteString(OutS,LowerStr(Copy(CurrSym^.Value,2,MAXSYMBOLSIZE)));{XXX - ?should it be length?}
        end
      else
        WriteString(OutS,Currsym^.Value);
      end
    ELSE
      WriteAnsiString(OutS, currsym^.Value);
    startpos := currlinepos;
    Inc(currlinepos,currsym^.length);
    if (FirstWordStackPos=-1) then
      begin
      FirstWordPos:=startpos;
      FirstWordStackPos:=Top;
{$ifdef debug}
      write('First word : ',currlinepos,': ',currsym^.value);
      If (FirstWordStackPos>0) then
        writeln(' [Stack: ',FirstWordStackPos,' Item: "',EntryNames[Stack[FirstWordStackPos].IndentSymbol],'" Pos: ',Stack[FirstWordStackPos].Prevmargin,']')
      else
        Writeln(' No stack')
{$endif debug}
      end;
  END; { of PrintSymbol }


Procedure TPrettyPrinter.PPSymbol;
{ Find position for symbol and then print it }
  VAR  newlinepos: INTEGER;
  BEGIN
    WriteCRs(currsym^.crsbefore);
    IF ((currLinePos<>0) and (currlinepos + currsym^.spacesbefore > currmargin)) OR
       (currsym^.name IN [opencomment, closecomment,dopencomment, dclosecomment])
    THEN
      newlinepos := currlinepos + currsym^.spacesbefore
    ELSE
      newlinepos := currmargin;
    IF newlinepos + currsym^.length > LINESIZE THEN
      BEGIN {XXX - this needs to be cleaned for case of long symbol values}
      WriteCRs(1);
      IF currmargin + currsym^.length <= LINESIZE THEN
        newlinepos := currmargin
      ELSE IF currsym^.length < LINESIZE THEN
        newlinepos := LINESIZE - currsym^.length
      ELSE
        newlinepos := 0;
      END;
    MoveLinePos(newlinepos);
    PrintSymbol;
  END; { of PPSymbol }


Procedure TPrettyPrinter.Gobble(terminators: keysymset);
  { Print symbols which follow a formatting symbol but which do not
    affect layout }
  BEGIN
{$ifdef debug}
    Inc(GobbleLevel);
    Writeln('Gobble start ',GobbleLevel,' : ',EntryNames[currsym^.name]);
{$endif debug}
    IF top < MAXSTACKSIZE THEN PushStack(currsym^.name, currmargin);
    currmargin := currlinepos;
    WHILE NOT ((nextsym^.name IN terminators)
    OR (nextsym^.name = endoffile)) DO BEGIN
      GetSymbol;
      PPSymbol;
    END;
    LShift;
{$ifdef debug}
    Writeln('Gobble end ',gobblelevel,' : ',EntryNames[nextsym^.name],' ',nextsym^.name in terminators );
    Dec(GobbleLevel);
{$endif debug}
  END; { of Gobble }



Function TPrettyPrinter.ReadConfigFile : Boolean;

Type
  TLineType = (ltNormal,ltIndent,ltGobble);

Var
  I,J : Longint;

  Procedure SetOption(TheKey : KeySymbol;Var OptionList : String);

  Var TheOpt  : Options;
      Found : Boolean;
      K : longint;
      opt : string;
      TS : TTokenScope;

  begin
    Repeat
      K:=pos(',',optionlist);
      If k>0 then
        begin
        opt:=Copy(OptionList,1,k-1);
        strip(opt);
        Delete(OptionList,1,k);
        end
      else
        opt:=OptionList;
      If Length(Opt)>0 then
        begin
        Found:=False;
        for TheOpt :=firstopt to lastopt do
          begin
          found:=opt=OptionNames[Theopt];
          If found then break;
          end;
        If not found then
          Verbose ('Unknown option on line '+inttostr(i)+': '+Opt)
        else
          For TS:=Low(TTokenScope) to High(TTokenScope) do
            Option[TS,TheKey]^.Selected:=Option[TS,TheKey]^.Selected+[TheOpt];
        end;
    until k=0;
  end;

  Function GetKeySimList(Const aType : String; Var OptionList : String) : keysymset;

  Var
      TheIndent : Keysymbol;
      Found : Boolean;
      K : longint;
      opt : string;

  begin
    Result:=[];
    Repeat
      K:=pos(',',optionlist);
      If k>0 then
        begin
        opt:=Copy(OptionList,1,k-1);
        strip(opt);
        Delete(OptionList,1,k);
        end
      else
        opt:=OptionList;
      If Length(Opt)>0 then
        begin
        Found:=False;
        for TheIndent :=firstKey to lastKey do
          begin
          found:=opt=EntryNames[Theindent];
          If found then break;
          end;
        If not found then
          begin
          Verbose ('Unknown indent '+aType+' on line '+inttostr(i)+': '+Opt);
          exit;
          end;
        Include(Result,Theindent);
        end;
    until k=0;
  end;

  Procedure SetIndent(TheKey : KeySymbol; Var OptionList : String);

  Var
    TS : TTokenScope;
    Syms : KeySymSet;

  begin
    Syms:=GetKeySimList('indent',OptionList);
    For TS:=Low(TTokenScope) to High(TTokenScope) do
      With Option[TS,TheKey]^ do
         dindsym:=dindsym+Syms;
  end;

  Procedure SetGobble(TheKey : KeySymbol; Var OptionList : String);

  Var
    TS : TTokenScope;
    Syms : KeySymSet;

  begin
    Syms:=GetKeySimList('gobble',OptionList);
    For TS:=Low(TTokenScope) to High(TTokenScope) do
      With Option[TS,TheKey]^ do
         Terminators:=Terminators+Syms;
  end;

  Function CheckLineType (var Name : String) : TLineType;

  begin
    If (Name[1]='[') and (Name[Length(Name)]=']') then
     begin
     Name:=Copy(Name,2,Length(Name)-2);
     Result:=ltIndent
     end
   else If (Name[1]='<') and (Name[Length(Name)]='>') then
     begin
     Name:=Copy(Name,2,Length(Name)-2);
     Result:=ltgobble
     end
   else
     Result:=ltNormal;
  end;

Var
  TheKey : KeySymbol;
  Found : Boolean;
  Line, Name : String;
  L : TStringList;
  LT : TLineType;
    
begin
  ReadConfigFile:=false;
  L:=TStringList.Create;
  Try
    L.LoadFromStream(CfgS);
    For I:=1 to L.Count do
      begin
      Line:=L[i-1];
      { Strip comment }
      If pos('#',Line)<>0 then
        Line:=Copy(Line,1,Pos('#',Line)-1);
      If length(Line)<>0 then
        begin
        J:=Pos('=',Line);
        If J=0 then
          verbose ('Error in config file on line '+IntToStr(i))
        else
          begin
          Line:=LowerStr(Line);
          Name:=Copy(Line,1,j-1);
          Delete(Line,1,J);
          { indents or options ? }
          LT:=CheckLineType(Name);
          Strip(Name);
          found:=false;
          for thekey:=firstkey to lastkey do
            begin
            found:=Name=EntryNames[thekey];
            If Found then break;
            end;
          If not found then
            Verbose ('Unknown keyword on line '+inttostr(i)+': '+Name)
          else
            Case LT of
             ltIndent: SetIndent(TheKey,Line);
             ltNormal: SetOption(TheKey,Line);
             ltGobble: SetGobble(TheKey,Line);
            end;
          end;
        end;
      end;
  Finally
    L.Free;
  end;
  Verbose ('Processed configfile: read '+IntToStr(I)+' lines');
  ReadConfigFile:=true;
end;

Procedure GenerateCfgFile(S : TStream);

Var TheKey,TheIndent : KeySymbol;
    TheOpt : Options;
    Written : Boolean;
    Option : OptionTable;

begin
  CreateOptions(option);
  SetDefaults(option);
  SetDefaultIndents(option);
  For TheKey:=Firstkey to lastkey do
    begin
    { Write options }
    WriteString (S,EntryNames[TheKey]+'=');
    Written:=False;
    for TheOpt:=FirstOpt to LastOpt do
      If TheOpt in Option[tsInterface,TheKey]^.Selected then
        begin
        if written then
           WriteString (S,',')
        else
           Written:=True;
        writeString (S,OptionNames[TheOpt]);
        end;
    WriteCr (S);
    { Write de-indent keysyms, if any }
    If Option[tsInterface,TheKey]^.dindsym<>[] then
      begin
      WriteString (S,'['+EntryNames[TheKey]+']=');
      Written:=False;
      For TheIndent:=FirstKey to lastkey do
      If TheIndent in Option[tsInterface,TheKey]^.dindsym then
        begin
        if written then
           WriteString (S,',')
        else
           Written:=True;
        WriteString (S,EntryNames[Theindent]);
        end;
      WriteCr (S);
      end;
    end;
end;

Function trimMiddle ( a:ansistring; lnght: integer; size: integer):string;
var
    half:Integer;
begin
    if lnght > size 
    then
    begin
      half := (size - 3) div 2;
      trimMiddle := copy(a,1,half) + '...' + copy(a,lnght-half+1,half);
    end
    else
      trimMiddle := a;
end;

Function TPrettyPrinter.PrettyPrint : Boolean;

Begin
  PrettyPrint:=False;
  If Not Assigned(Ins) or Not Assigned(OutS) then
    exit;
  If Not Assigned(CfgS) then
    begin
    SetDefaults(Option);
    SetDefaultIndents(Option);
    end
  else
    ReadConfigFile;
  { Initialize variables }
  top := 0;
  currlinepos := 0;
  currmargin := 0;
  inlines := 0;
  outlines := 0;
  CrPending := FALSE;
  FirstWordStackPos:=-1;
  RecordLevel := 0;
  GetChar;
  NEW(currsym);
  NEW(nextsym);
  GetSymbol;
  WHILE nextsym^.name <> endoffile DO BEGIN
    GetSymbol;
{$ifdef debug}
    Writeln('line in-'+IntToStr(inlines)+' out-'+IntToStr(outlines)+
            ' symbol "'+EntryNames[currsym^.name]+'" = "'+
            trimMiddle(currsym^.value,length(currsym^.value),MAXSHOWSIZE)+'"');
{$endif debug}
    sets := option[FTokenScope,currsym^.name];
    IF (CrPending AND NOT (crsupp IN sets^.selected))
    OR (crbefore IN sets^.selected) THEN BEGIN
      InsertCR;
      CrPending := FALSE
    END;
    IF blinbefore IN sets^.selected THEN BEGIN
      InsertBlankLine;
      CrPending := FALSE
    END;
    IF dindonkey IN sets^.selected THEN
      LShiftOn(sets^.dindsym);
    IF dindent IN sets^.selected THEN
      LShift;
    IF spbef IN sets^.selected THEN InsertSpace(currsym);
    PPSymbol;
    IF spaft IN sets^.selected THEN InsertSpace(nextsym);
    IF inbytab IN sets^.selected THEN
      RShift(currsym^.name)
    else IF inbyindent IN sets^.selected THEN
      RShiftIndent(currsym^.name);
    IF gobsym IN sets^.selected THEN Gobble(sets^.terminators);
    IF crafter IN sets^.selected THEN CrPending := TRUE
  END;
  IF CrPending THEN WriteCRs(1);
  Verbose(IntToStr(inlines)+' lines read, '+IntToStr(outlines)+' lines written.');
  PrettyPrint:=True;
end;

Constructor TPrettyPrinter.Create;

Begin
  Indent:=DefIndent;
  LineSize:=DefLineSize;
  CreateOptions (Option);
  SetTerminators(Option);
  InS:=Nil;
  OutS:=Nil;
  CfgS:=Nil;
End;

{ ---------------------------------------------------------------------
    Unit initialization
  ---------------------------------------------------------------------}


Begin
  dblch := [becomes, notequal, lessorequal, greaterorequal, opencomment];
end.