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

fcl-passrc: fixed checking statement after except-on

Browse Source
This commit is contained in:
mattias 2021-01-19 19:09:02 +00:00
parent d07e0cd1d2
commit 5810175e08
3 changed files with 61 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
compiler/packages/fcl-passrc/src/pasresolver.pp
View File

@ -3935,10 +3935,16 @@ end;
{ EPasResolve }
procedure EPasResolve.SetPasElement(AValue: TPasElement);
var
Old: TPasElement;
begin
if FPasElement=AValue then Exit;
if PasElement<>nil then
Old:=FPasElement;
if Old<>nil then
begin
Old:=nil;
PasElement.Release{$IFDEF CheckPasTreeRefCount}('EPasResolve.SetPasElement'){$ENDIF};
end;
FPasElement:=AValue;
if PasElement<>nil then
PasElement.AddRef{$IFDEF CheckPasTreeRefCount}('EPasResolve.SetPasElement'){$ENDIF};
@ -7523,11 +7529,13 @@ procedure TPasResolver.FinishExceptOnExpr;
var
El: TPasImplExceptOn;
ResolvedType: TPasResolverResult;
TypeEl: TPasType;
begin
CheckTopScope(TPasExceptOnScope);
El:=TPasImplExceptOn(FTopScope.Element);
ComputeElement(El.TypeEl,ResolvedType,[rcType]);
CheckIsClass(El.TypeEl,ResolvedType);
TypeEl:=El.TypeEl;
ComputeElement(TypeEl,ResolvedType,[rcType]);
CheckIsClass(TypeEl,ResolvedType);
end;
procedure TPasResolver.FinishExceptOnStatement;

38
compiler/packages/fcl-passrc/src/pparser.pp
View File

@ -5937,10 +5937,23 @@ var
function CloseBlock: boolean; // true if parent reached
var C: TPasImplBlockClass;
NeedUnget: Boolean;
begin
C:=TPasImplBlockClass(CurBlock.ClassType);
if C=TPasImplExceptOn then
Engine.FinishScope(stExceptOnStatement,CurBlock)
begin
Engine.FinishScope(stExceptOnStatement,CurBlock);
NeedUnget:=CurToken=tkSemicolon;
if NeedUnget then
NextToken;
if (CurToken in [tkend,tkelse])
or ((CurToken=tkIdentifier) and (lowercase(CurTokenString)='on')) then
// ok
else
ParseExcExpectedAorB('end','on');
if NeedUnget then
UngetToken;
end
else if C=TPasImplWithDo then
Engine.FinishScope(stWithExpr,CurBlock);
CurBlock:=CurBlock.Parent as TPasImplBlock;
@ -5999,6 +6012,7 @@ var
TypeEl: TPasType;
ImplRaise: TPasImplRaise;
VarEl: TPasVariable;
ImplExceptOn: TPasImplExceptOn;
begin
NewImplElement:=nil;
@ -6422,6 +6436,8 @@ begin
// ParseExc;
CheckStatementCanStart;
//writeln('TPasParser.ParseStatement ',CurToken,' ',CurTokenString);
// On is usable as an identifier
if lowerCase(CurTokenText)='on' then
begin
@ -6432,31 +6448,33 @@ begin
begin
SrcPos:=CurTokenPos;
ExpectIdentifier;
El:=TPasImplExceptOn(CreateElement(TPasImplExceptOn,'',CurBlock,SrcPos));
ImplExceptOn:=TPasImplExceptOn(CreateElement(TPasImplExceptOn,'',CurBlock,SrcPos));
El:=ImplExceptOn;
SrcPos:=CurSourcePos;
Name:=CurTokenString;
NextToken;
//writeln('TPasParser.ParseStatement ',CurToken,' ',CurTokenString);
//writeln('ON t=',Name,' Token=',CurTokenText);
if CurToken=tkColon then
begin
// the first expression was the variable name
NextToken;
TypeEl:=ParseSimpleType(El,SrcPos,'');
TPasImplExceptOn(El).TypeEl:=TypeEl;
VarEl:=TPasVariable(CreateElement(TPasVariable,Name,El,SrcPos));
TPasImplExceptOn(El).VarEl:=VarEl;
TypeEl:=ParseSimpleType(ImplExceptOn,SrcPos,'');
ImplExceptOn.TypeEl:=TypeEl;
VarEl:=TPasVariable(CreateElement(TPasVariable,Name,ImplExceptOn,SrcPos));
ImplExceptOn.VarEl:=VarEl;
VarEl.VarType:=TypeEl;
TypeEl.AddRef{$IFDEF CheckPasTreeRefCount}('TPasVariable.VarType'){$ENDIF};
if TypeEl.Parent=El then
if TypeEl.Parent=ImplExceptOn then
TypeEl.Parent:=VarEl;
end
else
begin
UngetToken;
TPasImplExceptOn(El).TypeEl:=ParseSimpleType(El,SrcPos,'');
ImplExceptOn.TypeEl:=ParseSimpleType(ImplExceptOn,SrcPos,'');
end;
Engine.FinishScope(stExceptOnExpr,El);
CreateBlock(TPasImplExceptOn(El));
Engine.FinishScope(stExceptOnExpr,ImplExceptOn);
CreateBlock(ImplExceptOn);
El:=nil;
ExpectToken(tkDo);
end else

22
compiler/packages/fcl-passrc/tests/tcresolver.pas
View File

@ -342,6 +342,7 @@ type
Procedure TestTryStatement;
Procedure TestTryExceptOnNonTypeFail;
Procedure TestTryExceptOnNonClassFail;
Procedure TestTryStatementMissingOnFail;
Procedure TestRaiseNonVarFail;
Procedure TestRaiseNonClassFail;
Procedure TestRaiseDescendant;
@ -1738,6 +1739,8 @@ begin
end;
ok:=true;
end;
on E: Exception do
Fail('Expected EPasResolve but got '+E.ClassName);
end;
AssertEquals('Missing resolver error {'+Msg+'} ('+IntToStr(MsgNumber)+')',true,ok);
end;
@ -1758,6 +1761,8 @@ begin
MsgNumber,Parser.LastMsgNumber);
ok:=true;
end;
on E: Exception do
Fail('Expected EParserError but got '+E.ClassName);
end;
AssertEquals('Missing parser error '+Msg+' ('+IntToStr(MsgNumber)+')',true,ok);
end;
@ -5405,6 +5410,23 @@ begin
CheckResolverException('class expected, but Longint found',nXExpectedButYFound);
end;
procedure TTestResolver.TestTryStatementMissingOnFail;
begin
StartProgram(true,[supTObject]);
Add([
'procedure Run;',
'begin',
' try',
' except',
' on TObject do ;',
' Run;',
' end;',
'end;',
'begin',
'']);
CheckParserException('Expected "end" or "on"',nParserExpectToken2Error);
end;
procedure TTestResolver.TestRaiseNonVarFail;
begin
StartProgram(false);