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

* Empty sections in advanced records

Browse Source 
git-svn-id: trunk@47509 -
(cherry picked from commit 713d6a0649)
This commit is contained in:
michael 2020-11-21 10:43:48 +00:00 committed by Florian Klämpfl
parent e0cc112e09
commit af1bb99fe8
4 changed files with 67 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -534,6 +534,7 @@ type
procedure ClearTypeReferences(aType: TPasElement); override;
public
DestType: TPasType;
SubType: TPasType;
Expr: TPasExpr;
end;
@ -3303,6 +3304,7 @@ end;
destructor TPasAliasType.Destroy;
begin
ReleaseAndNil(TPasElement(SubType){$IFDEF CheckPasTreeRefCount},'TPasAliasType.SubType'{$ENDIF});
ReleaseAndNil(TPasElement(DestType){$IFDEF CheckPasTreeRefCount},'TPasAliasType.DestType'{$ENDIF});
ReleaseAndNil(TPasElement(Expr){$IFDEF CheckPasTreeRefCount},'TPasAliasType.Expr'{$ENDIF});
inherited Destroy;

8
packages/fcl-passrc/src/paswrite.pp
View File

@ -1417,11 +1417,11 @@ end;
procedure TPasWriter.WriteImplRaise(aRaise: TPasImplRaise);
begin
if assigned(aRaise.ExceptObject) then
if assigned(aRaise.ExceptObject) then
begin
Add('raise %s',[GetExpr(aRaise.ExceptObject)]);
if aRaise.ExceptAddr<>Nil then
Add(' at %s',[GetExpr(aRaise.ExceptAddr)]);
Add('raise %s',[GetExpr(aRaise.ExceptObject)]);
if aRaise.ExceptAddr<>Nil then
Add(' at %s',[GetExpr(aRaise.ExceptAddr)]);
end
else
Add('raise');

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

@ -1759,12 +1759,20 @@ begin
end;
// read nested specialize arguments
ReadSpecializeArguments(ST,ST.Params);
// Important: resolve type reference AFTER args, because arg count is needed
ST.DestType:=ResolveTypeReference(GenName,ST,ST.Params.Count);
if CurToken<>tkGreaterThan then
ParseExcTokenError('[20190801113005]');
// ToDo: cascaded specialize A<B>.C<D>
// Check for cascaded specialize A<B>.C or A<B>.C<D>
NextToken;
if CurToken<>tkDot then
UnGetToken
else
begin
NextToken;
ST.SubType:=ParseSimpleType(ST,CurSourcePos,GenName,False);
end;
// Important: resolve type reference AFTER args, because arg count is needed
ST.DestType:=ResolveTypeReference(GenName,ST,ST.Params.Count);
Engine.FinishScope(stTypeDef,ST);
Result:=ST;
@ -6846,6 +6854,24 @@ var
Scanner.UnSetTokenOption(toOperatorToken);
end;
Function CheckSection : Boolean;
begin
// Advanced records can have empty sections.
{ Use Case:
Record
type
const
var
Case Integer of
end;
}
NextToken;
Result:=CurToken in [tkvar,tktype,tkConst,tkCase];
if Not Result then
UngetToken;
end;
Var
VariantName : String;
v : TPasMemberVisibility;
@ -6874,6 +6900,8 @@ begin
DisableIsClass;
if Not AllowMethods then
ParseExc(nErrRecordTypesNotAllowed,SErrRecordTypesNotAllowed);
if CheckSection then
continue;
ExpectToken(tkIdentifier);
ParseMembersLocalTypes(ARec,v);
end;
@ -6882,6 +6910,8 @@ begin
DisableIsClass;
if Not AllowMethods then
ParseExc(nErrRecordConstantsNotAllowed,SErrRecordConstantsNotAllowed);
if CheckSection then
continue;
ExpectToken(tkIdentifier);
ParseMembersLocalConsts(ARec,v);
end;
@ -6889,6 +6919,8 @@ begin
begin
if Not AllowMethods then
ParseExc(nErrRecordVariablesNotAllowed,SErrRecordVariablesNotAllowed);
if CheckSection then
continue;
ExpectToken(tkIdentifier);
OldCount:=ARec.Members.Count;
ParseInlineVarDecl(ARec, ARec.Members, v, AEndToken=tkBraceClose);

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

@ -363,6 +363,8 @@ type
Procedure TestAdvRec_ProcOverrideFail;
Procedure TestAdvRec_ProcMessageFail;
Procedure TestAdvRec_DestructorFail;
Procedure TestAdvRec_CaseInVar;
Procedure TestAdvRec_EmptySections;
Procedure TestAdvRecordInFunction;
Procedure TestAdvRecordInAnonFunction;
Procedure TestAdvRecordClassOperator;
@ -2612,6 +2614,29 @@ begin
ParseRecordFail(SParserNoConstructorAllowed,nParserNoConstructorAllowed);
end;
procedure TTestRecordTypeParser.TestAdvRec_CaseInVar;
// Found in System.UITypes.pas
begin
StartRecord(true);
AddMember('var');
AddMember('Case Integer of');
AddMember(' 1 : (x: integer);');
AddMember(' 2 : (y,z: integer)');
ParseRecord;
end;
procedure TTestRecordTypeParser.TestAdvRec_EmptySections;
begin
StartRecord(true);
AddMember('const');
AddMember('type');
AddMember('var');
AddMember(' x: integer;');
ParseRecord;
end;
procedure TTestRecordTypeParser.TestAdvRecordInFunction;
// Src from bug report 36179