paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-09-23 08:51:36 +02:00
Code Issues Packages Projects Releases Wiki Activity

--- Merging r34357 into '.':

Browse Source 
U    packages/fcl-passrc/fpmake.pp
A    packages/fcl-passrc/tests/tcresolver.pas
U    packages/fcl-passrc/tests/testpassrc.lpi
U    packages/fcl-passrc/tests/tcbaseparser.pas
U    packages/fcl-passrc/tests/tcstatements.pas
U    packages/fcl-passrc/tests/tcscanner.pas
U    packages/fcl-passrc/tests/tcexprparser.pas
U    packages/fcl-passrc/tests/tctypeparser.pas
U    packages/fcl-passrc/tests/testpassrc.lpr
U    packages/fcl-passrc/tests/tconstparser.pas
U    packages/fcl-passrc/src/pparser.pp
U    packages/fcl-passrc/src/pastree.pp
A    packages/fcl-passrc/src/pasresolver.pp
U    packages/fcl-passrc/src/pscanner.pp
U    packages/pastojs/tests/tcconverter.pp
U    packages/pastojs/src/fppas2js.pp
--- Recording mergeinfo for merge of r34357 into '.':
 U   .
--- Merging r34429 into '.':
G    packages/fcl-passrc/tests/tctypeparser.pas
U    packages/fcl-passrc/tests/tcresolver.pas
G    packages/fcl-passrc/tests/tcbaseparser.pas
G    packages/fcl-passrc/tests/tcstatements.pas
G    packages/fcl-passrc/src/pparser.pp
G    packages/fcl-passrc/src/pastree.pp
U    packages/fcl-passrc/src/pasresolver.pp
G    packages/fcl-passrc/src/pscanner.pp
--- Recording mergeinfo for merge of r34429 into '.':
 G   .

# revisions: 34357,34429

git-svn-id: branches/fixes_3_0@35976 -
This commit is contained in:
marco 2017-04-27 16:40:51 +00:00
parent a0da5c15d7
commit 6ed7b60dc6
17 changed files with 6099 additions and 913 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.gitattributes vendored
View File

@ -2521,6 +2521,7 @@ packages/fcl-passrc/Makefile.fpc.fpcmake svneol=native#text/plain
packages/fcl-passrc/examples/test_parser.pp svneol=native#text/plain
packages/fcl-passrc/examples/testunit1.pp svneol=native#text/plain
packages/fcl-passrc/fpmake.pp svneol=native#text/plain
packages/fcl-passrc/src/pasresolver.pp svneol=native#text/plain
packages/fcl-passrc/src/passrcutil.pp svneol=native#text/plain
packages/fcl-passrc/src/pastounittest.pp svneol=native#text/plain
packages/fcl-passrc/src/pastree.pp svneol=native#text/plain
@ -2535,6 +2536,7 @@ packages/fcl-passrc/tests/tcmoduleparser.pas svneol=native#text/plain
packages/fcl-passrc/tests/tconstparser.pas svneol=native#text/plain
packages/fcl-passrc/tests/tcpassrcutil.pas svneol=native#text/plain
packages/fcl-passrc/tests/tcprocfunc.pas svneol=native#text/plain
packages/fcl-passrc/tests/tcresolver.pas svneol=native#text/plain
packages/fcl-passrc/tests/tcscanner.pas svneol=native#text/plain
packages/fcl-passrc/tests/tcstatements.pas svneol=native#text/plain
packages/fcl-passrc/tests/tctypeparser.pas svneol=native#text/plain

7
packages/fcl-passrc/fpmake.pp
View File

@ -39,6 +39,13 @@ begin
AddUnit('pastree');
AddUnit('pscanner');
end;
T:=P.Targets.AddUnit('pasresolver.pp');
with T.Dependencies do
begin
AddUnit('pastree');
AddUnit('pscanner');
AddUnit('pparser');
end;
T.ResourceStrings := True;
T:=P.Targets.AddUnit('pastounittest.pp');
with T.Dependencies do

2395
packages/fcl-passrc/src/pasresolver.pp Normal file
View File

File diff suppressed because it is too large Load Diff

1018
packages/fcl-passrc/src/pastree.pp
View File

File diff suppressed because it is too large Load Diff

1021
packages/fcl-passrc/src/pparser.pp
View File

File diff suppressed because it is too large Load Diff

24
packages/fcl-passrc/src/pscanner.pp
View File

