mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-06 09:27:59 +02:00
1976 lines
61 KiB
ObjectPascal
1976 lines
61 KiB
ObjectPascal
{ This is a test-program for the fcl-passrc package (except writer-class).
|
|
|
|
Please notice that i have done this to find out how good the parser workes,
|
|
it is not thought to be a good example to use the fcl-passrc package but
|
|
may give you hints on using it.
|
|
|
|
It is done to test the source of these units for usability, completeness and
|
|
bugs. It is base on the fcl-passrc exampe.
|
|
It workes like a pretty-printer to compare the output of this program with
|
|
the original code, but is not thought to be a real pretty-printer as
|
|
e.g. the semicolons can sometimes not be set at the place they sould be
|
|
(this imformation is not available from the parsing-engine, as a parser
|
|
should only give you a positiv result if the source is valid, otherwise
|
|
you get a negative result).
|
|
Also the output is not always in the same order as in input as this
|
|
information is not available easily.
|
|
|
|
!!!Do not expect this program to produce executeable output!!!
|
|
|
|
Status: -workes with one Unit or Program
|
|
-Some type declarations missing
|
|
-string[n] the [n] part missing -> missing in parser
|
|
-array of const -> missing in parser
|
|
-Hints deprecated, etc. missing sometimes
|
|
-the parser splits x,y:atype
|
|
x:atype
|
|
y:atype
|
|
i tryed to put them together again
|
|
- () missing in statements: () expression and typecast
|
|
-missing forward class declaration like x=class
|
|
-incomplete !
|
|
|
|
parser: -ugly ''' quotation from scanner, why not #39 ?
|
|
-see comments in the program for hints
|
|
-incomplete !
|
|
|
|
Usage: call with one complete filename of a Unit or Program
|
|
defaults for the parser are 'linux' and 'i386'
|
|
|
|
Output: is 'pretty-printed' to stdout or unformated
|
|
The unformated output is thought to be diffed with the original
|
|
source to see differences caused by the parser (a tool to unformat
|
|
a souce file is in progress but not finished jet).
|
|
|
|
Bugs: 1. In case of unimplemented statements (like up to now asm) the parser
|
|
cause a excemtion to abort the program hard.
|
|
2. Missing implementaion in this program should not print out anything
|
|
or result in not pascal conform output.
|
|
|
|
Hit: The parser uses directives given in the source file.
|
|
|
|
Hints to read the code:
|
|
There are comments in the code with hints and marks of possible bugs.
|
|
During development some code was modified for true order output but the
|
|
old code is still available as a comment as it is easier to understand.
|
|
This is programmed using 'recursive' calls. Most options in functions are
|
|
for printing the output.
|
|
There is no writer-class used to keep it simple and see what is done.
|
|
All output is produced by direct writing to stdout, this cause problems in
|
|
furter development; a function result as string may be more usable.
|
|
|
|
The parser was written to be used for unit interface and was expanded to
|
|
work with program and implementation too. It does nearly no seperate
|
|
things for programs, they are adapted to the unit scheme (see main).
|
|
|
|
The order will change in following case:
|
|
-function with forward declaration (also overloading etc.)
|
|
|
|
|
|
Inheritance (only the important ones):
|
|
|
|
TInterfaceSection, TImplementationSection, TProgramSection
|
|
|
|
|
TPasSection
|
|
|
|
|
TPasDeclarations
|
|
|
|
|
TPasElement
|
|
|
|
|
TPasElementBase
|
|
|
|
|
TObject
|
|
|
|
TInitializationSection, TFinalizationSection
|
|
|
|
|
TPasImplBlock
|
|
|
|
|
TPasImplElement
|
|
|
|
|
TPasElement
|
|
|
|
|
TPasElementBase
|
|
|
|
|
TObject
|
|
|
|
TPasProgram
|
|
|
|
|
TPasModule
|
|
|
|
|
TPasElement
|
|
|
|
|
TPasElementBase
|
|
|
|
|
TObject
|
|
|
|
Dependance Structure :
|
|
|
|
TPasPackage = class(TPasElement)
|
|
|
|
|
Modules: TFPList;
|
|
|
|
TPasModule = class(TPasElement)
|
|
|-InterfaceSection: TInterfaceSection;
|
|
| |-Declarations -> forward part, unit only
|
|
|
|
|
|-ImplementationSection: TImplementationSection;
|
|
| |-Declarations -> full declaration, unit and program
|
|
| |-Functions: TFPList;
|
|
| |-TPasFunction = class(TPasProcedureBase)
|
|
| |-Body: TProcedureBody;
|
|
| |-Declarations -> declaration and sub function
|
|
| |-Body: TPasImplBlock; -> procedure block
|
|
|
|
|
|-InitializationSection: TInitializationSection;
|
|
| |-TPasImplBlock.Elements: TFPList; -> main block
|
|
|
|
|
|-FinalizationSection: TFinalizationSection;
|
|
|-TPasImplBlock.Elements: TFPList; -> unit only
|
|
|
|
Declarations = class(TPasElement)
|
|
|-Declarations: TFPList; -> the following are all in here
|
|
|-ResStrings: TFPList;
|
|
|-Types: TFPList;
|
|
|-Consts: TFPList;
|
|
|-Classes: TFPList;
|
|
|-Functions: TFPList;
|
|
|-Variables: TFPList;
|
|
|-Properties: TFPList;
|
|
}
|
|
|
|
|
|
program test_parser1;
|
|
{$mode objfpc}{$H+}
|
|
|
|
uses SysUtils, Classes, PParser, PasTree;
|
|
|
|
//# types the parser needs
|
|
|
|
type
|
|
{ We have to override abstract TPasTreeContainer methods.
|
|
See utils/fpdoc/dglobals.pp for an implementation of TFPDocEngine,
|
|
a "real" engine. }
|
|
TSimpleEngine = class(TPasTreeContainer)
|
|
public
|
|
function CreateElement(AClass: TPTreeElement; const AName: String;
|
|
AParent: TPasElement; AVisibility: TPasMemberVisibility;
|
|
const ASourceFilename: String; ASourceLinenumber: Integer): TPasElement;
|
|
override;
|
|
function FindElement(const AName: String): TPasElement; override;
|
|
end;
|
|
|
|
function TSimpleEngine.CreateElement(AClass: TPTreeElement; const AName: String;
|
|
AParent: TPasElement; AVisibility: TPasMemberVisibility;
|
|
const ASourceFilename: String; ASourceLinenumber: Integer): TPasElement;
|
|
begin
|
|
Result := AClass.Create(AName, AParent);
|
|
Result.Visibility := AVisibility;
|
|
Result.SourceFilename := ASourceFilename;
|
|
Result.SourceLinenumber := ASourceLinenumber;
|
|
end;
|
|
|
|
function TSimpleEngine.FindElement(const AName: String): TPasElement;
|
|
begin
|
|
{ dummy implementation, see TFPDocEngine.FindElement for a real example }
|
|
Result := nil;
|
|
end;
|
|
|
|
|
|
//# main var
|
|
var
|
|
M: TPasModule;
|
|
E: TPasTreeContainer;
|
|
I: Integer;
|
|
cmdl, TargetOS, TargetCPU : string;
|
|
isim, //is Impleamentation, only for GetTPasProcedureBody
|
|
Unformated:boolean; // no Formating in output
|
|
|
|
|
|
//# tools
|
|
|
|
function GetIndent(indent:integer):String;
|
|
var i:integer;
|
|
begin
|
|
Result:='';
|
|
if not Unformated then
|
|
for i:=1 to indent do Result:=Result+' ';
|
|
end;
|
|
|
|
//delete ugly quoting '''STRING'''
|
|
function DelQuot(s:String):String;
|
|
var i:integer;
|
|
const s1=#39#39#39;
|
|
begin
|
|
Result:='';
|
|
i:=pos(s1,s);
|
|
while i > 0 do
|
|
begin
|
|
if i > 0 then delete(s,i,2);
|
|
i:=pos(s1,s);
|
|
end;
|
|
//if i > 0 then delete(s,i,2);
|
|
Result:=s;
|
|
end;
|
|
|
|
//LeadingSpace only valid if Formated output (as this will be one line in output)
|
|
//UnFormated: all is printed in a new line
|
|
procedure WriteFmt(LeadingSpace:boolean; s:String; Semicolon:boolean);
|
|
begin
|
|
if Semicolon then s:=s+';';
|
|
if Unformated then writeln(s)
|
|
else if LeadingSpace then write(' ',s)
|
|
else write(s);
|
|
end;
|
|
|
|
//# parsing output
|
|
|
|
function GetTPasImplBlock(lb:TPasImplBlock; indent,declistby:integer;
|
|
LastNoSem,NoFirstIndent:boolean):boolean; forward;
|
|
|
|
function GetTPasImplElement(le:TPasImplElement; lindent:integer;
|
|
lLastNoSem,NoFirstIndent:boolean):boolean; forward;
|
|
|
|
procedure GetDecls(Decl:TPasDeclarations; indent:integer); forward;
|
|
//procedure PrintDecls(Decl:TPasDeclarations; indent:integer); forward;
|
|
|
|
//# most is for implementation or implblocks except the expr things
|
|
|
|
function ReturnTPasMemberHints(h:TPasMemberHints):String;
|
|
begin
|
|
Result:='';
|
|
if hDeprecated in h then Result:=' deprecated';
|
|
if hLibrary in h then Result:=Result+' library';
|
|
if hPlatform in h then Result:=Result+' platform';
|
|
if hExperimental in h then Result:=Result+' experimental';
|
|
if hUnimplemented in h then Result:=Result+' unimplemented';
|
|
end;
|
|
|
|
function GetTPasMemberHints(h:TPasMemberHints):Boolean;
|
|
begin
|
|
Result:=false;
|
|
if hDeprecated in h then begin write(' deprecated'); Result:=true; end;
|
|
if hLibrary in h then begin write(' library'); Result:=true; end;
|
|
if hPlatform in h then begin write(' platform'); Result:=true; end;
|
|
if hExperimental in h then begin write(' experimental'); Result:=true; end;
|
|
if hUnimplemented in h then begin write(' unimplemented'); Result:=true; end;
|
|
end;
|
|
|
|
|
|
|
|
|
|
function GetTPasExprKind(lpek:TPasExprKind):String;
|
|
begin
|
|
Result:='';
|
|
case lpek of
|
|
pekIdent:Result:='ID';
|
|
pekNumber:Result:='NUMBER';
|
|
pekString:Result:='STRING';
|
|
pekSet:Result:='SET';
|
|
pekNil:Result:='NIL';
|
|
pekBoolConst:Result:='BOOL';
|
|
pekRange:Result:='RANGE';
|
|
pekUnary:Result:='UNARY';
|
|
pekBinary:Result:='BINARY';
|
|
pekFuncParams:Result:='FUNCPAR';
|
|
pekArrayParams:Result:='ARRAYPAR';
|
|
pekListOfExp:Result:='EXPLIST';
|
|
end;
|
|
end;
|
|
|
|
procedure GetTPasExpr(lex:TPasExpr);
|
|
var lex1:TpasExpr;
|
|
lpe:TParamsExpr;
|
|
l:integer;
|
|
lbk,rbk,sep:string;
|
|
lav:TArrayValues;
|
|
lrv:TRecordValues;
|
|
rvi:TRecordValuesItem;
|
|
|
|
|
|
function GetExpKind(ek:TPasExprKind; var lbrak,rbrak:string):string;
|
|
begin
|
|
lbrak:='';
|
|
rbrak:='';
|
|
Result:='';
|
|
case ek of
|
|
pekIdent:Result:='ID';
|
|
pekNumber:Result:='NU';
|
|
pekString:begin lbrak:=#39; rbrak:=#39; Result:=#39; end;
|
|
pekSet:begin lbrak:='['; rbrak:=']'; Result:=','; end;
|
|
pekNil:Result:='NIL';
|
|
pekBoolConst:Result:='';
|
|
pekRange:Result:='..';
|
|
pekUnary:Result:='';
|
|
pekBinary:Result:='';
|
|
pekFuncParams:begin lbrak:='('; rbrak:=')'; Result:=','; end;
|
|
pekArrayParams:begin lbrak:='['; rbrak:=']'; Result:=','; end;
|
|
pekListOfExp:Result:=',';
|
|
pekInherited:Result:=' InheriteD';
|
|
pekSelf:Result:=' SelF';
|
|
end;
|
|
end;
|
|
|
|
function GetOp(lop:TExprOpCode):string;
|
|
begin
|
|
Result:='';
|
|
case lop of
|
|
eopNone:Result:='';
|
|
eopAdd:Result:='+';
|
|
eopSubtract:Result:='-';
|
|
eopMultiply:Result:='*';
|
|
eopDivide:Result:='/';
|
|
eopDiv:Result:=' div ';
|
|
eopMod:Result:=' mod ';
|
|
eopPower:Result:='^';
|
|
eopShr:Result:=' shr ';
|
|
eopSHl:Result:=' shl ';
|
|
eopNot:Result:=' not ';
|
|
eopAnd:Result:=' and ';
|
|
eopOr:Result:=' or ';
|
|
eopXor:Result:=' xor ';
|
|
eopEqual:Result:='=';
|
|
eopNotEqual:Result:='<>';
|
|
eopLessThan:Result:='<';
|
|
eopGreaterThan:Result:='>';
|
|
eopLessthanEqual:Result:='<=';
|
|
eopGreaterThanEqual:Result:='>=';
|
|
eopIn:Result:=' in ';
|
|
eopIs:Result:=' is ';
|
|
eopAs:Result:=' as ';
|
|
eopSymmetricaldifference:Result:='><';
|
|
eopAddress:Result:='@';
|
|
eopDeref:Result:='^';
|
|
eopSubIdent:Result:='.';
|
|
end;
|
|
end;
|
|
|
|
begin
|
|
if lex is TBinaryExpr then //compined constants
|
|
begin
|
|
sep:=GetExpKind(lex.Kind,lbk,rbk);
|
|
//write('|');
|
|
write(lbk);
|
|
GetTPasExpr(TBinaryExpr(lex).left);
|
|
write(GetOp(TBinaryExpr(lex).OpCode));
|
|
write(sep);
|
|
GetTPasExpr(TBinaryExpr(lex).right);
|
|
write(rbk);
|
|
//write('|');
|
|
//write(' [',lex.Name,' ',GetTPasExprKind(lex.Kind),']');
|
|
end
|
|
else
|
|
begin
|
|
//write('UNARY');
|
|
if lex is TUnaryExpr then
|
|
begin
|
|
lex1:=TUnaryExpr(lex).Operand;
|
|
if lex.OpCode = eopDeref then
|
|
begin
|
|
GetTPasExpr(lex1);
|
|
write(GetOp(lex.OpCode)); //unary last, only: p^
|
|
end
|
|
else
|
|
begin
|
|
write(GetOp(lex.OpCode)); //unary first: -1
|
|
GetTPasExpr(lex1);
|
|
end;
|
|
end;
|
|
if lex is TPrimitiveExpr then write(TPrimitiveExpr(lex).Value) //simple constant
|
|
else
|
|
if lex is TBoolConstExpr then write(TBoolConstExpr(lex).Value)
|
|
else
|
|
if lex is TNilExpr then write('nil')
|
|
else
|
|
if lex is TInheritedExpr then write('Inherited ')
|
|
else
|
|
if lex is TSelfExpr then write('Self')
|
|
else
|
|
if lex is TParamsExpr then //writeln(param1,param2,..,paramn);
|
|
begin
|
|
//write(' PAREX ');
|
|
lpe:=TParamsExpr(lex);
|
|
GetTPasExpr(lpe.Value);
|
|
if length(lpe.Params) >0 then
|
|
begin
|
|
sep:=GetExpKind(lpe.Kind,lbk,rbk);
|
|
write(lbk); //write('(');
|
|
for l:=0 to High(lpe.Params)-1 do
|
|
begin
|
|
GetTPasExpr(lpe.Params[l]);
|
|
write(sep); //seperator
|
|
end;
|
|
GetTPasExpr(lpe.Params[High(lpe.Params)]);
|
|
write(rbk);//write(')');
|
|
end
|
|
else
|
|
begin //funcion()
|
|
sep:=GetExpKind(lpe.Kind,lbk,rbk);
|
|
write(lbk,rbk);
|
|
end;
|
|
end
|
|
else if lex is TArrayValues then //const AnArrayConst: Array[1..3] of Integer = (1,2,3);
|
|
begin
|
|
write('(');
|
|
lav:=TArrayValues(lex);
|
|
if length(lav.Values) > 0 then
|
|
begin
|
|
for l:=0 to high(lav.Values)-1 do
|
|
begin
|
|
GetTPasExpr(TPasExpr(lav.Values[l]));
|
|
write(',');
|
|
end;
|
|
GetTPasExpr(TPasExpr(lav.Values[high(lav.Values)]));
|
|
end;
|
|
write(')');
|
|
end
|
|
else if lex is TRecordValues then
|
|
begin
|
|
write('(');
|
|
lrv:=TRecordValues(lex);
|
|
if length(lrv.Fields) > 0 then
|
|
begin
|
|
for l:=0 to high(lrv.Fields)-1 do
|
|
begin
|
|
rvi:=TRecordValuesItem(lrv.Fields[l]);
|
|
write(rvi.Name,':');
|
|
GetTPasExpr(rvi.ValueExp);
|
|
write(';');
|
|
end;
|
|
rvi:=TRecordValuesItem(lrv.Fields[high(lrv.Fields)]);
|
|
write(rvi.Name,':');
|
|
GetTPasExpr(rvi.ValueExp);
|
|
end;
|
|
write(')');
|
|
end
|
|
else
|
|
begin
|
|
//?
|
|
//writeln('{ Unknown Expression: ');
|
|
//if assigned(lex) then GetTPasExprKind(lex.Kind);
|
|
//writeln('}');
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
|
|
//NoFirstIndent only for block in case:
|
|
procedure GetTPasSmt(lsmt:TPasImplStatement; lindent:integer; DoNoSem,NoFirstIndent:boolean);
|
|
var l:integer;
|
|
lics:TPasImplCaseStatement;
|
|
DoSem:boolean;
|
|
liwd:TPasImplWithDo;
|
|
liwhd:TPasImplWhileDo;
|
|
lieo:TPasImplExceptOn;
|
|
lifl:TPasImplForLoop;
|
|
lir:TPasImplRaise;
|
|
s,s1:String;//s1 only first line of block statement
|
|
|
|
begin
|
|
DoSem:=true;
|
|
s:=GetIndent(lindent);
|
|
if NoFirstIndent then s1:=' ' else s1:=s;
|
|
if lsmt is TPasImplSimple then
|
|
begin
|
|
write(s1); GetTPasExpr(TPasImplSimple(lsmt).expr);
|
|
//DoSem:=true;
|
|
end
|
|
else if lsmt is TPasImplAssign then
|
|
begin
|
|
write(s1); GetTPasExpr(TPasImplAssign(lsmt).left);
|
|
write(':= ');
|
|
GetTPasExpr(TPasImplAssign(lsmt).right);
|
|
//DoSem:=true;
|
|
end
|
|
else if lsmt is TPasImplCaseStatement then
|
|
begin
|
|
lics:=TPasImplCaseStatement(lsmt);
|
|
if lics.Expressions.Count>0 then
|
|
begin
|
|
write(s);
|
|
for l:=0 to lics.Expressions.Count-2 do
|
|
write(DelQuot(TPasExpr(lics.Expressions[l]).GetDeclaration(True)),',');
|
|
write(DelQuot(TPasExpr(lics.Expressions[lics.Expressions.Count-1]).GetDeclaration(True)),': '); // !!bug too much ' in expression
|
|
//if not assigned(lics.Body) then writeln('TPasImplCaseStatement missing BODY');
|
|
//if assigned(lics.Body) and (TPasImplBlock(lics.Body).Elements.Count >0) then
|
|
// GetTPasImplBlock(TPasImplBlock(lics.Body),lindent+1,0,false,true)
|
|
// else GetTPasImplBlock(TPasImplBlock(lics),lindent+1,0,false,true); // !!bug missing body, assigned but empty
|
|
if assigned(lics.Body) then
|
|
begin
|
|
if not GetTPasImplElement(lics.Body,lindent+1,false,true) then ;//writeln(';');
|
|
end
|
|
else writeln(';');
|
|
end;
|
|
DoSem:=false;
|
|
end
|
|
else if lsmt is TPasImplWithDo then
|
|
begin
|
|
liwd:=TPasImplWithDo(lsmt); // !!Bug: missing with do at following with do !solved see Bug
|
|
write(s1,'with ',liwd.Name);
|
|
if liwd.Expressions.Count>0 then
|
|
begin
|
|
for l:=0 to liwd.Expressions.Count-2 do
|
|
write(TPasExpr(liwd.Expressions[l]).GetDeclaration(true),',');
|
|
write(TPasExpr(liwd.Expressions[liwd.Expressions.Count-1]).GetDeclaration(true));
|
|
end;
|
|
writeln(' do');
|
|
//if TPasImplBlock(liwd.Body).Elements.Count >0 then
|
|
//GetTPasImplBlock(TPasImplBlock(liwd.Body),0); // !!Bug: BODY Not used
|
|
//else
|
|
GetTPasImplBlock(TPasImplBlock(liwd),lindent+1,0,false,false);
|
|
DoSem:=false;
|
|
end
|
|
else if lsmt is TPasImplWhileDo then
|
|
begin
|
|
liwhd:=TPasImplWhileDo(lsmt);
|
|
writeln(s1,'while ',DelQuot(liwhd.Condition),' do');
|
|
//if not GetTPasImplBlock(TPasImplBlock(liwhd.Body),0) then // !!Bug: BODY Not used
|
|
GetTPasImplBlock(TPasImplBlock(liwhd),lindent,0,DoNoSem,false); //OK for all constructs
|
|
DoNoSem:=false; //?
|
|
DoSem:=false;
|
|
end
|
|
else if lsmt is TPasImplExceptOn then
|
|
begin
|
|
lieo:=TPasImplExceptOn(lsmt);
|
|
writeln(s,'on ',lieo.VariableName,': ',lieo.TypeName,' do');
|
|
if TPasImplBlock(lieo.Body) is TPasImplRaise then
|
|
begin
|
|
write(s,'raise ');//raise is in TPasImplBlock in this case
|
|
GetTPasImplBlock(TPasImplBlock(lieo.Body),lindent+1,0,false,true);
|
|
end
|
|
else GetTPasImplBlock(TPasImplBlock(lieo.Body),lindent+1,0,false,false);
|
|
DoSem:=false;
|
|
end
|
|
else if lsmt is TPasImplForLoop then
|
|
begin
|
|
lifl:=TPasImplForLoop(lsmt);
|
|
//TODO variable
|
|
write(s1,'for ',lifl.Variable.Name,':= ',lifl.StartExpr.GetDeclaration(True),' ');
|
|
if lifl.Down then write('down');
|
|
writeln('to ',lifl.EndExpr.GetDeclaration(True),' do');
|
|
GetTPasImplBlock(TPasImplBlock(lifl),lindent+1,0,false,false);
|
|
DoSem:=false;
|
|
end
|
|
else if lsmt is TPasImplRaise then
|
|
begin
|
|
write(s1,'raise ');
|
|
lir:=TPasImplRaise(lsmt);
|
|
if not GetTPasImplBlock(TPasImplBlock(lir),lindent,0,DoNoSem,true) then
|
|
writeln(';');
|
|
DoNoSem:=false;
|
|
DoSem:=false;
|
|
end
|
|
else
|
|
begin
|
|
if assigned(lsmt.Elements) then
|
|
begin
|
|
writeln('{ Unknown SMT(s): '); //,lsmt.Name,' ',lsmt.ElementTypeName);
|
|
for l:=0 to lsmt.Elements.Count-1 do
|
|
write(s,' SMT ',l,' ',TPasElement(lsmt.Elements[l]).Name);
|
|
writeln('}');
|
|
end;
|
|
DoSem:=false;
|
|
end;
|
|
if not DoNoSem then
|
|
begin
|
|
if DoSem then writeln(';');
|
|
end
|
|
else writeln;
|
|
end;
|
|
|
|
|
|
//result: result of TPasImplBlock or valid element
|
|
//NoFirstIndent only for block in case:
|
|
function GetTPasImplElement(le:TPasImplElement; lindent:integer;
|
|
lLastNoSem,NoFirstIndent:boolean):boolean;
|
|
var liie:TPasImplIfElse;
|
|
lico:TPasImplCaseOf;
|
|
lice:TPasImplCaseElse;
|
|
liru:TPasImplRepeatUntil;
|
|
lit:TPasImplTry;
|
|
//lic:TPasImplCommand;
|
|
s,s1:String;//s1 only first line of block statement
|
|
|
|
begin
|
|
Result:=true;
|
|
s:=GetIndent(lindent);
|
|
if NoFirstIndent then s1:=' ' else s1:=s;
|
|
if le is TPasImplStatement then
|
|
begin
|
|
if NoFirstIndent then lindent:=0;
|
|
GetTPasSmt(TPasImplStatement(le),lindent+1,lLastNoSem,NoFirstIndent);
|
|
end
|
|
else if le is TPasImplIfElse then
|
|
begin
|
|
liie:=TPasImplIfElse(le);
|
|
write(s1,'if ',DelQuot(liie.Condition),' then ');
|
|
if assigned(liie.ElseBranch) then
|
|
begin
|
|
writeln;
|
|
GetTPasImplElement(liie.IfBranch,lindent+1,true,false);
|
|
writeln(s,'else');// {if}');
|
|
GetTPasImplElement(liie.ElseBranch,lindent+1,lLastNoSem,false);
|
|
end
|
|
else
|
|
begin //no else part
|
|
if assigned(liie.IfBranch) then
|
|
begin
|
|
writeln;
|
|
if not GetTPasImplElement(liie.IfBranch,lindent+1,false,false) then
|
|
writeln(';');
|
|
end
|
|
else writeln(';'); //empty if then;
|
|
end;
|
|
end
|
|
else if le is TPasImplCaseOf then
|
|
begin
|
|
lico:=TPasImplCaseOf(le);
|
|
writeln(s1,'case ',lico.Expression,' of ');
|
|
if assigned(lico.ElseBranch) then //workaround duplicate bug
|
|
begin //reduce count of CaseOf as CaseElse is in there
|
|
lice:=lico.ElseBranch;
|
|
GetTPasImplBlock(TPasImplBlock(lico),lindent+1,1,false,false);
|
|
end
|
|
else GetTPasImplBlock(TPasImplBlock(lico),lindent+1,0,false,false); // !! else duplicate in here
|
|
if assigned(lico.ElseBranch) then
|
|
begin
|
|
writeln(s,'else');//' {case}');
|
|
lice:=lico.ElseBranch;
|
|
GetTPasImplBlock(TPasImplBlock(lice),lindent+1,0,false,false);
|
|
end;
|
|
if lLastNoSem then writeln(s,'end')//' {case}')
|
|
else writeln(s,'end;');// {case}');
|
|
//Result:=false; ??? GetTPasImplBlock
|
|
end
|
|
else if le is TPasImplRepeatUntil then
|
|
begin
|
|
liru:=TPasImplRepeatUntil(le);
|
|
writeln(s1,'repeat');
|
|
GetTPasImplBlock(TPasImplBlock(liru),lindent+1,0,false,false);
|
|
write(s,'until ',DelQuot(liru.Condition));
|
|
if lLastNoSem then writeln
|
|
else writeln(';');
|
|
end
|
|
else if le is TPasImplTryFinally then
|
|
begin
|
|
writeln(s,'finally');
|
|
GetTPasImplBlock(TPasImplBlock(le),lindent+1,0,false,false);
|
|
end
|
|
else if le is TPasImplTryExcept then
|
|
begin
|
|
writeln(s,'except');
|
|
GetTPasImplBlock(TPasImplBlock(le),lindent+1,0,false,false);
|
|
end
|
|
else if le is TPasImplTryExceptElse then
|
|
begin
|
|
writeln(s,'else');// {try}');
|
|
GetTPasImplBlock(TPasImplBlock(le),lindent+1,0,false,false);
|
|
end
|
|
else if le is TPasImplTry then
|
|
begin
|
|
lit:=TPasImplTry(le);
|
|
writeln(s1,'try');
|
|
GetTPasImplBlock(TPasImplBlock(le),lindent+1,0,false,false);
|
|
if assigned(lit.FinallyExcept) then
|
|
GetTPasImplElement(TPasImplElement(lit.FinallyExcept),lindent+1,false,false);
|
|
if assigned(lit.ElseBranch) then
|
|
GetTPasImplElement(TPasImplElement(lit.ElseBranch),lindent+1,false,false);
|
|
if lLastNoSem then writeln(s,'end')// {try} ') //there is no ImplBeginBlock
|
|
else writeln(s,'end;');// {try} ');
|
|
end
|
|
else if le is TPasImplCommand then
|
|
begin
|
|
//ignore because empty
|
|
// lic:=TPasImplCommand(le);
|
|
// writeln(' CMD ',lic.Command,' ',lic.Name,' ',lic.ElementTypeName);
|
|
end
|
|
else if le is TPasImplLabelMark then
|
|
begin
|
|
writeln(s1,'label ',TPasImplLabelMark(le).LabelId,';');
|
|
end
|
|
else if le is TPasImplBlock then
|
|
begin
|
|
//IfElse, case:
|
|
Result:=GetTPasImplBlock(TPasImplBlock(le),lindent+1,0,lLastNoSem,NoFirstIndent);
|
|
end
|
|
else
|
|
begin
|
|
Result:=false;
|
|
//writeln(s,';');
|
|
//writeln(' EL ',l);//,' ',le.Name)//,' ',le.ElementTypeName,' ',le.FullName);
|
|
end;
|
|
end;
|
|
|
|
// indent: indent from page left side
|
|
// DecListBy: dec(elements.count) because of case duplicate else bug
|
|
// LastNoSem: only true on last expr before else in a if clause
|
|
// NoFirstIndent: if line was started by other block like in case at -> 1:Noindent;
|
|
// Result: true if elements not empty
|
|
function GetTPasImplBlock(lb:TPasImplBlock; indent,declistby:integer;
|
|
LastNoSem,NoFirstIndent:boolean):boolean;
|
|
var l,n:integer;
|
|
lbe:TPasImplElement;
|
|
NoSem:boolean;
|
|
ls:String;
|
|
|
|
begin
|
|
Result:=false;
|
|
NoSem:=false;
|
|
ls:=GetIndent(indent);
|
|
if not assigned(lb) then exit;
|
|
//if lb is TPasImplRaise then writeln('RAISE');
|
|
if assigned(lb.Elements) then
|
|
begin
|
|
if lb is TPasImplBeginBlock then
|
|
begin
|
|
NoSem:=LastNoSem;
|
|
LastNoSem:=false;
|
|
if NoFirstIndent then
|
|
begin
|
|
writeln('begin');////NFI');
|
|
NoFirstIndent:=false;
|
|
end
|
|
else writeln(ls,'begin');
|
|
inc(indent);
|
|
end;
|
|
|
|
if lb.Elements.Count >0 then
|
|
begin
|
|
Result:=true;
|
|
n:=lb.Elements.Count-1;
|
|
//workaround CaseOf duplicate bug
|
|
if (declistby >0)and(lb.Elements.Count >declistby) then dec(n,declistby);
|
|
for l:=0 to n do
|
|
begin
|
|
lbe:=TPasImplElement(lb.Elements[l]);
|
|
//write(l:2,'/',n:2,' '); //No of curent element, max element
|
|
if ((l = 0)and NoFirstIndent) then
|
|
begin //index0
|
|
if l=n then GetTPasImplElement(lbe,0,LastNoSem,false)
|
|
else GetTPasImplElement(lbe,0,false,false)
|
|
end
|
|
else if l<>n then GetTPasImplElement(lbe,indent,false,false) //other index
|
|
else GetTPasImplElement(lbe,indent,LastNoSem,false); //indexn
|
|
end;
|
|
end
|
|
else
|
|
begin //block is empty
|
|
//write(ls,' {!EMPTY!}');
|
|
{if not NoSem then
|
|
begin
|
|
if lb is TPasImplBeginBlock then writeln //empty compound need no ;
|
|
else writeln(';')
|
|
end
|
|
else
|
|
writeln;}
|
|
end;
|
|
if lb is TPasImplBeginBlock then
|
|
if not NoSem then writeln(ls,'end;')// {Block}')
|
|
else writeln(ls,'end');// {Block}');
|
|
end
|
|
else
|
|
writeln(';'); //writeln(' {!empty!};')
|
|
end;
|
|
|
|
|
|
//# Declarations (type,var,const,..)
|
|
|
|
procedure GetTPasArrayType(lpat:TPasArrayType);
|
|
begin
|
|
if lpat.IsPacked then write('packed ');
|
|
write('Array');
|
|
if lpat.IndexRange <> '' then write('[',lpat.IndexRange,']');
|
|
if assigned(lpat.ElType) then write(' of ',lpat.ElType.Name);
|
|
// BUG: of const missing in Procedure ConstArrayArgProc(A: Array of const); pparser: 643
|
|
end;
|
|
|
|
//write out one variable or constant declaration, also used in types
|
|
//In spite of the use of GetPasVariables this is still used !
|
|
procedure GetTPasVar(lpv:TPasVariable; lindent:integer; NoLF:boolean);//BUG string[] pparser: 482
|
|
var i,j:integer;
|
|
//lppt:TPasProcedureType;
|
|
//lpa:TPasArgument;
|
|
//lpat:TPasArrayType;
|
|
s,s1:string;
|
|
prct:TPasRecordType;
|
|
|
|
begin
|
|
if not Assigned(lpv) then exit;
|
|
s:=GetIndent(lindent);
|
|
write(s,lpv.Name);//,' ',lpv.value,' ',lpv.Modifiers,' ',lpv.AbsoluteLocation);
|
|
if assigned(lpv.VarType) then
|
|
begin
|
|
//if TPasType(lpa.ArgType).ElementTypeName <>'unresolved type reference' then
|
|
//,TPasType(lpa.ArgType).Name,' ');//,TPasType(lpa.ArgType).FullName,TPasType(lpa.ArgType).ElementTypeName)
|
|
// PParser 2099: ArgType := nil; if IsUntyped then => Arg.ArgType := ArgType;
|
|
// else write(':? ');
|
|
write(': ');
|
|
if lpv.VarType is TPasArrayType then
|
|
begin
|
|
GetTPasArrayType(TPasArrayType(lpv.VarType));
|
|
end
|
|
else if lpv.VarType is TPasSetType then
|
|
begin
|
|
write('set of ',TPasSetType(lpv.VarType).EnumType.Name);
|
|
end
|
|
else
|
|
begin
|
|
if lpv.VarType is TPasPointerType then
|
|
write('^',TPasPointerType(lpv.VarType).DestType.Name)
|
|
else if lpv.VarType is TPasRecordType then //var record
|
|
begin
|
|
j:=lindent+Length(lpv.Name)+4;
|
|
s1:=GetIndent(j);
|
|
prct:=TPasRecordType(lpv.VarType);
|
|
if prct.IsBitPacked then write('bitpacked ');
|
|
if prct.IsPacked then write('packed ');
|
|
writeln('Record');
|
|
for i:=0 to prct.Members.Count-1 do
|
|
begin
|
|
GetTPasVar(TPasVariable(prct.Members[i]),j+1,false);
|
|
end;
|
|
write(s1,'end');
|
|
end
|
|
else
|
|
begin
|
|
write(TPasType(lpv.VarType).Name);
|
|
//if TPasType(lpv.VarType) is TPasAliasType then write(TPasAliasType(lpv.VarType).Name);
|
|
end;
|
|
end;
|
|
end;
|
|
if lpv.Value <> '' then write('=',lpv.Value);
|
|
if assigned(lpv.Expr) then // var ?, const AnArrayConst : Array[1..3] of Integer = (1,2,3);
|
|
begin
|
|
write('=');
|
|
GetTPasExpr(lpv.Expr);
|
|
end;
|
|
|
|
if lpv.Modifiers <>'' then //Modifiers starts with ;
|
|
begin
|
|
write(' ',lpv.Modifiers,';');
|
|
if GetTPasMemberHints(lpv.Hints) then write(';');
|
|
end
|
|
else
|
|
begin
|
|
GetTPasMemberHints(lpv.Hints);
|
|
write(';');
|
|
end;
|
|
if not NoLF then writeln;
|
|
end;
|
|
|
|
//write out a list of variables only
|
|
//more compact than the output of seperate calls of GetTPasVar
|
|
procedure GetPasVariables(vl:TFPList; lindent:integer; NoLF,NoSEM:boolean);
|
|
var v,i,j:integer;
|
|
s,s1:string;
|
|
prct:TPasRecordType;
|
|
lpv:TPasVariable;
|
|
|
|
same:boolean;
|
|
samestr,tmpstr:Ansistring;
|
|
samevar:array of integer;
|
|
svi:integer;
|
|
|
|
begin
|
|
if vl.Count <= 0 then exit;
|
|
s:=GetIndent(lindent);
|
|
//> compare all variable types as string to find the ones with same type
|
|
samestr:='';
|
|
svi:=0;
|
|
SetLength(samevar,vl.count);
|
|
for v:=0 to vl.count-1 do
|
|
begin
|
|
tmpstr:='';
|
|
same:=true;
|
|
lpv:=TPasVariable(vl[v]);
|
|
//write(s,lpv.Name);
|
|
if assigned(lpv.VarType) then
|
|
begin
|
|
tmpstr:=tmpstr+': ';
|
|
if lpv.VarType is TPasArrayType then
|
|
begin
|
|
//GetTPasArrayType(TPasArrayType(lpv.VarType));
|
|
tmpstr:=tmpstr+'array'+TPasArrayType(lpv.VarType).IndexRange;
|
|
if assigned(TPasArrayType(lpv.VarType).ElType) then
|
|
tmpstr:=tmpstr+TPasArrayType(lpv.VarType).ElType.Name;
|
|
end
|
|
else if lpv.VarType is TPasSetType then
|
|
begin
|
|
tmpstr:=tmpstr+'set of '+TPasSetType(lpv.VarType).EnumType.Name;
|
|
end
|
|
else
|
|
begin
|
|
if lpv.VarType is TPasPointerType then
|
|
tmpstr:=tmpstr+'^'+TPasPointerType(lpv.VarType).DestType.Name
|
|
else if lpv.VarType is TPasRecordType then //var record
|
|
begin
|
|
prct:=TPasRecordType(lpv.VarType);
|
|
if prct.IsBitPacked then tmpstr:=tmpstr+'bitpacked ';
|
|
if prct.IsPacked then tmpstr:=tmpstr+'packed ';
|
|
tmpstr:=tmpstr+'Record ';
|
|
for i:=0 to prct.Members.Count-1 do
|
|
begin
|
|
//todo
|
|
//GetTPasVar(TPasVariable(prct.Members[i]),j+1,false);
|
|
end;
|
|
tmpstr:=tmpstr+'end';
|
|
end
|
|
else
|
|
begin
|
|
tmpstr:=tmpstr+TPasType(lpv.VarType).Name;
|
|
end;
|
|
end;
|
|
end
|
|
else same:=false;
|
|
if lpv.Value <> '' then same:=false;//=
|
|
if assigned(lpv.Expr) then // var ?, const AnArrayConst : Array[1..3] of Integer = (1,2,3);
|
|
begin
|
|
same:=false;//=
|
|
end;
|
|
if lpv.Modifiers <>'' then //Modifiers starts with ;
|
|
begin
|
|
tmpstr:=tmpstr+' '+lpv.Modifiers+';';
|
|
tmpstr:=tmpstr+ReturnTPasMemberHints(lpv.Hints);
|
|
end
|
|
else
|
|
begin
|
|
tmpstr:=tmpstr+ReturnTPasMemberHints(lpv.Hints);
|
|
end;
|
|
//if v = 0 then begin samestr:=tmpstr; end;
|
|
if (not same)or(samestr <> tmpstr) then
|
|
begin
|
|
samestr:=tmpstr;
|
|
inc(svi);
|
|
end;
|
|
samevar[v]:=svi;
|
|
end;
|
|
//compare <
|
|
//now print them
|
|
svi:=-1;
|
|
for v:=0 to vl.count-1 do
|
|
begin
|
|
lpv:=TPasVariable(vl[v]);
|
|
if not Assigned(lpv) then continue;
|
|
if svi <> samevar[v] then
|
|
begin
|
|
svi:=samevar[v];
|
|
if v>0 then writeln;
|
|
write(s,lpv.Name);//variblenname
|
|
end
|
|
else write(lpv.Name);
|
|
if (v < vl.Count-1)and(samevar[v+1]=svi) then write(',')
|
|
else
|
|
begin
|
|
if assigned(lpv.VarType) then
|
|
begin
|
|
write(': ');
|
|
if lpv.VarType is TPasArrayType then
|
|
begin
|
|
GetTPasArrayType(TPasArrayType(lpv.VarType));
|
|
end
|
|
else if lpv.VarType is TPasSetType then
|
|
begin
|
|
write('set of ',TPasSetType(lpv.VarType).EnumType.Name);
|
|
end
|
|
else
|
|
begin
|
|
if lpv.VarType is TPasPointerType then
|
|
write('^',TPasPointerType(lpv.VarType).DestType.Name)
|
|
else if lpv.VarType is TPasRecordType then //var record
|
|
begin
|
|
j:=lindent+Length(lpv.Name)+4;
|
|
s1:=GetIndent(j);
|
|
prct:=TPasRecordType(lpv.VarType);
|
|
if prct.IsBitPacked then write('bitpacked ');
|
|
if prct.IsPacked then write('packed ');
|
|
writeln('Record');
|
|
{for i:=0 to prct.Members.Count-1 do
|
|
begin
|
|
GetTPasVar(TPasVariable(prct.Members[i]),j+1,false);
|
|
end;}
|
|
if prct.Members.Count > 0 then
|
|
GetPasVariables(prct.Members,j+1,false,false);
|
|
write(s1,'end');
|
|
end
|
|
else
|
|
begin
|
|
write(TPasType(lpv.VarType).Name);
|
|
end;
|
|
end;
|
|
end;
|
|
if lpv.Value <> '' then write('=',lpv.Value);
|
|
if assigned(lpv.Expr) then // var ?, const AnArrayConst : Array[1..3] of Integer = (1,2,3);
|
|
begin
|
|
write('=');
|
|
GetTPasExpr(lpv.Expr);
|
|
end;
|
|
|
|
if lpv.Modifiers <>'' then //Modifiers starts with ;
|
|
begin
|
|
write(' ',lpv.Modifiers,';');
|
|
if GetTPasMemberHints(lpv.Hints) then write(';');
|
|
end
|
|
else
|
|
begin
|
|
GetTPasMemberHints(lpv.Hints);
|
|
if (v < vl.Count-1) then write(';')
|
|
else if (not NoSEM) then write(';');
|
|
end;
|
|
//if not NoLF then writeln;
|
|
end;
|
|
end;
|
|
if not NoLF then writeln;
|
|
end;
|
|
|
|
function GetTPasArgumentAccess(acc:TArgumentAccess):String;
|
|
|
|
begin
|
|
Result:='';
|
|
case acc of
|
|
//argDefault:Result:='default'; //normal proccall is default
|
|
argConst:Result:='const';
|
|
argVar:Result:='var';
|
|
argOut:Result:='out';
|
|
end;
|
|
end;
|
|
|
|
procedure GetTPasProcedureType(lppt:TPasProcedureType; indent:integer);
|
|
|
|
Var
|
|
l : integer;
|
|
lpa:TPasArgument;
|
|
samevar:array of integer;//same index same type
|
|
aktaa:TArgumentAccess;
|
|
svi:integer;
|
|
same:boolean;
|
|
aktname,tmpname:String;
|
|
|
|
begin
|
|
if assigned(lppt.Args) and (lppt.Args.Count > 0) then
|
|
begin
|
|
write('(');
|
|
if lppt.Args.Count > 0 then
|
|
begin
|
|
//produce more compact output than the commented block below
|
|
//>find same declaration
|
|
//look ahead what is the same
|
|
SetLength(samevar,lppt.Args.Count);
|
|
svi:=0;
|
|
aktname:='';
|
|
for l:=0 to lppt.Args.Count-1 do
|
|
begin
|
|
same:=true;
|
|
tmpname:='';
|
|
lpa:=TPasArgument(lppt.Args.Items[l]);
|
|
if assigned(lpa.ArgType) then
|
|
begin
|
|
if lpa.ArgType is TPasArrayType then
|
|
begin
|
|
if assigned(TPasArrayType(lpa.ArgType).ElType) then tmpname:=TPasArrayType(lpa.ArgType).ElType.Name;
|
|
end
|
|
else tmpname:=TPasType(lpa.ArgType).Name;
|
|
end;
|
|
if l=0 then begin aktaa:=lpa.Access; aktname:=tmpname; end;
|
|
if lpa.Access <> aktaa then begin same:=false; aktaa:=lpa.Access; end;//access type
|
|
if (tmpname = '')or(tmpname <> aktname) then begin same:=false; aktname:=tmpname; end;//type name
|
|
if lpa.Value <> '' then same:=false;//var=value
|
|
if not same then inc(svi);
|
|
samevar[l]:=svi;
|
|
end;
|
|
//find same declaration<
|
|
svi:=-1;
|
|
same:=false;
|
|
for l:=0 to lppt.Args.Count-1 do
|
|
begin
|
|
lpa:=TPasArgument(lppt.Args.Items[l]);
|
|
if svi <> samevar[l] then
|
|
begin
|
|
svi:=samevar[l];
|
|
if lpa.Access <> argDefault then write(GetTPasArgumentAccess(lpa.Access),' ');
|
|
write(lpa.Name);//variblenname
|
|
end
|
|
else write(lpa.Name);
|
|
if (l < lppt.Args.Count-1)and(samevar[l+1]=svi) then write(',')
|
|
else
|
|
begin
|
|
if assigned(lpa.ArgType) then
|
|
begin
|
|
write(': ');
|
|
if lpa.ArgType is TPasArrayType then
|
|
GetTPasArrayType(TPasArrayType(lpa.ArgType))
|
|
else write(TPasType(lpa.ArgType).Name);
|
|
end;
|
|
if lpa.Value <> '' then write('=',lpa.Value);
|
|
if l< lppt.Args.Count-1 then write('; ');
|
|
end;
|
|
end;
|
|
write(')');
|
|
end;
|
|
end;
|
|
if (lppt is TPasFunctionType) then
|
|
write(': ',TPasFunctionType(lppt).ResultEl.ResultType.Name);
|
|
if lppt.IsOfObject then
|
|
write(' of Object');
|
|
end;
|
|
|
|
procedure GetTypes(pe:TPasElement; lindent:integer);
|
|
var i,j,k:integer;
|
|
s,s1,s2:string;
|
|
pet:TPasEnumType;
|
|
pev:TPasEnumValue;
|
|
|
|
prt:TPasRangeType;
|
|
prct:TPasRecordType;
|
|
pv:TPasVariant;
|
|
pst:TPasSetType;
|
|
|
|
|
|
function GetVariantRecord(pe:TPasElement; lindent:integer):boolean;
|
|
var i,j,k:integer;
|
|
prct:TPasRecordType;
|
|
pv:TPasVariant;
|
|
s,s1:string;
|
|
|
|
begin
|
|
Result:=false;
|
|
j:=lindent+Length(pe.Name)+2;
|
|
s:=GetIndent(lindent);
|
|
s1:=GetIndent(lindent+2);
|
|
prct:=TPasRecordType(pe);
|
|
{Now i use GetPasVariables for more compact output
|
|
for i:=0 to prct.Members.Count-1 do
|
|
begin
|
|
GetTPasVar(TPasVariable(prct.Members[i]),1,true);
|
|
end;}
|
|
if prct.Members.Count > 0 then GetPasVariables(prct.Members,1,true,true);
|
|
if assigned(prct.Variants) then
|
|
begin
|
|
Result:=true;
|
|
writeln(';');
|
|
write(s,'case ');
|
|
if prct.VariantEl.GetDeclaration(True) <>'' then write(prct.VariantEl.GetDeclaration(True),'=');
|
|
write(TPasType(prct.VariantEl).Name);
|
|
writeln(' of');
|
|
if assigned(prct.Variants)then
|
|
if prct.Variants.Count >0 then
|
|
begin
|
|
for i:=0 to prct.Variants.Count-1 do
|
|
begin
|
|
pv:=TPasVariant(prct.Variants[i]);
|
|
write(s1,pv.Name);
|
|
for k:=0 to pv.Values.Count-1 do write(TPasElement(pv.Values[k]).GetDeclaration(true));
|
|
write(': (');
|
|
if GetVariantRecord(TPasElement(pv.Members),j+1) then
|
|
writeln(s1,');')
|
|
else writeln(');');
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
begin
|
|
s:=GetIndent(lindent);
|
|
write(s,pe.Name,'=');
|
|
if pe is TPasArrayType then
|
|
begin
|
|
GetTPasArrayType(TPasArrayType(pe));
|
|
writeln(';');
|
|
end
|
|
else if pe is TPasEnumType then
|
|
begin
|
|
pet:=TPasEnumType(pe);
|
|
write('(');
|
|
if pet.Values.Count > 0 then
|
|
begin
|
|
for j:=0 to pet.Values.Count-2 do
|
|
begin
|
|
pev:=TPasEnumValue(pet.Values[j]);
|
|
write(pev.name,',');
|
|
//pev.Value ?
|
|
//pev.AssignedValue ?
|
|
//pev.IsValueUsed ?
|
|
end;
|
|
pev:=TPasEnumValue(pet.Values[pet.Values.Count-1]);
|
|
write(pev.name);
|
|
end;
|
|
writeln(');');
|
|
end
|
|
else if pe is TPasFileType then
|
|
begin
|
|
writeln('file of ',TPasFileType(pe).ElType.Name,';');
|
|
end
|
|
else if pe is TPasProcedureType then
|
|
begin
|
|
if pe is TPasFunctionType then
|
|
Write('function ')
|
|
else
|
|
Write('procedure ');
|
|
GetTPasProcedureType(TPasProcedureType(pe), lindent);
|
|
Writeln(';');
|
|
end
|
|
else if pe is TPasPointerType then
|
|
begin
|
|
//writeln('pointer');
|
|
writeln('^',TPasPointerType(pe).DestType.Name,';');
|
|
end
|
|
else if pe is TPasRangeType then
|
|
begin
|
|
prt:=TPasRangeType(pe);
|
|
writeln(prt.RangeStart,'..',prt.RangeEnd,';');
|
|
end
|
|
else if pe is TPasRecordType then
|
|
begin
|
|
j:=lindent+Length(pe.Name)+2;
|
|
s1:=GetIndent(j);
|
|
s2:=GetIndent(j+1);
|
|
prct:=TPasRecordType(pe);
|
|
if prct.IsBitPacked then write('bitpacket ');
|
|
if prct.IsPacked then write('packet');
|
|
writeln('record');
|
|
{Now i use GetPasVariables for more compact output
|
|
for i:=0 to prct.Members.Count-1 do
|
|
begin
|
|
GetTPasVar(TPasVariable(prct.Members[i]),j+1,false);
|
|
end;}
|
|
GetPasVariables(prct.Members,j+2,false,false);
|
|
if assigned(prct.Variants) then
|
|
begin
|
|
write(s1,'case ');
|
|
if prct.VariantEl.Name <>'' then write(prct.VariantEl.Name,'=');
|
|
write(TPasType(prct.VariantEl).Name);
|
|
writeln(' of');
|
|
if assigned(prct.Variants)then
|
|
if prct.Variants.Count >0 then
|
|
begin
|
|
for i:=0 to prct.Variants.Count-1 do
|
|
begin
|
|
pv:=TPasVariant(prct.Variants[i]);
|
|
write(s2,pv.Name);
|
|
for k:=0 to pv.Values.Count-1 do write(TPasElement(pv.Values[k]).GetDeclaration(true));
|
|
write(': (');
|
|
if GetVariantRecord(TPasElement(pv.Members),j+2) then
|
|
writeln(s2,');')
|
|
else writeln(');');
|
|
end;
|
|
end;
|
|
end;
|
|
writeln(s1,'end;');
|
|
end
|
|
else if pe is TPasSetType then
|
|
begin
|
|
pst:=TPasSetType(pe);
|
|
writeln('set of ',pst.EnumType.Name,';');
|
|
end
|
|
else if pe is TPasClassOfType then writeln('Class of ',TPasClassOfType(pe).DestType.Name,';')
|
|
else if pe is tPasAliasType then
|
|
begin
|
|
pe:=tPasAliasType(PE).DestType;
|
|
write(PE.name);
|
|
if pe is tPasStringType then
|
|
begin
|
|
if (TPasStringType(PE).LengthExpr<>'') then
|
|
Write('[',TPasStringType(PE).LengthExpr,']');
|
|
end;
|
|
Writeln(';');
|
|
end
|
|
else if pe is tPasUnresolvedTypeRef then writeln(TPasUnresolvedTypeRef(PE).name,';')
|
|
else
|
|
begin
|
|
|
|
writeln('{ Unknown TYPE(s): ');
|
|
writeln(s,pe.Name,' ',pe.classname);
|
|
writeln('}');
|
|
writeln;
|
|
end;
|
|
end;
|
|
|
|
|
|
|
|
procedure GetTCallingConvention(cc:TCallingConvention); //TODO: test it
|
|
begin
|
|
case cc of
|
|
//ccDefault:write(' default;'); //normal proccall is default
|
|
ccRegister:WriteFmt(true,'Register;',false);
|
|
ccPascal :WriteFmt(true,'Pascal;',false);
|
|
ccCDecl :WriteFmt(true,'CDecl;',false);
|
|
ccStdCall :WriteFmt(true,'StdCall;',false);
|
|
ccOldFPCCall:WriteFmt(true,'OldFPCall;',false);
|
|
ccSafeCall:WriteFmt(true,'SaveCall;',false);
|
|
end;
|
|
end;
|
|
|
|
procedure GetHiddenModifiers(Mfs:TProcTypeModifiers);
|
|
|
|
begin
|
|
if ptmVarargs in Mfs then WriteFmt(true,'varargs;',false);
|
|
end;
|
|
|
|
procedure GetHiddenModifiers(Mfs:TProcedureModifiers);
|
|
begin
|
|
if pmInline in Mfs then WriteFmt(true,'inline;',false);
|
|
if pmAssembler in Mfs then WriteFmt(true,'assembler;',false);
|
|
if pmCompilerProc in Mfs then WriteFmt(true,'compilerproc;',false);
|
|
end;
|
|
|
|
procedure GetTPasProcedure(lpp:TPasProcedure; indent:integer);
|
|
var l:integer;
|
|
lppt:TPasProcedureType;
|
|
s:String;
|
|
|
|
|
|
begin
|
|
if not Assigned(lpp) then exit;
|
|
s:=GetIndent(indent);
|
|
if lpp is TPasConstructor then write(s,'Constructor ')
|
|
else if TPasElement(lpp) is TPasConstructorImpl then write(s,'Constructor ')
|
|
else if lpp is TPasDestructor then write(s,'Destructor ')
|
|
else if TPasElement(lpp) is TPasDestructorImpl then write(s,'Destructor ')
|
|
else if lpp is TPasClassProcedure then write(s,'Class Procedure ') //pparser.pp: 3221
|
|
else if lpp is TPasClassFunction then write(s,'Class Function ')
|
|
else if lpp is TPasFunction then write(s,'Function ')
|
|
else write(s,'Procedure ');
|
|
write(lpp.Name);//,' ',lpp.TypeName);
|
|
if assigned(lpp.ProcType) then
|
|
begin
|
|
lppt:=lpp.ProcType;
|
|
GetTPasProcedureType(lppt,Indent);
|
|
end;
|
|
//writeln(';');
|
|
WriteFmt(false,'',true);
|
|
if lpp.IsVirtual then WriteFmt(true,'virtual;',false);
|
|
if lpp.IsOverload then WriteFmt(true,'overload;',false);
|
|
if lpp.IsAbstract then WriteFmt(true,'abstract;',false);
|
|
if lpp.IsDynamic then WriteFmt(true,'dynamic;',false);
|
|
if lpp.IsOverride then WriteFmt(true,'override;',false);
|
|
if lpp.IsExported then WriteFmt(true,'exported;',false);
|
|
if lpp.IsExternal then WriteFmt(true,'external;',false);
|
|
//pparser 2360: everyting behind external is ignored !!!
|
|
if lpp.IsMessage then
|
|
begin
|
|
write('message ');
|
|
if lpp.MessageType = pmtString then writeln(false,lpp.MessageName,true)
|
|
else WriteFmt(false,lpp.MessageName,true);//pmtInteger
|
|
end;
|
|
if lpp.IsReintroduced then WriteFmt(true,'reintroduce;',false);
|
|
if lpp.IsStatic then WriteFmt(true,'static;',false);
|
|
if lpp.IsForward then WriteFmt(true,'forward;',false);
|
|
GetHiddenModifiers(lpp.Modifiers);
|
|
GetHiddenModifiers(lpp.ProcType.Modifiers);
|
|
GetTCallingConvention(lpp.CallingConvention);
|
|
if GetTPasMemberHints(TPasElement(lpp).Hints) then WriteFmt(false,'',true); //BUG ? missing hints
|
|
if not Unformated then writeln;
|
|
end;
|
|
|
|
procedure GetTPasProcedureBody(pb:TProcedureBody; indent:integer);
|
|
var j:integer;
|
|
pd:TPasDeclarations;
|
|
pib:TPasImplBlock;
|
|
begin
|
|
if assigned(pb) then
|
|
begin
|
|
if assigned(pb.Body)then
|
|
begin
|
|
if assigned(TPasDeclarations(pb).Functions)then
|
|
begin
|
|
pd:=TPasDeclarations(pb);
|
|
if isim then
|
|
begin
|
|
//writeln;
|
|
GetDecls(pd,indent+1); //~recursion
|
|
//PrintDecls(pd,indent+1); //~recursion
|
|
end
|
|
else
|
|
if pd.Functions.Count >0 then //sub-functions
|
|
begin
|
|
for j:=0 to pd.Functions.Count-1 do
|
|
GetTPasProcedure(TPasProcedure(pd.Functions[j]),indent+1);
|
|
end;
|
|
end;
|
|
pib:=TPasImplBlock(pb.Body);
|
|
if assigned(pib) then
|
|
begin
|
|
GetTPasImplBlock(pib,indent,0,false,false); //indent depend on sub function level
|
|
if not Unformated then writeln; //('//block');
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure GetTpasOverloadedProc(pop:TPasOverloadedProc; indent:integer);
|
|
var pp:TPasProcedure;
|
|
j:integer;
|
|
begin
|
|
if assigned(pop) then
|
|
begin
|
|
if pop.Overloads.Count >0 then
|
|
begin
|
|
for j:=0 to pop.Overloads.Count-1 do
|
|
begin
|
|
pp:=TPasProcedure(pop.Overloads[j]);
|
|
GetTPasProcedure(pp,indent);
|
|
GetTPasProcedureBody(pp.Body,indent);
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function GetVisibility(v:TPasMemberVisibility):String;
|
|
begin
|
|
Result:='';
|
|
case v of
|
|
//visDefault:Result:='default';
|
|
visPrivate:Result:='private';
|
|
visProtected:Result:='protected';
|
|
visPublic:Result:='public';
|
|
visPublished:Result:='published';
|
|
visAutomated:Result:='automated';
|
|
visStrictPrivate:Result:='strictprivate';
|
|
visStrictProtected:Result:='strictprotected';
|
|
end;
|
|
end;
|
|
|
|
procedure GetTPasClass(pc:TPasClassType; indent:integer);
|
|
var j,l:integer;
|
|
s,s1,s2:String;
|
|
lpe:TPasElement;
|
|
lpp:TPasProperty;
|
|
lpa:TPasArgument;
|
|
vis:TPasMemberVisibility;
|
|
vars:TFPList;
|
|
IsVar:boolean;
|
|
|
|
procedure PrintVars;
|
|
begin
|
|
if vars.Count > 0 then GetPasVariables(vars,indent+1,false,false);
|
|
IsVar:=False;
|
|
vars.Clear;
|
|
end;
|
|
|
|
begin
|
|
if assigned(pc) then
|
|
begin
|
|
s:=GetIndent(indent);
|
|
if (pc.GenericTemplateTypes<>Nil) then
|
|
begin
|
|
write(s,'generic ',pc.Name);
|
|
for l:=0 to pc.GenericTemplateTypes.Count-1 do
|
|
begin
|
|
if l=0 then
|
|
Write('<')
|
|
else
|
|
Write(',');
|
|
Write(TPasGenericTemplateType(pc.GenericTemplateTypes[l]).Name);
|
|
end;
|
|
Write('> = ');
|
|
end
|
|
else
|
|
write(s,pc.Name,' = ');
|
|
if pc.IsPacked then write('packed ');
|
|
write(ObjKindNames[pc.ObjKind]);
|
|
if assigned(pc.AncestorType) and (pc.AncestorType.ElementTypeName <> '') then
|
|
begin
|
|
write('(',pc.AncestorType.Name,')');
|
|
end;
|
|
if pc.IsForward or pc.IsShortDefinition then //pparser.pp: 3417 :class(anchestor); is allowed !
|
|
begin
|
|
writeln(';');
|
|
exit;
|
|
end;
|
|
//Members: TFPList;
|
|
//InterfaceGUID: String;
|
|
//ClassVars: TFPList; //is this always empty ?
|
|
//Modifiers: TStringList;
|
|
//Interfaces: TFPList;
|
|
s1:=GetIndent(indent+1);
|
|
s2:=GetIndent(indent+2);
|
|
if pc.Members.Count > 0 then
|
|
begin
|
|
writeln;
|
|
vars:=TFPList.Create;
|
|
IsVar:=false;
|
|
for j:=0 to pc.Members.Count-1 do
|
|
begin
|
|
lpe:=TPasElement(pc.Members[j]);
|
|
|
|
//Class visibility, written on change
|
|
if j=0 then
|
|
begin
|
|
vis:=lpe.Visibility;
|
|
if GetVisibility(vis) <> '' then writeln(s1,GetVisibility(vis));
|
|
end
|
|
else
|
|
if vis <> lpe.Visibility then
|
|
begin
|
|
if IsVar then PrintVars;
|
|
if lpe.Visibility <> visDefault then //Class Function = visDefault
|
|
begin
|
|
vis:=lpe.Visibility;
|
|
if GetVisibility(vis) <> '' then writeln(s1,GetVisibility(vis));
|
|
end;
|
|
end;
|
|
|
|
if lpe is TPasOverloadedProc then
|
|
begin
|
|
if IsVar then PrintVars;
|
|
GetTPasOverloadedProc(TPasOverloadedProc(lpe),indent+2);
|
|
end
|
|
else if lpe is TPasProcedure then //TPasClassProcedure and
|
|
begin //TPasClassFunction are both child of TPasProcedure
|
|
if IsVar then PrintVars;
|
|
GetTPasProcedure(TPasProcedure(lpe),indent+2);
|
|
end
|
|
else if lpe is TPasProperty then
|
|
begin
|
|
if IsVar then PrintVars;
|
|
lpp:=TPasProperty(lpe);
|
|
write(s2,'property ',lpp.Name);
|
|
if lpp.Args.Count >0 then
|
|
begin
|
|
for l:=0 to lpp.Args.Count-1 do
|
|
begin
|
|
lpa:=TPasArgument(lpp.Args.Items[l]);
|
|
if GetTPasArgumentAccess(lpa.Access) <> '' then
|
|
write('[',GetTPasArgumentAccess(lpa.Access),' ',lpa.Name)
|
|
else write('[',lpa.Name); //variblename
|
|
if assigned(lpa.ArgType) then
|
|
begin
|
|
//if TPasType(lpa.ArgType).ElementTypeName <>'unresolved type reference' then
|
|
//,TPasType(lpa.ArgType).Name,' ');
|
|
//,TPasType(lpa.ArgType).FullName,TPasType(lpa.ArgType).ElementTypeName)
|
|
// PParser 2099: ArgType := nil; if IsUntyped then => Arg.ArgType := ArgType;
|
|
// else write(':? ');
|
|
write(': ');
|
|
if lpa.ArgType is TPasArrayType then
|
|
begin
|
|
GetTPasArrayType(TPasArrayType(lpa.ArgType));
|
|
end
|
|
else write(TPasType(lpa.ArgType).Name);
|
|
end;
|
|
if lpa.Value <> '' then write('=',lpa.Value);
|
|
write(']');
|
|
end;
|
|
end;//args
|
|
if assigned(lpp.VarType) then
|
|
begin
|
|
write(': ',TPasType(lpp.VarType).Name);
|
|
end;
|
|
if lpp.IndexValue <> '' then write(' Index ',lpp.IndexValue);
|
|
if lpp.ReadAccessorName <> '' then write(' Read ',lpp.ReadAccessorName);
|
|
if lpp.WriteAccessorName <> '' then write(' Write ',lpp.WriteAccessorName);
|
|
if lpp.ImplementsName <> '' then write(' Implements ',lpp.ImplementsName);
|
|
if lpp.IsDefault then write(' Default ',lpp.DefaultValue);
|
|
if lpp.IsNodefault then write(' NoDefault');
|
|
if lpp.StoredAccessorName <> '' then write(' Stored ',lpp.StoredAccessorName);
|
|
GetTPasMemberHints(lpp.Hints);
|
|
writeln(';');
|
|
end
|
|
else if lpe is TPasVariable then
|
|
begin
|
|
//this is done with printvars
|
|
//GetTPasVar(TPasVariable(lpe),indent+1,false);
|
|
IsVar:=true;
|
|
vars.add(lpe);
|
|
end
|
|
else
|
|
begin
|
|
if IsVar then PrintVars;
|
|
writeln('{ Unknown Declaration(s) in Class/Object/Interface: ');
|
|
writeln(s,lpe.Name);
|
|
writeln('}');
|
|
end;
|
|
end;
|
|
//writeln(s,'end;');//'//class');
|
|
if IsVar then PrintVars;
|
|
vars.free;
|
|
end
|
|
else writeln;//(';'); //x=class(y);
|
|
|
|
writeln(s,'end;');
|
|
end;
|
|
end;
|
|
|
|
|
|
procedure GetDecls(Decl:TPasDeclarations; indent:integer);
|
|
var i,j:integer;
|
|
pe:TPasElement;
|
|
pp:TPasProcedure;
|
|
ps:TPasSection;
|
|
s:string;
|
|
x:(None,ResStrings,Types,Consts,Classes,Functions,Variables,Properties);
|
|
l:TFPList;
|
|
|
|
procedure PrintVars;
|
|
begin
|
|
if l.Count > 0 then GetPasVariables(l,indent+1,false,false);
|
|
end;
|
|
|
|
begin
|
|
s:=GetIndent(indent);
|
|
x:=None;
|
|
if assigned(Decl)then
|
|
begin
|
|
l:=TFPList.Create;
|
|
pe:=TPasElement(Decl);
|
|
if pe is TPasSection then
|
|
begin
|
|
{(Decl is TInterfaceSection)or(Decl is TImplementationSection) or
|
|
(Decl is TProgramSection}
|
|
ps:=TPasSection(pe);
|
|
if ps.UsesList.Count >0 then
|
|
begin
|
|
write(s,'uses ');
|
|
ps:=TPasSection(Decl);
|
|
if not Unformated then begin writeln; write(s,' '); end;
|
|
for i:=0 to ps.UsesList.Count-2 do
|
|
if UpCase(TPasElement(ps.UsesList[i]).Name) = 'SYSTEM' then continue //do not print system
|
|
else write(TPasElement(ps.UsesList[i]).Name,','); //as it is added by parser
|
|
writeln(TPasElement(ps.UsesList[ps.UsesList.Count-1]).Name,';');
|
|
if not Unformated then writeln;
|
|
end;
|
|
end;
|
|
if assigned(Decl.Declarations)and(Decl.Declarations.Count > 0) then
|
|
for j:=0 to Decl.Declarations.Count-1 do
|
|
begin
|
|
pe:=TPasElement(Decl.Declarations[j]);
|
|
if pe is TPasResString then
|
|
begin
|
|
if x = Variables then PrintVars;
|
|
if x <> ResStrings then
|
|
begin
|
|
if not Unformated then writeln;
|
|
writeln(s,'ResourceString');
|
|
x:=ResStrings;
|
|
end;
|
|
writeln(s,pe.Name,'=',DelQuot(TPasResString(pe).Expr.GetDeclaration(false)),';'); //too much '''
|
|
end
|
|
else if pe is TPasConst then
|
|
begin
|
|
if x = Variables then PrintVars;
|
|
if x <> Consts then
|
|
begin
|
|
if not Unformated then writeln;
|
|
writeln(s,'const');
|
|
x:=Consts;
|
|
end;
|
|
GetTPasVar(TPasVariable(pe),indent+1,false);
|
|
end
|
|
else if pe is TPasVariable then
|
|
begin
|
|
if x <> Variables then
|
|
begin
|
|
if not Unformated then writeln;
|
|
writeln(s,'var');
|
|
x:=Variables;
|
|
l.Clear;
|
|
end;
|
|
l.Add(pe);
|
|
//this is done with printvars
|
|
//GetTPasVar(TPasVariable(pe),indent+1,false);
|
|
end
|
|
else if pe is TPasClassType then
|
|
begin
|
|
if x = Variables then PrintVars;
|
|
if x <> Types then
|
|
begin
|
|
if not Unformated then writeln;
|
|
writeln(s,'Type');
|
|
x:=Types;
|
|
end;
|
|
GetTPasClass(TPasClassType(pe),indent+1);
|
|
end
|
|
else if pe is TPasType then
|
|
begin
|
|
if x = Variables then PrintVars;
|
|
if x <> Types then
|
|
begin
|
|
if not Unformated then writeln;
|
|
writeln(s,'Type');
|
|
x:=Types;
|
|
end;
|
|
GetTypes(TPasElement(pe),indent+1);
|
|
end
|
|
else if pe is TPasProcedureBase then
|
|
begin
|
|
if x = Variables then PrintVars;
|
|
if (x <> Functions)and not Unformated then writeln;
|
|
x:=Functions;
|
|
if pe is TPasOverloadedProc then
|
|
begin
|
|
GetTpasOverloadedProc(TPasOverloadedProc(pe),indent);
|
|
end
|
|
else
|
|
begin
|
|
pp:=TPasProcedure(pe);
|
|
GetTPasProcedure(pp,indent);
|
|
GetTPasProcedureBody(pp.Body,indent);
|
|
end;
|
|
end
|
|
else
|
|
begin
|
|
if x = Variables then PrintVars;
|
|
x:=None;
|
|
writeln('{ Unknown Declaration: ',pe.Name,' }');
|
|
end;
|
|
end;
|
|
if x = Variables then PrintVars;
|
|
l.Free;
|
|
end;
|
|
end;
|
|
|
|
{replaced by GetDecls
|
|
this does the same but not in true order
|
|
|
|
procedure PrintDecls(Decl:TPasDeclarations; indent:integer);
|
|
var i:integer;
|
|
pe:TPasElement;
|
|
pp:TPasProcedure;
|
|
ps:TPasSection;
|
|
s:string;
|
|
istype:boolean;
|
|
|
|
begin
|
|
istype:=false;
|
|
s:=GetIndent(indent);
|
|
if (Decl is TInterfaceSection)or(Decl is TImplementationSection) or
|
|
(Decl is TProgramSection) then
|
|
if TPasSection(Decl).UsesList.Count >0 then
|
|
begin
|
|
write(s,'uses ');
|
|
ps:=TPasSection(Decl);
|
|
if not Unformated then begin writeln; write(s,' '); end;
|
|
for i:=0 to ps.UsesList.Count-2 do
|
|
if UpCase(TPasElement(ps.UsesList[i]).Name) = 'SYSTEM' then continue //do not print system
|
|
else write(TPasElement(ps.UsesList[i]).Name,','); //as it is added by parser
|
|
writeln(TPasElement(ps.UsesList[ps.UsesList.Count-1]).Name,';');
|
|
if not Unformated then writeln;
|
|
end;
|
|
|
|
if assigned(Decl.ResStrings) then
|
|
if Decl.ResStrings.Count >0 then
|
|
begin
|
|
writeln('ResourceString');
|
|
for i := 0 to Decl.ResStrings.Count - 1 do
|
|
begin
|
|
pe:=TPasElement(Decl.ResStrings[i]);
|
|
writeln(s,pe.Name,'=',DelQuot(TPasResString(pe).Value),';'); //too much '''
|
|
end;
|
|
if not Unformated then writeln;
|
|
end;
|
|
|
|
if assigned(Decl.Consts)then
|
|
if Decl.Consts.Count >0 then
|
|
begin
|
|
writeln(s,'const');
|
|
for i:=0 to Decl.Consts.Count-1 do GetTPasVar(TPasVariable(Decl.Consts[i]),indent+1,false);
|
|
if not Unformated then writeln;
|
|
end;
|
|
|
|
if assigned(Decl.Types) then
|
|
if Decl.Types.Count >0 then
|
|
begin
|
|
writeln(s,'Type');
|
|
for i := 0 to Decl.Types.Count - 1 do
|
|
begin
|
|
GetTypes(TPasElement(Decl.Types[i]),indent+1);
|
|
end;
|
|
if not Unformated then writeln;
|
|
istype:=true;
|
|
end;
|
|
|
|
if assigned(Decl.Classes) then
|
|
if Decl.Classes.Count >0 then
|
|
begin
|
|
if not istype then writeln('Type');
|
|
for i := 0 to Decl.Classes.Count - 1 do
|
|
begin
|
|
pe:=TPasElement(Decl.Classes[i]);
|
|
GetTPasClass(TPasClassType(pe),indent+1);
|
|
if not Unformated then writeln;
|
|
end;
|
|
end;
|
|
|
|
if assigned(Decl.Variables)then
|
|
if Decl.Variables.Count >0 then
|
|
begin
|
|
writeln(s,'var');
|
|
//Now i use GetPasVariables for more compact output
|
|
//for i:=0 to Decl.Variables.Count-1 do GetTPasVar(TPasVariable(Decl.Variables[i]),indent+1,false);
|
|
GetPasVariables(Decl.Variables,indent+1,false,false);
|
|
if not Unformated then writeln;
|
|
end;
|
|
|
|
if assigned(Decl.Functions) then
|
|
begin
|
|
for i := 0 to Decl.Functions.Count - 1 do
|
|
begin
|
|
pe:=TPasElement(Decl.Functions[i]);
|
|
if pe is TPasOverloadedProc then
|
|
begin
|
|
GetTpasOverloadedProc(TPasOverloadedProc(pe),indent);
|
|
end
|
|
else
|
|
begin
|
|
pp:=TPasProcedure(pe);
|
|
GetTPasProcedure(pp,indent);
|
|
GetTPasProcedureBody(pp.Body,indent);
|
|
end;
|
|
end;
|
|
end;
|
|
end; }
|
|
|
|
//# parameter
|
|
|
|
procedure PrintUsage;
|
|
begin
|
|
writeln('usage: test_parser1 <Options> <Commandline> File');
|
|
writeln;
|
|
writeln(' <Options> : Options for test_parser1');
|
|
writeln(' -u : Unformated output');
|
|
writeln(' -OS <os> : <os> = WINDOWS, LINUX (default), FREEBSD, NETBSD,');
|
|
writeln(' SUNOS, BEOS, QNX, GO32V2');
|
|
writeln(' -CPU <cpu> : <cpu> = i386 (default), x86_64');
|
|
writeln(' <Commandline> : is the commandline for the parser');
|
|
writeln(' -d<define> : <define> = Directive');
|
|
writeln(' -Fi<include_path> : <include_path> = ?');
|
|
writeln(' -I<include_path> : <include_path> = ?');
|
|
writeln(' -Sd : mode delphi');
|
|
writeln(' File : a pascal source file (Program or Unit)');
|
|
end;
|
|
|
|
procedure GetParam;
|
|
begin
|
|
if paramcount>0 then
|
|
begin
|
|
cmdl:='';
|
|
i:=1;
|
|
repeat
|
|
if paramstr(i) = '-h' then
|
|
begin
|
|
PrintUsage;
|
|
halt(0);
|
|
end
|
|
else if paramstr(i) = '-u' then Unformated:= true
|
|
else if paramstr(i) = '-OS' then
|
|
begin
|
|
if i < paramcount then
|
|
begin
|
|
inc(i);
|
|
TargetOS:=paramstr(i);
|
|
if (TargetOS = '')or(TargetOS[1] = '-') then halt(1);
|
|
end
|
|
else halt(1);
|
|
end
|
|
else if paramstr(i) = '-CPU' then
|
|
begin
|
|
if i < paramcount then
|
|
begin
|
|
inc(i);
|
|
TargetCPU:=paramstr(i);
|
|
if (TargetCPU = '')or(TargetCPU[1] = '-') then halt(1);
|
|
end
|
|
else halt(1);
|
|
end
|
|
else
|
|
cmdl:=cmdl+' '+paramstr(i);
|
|
inc(i);
|
|
until i > paramcount;
|
|
end;
|
|
if (Paramcount < 1)or(cmdl = '') then
|
|
begin
|
|
// remember to put the whole cmdline in quotes, and
|
|
// to always add some path options. Even if only -Fu. -Fi.
|
|
writeln('Error: No file for input given !');
|
|
PrintUsage;
|
|
halt(1);
|
|
end;
|
|
end;
|
|
|
|
//# *** main ***
|
|
|
|
begin
|
|
isim:=false;
|
|
Unformated:=false;//false to format output to be human readable
|
|
TargetOS:='linux';
|
|
TargetCPU:='i386';
|
|
GetParam;
|
|
//writeln(TargetOS,' ',TargetCPU,' ',cmdl);halt;
|
|
E := TSimpleEngine.Create;
|
|
try
|
|
try
|
|
M := ParseSource(E, cmdl ,TargetOS ,TargetCPU,False);
|
|
except
|
|
on excep:EParserError do
|
|
begin
|
|
writeln(excep.message,' line:',excep.row,' column:',excep.column,' file:',excep.filename);
|
|
raise;
|
|
end;
|
|
end;
|
|
if M is TPasProgram then
|
|
begin
|
|
writeln('Program ',M.Name,';');
|
|
if not Unformated then writeln;
|
|
if assigned(M.ImplementationSection) then
|
|
begin
|
|
isim:=true;
|
|
if not Unformated then writeln;
|
|
GetDecls(M.ImplementationSection as TPasDeclarations,0);
|
|
//PrintDecls(M.ImplementationSection as TPasDeclarations,0);
|
|
end;
|
|
if assigned(M.InitializationSection) then // MAIN BLOCK
|
|
begin
|
|
isim:=false;
|
|
if not Unformated then writeln;
|
|
writeln('begin');//writeln('begin {Begin MAIN Program}')
|
|
GetTPasImplBlock(M.InitializationSection as TPasImplBlock,1,0,false,false);
|
|
end;
|
|
end
|
|
else
|
|
begin
|
|
{ Cool, we successfully parsed the unit.
|
|
Now output some info about it. }
|
|
writeln('Unit ',M.Name,';');
|
|
if not Unformated then writeln;
|
|
Writeln('Interface');
|
|
if not Unformated then writeln;
|
|
GetDecls(M.InterfaceSection as TPasDeclarations,0);
|
|
//PrintDecls(M.InterfaceSection as TPasDeclarations,0);
|
|
|
|
if assigned(M.ImplementationSection) then
|
|
begin
|
|
isim:=true;
|
|
if not Unformated then writeln;
|
|
Writeln('Implementation');
|
|
if not Unformated then writeln;
|
|
GetDecls(M.ImplementationSection as TPasDeclarations,0);
|
|
//PrintDecls(M.ImplementationSection as TPasDeclarations,0);
|
|
if TPasElement(M.ImplementationSection) is TPasImplElement then writeln('{MAIN}');
|
|
end;
|
|
if assigned(M.InitializationSection) then //is this begin .. end. of a unit too ?
|
|
begin
|
|
isim:=true;
|
|
if not Unformated then writeln;
|
|
Writeln('Initialization');
|
|
if not Unformated then writeln;
|
|
GetTPasImplBlock(M.InitializationSection as TPasImplBlock,1,0,false,false);
|
|
end;
|
|
|
|
if assigned(M.FinalizationSection) then
|
|
begin
|
|
isim:=true;
|
|
if not Unformated then writeln;
|
|
Writeln('Finalization');
|
|
if not Unformated then writeln;
|
|
GetTPasImplBlock(M.FinalizationSection as TPasImplBlock,1,0,false,false);
|
|
end;
|
|
end;
|
|
if not Unformated then writeln('end.')
|
|
else
|
|
begin
|
|
writeln('end');
|
|
writeln('.');
|
|
end;
|
|
FreeAndNil(M);
|
|
finally
|
|
FreeAndNil(E);
|
|
end;
|
|
end.
|