paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-07 01:08:09 +02:00
Code Issues Packages Projects Releases Wiki Activity
1ed9054bb9
fpc/utils/ptopu.pp
michael dc96e41047 * Patch from Bart Broersma to silence warning (bug ID 34285) 
git-svn-id: trunk@43137 -
2019-10-06 07:49:13 +00:00

1416 lines
42 KiB
ObjectPascal
Raw Blame History

{$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{$ifdef debug}(currmsym: keysymbol){$endif debug};
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{$ifdef debug}(currmsym: keysymbol){$endif debug};
{ 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{$ifdef debug}(currsym^.name){$endif debug};
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.
Reference in New Issue View Git Blame Copy Permalink