@ -317,6 +317,7 @@ type
function FindSourceFile(const AName: string): TLineReader; override;
function FindIncludeFile(const AName: string): TLineReader; override;
Property OwnsStreams : Boolean Read FOwnsStreams write SetOwnsStreams;
Property Streams: TStringList read FStreams;
end;
EScannerError = class(Exception);
@ -324,9 +325,20 @@ type
TPascalScannerPPSkipMode = (ppSkipNone, ppSkipIfBranch, ppSkipElseBranch, ppSkipAll);
TPOption = (po_delphi,po_cassignments);
TPOption = (
po_delphi, // Delphi mode: forbid nested comments
po_cassignments, // allow C-operators += -= *= /=
po_resolvestandardtypes // search for 'longint', 'string', etc., do not use dummies, TPasResolver sets this to use its declarations
);
TPOptions = set of TPOption;
type
TPasSourcePos = Record
FileName: String;
Row, Column: Cardinal;
end;
type
{ TPascalScanner }
TPScannerLogHandler = Procedure (Sender : TObject; Const Msg : String) of object;
@ -390,6 +402,7 @@ type
function FetchToken: TToken;
Procedure AddDefine(S : String);
Procedure RemoveDefine(S : String);
function CurSourcePos: TPasSourcePos;
property FileResolver: TBaseFileResolver read FFileResolver;
property CurSourceFile: TLineReader read FCurSourceFile;
@ -751,7 +764,7 @@ begin
While (I=-1) and (J<IncludePaths.Count-1) do
begin
FN:=IncludeTrailingPathDelimiter(IncludePaths[i])+AName;
I:=FStreams.INdexOf(FN);
I:=FStreams.IndexOf(FN);
Inc(J);
end;
end;
@ -1950,4 +1963,11 @@ begin
FDefines.Delete(I);
end;
function TPascalScanner.CurSourcePos: TPasSourcePos;
begin
Result.FileName:=CurFilename;
Result.Row:=CurRow;
Result.Column:=CurColumn;
end;
end.

326
packages/fcl-passrc/tests/tcbaseparser.pas
View File

