paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-20 21:09:24 +02:00
Code Issues Packages Projects Releases Wiki Activity

fcl-passrc: resolver: fixed error during parsing with-do

Browse Source 
git-svn-id: trunk@41082 -
This commit is contained in:
Mattias Gaertner 2019-01-27 10:03:09 +00:00
parent 597a23d278
commit fb78404e1c
2 changed files with 78 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -5625,14 +5625,13 @@ var
var
SubBlock: TPasImplElement;
Left, Right: TPasExpr;
Left, Right, Expr: TPasExpr;
El : TPasImplElement;
lt : TLoopType;
SrcPos: TPasSourcePos;
Name: String;
TypeEl: TPasType;
ImplRaise: TPasImplRaise;
Expr: TPasExpr;
begin
NewImplElement:=nil;
@ -5829,12 +5828,11 @@ begin
SrcPos:=CurTokenPos;
NextToken;
El:=TPasImplWithDo(CreateElement(TPasImplWithDo,'',CurBlock,SrcPos));
Left:=DoParseExpression(CurBlock);
Expr:=DoParseExpression(CurBlock);
//writeln(i,'WITH Expr="',Expr,'" Token=',CurTokenText);
TPasImplWithDo(El).AddExpression(Left);
Left.Parent:=El;
Engine.BeginScope(stWithExpr,Left);
Left:=nil;
TPasImplWithDo(El).AddExpression(Expr);
Expr.Parent:=El;
Engine.BeginScope(stWithExpr,Expr);
CreateBlock(TPasImplWithDo(El));
El:=nil;
repeat
@ -5842,11 +5840,10 @@ begin
if CurToken<>tkComma then
ParseExcTokenError(TokenInfos[tkdo]);
NextToken;
Left:=DoParseExpression(CurBlock);
Expr:=DoParseExpression(CurBlock);
//writeln(i,'WITH ...,Expr="',Expr,'" Token=',CurTokenText);
TPasImplWithDo(CurBlock).AddExpression(Left);
Engine.BeginScope(stWithExpr,Left);
Left:=nil;
TPasImplWithDo(CurBlock).AddExpression(Expr);
Engine.BeginScope(stWithExpr,Expr);
until false;
end;
tkcase:

70
packages/fcl-passrc/tests/tcresolver.pas
View File

@ -256,6 +256,7 @@ type
// enums and sets
Procedure TestEnums;
Procedure TestEnumRangeFail;
Procedure TestEnumDotValueFail;
Procedure TestSets;
Procedure TestSetOperators;
Procedure TestEnumParams;
@ -884,6 +885,7 @@ type
Procedure TestClassHelper_NestedInheritedParentFail;
Procedure TestClassHelper_AccessFields;
Procedure TestClassHelper_CallClassMethodFail;
Procedure TestClassHelper_WithHelperFail;
Procedure TestClassHelper_AsTypeFail;
Procedure TestClassHelper_Enumerator;
Procedure TestClassHelper_FromUnitInterface;
@ -898,6 +900,8 @@ type
Procedure TestTypeHelper_HelperForProcTypeFail;
Procedure TestTypeHelper_DefaultPropertyFail;
Procedure TestTypeHelper_Enum;
Procedure TestTypeHelper_EnumDotValueFail;
Procedure TestTypeHelper_EnumHelperDotProcFail;
Procedure TestTypeHelper_Enumerator;
Procedure TestTypeHelper_Constructor_NewInstance;
@ -3548,6 +3552,17 @@ begin
CheckParserException('Const ranges are not allowed',nParserNoConstRangeAllowed);
end;
procedure TTestResolver.TestEnumDotValueFail;
begin
StartProgram(false);
Add([
'type TFlag = (a,b,c);',
'var f: TFlag;',
'begin',
' f:=f.a;']);
CheckResolverException('illegal qualifier "." after "f:TFlag"',nIllegalQualifierAfter);
end;
procedure TTestResolver.TestSets;
begin
StartProgram(false);
@ -16102,6 +16117,20 @@ begin
CheckResolverException(sHelpersCannotBeUsedAsTypes,nHelpersCannotBeUsedAsTypes);
end;
procedure TTestResolver.TestClassHelper_WithHelperFail;
begin
StartProgram(false);
Add([
'type',
' TObject = class end;',
' THelper = class helper for TObject',
' end;',
'begin',
' with THelper do ;',
'']);
CheckResolverException(sHelpersCannotBeUsedAsTypes,nHelpersCannotBeUsedAsTypes);
end;
procedure TTestResolver.TestClassHelper_AsTypeFail;
begin
StartProgram(false);
@ -16559,6 +16588,7 @@ begin
' TFlag = (Red, Green, Blue);',
' THelper = type helper for TFlag',
' function toString: string;',
' class procedure Fly;',
' end;',
'function THelper.toString: string;',
'begin',
@ -16566,14 +16596,54 @@ begin
' if Self=TFlag.Blue then ;',
' Result:=str(Self);',
'end;',
'class procedure THelper.Fly;',
'begin',
'end;',
'var',
' f: TFlag;',
'begin',
' f.toString;',
' TFlag.Fly;',
'']);
ParseProgram;
end;
procedure TTestResolver.TestTypeHelper_EnumDotValueFail;
begin
StartProgram(false);
Add([
'{$modeswitch typehelpers}',
'type',
' TFlag = (Red, Green, Blue);',
' THelper = type helper for TFlag',
' end;',
'var',
' f: TFlag;',
'begin',
' f:=f.red;',
'']);
CheckResolverException('identifier not found "red"',nIdentifierNotFound);
end;
procedure TTestResolver.TestTypeHelper_EnumHelperDotProcFail;
begin
StartProgram(false);
Add([
'{$modeswitch typehelpers}',
'type',
' TFlag = (Red, Green, Blue);',
' THelper = type helper for TFlag',
' procedure Fly;',
' end;',
'procedure THelper.Fly;',
'begin',
'end;',
'begin',
' TFlag.Fly;',
'']);
CheckResolverException('Cannot access this member from a type helper',nCannotAccessThisMemberFromAX);
end;
procedure TTestResolver.TestTypeHelper_Enumerator;
begin
StartProgram(false);