@ -7,6 +7,8 @@ interface
uses
Classes, SysUtils, fpcunit, pastree, pscanner, pparser, testregistry;
const
MainFilename = 'afile.pp';
Type
{ TTestEngine }
@ -29,7 +31,7 @@ Type
Private
FDeclarations: TPasDeclarations;
FDefinition: TPasElement;
FEngine : TTestEngine;
FEngine : TPasTreeContainer;
FModule: TPasModule;
FParseResult: TPasElement;
FScanner : TPascalScanner;
@ -48,6 +50,7 @@ Type
protected
procedure SetUp; override;
procedure TearDown; override;
procedure CreateEngine(var TheEngine: TPasTreeContainer); virtual;
Procedure StartUnit(AUnitName : String);
Procedure StartProgram(AFileName : String; AIn : String = ''; AOut : String = '');
Procedure StartLibrary(AFileName : String);
@ -78,10 +81,11 @@ Type
Procedure AssertEquals(Const Msg : String; AExpected, AActual: TAssignKind); overload;
Procedure AssertEquals(Const Msg : String; AExpected, AActual: TProcedureMessageType); overload;
Procedure AssertEquals(Const Msg : String; AExpected, AActual: TOperatorType); overload;
Procedure AssertSame(Const Msg : String; AExpected, AActual: TPasElement); overload;
Procedure HaveHint(AHint : TPasMemberHint; AHints : TPasMemberHints);
Property Resolver : TStreamResolver Read FResolver;
Property Scanner : TPascalScanner Read FScanner;
Property Engine : TTestEngine read FEngine;
Property Engine : TPasTreeContainer read FEngine;
Property Parser : TTestPasParser read FParser ;
Property Source : TStrings Read FSource;
Property Module : TPasModule Read FModule;
@ -94,9 +98,296 @@ Type
Property UseImplementation : Boolean Read FUseImplementation Write FUseImplementation;
end;
function ExtractFileUnitName(aFilename: string): string;
function GetPasElementDesc(El: TPasElement): string;
procedure ReadNextPascalToken(var Position: PChar; out TokenStart: PChar;
NestedComments: boolean; SkipDirectives: boolean);
implementation
uses typinfo;
function ExtractFileUnitName(aFilename: string): string;
var
p: Integer;
begin
Result:=ExtractFileName(aFilename);
if Result='' then exit;
for p:=length(Result) downto 1 do
case Result[p] of
'/','\': exit;
'.':
begin
Delete(Result,p,length(Result));
exit;
end;
end;
end;
function GetPasElementDesc(El: TPasElement): string;
begin
if El=nil then exit('nil');
Result:=El.Name+':'+El.ClassName+'['+El.SourceFilename+','+IntToStr(El.SourceLinenumber)+']';
end;
procedure ReadNextPascalToken(var Position: PChar; out TokenStart: PChar;
NestedComments: boolean; SkipDirectives: boolean);
const
IdentChars = ['a'..'z','A'..'Z','_','0'..'9'];
HexNumberChars = ['0'..'9','a'..'f','A'..'F'];
var
c1:char;
CommentLvl: Integer;
Src: PChar;
begin
Src:=Position;
// read till next atom
while true do
begin
case Src^ of
#0: break;
#1..#32: // spaces and special characters
inc(Src);
#$EF:
if (Src[1]=#$BB)
and (Src[2]=#$BF) then
begin
// skip UTF BOM
inc(Src,3);
end
else
break;
'{': // comment start or compiler directive
if (Src[1]='$') and (not SkipDirectives) then
// compiler directive
break
else begin
// Pascal comment => skip
CommentLvl:=1;
while true do
begin
inc(Src);
case Src^ of
#0: break;
'{':
if NestedComments then
inc(CommentLvl);
'}':
begin
dec(CommentLvl);
if CommentLvl=0 then
begin
inc(Src);
break;
end;
end;
end;
end;
end;
'/': // comment or real division
if (Src[1]='/') then
begin
// comment start -> read til line end
inc(Src);
while not (Src^ in [#0,#10,#13]) do
inc(Src);
end
else
break;
'(': // comment, bracket or compiler directive
if (Src[1]='*') then
begin
if (Src[2]='$') and (not SkipDirectives) then
// compiler directive
break
else
begin
// comment start -> read til comment end
inc(Src,2);
CommentLvl:=1;
while true do
begin
case Src^ of
#0: break;
'(':
if NestedComments and (Src[1]='*') then
inc(CommentLvl);
'*':
if (Src[1]=')') then
begin
dec(CommentLvl);
if CommentLvl=0 then
begin
inc(Src,2);
break;
end;
inc(Position);
end;
end;
inc(Src);
end;
end;
end else
// round bracket open
break;
else
break;
end;
end;
// read token
TokenStart:=Src;
c1:=Src^;
case c1 of
#0:
;
'A'..'Z','a'..'z','_':
begin
// identifier
inc(Src);
while Src^ in IdentChars do
inc(Src);
end;
'0'..'9': // number
begin
inc(Src);
// read numbers
while (Src^ in ['0'..'9']) do
inc(Src);
if (Src^='.') and (Src[1]<>'.') then
begin
// real type number
inc(Src);
while (Src^ in ['0'..'9']) do
inc(Src);
end;
if (Src^ in ['e','E']) then
begin
// read exponent
inc(Src);
if (Src^='-') then inc(Src);
while (Src^ in ['0'..'9']) do
inc(Src);
end;
end;
'''','#': // string constant
while true do
case Src^ of
#0: break;
'#':
begin
inc(Src);
while Src^ in ['0'..'9'] do
inc(Src);
end;
'''':
begin
inc(Src);
while not (Src^ in ['''',#0]) do
inc(Src);
if Src^='''' then
inc(Src);
end;
else
break;
end;
'$': // hex constant
begin
inc(Src);
while Src^ in HexNumberChars do
inc(Src);
end;
'&': // octal constant or keyword as identifier (e.g. &label)
begin
inc(Src);
if Src^ in ['0'..'7'] then
while Src^ in ['0'..'7'] do
inc(Src)
else
while Src^ in IdentChars do
inc(Src);
end;
'{': // compiler directive (it can't be a comment, because see above)
begin
CommentLvl:=1;
while true do
begin
inc(Src);
case Src^ of
#0: break;
'{':
if NestedComments then
inc(CommentLvl);
'}':
begin
dec(CommentLvl);
if CommentLvl=0 then
begin
inc(Src);
break;
end;
end;
end;
end;
end;
'(': // bracket or compiler directive
if (Src[1]='*') then
begin
// compiler directive -> read til comment end
inc(Src,2);
while (Src^<>#0) and ((Src^<>'*') or (Src[1]<>')')) do
inc(Src);
inc(Src,2);
end
else
// round bracket open
inc(Src);
#192..#255:
begin
// read UTF8 character
inc(Src);
if ((ord(c1) and %11100000) = %11000000) then
begin
// could be 2 byte character
if (ord(Src[0]) and %11000000) = %10000000 then
inc(Src);
end
else if ((ord(c1) and %11110000) = %11100000) then
begin
// could be 3 byte character
if ((ord(Src[0]) and %11000000) = %10000000)
and ((ord(Src[1]) and %11000000) = %10000000) then
inc(Src,2);
end
else if ((ord(c1) and %11111000) = %11110000) then
begin
// could be 4 byte character
if ((ord(Src[0]) and %11000000) = %10000000)
and ((ord(Src[1]) and %11000000) = %10000000)
and ((ord(Src[2]) and %11000000) = %10000000) then
inc(Src,3);
end;
end;
else
inc(Src);
case c1 of
'<': if Src^ in ['>','='] then inc(Src);
'.': if Src^='.' then inc(Src);
'@':
if Src^='@' then
begin
// @@ label
repeat
inc(Src);
until not (Src^ in IdentChars);
end
else
if (Src^='=') and (c1 in [':','+','-','/','*','<','>']) then
inc(Src);
end;
end;
Position:=Src;
end;
{ TTestEngine }
destructor TTestEngine.Destroy;
@ -158,7 +449,7 @@ begin
FResolver:=TStreamResolver.Create;
FResolver.OwnsStreams:=True;
FScanner:=TPascalScanner.Create(FResolver);
FEngine:=TTestEngine.Create;
CreateEngine(FEngine);
FParser:=TTestPasParser.Create(FScanner,FResolver,FEngine);
FSource:=TStringList.Create;
FModule:=Nil;
@ -178,7 +469,11 @@ begin
FImplementation:=False;
FEndSource:=False;
FIsUnit:=False;
FreeAndNil(FModule);
if Assigned(FModule) then
begin
FModule.Release;
FModule:=nil;
end;
FreeAndNil(FSource);
FreeAndNil(FParseResult);
FreeAndNil(FParser);
@ -206,11 +501,16 @@ begin
Inherited;
end;
procedure TTestParser.CreateEngine(var TheEngine: TPasTreeContainer);
begin
TheEngine:=TTestEngine.Create;
end;
procedure TTestParser.StartUnit(AUnitName: String);
begin
FIsUnit:=True;
If (AUnitName='') then
AUnitName:='afile';
AUnitName:=ExtractFileUnitName(MainFilename);
Add('unit '+aUnitName+';');
Add('');
Add('interface');
@ -228,7 +528,7 @@ begin
begin
AFileName:=AFileName+'('+AIn;
if (AOut<>'') then
AFileName:=AFIleName+','+AOut;
AFileName:=AFileName+','+AOut;
AFileName:=AFileName+')';
end;
Add('program '+AFileName+';');
@ -304,8 +604,8 @@ begin
StartImplementation;
EndSource;
If (FFileName='') then
FFileName:='afile.pp';
FResolver.AddStream(FFileName,TStringStream.Create(FSource.text));
FFileName:=MainFilename;
FResolver.AddStream(FFileName,TStringStream.Create(FSource.Text));
FScanner.OpenFile(FFileName);
Writeln('// Test : ',Self.TestName);
Writeln(FSource.Text);
@ -345,6 +645,7 @@ end;
function TTestParser.AssertExpression(const Msg: String; AExpr: TPasExpr;
aKind: TPasExprKind; AClass: TClass): TPasExpr;
begin
AssertNotNull(AExpr);
AssertEquals(Msg+': Correct expression kind',aKind,AExpr.Kind);
AssertEquals(Msg+': Correct expression class',AClass,AExpr.ClassType);
Result:=AExpr;
@ -521,7 +822,14 @@ procedure TTestParser.AssertEquals(const Msg: String; AExpected,
AActual: TOperatorType);
begin
AssertEquals(Msg,GetEnumName(TypeInfo(TOperatorType),Ord(AExpected)),
GetEnumName(TypeInfo(TOperatorType),Ord(AExpected)));
GetEnumName(TypeInfo(TOperatorType),Ord(AActual)));
end;
procedure TTestParser.AssertSame(const Msg: String; AExpected,
AActual: TPasElement);
begin
if AExpected=AActual then exit;
AssertEquals(Msg,GetPasElementDesc(AExpected),GetPasElementDesc(AActual));
end;
procedure TTestParser.HaveHint(AHint: TPasMemberHint; AHints: TPasMemberHints);

11
packages/fcl-passrc/tests/tcexprparser.pas
View File

@ -211,12 +211,14 @@ begin
DeclareVar('record a : array[1..2] of integer; end ','b');
ParseExpression('b.a[1]');
P:=TParamsExpr(AssertExpression('Simple identifier',theExpr,pekArrayParams,TParamsExpr));
B:=AssertExpression('Name of array',P.Value,pekBinary,TBInaryExpr) as TBInaryExpr;
B:=AssertExpression('Name of array',P.Value,pekBinary,TBInaryExpr) as TBinaryExpr;
AssertEquals('name is Subident',eopSubIdent,B.Opcode);
AssertExpression('Name of array',B.Left,pekIdent,'b');
AssertExpression('Name of array',B.Right,pekIdent,'a');
AssertEquals('One dimension',1,Length(p.params));
AssertExpression('Simple identifier',p.params[0],pekNumber,'1');
TAssert.AssertSame('B.left.parent=B',B,B.left.Parent);
TAssert.AssertSame('B.right.parent=B',B,B.right.Parent);
end;
procedure TTestExpressions.TestArrayElement2Dims;
@ -291,6 +293,9 @@ begin
B:=TBinaryExpr(AssertExpression('First element is range',P.Params[0],pekRange,TBinaryExpr));
AssertExpression('Left is 0',B.Left,pekNumber,'0');
AssertExpression('Right is 10',B.Right,pekNumber,'10');
B:=TBinaryExpr(TheExpr);
TAssert.AssertSame('B.left.parent=B',B,B.left.Parent);
TAssert.AssertSame('B.right.parent=B',B,B.right.Parent);
end;
procedure TTestExpressions.TestBracketsTotal;
@ -868,7 +873,7 @@ Var
I : Integer;
begin
StartProgram('afile');
StartProgram(ExtractFileUnitName(MainFilename));
if FVariables.Count=0 then
DeclareVar('integer');
Add('Var');
@ -913,6 +918,8 @@ begin
ARight:=Result.Right;
AssertNotNull('Have left',ALeft);
AssertNotNull('Have right',ARight);
TAssert.AssertSame('Result.left.parent=B',Result,Result.left.Parent);
TAssert.AssertSame('Result.right.parent=B',Result,Result.right.Parent);
end;
function TTestExpressions.AssertUnaryExpr(const Msg: String; Op: TExprOpCode;

29
packages/fcl-passrc/tests/tconstparser.pas
View File

@ -205,6 +205,8 @@ begin
ParseConst('1 + 2');
CheckExprNameKindClass(pekBinary,TBinaryExpr);
B:=TBinaryExpr(TheExpr);
TAssert.AssertSame('B.Left.Parent=B',B,B.left.Parent);
TAssert.AssertSame('B.right.Parent=B',B,B.right.Parent);
AssertExpression('Left expression',B.Left,pekNumber,'1');
AssertExpression('Right expression',B.Right,pekNumber,'2');
end;
@ -547,24 +549,33 @@ begin
end;
procedure TTestResourcestringParser.DoTestSum;
var
B: TBinaryExpr;
begin
ParseResourcestring('''Something''+'' else''');
CheckExprNameKindClass(pekBinary,TBinaryExpr);
AssertEquals('Correct left',TPrimitiveExpr,TBinaryExpr(TheExpr).Left.ClassType);
AssertEquals('Correct right',TPrimitiveExpr,TBinaryExpr(TheExpr).Right.ClassType);
AssertEquals('Correct left expression value','''Something''',TPrimitiveExpr(TBinaryExpr(TheExpr).Left).Value);
AssertEquals('Correct right expression value',''' else''',TPrimitiveExpr(TBinaryExpr(TheExpr).Right).Value);
B:=TBinaryExpr(TheExpr);
TAssert.AssertSame('B.left.parent=B',B,B.left.Parent);
TAssert.AssertSame('B.right.parent=B',B,B.right.Parent);
AssertEquals('Correct left',TPrimitiveExpr,B.Left.ClassType);
AssertEquals('Correct right',TPrimitiveExpr,B.Right.ClassType);
AssertEquals('Correct left expression value','''Something''',TPrimitiveExpr(B.Left).Value);
AssertEquals('Correct right expression value',''' else''',TPrimitiveExpr(B.Right).Value);
end;
procedure TTestResourcestringParser.DoTestSum2;
var
B: TBinaryExpr;
begin
ParseResourcestring('''Something''+different');
CheckExprNameKindClass(pekBinary,TBinaryExpr);
AssertEquals('Correct left',TPrimitiveExpr,TBinaryExpr(TheExpr).Left.ClassType);
AssertEquals('Correct right',TPrimitiveExpr,TBinaryExpr(TheExpr).Right.ClassType);
AssertEquals('Correct left expression value','''Something''',TPrimitiveExpr(TBinaryExpr(TheExpr).Left).Value);
AssertEquals('Correct right expression value','different',TPrimitiveExpr(TBinaryExpr(TheExpr).Right).Value);
B:=TBinaryExpr(TheExpr);
TAssert.AssertSame('B.left.parent=B',B,B.left.Parent);
TAssert.AssertSame('B.right.parent=B',B,B.right.Parent);
AssertEquals('Correct left',TPrimitiveExpr,B.Left.ClassType);
AssertEquals('Correct right',TPrimitiveExpr,B.Right.ClassType);
AssertEquals('Correct left expression value','''Something''',TPrimitiveExpr(B.Left).Value);
AssertEquals('Correct right expression value','different',TPrimitiveExpr(B.Right).Value);
end;
procedure TTestResourcestringParser.TestSimple;

1424
packages/fcl-passrc/tests/tcresolver.pas Normal file
View File

File diff suppressed because it is too large Load Diff

3
packages/fcl-passrc/tests/tcscanner.pas
View File

@ -1381,9 +1381,6 @@ begin
AssertEQuals('Correct identifier', 'somethingweird',LastIdentifier);
end;
initialization
RegisterTests([TTestTokenFinder,TTestStreamLineReader,TTestScanner]);
end.

19
packages/fcl-passrc/tests/tcstatements.pas
View File

@ -121,7 +121,7 @@ procedure TTestStatementParser.AddStatements(ASource: array of string);
Var
I :Integer;
begin
StartProgram('afile');
StartProgram(ExtractFileUnitName(MainFilename));
if FVariables.Count>0 then
begin
Add('Var');
@ -369,9 +369,10 @@ begin
S:=Statement as TPasImplSimple;
AssertExpression('Doit call',S.Expr,pekBinary,TBinaryExpr);
B:=S.Expr as TBinaryExpr;
TAssert.AssertSame('B.left.Parent=B',B,B.left.Parent);
TAssert.AssertSame('B.right.Parent=B',B,B.right.Parent);
AssertExpression('Unit name',B.Left,pekIdent,'Unita');
AssertExpression('Doit call',B.Right,pekIdent,'Doit');
end;
procedure TTestStatementParser.TestCallQualified2;
@ -662,7 +663,7 @@ begin
DeclareVar('integer');
TestStatement(['For a:=1 to 10 do',';']);
F:=AssertStatement('For statement',TPasImplForLoop) as TPasImplForLoop;
AssertEquals('Loop variable name','a',F.VariableName);
AssertExpression('Loop variable name',F.VariableName,pekIdent,'a');
AssertEquals('Loop type',ltNormal,F.Looptype);
AssertEquals('Up loop',False,F.Down);
AssertExpression('Start value',F.StartExpr,pekNumber,'1');
@ -679,7 +680,7 @@ begin
DeclareVar('integer');
TestStatement(['For a in SomeSet Do',';']);
F:=AssertStatement('For statement',TPasImplForLoop) as TPasImplForLoop;
AssertEquals('Loop variable name','a',F.VariableName);
AssertExpression('Loop variable name',F.VariableName,pekIdent,'a');
AssertEquals('Loop type',ltIn,F.Looptype);
AssertEquals('In loop',False,F.Down);
AssertExpression('Start value',F.StartExpr,pekIdent,'SomeSet');
@ -696,7 +697,7 @@ begin
DeclareVar('integer');
TestStatement(['For a:=1+1 to 5+5 do',';']);
F:=AssertStatement('For statement',TPasImplForLoop) as TPasImplForLoop;
AssertEquals('Loop variable name','a',F.VariableName);
AssertExpression('Loop variable name',F.VariableName,pekIdent,'a');
AssertEquals('Up loop',False,F.Down);
AssertExpression('Start expression',F.StartExpr,pekBinary,TBinaryExpr);
B:=F.StartExpr as TBinaryExpr;
@ -718,7 +719,7 @@ begin
DeclareVar('integer');
TestStatement(['For a:=1 to 10 do','begin','end']);
F:=AssertStatement('For statement',TPasImplForLoop) as TPasImplForLoop;
AssertEquals('Loop variable name','a',F.VariableName);
AssertExpression('Loop variable name',F.VariableName,pekIdent,'a');
AssertEquals('Up loop',False,F.Down);
AssertExpression('Start value',F.StartExpr,pekNumber,'1');
AssertExpression('End value',F.EndExpr,pekNumber,'10');
@ -736,7 +737,7 @@ begin
DeclareVar('integer');
TestStatement(['For a:=10 downto 1 do','begin','end']);
F:=AssertStatement('For statement',TPasImplForLoop) as TPasImplForLoop;
AssertEquals('Loop variable name','a',F.VariableName);
AssertExpression('Loop variable name',F.VariableName,pekIdent,'a');
AssertEquals('Down loop',True,F.Down);
AssertExpression('Start value',F.StartExpr,pekNumber,'10');
AssertExpression('End value',F.EndExpr,pekNumber,'1');
@ -754,14 +755,14 @@ begin
DeclareVar('integer','b');
TestStatement(['For a:=1 to 10 do','For b:=11 to 20 do','begin','end']);
F:=AssertStatement('For statement',TPasImplForLoop) as TPasImplForLoop;
AssertEquals('Loop variable name','a',F.VariableName);
AssertExpression('Loop variable name',F.VariableName,pekIdent,'a');
AssertEquals('Up loop',False,F.Down);
AssertExpression('Start value',F.StartExpr,pekNumber,'1');
AssertExpression('End value',F.EndExpr,pekNumber,'10');
AssertNotNull('Have while body',F.Body);
AssertEquals('begin end block',TPasImplForLoop,F.Body.ClassType);
F:=F.Body as TPasImplForLoop;
AssertEquals('Loop variable name','b',F.VariableName);
AssertExpression('Loop variable name',F.VariableName,pekIdent,'b');
AssertEquals('Up loop',False,F.Down);
AssertExpression('Start value',F.StartExpr,pekNumber,'11');
AssertExpression('End value',F.EndExpr,pekNumber,'20');

11
packages/fcl-passrc/tests/tctypeparser.pas
View File

@ -695,6 +695,8 @@ begin
AssertNotNull('have right expr', B.Right);
AssertEquals('argument right expr type', TPrimitiveExpr, B.right.ClassType);
AssertEquals('argument right expr value', '2', TPrimitiveExpr(B.right).Value);
TAssert.AssertSame('B.left.parent=B',B,B.left.Parent);
TAssert.AssertSame('B.right.parent=B',B,B.right.Parent);
end;
procedure TTestProcedureTypeParser.DoTestProcedureOneArgDefaultSet(
@ -1744,6 +1746,7 @@ procedure TTestRecordTypeParser.TestTwoFieldPrivateNoDelphi;
Var
EC : TClass;
begin
EC:=nil;
try
TestFields(['private','x : integer'],'',False);
Fail('Need po_Delphi for visibility specifier');
@ -1759,16 +1762,22 @@ end;
procedure TTestRecordTypeParser.TestTwoFieldProtected;
Var
B : Boolean;
EName: String;
begin
B:=false;
EName:='';
try
TestFields(['protected','x : integer'],'',False);
Fail('Protected not allowed as record visibility specifier')
except
on E : Exception do
begin
EName:=E.ClassName;
B:=E is EParserError;
end;
end;
If not B then
Fail('Wrong exception class.');
Fail('Wrong exception class "'+EName+'".');
end;
procedure TTestRecordTypeParser.TestTwoFieldPrivate;

6
packages/fcl-passrc/tests/testpassrc.lpi
View File

@ -38,7 +38,7 @@
<PackageName Value="FCL"/>
</Item1>
</RequiredPackages>
<Units Count="12">
<Units Count="13">
<Unit0>
<Filename Value="testpassrc.lpr"/>
<IsPartOfProject Value="True"/>
@ -87,6 +87,10 @@
<Filename Value="tcpassrcutil.pas"/>
<IsPartOfProject Value="True"/>
</Unit11>
<Unit12>
<Filename Value="tcresolver.pas"/>
<IsPartOfProject Value="True"/>
</Unit12>
</Units>
</ProjectOptions>
<CompilerOptions>

2
packages/fcl-passrc/tests/testpassrc.lpr
View File

@ -5,7 +5,7 @@ program testpassrc;
uses
Classes, consoletestrunner, tcscanner, tctypeparser, tcstatements,
tcbaseparser, tcmoduleparser, tconstparser, tcvarparser, tcclasstype,
tcexprparser, tcprocfunc, tcpassrcutil;
tcexprparser, tcprocfunc, tcpassrcutil, tcresolver;
type

694
packages/pastojs/src/fppas2js.pp
View File

File diff suppressed because it is too large Load Diff

20
packages/pastojs/tests/tcconverter.pp
View File

@ -63,6 +63,8 @@ type
Class Function CreateCondition: TPasExpr;
end;
{ TTestTestConverter }
TTestTestConverter = class(TTestConverter)
published
procedure TestEmpty;
@ -584,7 +586,7 @@ begin
AssertNull('No second statement',L.B);
L:=AssertListStatement('try..except block is statement list',El.BCatch);
AssertAssignStatement('Correct assignment in except..end block',L.A,'b','c');
AssertEquals('Correct exception object name',DefaultJSExceptionObject,El.Ident);
AssertEquals('Correct exception object name',lowercase(DefaultJSExceptionObject),El.Ident);
AssertNull('No second statement',L.B);
end;
@ -621,18 +623,18 @@ begin
O.Body:=CreateAssignStatement('b','c');
// Convert
El:=TJSTryFinallyStatement(Convert(T,TJSTryCatchStatement));
AssertEquals('Correct exception object name',DefaultJSExceptionObject,EL.Ident);
AssertEquals('Correct exception object name',lowercase(DefaultJSExceptionObject),EL.Ident);
L:=AssertListStatement('try..except block is statement list',El.BCatch);
AssertNull('No second statement',L.B);
I:=TJSIfStatement(AssertElement('On block is if',TJSIfStatement,L.A));
Ic:=TJSRelationalExpressionInstanceOf(AssertElement('If condition is InstanceOf expression',TJSRelationalExpressionInstanceOf,I.Cond));
Assertidentifier('InstanceOf left is exception object',Ic.A,DefaultJSExceptionObject);
Assertidentifier('InstanceOf left is exception object',Ic.A,lowercase(DefaultJSExceptionObject));
// Lowercased exception - May need checking
Assertidentifier('InstanceOf right is original exception type',Ic.B,'exception');
L:=AssertListStatement('On block is always a list',i.btrue);
V:=TJSVarDeclaration(AssertElement('First statement in list is a var declaration',TJSVarDeclaration,L.A));
AssertEquals('Variable name is identifier in On A : Ex do','e',V.Name);
Assertidentifier('Variable init is exception object',v.init,DefaultJSExceptionObject);
Assertidentifier('Variable init is exception object',v.init,lowercase(DefaultJSExceptionObject));
L:=AssertListStatement('Second statement is again list',L.B);
AssertAssignStatement('Original assignment in second statement',L.A,'b','c');
end;
@ -669,20 +671,20 @@ begin
O.Body:=TPasImplRaise.Create('',Nil);
// Convert
El:=TJSTryFinallyStatement(Convert(T,TJSTryCatchStatement));
AssertEquals('Correct exception object name',DefaultJSExceptionObject,EL.Ident);
AssertEquals('Correct exception object name',lowercase(DefaultJSExceptionObject),EL.Ident);
L:=AssertListStatement('try..except block is statement list',El.BCatch);
AssertNull('No second statement',L.B);
I:=TJSIfStatement(AssertElement('On block is if',TJSIfStatement,L.A));
Ic:=TJSRelationalExpressionInstanceOf(AssertElement('If condition is InstanceOf expression',TJSRelationalExpressionInstanceOf,I.Cond));
Assertidentifier('InstanceOf left is exception object',Ic.A,DefaultJSExceptionObject);
Assertidentifier('InstanceOf left is exception object',Ic.A,lowercase(DefaultJSExceptionObject));
// Lowercased exception - May need checking
L:=AssertListStatement('On block is always a list',i.btrue);
V:=TJSVarDeclaration(AssertElement('First statement in list is a var declaration',TJSVarDeclaration,L.A));
AssertEquals('Variable name is identifier in On A : Ex do','e',V.Name);
Assertidentifier('Variable init is exception object',v.init,DefaultJSExceptionObject);
Assertidentifier('Variable init is exception object',v.init,lowercase(DefaultJSExceptionObject));
L:=AssertListStatement('Second statement is again list',L.B);
R:=TJSThrowStatement(AssertElement('On block is throw statement',TJSThrowStatement,L.A));
Assertidentifier('R expression is original exception ',R.A,DefaultJSExceptionObject);
Assertidentifier('R expression is original exception ',R.A,lowercase(DefaultJSExceptionObject));
end;
Procedure TTestStatementConverter.TestVariableStatement;
@ -1206,7 +1208,7 @@ Function TTestConverter.Convert(AElement: TPasElement; AClass: TJSElementClass
): TJSElement;
begin
FSource:=AElement;
Result:=FConverter.ConvertElement(AElement);
Result:=FConverter.ConvertPasElement(AElement,nil);
FRes:=Result;
if (AClass<>Nil) then
begin