paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-08-14 18:29:13 +02:00
Code Issues Packages Projects Releases Wiki Activity

fcl-passrc: parser: local and anonymous records cannot be advanced, resolver: adv records: recordvalues, class methods must be static, sub class

Browse Source 
git-svn-id: trunk@40795 -
This commit is contained in:
Mattias Gaertner 2019-01-07 15:54:33 +00:00
parent d6891557d3
commit 5efbfcc2b0
4 changed files with 205 additions and 50 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
packages/fcl-passrc/src/pasresolveeval.pas
View File

@ -154,14 +154,14 @@ const
nMethodHidesMethodOfBaseType = 3077; nMethodHidesMethodOfBaseType = 3077;
nContextExpectedXButFoundY = 3078; nContextExpectedXButFoundY = 3078;
nContextXInvalidY = 3079; nContextXInvalidY = 3079;
// free 3080; nIdentifierXIsNotAnInstanceField = 3080;
nXIsNotSupported = 3081; nXIsNotSupported = 3081;
nOperatorIsNotOverloadedAOpB = 3082; nOperatorIsNotOverloadedAOpB = 3082;
nIllegalQualifierAfter = 3084; nIllegalQualifierAfter = 3084;
nIllegalQualifierInFrontOf = 3085; nIllegalQualifierInFrontOf = 3085;
nIllegalQualifierWithin = 3086; nIllegalQualifierWithin = 3086;
nMethodClassXInOtherUnitY = 3087; nMethodClassXInOtherUnitY = 3087;
// free 3088 nClassMethodsMustBeStaticInRecords = 3088;
nCannotMixMethodResolutionAndDelegationAtX = 3089; nCannotMixMethodResolutionAndDelegationAtX = 3089;
nImplementsDoesNotSupportArrayProperty = 3101; nImplementsDoesNotSupportArrayProperty = 3101;
nImplementsDoesNotSupportIndex = 3102; nImplementsDoesNotSupportIndex = 3102;
@ -277,6 +277,7 @@ resourcestring
sMethodHidesMethodOfBaseType = 'Method "%s" hides method of base type "%s" at %s'; sMethodHidesMethodOfBaseType = 'Method "%s" hides method of base type "%s" at %s';
sContextExpectedXButFoundY = '%s: expected "%s", but found "%s"'; sContextExpectedXButFoundY = '%s: expected "%s", but found "%s"';
sContextXInvalidY = '%s: invalid %s'; sContextXInvalidY = '%s: invalid %s';
sIdentifierXIsNotAnInstanceField = 'Identifier "%s" is not an instance field';
sConstructingClassXWithAbstractMethodY = 'Constructing a class "%s" with abstract method "%s"'; sConstructingClassXWithAbstractMethodY = 'Constructing a class "%s" with abstract method "%s"';
sXIsNotSupported = '%s is not supported'; sXIsNotSupported = '%s is not supported';
sOperatorIsNotOverloadedAOpB = 'Operator is not overloaded: "%s" %s "%s"'; sOperatorIsNotOverloadedAOpB = 'Operator is not overloaded: "%s" %s "%s"';
@ -285,6 +286,7 @@ resourcestring
sIllegalQualifierWithin = 'illegal qualifier "%s" within "%s"'; sIllegalQualifierWithin = 'illegal qualifier "%s" within "%s"';
sMethodClassXInOtherUnitY = 'method class "%s" in other unit "%s"'; sMethodClassXInOtherUnitY = 'method class "%s" in other unit "%s"';
sNoMatchingImplForIntfMethodXFound = 'No matching implementation for interface method "%s" found'; sNoMatchingImplForIntfMethodXFound = 'No matching implementation for interface method "%s" found';
sClassMethodsMustBeStaticInRecords = 'Class methods must be static in records';
sCannotMixMethodResolutionAndDelegationAtX = 'Cannot mix method resolution and delegation at %s'; sCannotMixMethodResolutionAndDelegationAtX = 'Cannot mix method resolution and delegation at %s';
sImplementsDoesNotSupportArrayProperty = '"implements" does dot support array property'; sImplementsDoesNotSupportArrayProperty = '"implements" does dot support array property';
sImplementsDoesNotSupportIndex = '"implements" does not support "index"'; sImplementsDoesNotSupportIndex = '"implements" does not support "index"';

117
packages/fcl-passrc/src/pasresolver.pp
View File

@ -913,7 +913,7 @@ type
DeclarationProc: TPasProcedure; // the corresponding forward declaration DeclarationProc: TPasProcedure; // the corresponding forward declaration
ImplProc: TPasProcedure; // the corresponding proc with Body ImplProc: TPasProcedure; // the corresponding proc with Body
OverriddenProc: TPasProcedure; // if IsOverride then this is the ancestor proc (virtual or override) OverriddenProc: TPasProcedure; // if IsOverride then this is the ancestor proc (virtual or override)
ClassScope: TPasClassOrRecordScope; ClassOrRecordScope: TPasClassOrRecordScope;
SelfArg: TPasArgument; SelfArg: TPasArgument;
Flags: TPasProcedureScopeFlags; Flags: TPasProcedureScopeFlags;
BoolSwitches: TBoolSwitches; // if Body<>nil then body start, otherwise when FinishProc BoolSwitches: TBoolSwitches; // if Body<>nil then body start, otherwise when FinishProc
@ -1860,7 +1860,7 @@ type
function IsVariableConst(El, PosEl: TPasElement; RaiseIfConst: boolean): boolean; virtual; function IsVariableConst(El, PosEl: TPasElement; RaiseIfConst: boolean): boolean; virtual;
function ResolvedElCanBeVarParam(const ResolvedEl: TPasResolverResult; function ResolvedElCanBeVarParam(const ResolvedEl: TPasResolverResult;
PosEl: TPasElement; RaiseIfConst: boolean = true): boolean; PosEl: TPasElement; RaiseIfConst: boolean = true): boolean;
function ResolvedElIsClassInstance(const ResolvedEl: TPasResolverResult): boolean; function ResolvedElIsClassOrRecordInstance(const ResolvedEl: TPasResolverResult): boolean;
// utility functions // utility functions
function ElHasModeSwitch(El: TPasElement; ms: TModeSwitch): boolean; function ElHasModeSwitch(El: TPasElement; ms: TModeSwitch): boolean;
function GetElModeSwitches(El: TPasElement): TModeSwitches; function GetElModeSwitches(El: TPasElement): TModeSwitches;
@ -2975,7 +2975,7 @@ var
begin begin
Result:=inherited FindIdentifier(Identifier); Result:=inherited FindIdentifier(Identifier);
if Result<>nil then exit; if Result<>nil then exit;
CurScope:=ClassScope; CurScope:=ClassOrRecordScope;
if CurScope=nil then exit; if CurScope=nil then exit;
repeat repeat
Result:=CurScope.FindIdentifier(Identifier); Result:=CurScope.FindIdentifier(Identifier);
@ -3000,7 +3000,7 @@ var
begin begin
inherited IterateElements(aName, StartScope, OnIterateElement, Data, Abort); inherited IterateElements(aName, StartScope, OnIterateElement, Data, Abort);
if Abort then exit; if Abort then exit;
CurScope:=ClassScope; CurScope:=ClassOrRecordScope;
if CurScope=nil then exit; if CurScope=nil then exit;
repeat repeat
CurScope.IterateElements(aName, StartScope, OnIterateElement, Data, Abort); CurScope.IterateElements(aName, StartScope, OnIterateElement, Data, Abort);
@ -3022,7 +3022,7 @@ var
begin begin
Result:=Self; Result:=Self;
repeat repeat
if Result.ClassScope<>nil then exit; if Result.ClassOrRecordScope<>nil then exit;
Proc:=TPasProcedure(Element); Proc:=TPasProcedure(Element);
if not (Proc.Parent is TProcedureBody) then exit(nil); if not (Proc.Parent is TProcedureBody) then exit(nil);
Proc:=Proc.Parent.Parent as TPasProcedure; Proc:=Proc.Parent.Parent as TPasProcedure;
@ -3033,8 +3033,8 @@ end;
procedure TPasProcedureScope.WriteIdentifiers(Prefix: string); procedure TPasProcedureScope.WriteIdentifiers(Prefix: string);
begin begin
inherited WriteIdentifiers(Prefix); inherited WriteIdentifiers(Prefix);
if ClassScope<>nil then if ClassOrRecordScope<>nil then
ClassScope.WriteIdentifiers(Prefix+'CS '); ClassOrRecordScope.WriteIdentifiers(Prefix+'CS ');
end; end;
destructor TPasProcedureScope.Destroy; destructor TPasProcedureScope.Destroy;
@ -5569,9 +5569,14 @@ begin
RaiseMsg(20181218195552,nInvalidXModifierY,sInvalidXModifierY,['record '+GetElementTypeName(Proc),'abstract'],Proc); RaiseMsg(20181218195552,nInvalidXModifierY,sInvalidXModifierY,['record '+GetElementTypeName(Proc),'abstract'],Proc);
if Proc.IsForward then if Proc.IsForward then
RaiseMsg(20181218195514,nInvalidXModifierY,sInvalidXModifierY,['record '+GetElementTypeName(Proc),'forward'],Proc); RaiseMsg(20181218195514,nInvalidXModifierY,sInvalidXModifierY,['record '+GetElementTypeName(Proc),'forward'],Proc);
if Proc.IsStatic then if (Proc.ClassType=TPasClassProcedure)
if (Proc.ClassType<>TPasClassProcedure) and (Proc.ClassType<>TPasClassFunction) then or (Proc.ClassType=TPasClassFunction)
RaiseMsg(20181218195519,nInvalidXModifierY,sInvalidXModifierY,['record '+GetElementTypeName(Proc),'static'],Proc); or (Proc.ClassType=TPasClassConstructor)
or (Proc.ClassType=TPasClassDestructor) then
begin
if not Proc.IsStatic then
RaiseMsg(20190106121503,nClassMethodsMustBeStaticInRecords,sClassMethodsMustBeStaticInRecords,[],Proc);
end;
end end
else else
begin begin
@ -5742,7 +5747,7 @@ begin
// ToDo: store the scanner flags *before* it has parsed the token after the proc // ToDo: store the scanner flags *before* it has parsed the token after the proc
StoreScannerFlagsInProc(ProcScope); StoreScannerFlagsInProc(ProcScope);
ClassOrRecScope:=Scopes[ScopeCount-2] as TPasClassOrRecordScope; ClassOrRecScope:=Scopes[ScopeCount-2] as TPasClassOrRecordScope;
ProcScope.ClassScope:=ClassOrRecScope; ProcScope.ClassOrRecordScope:=ClassOrRecScope;
FindData:=Default(TFindOverloadProcData); FindData:=Default(TFindOverloadProcData);
FindData.Proc:=Proc; FindData.Proc:=Proc;
FindData.Args:=Proc.ProcType.Args; FindData.Args:=Proc.ProcType.Args;
@ -5842,7 +5847,7 @@ begin
// search proc in class/record // search proc in class/record
ImplProcScope:=ImplProc.CustomData as TPasProcedureScope; ImplProcScope:=ImplProc.CustomData as TPasProcedureScope;
ClassOrRecScope:=ImplProcScope.ClassScope; ClassOrRecScope:=ImplProcScope.ClassOrRecordScope;
if ClassOrRecScope=nil then if ClassOrRecScope=nil then
RaiseInternalError(20161013172346); RaiseInternalError(20161013172346);
ClassRecType:=NoNil(ClassOrRecScope.Element) as TPasMembersType; ClassRecType:=NoNil(ClassOrRecScope.Element) as TPasMembersType;
@ -5881,7 +5886,7 @@ begin
or (DeclProc.ClassType=TPasClassProcedure) or (DeclProc.ClassType=TPasClassProcedure)
or (DeclProc.ClassType=TPasClassFunction) then or (DeclProc.ClassType=TPasClassFunction) then
begin begin
if (not DeclProc.IsStatic) and (ClassOrRecScope is TPasClassScope) then if ClassOrRecScope is TPasClassScope then
begin begin
// 'Self' in a class proc is the hidden classtype argument // 'Self' in a class proc is the hidden classtype argument
SelfArg:=TPasArgument.Create('Self',DeclProc); SelfArg:=TPasArgument.Create('Self',DeclProc);
@ -5891,7 +5896,9 @@ begin
SelfArg.ArgType:=TPasClassScope(ClassOrRecScope).CanonicalClassOf; SelfArg.ArgType:=TPasClassScope(ClassOrRecScope).CanonicalClassOf;
SelfArg.ArgType.AddRef{$IFDEF CheckPasTreeRefCount}('TPasArgument.ArgType'){$ENDIF}; SelfArg.ArgType.AddRef{$IFDEF CheckPasTreeRefCount}('TPasArgument.ArgType'){$ENDIF};
AddIdentifier(ImplProcScope,'Self',SelfArg,pikSimple); AddIdentifier(ImplProcScope,'Self',SelfArg,pikSimple);
end; end
else
RaiseInternalError(20190106121745);
end end
else else
begin begin
@ -6071,6 +6078,14 @@ var
end; end;
end; end;
function ExpectedClassAccessorStatic: boolean;
begin
if (ClassScope<>nil) and (proClassPropertyNonStatic in Options) then
Result:=false
else
Result:=true;
end;
procedure CheckIndexArg(ArgNo: integer; const IndexResolved: TPasResolverResult; procedure CheckIndexArg(ArgNo: integer; const IndexResolved: TPasResolverResult;
ProcArg: TPasArgument; ErrorEl: TPasElement); ProcArg: TPasArgument; ErrorEl: TPasElement);
var var
@ -6476,7 +6491,7 @@ begin
begin begin
if Proc.ClassType<>TPasClassFunction then if Proc.ClassType<>TPasClassFunction then
RaiseXExpectedButYFound(20170216151834,'class function',GetElementTypeName(Proc),PropEl.ReadAccessor); RaiseXExpectedButYFound(20170216151834,'class function',GetElementTypeName(Proc),PropEl.ReadAccessor);
if Proc.IsStatic=(proClassPropertyNonStatic in Options) then if Proc.IsStatic<>ExpectedClassAccessorStatic then
if Proc.IsStatic then if Proc.IsStatic then
RaiseMsg(20170216151837,nClassPropertyAccessorMustNotBeStatic,sClassPropertyAccessorMustNotBeStatic,[],PropEl.ReadAccessor) RaiseMsg(20170216151837,nClassPropertyAccessorMustNotBeStatic,sClassPropertyAccessorMustNotBeStatic,[],PropEl.ReadAccessor)
else else
@ -6531,11 +6546,11 @@ begin
begin begin
if Proc.ClassType<>TPasClassProcedure then if Proc.ClassType<>TPasClassProcedure then
RaiseXExpectedButYFound(20170216151903,'class procedure',GetElementTypeName(Proc),PropEl.WriteAccessor); RaiseXExpectedButYFound(20170216151903,'class procedure',GetElementTypeName(Proc),PropEl.WriteAccessor);
if Proc.IsStatic=(proClassPropertyNonStatic in Options) then if Proc.IsStatic<>ExpectedClassAccessorStatic then
if Proc.IsStatic then if Proc.IsStatic then
RaiseMsg(20170216151905,nClassPropertyAccessorMustNotBeStatic,sClassPropertyAccessorMustNotBeStatic,[],PropEl.WriteAccessor) RaiseMsg(20170216151905,nClassPropertyAccessorMustNotBeStatic,sClassPropertyAccessorMustNotBeStatic,[],PropEl.WriteAccessor)
else else
RaiseMsg(20170216151906,nClassPropertyAccessorMustBeStatic,sClassPropertyAccessorMustBeStatic,[],PropEl.WriteAccessor); RaiseMsg(20170216151906,nClassPropertyAccessorMustBeStatic,sClassPropertyAccessorMustBeStatic,[],PropEl.WriteAccessor);
end end
else else
begin begin
@ -6617,12 +6632,22 @@ var
DirectAncestor: TPasType; // e.g. TPasAliasType or TPasClassType DirectAncestor: TPasType; // e.g. TPasAliasType or TPasClassType
AncestorClassEl: TPasClassType; AncestorClassEl: TPasClassType;
function IsDefaultAncestor(c: TPasClassType; const DefAncestorName: string): boolean;
begin
Result:=SameText(c.Name,DefAncestorName)
and (c.Parent is TPasSection);
end;
procedure FindDefaultAncestor(const DefAncestorName, Expected: string); procedure FindDefaultAncestor(const DefAncestorName, Expected: string);
var var
CurEl: TPasElement; CurEl: TPasElement;
begin begin
AncestorClassEl:=nil; AncestorClassEl:=nil;
if (CompareText(aClass.Name,DefAncestorName)=0) then exit; if SameText(aClass.Name,DefAncestorName) then
begin
if IsDefaultAncestor(aClass,DefAncestorName) then exit;
RaiseXExpectedButYFound(20190106132328,'top level '+DefAncestorName,'nested '+aClass.Name,aClass);
end;
CurEl:=FindElementWithoutParams(DefAncestorName,aClass,false); CurEl:=FindElementWithoutParams(DefAncestorName,aClass,false);
if not (CurEl is TPasType) then if not (CurEl is TPasType) then
RaiseXExpectedButYFound(20180321150128,Expected,GetElementTypeName(CurEl),aClass); RaiseXExpectedButYFound(20180321150128,Expected,GetElementTypeName(CurEl),aClass);
@ -6715,7 +6740,7 @@ begin
okClass: okClass:
begin begin
DefAncestorName:='TObject'; DefAncestorName:='TObject';
if (CompareText(aClass.Name,DefAncestorName)=0) or aClass.IsExternal then if aClass.IsExternal or IsDefaultAncestor(aClass,DefAncestorName) then
begin begin
// ok, no ancestor // ok, no ancestor
AncestorClassEl:=nil; AncestorClassEl:=nil;
@ -6736,7 +6761,7 @@ begin
DefAncestorName:='IInterface' DefAncestorName:='IInterface'
else else
DefAncestorName:='IUnknown'; DefAncestorName:='IUnknown';
if SameText(DefAncestorName,aClass.Name) then if IsDefaultAncestor(aClass,DefAncestorName) then
AncestorClassEl:=nil AncestorClassEl:=nil
else else
begin begin
@ -8128,7 +8153,7 @@ begin
SelfScope:=ProcScope.GetSelfScope; SelfScope:=ProcScope.GetSelfScope;
if SelfScope=nil then if SelfScope=nil then
RaiseMsg(20170216152141,nInheritedOnlyWorksInMethods,sInheritedOnlyWorksInMethods,[],El); RaiseMsg(20170216152141,nInheritedOnlyWorksInMethods,sInheritedOnlyWorksInMethods,[],El);
ClassRecScope:=SelfScope.ClassScope; ClassRecScope:=SelfScope.ClassOrRecordScope;
AncestorScope:=nil; AncestorScope:=nil;
if ClassRecScope is TPasClassScope then if ClassRecScope is TPasClassScope then
@ -8183,7 +8208,7 @@ begin
SelfScope:=ProcScope.GetSelfScope; SelfScope:=ProcScope.GetSelfScope;
if SelfScope=nil then if SelfScope=nil then
RaiseMsg(20170216152148,nInheritedOnlyWorksInMethods,sInheritedOnlyWorksInMethods,[],El); RaiseMsg(20170216152148,nInheritedOnlyWorksInMethods,sInheritedOnlyWorksInMethods,[],El);
ClassRecScope:=SelfScope.ClassScope; ClassRecScope:=SelfScope.ClassOrRecordScope;
AncestorScope:=nil; AncestorScope:=nil;
if ClassRecScope is TPasClassScope then if ClassRecScope is TPasClassScope then
@ -8895,7 +8920,7 @@ procedure TPasResolver.ResolveRecordValues(El: TRecordValues);
if SameText(Result.Name,aName) then if SameText(Result.Name,aName) then
exit; exit;
end; end;
if (RecType.VariantEl is TPasVariable) then if RecType.VariantEl is TPasVariable then
begin begin
Result:=TPasVariable(RecType.VariantEl); Result:=TPasVariable(RecType.VariantEl);
if SameText(Result.Name,aName) then if SameText(Result.Name,aName) then
@ -8938,9 +8963,12 @@ begin
Member:=GetMember(RecType,Field^.Name); Member:=GetMember(RecType,Field^.Name);
if Member=nil then if Member=nil then
RaiseIdentifierNotFound(20180429104703,Field^.Name,Field^.NameExp); RaiseIdentifierNotFound(20180429104703,Field^.Name,Field^.NameExp);
if not (Member is TPasVariable) then if Member.ClassType<>TPasVariable then
RaiseMsg(20180429121933,nVariableIdentifierExpected,sVariableIdentifierExpected, RaiseMsg(20180429121933,nIdentifierXIsNotAnInstanceField,sIdentifierXIsNotAnInstanceField,
[],Field^.ValueExp); [],Field^.ValueExp);
if TPasVariable(Member).VarModifiers*[vmClass,vmStatic]<>[] then
RaiseMsg(20190105221450,nIdentifierXIsNotAnInstanceField,sIdentifierXIsNotAnInstanceField,
['record assignment'],Field^.ValueExp);
CreateReference(Member,Field^.NameExp,rraAssign); CreateReference(Member,Field^.NameExp,rraAssign);
// check duplicates // check duplicates
for j:=0 to i-1 do for j:=0 to i-1 do
@ -8957,7 +8985,9 @@ begin
for i:=0 to RecType.Members.Count-1 do for i:=0 to RecType.Members.Count-1 do
begin begin
Member:=TPasElement(RecType.Members[i]); Member:=TPasElement(RecType.Members[i]);
if not (Member is TPasVariable) then continue; if Member.ClassType<>TPasVariable then continue;
if TPasVariable(Member).VarModifiers*[vmClass,vmStatic]<>[] then
continue;
j:=length(El.Fields)-1; j:=length(El.Fields)-1;
while (j>=0) and not SameText(Member.Name,El.Fields[j].Name) do while (j>=0) and not SameText(Member.Name,El.Fields[j].Name) do
dec(j); dec(j);
@ -9232,7 +9262,7 @@ var
i: Integer; i: Integer;
DeclEl: TPasElement; DeclEl: TPasElement;
Proc: TPasProcedure; Proc: TPasProcedure;
aClassType: TPasClassType; aClassOrRec: TPasMembersType;
begin begin
if IsElementSkipped(El) then exit; if IsElementSkipped(El) then exit;
if El is TPasDeclarations then if El is TPasDeclarations then
@ -9250,13 +9280,15 @@ begin
end; end;
end; end;
end end
else if El.ClassType=TPasClassType then else if El is TPasMembersType then
begin begin
aClassType:=TPasClassType(El); aClassOrRec:=TPasMembersType(El);
if aClassType.ObjKind in [okInterface,okDispInterface] then exit; if (aClassOrRec is TPasClassType)
for i:=0 to aClassType.Members.Count-1 do and (TPasClassType(aClassOrRec).ObjKind in [okInterface,okDispInterface])
then exit;
for i:=0 to aClassOrRec.Members.Count-1 do
begin begin
DeclEl:=TPasElement(aClassType.Members[i]); DeclEl:=TPasElement(aClassOrRec.Members[i]);
if DeclEl is TPasProcedure then if DeclEl is TPasProcedure then
begin begin
Proc:=TPasProcedure(DeclEl); Proc:=TPasProcedure(DeclEl);
@ -9660,7 +9692,7 @@ begin
RaiseNotYetImplemented(20161013170956,El); RaiseNotYetImplemented(20161013170956,El);
ProcScope.VisibilityContext:=ClassOrRecType; ProcScope.VisibilityContext:=ClassOrRecType;
ProcScope.ClassScope:=NoNil(ClassOrRecType.CustomData) as TPasClassOrRecordScope; ProcScope.ClassOrRecordScope:=NoNil(ClassOrRecType.CustomData) as TPasClassOrRecordScope;
end;// HasDot=true end;// HasDot=true
end; end;
@ -15084,7 +15116,7 @@ begin
and (TPasWithExprScope(StartScope).Scope is TPasClassOrRecordScope) then and (TPasWithExprScope(StartScope).Scope is TPasClassOrRecordScope) then
ClassRecScope:=TPasClassOrRecordScope(TPasWithExprScope(StartScope).Scope) ClassRecScope:=TPasClassOrRecordScope(TPasWithExprScope(StartScope).Scope)
else if (StartScope is TPasProcedureScope) then else if (StartScope is TPasProcedureScope) then
ClassRecScope:=TPasProcedureScope(StartScope).ClassScope ClassRecScope:=TPasProcedureScope(StartScope).ClassOrRecordScope
else else
RaiseInternalError(20170131150855,GetObjName(StartScope)); RaiseInternalError(20170131150855,GetObjName(StartScope));
TypeEl:=ClassRecScope.Element as TPasType; TypeEl:=ClassRecScope.Element as TPasType;
@ -18271,7 +18303,7 @@ begin
exit(NotLocked(IdentEl)); exit(NotLocked(IdentEl));
end; end;
function TPasResolver.ResolvedElIsClassInstance( function TPasResolver.ResolvedElIsClassOrRecordInstance(
const ResolvedEl: TPasResolverResult): boolean; const ResolvedEl: TPasResolverResult): boolean;
var var
TypeEl: TPasType; TypeEl: TPasType;
@ -18280,8 +18312,13 @@ begin
if ResolvedEl.BaseType<>btContext then exit; if ResolvedEl.BaseType<>btContext then exit;
TypeEl:=ResolvedEl.LoTypeEl; TypeEl:=ResolvedEl.LoTypeEl;
if TypeEl=nil then exit; if TypeEl=nil then exit;
if TypeEl.ClassType<>TPasClassType then exit; if TypeEl.ClassType=TPasClassType then
if TPasClassType(TypeEl).ObjKind<>okClass then exit; begin
if TPasClassType(TypeEl).ObjKind<>okClass then exit;
end
else if TypeEl.ClassType=TPasRecordType then
else
exit;
if (ResolvedEl.IdentEl is TPasVariable) if (ResolvedEl.IdentEl is TPasVariable)
or (ResolvedEl.IdentEl.ClassType=TPasArgument) or (ResolvedEl.IdentEl.ClassType=TPasArgument)
or (ResolvedEl.IdentEl.ClassType=TPasResultElement) then or (ResolvedEl.IdentEl.ClassType=TPasResultElement) then

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

@ -3557,7 +3557,9 @@ begin
RecordEl.SetGenericTemplates(List); RecordEl.SetGenericTemplates(List);
NextToken; NextToken;
ParseRecordFieldList(RecordEl,tkend, ParseRecordFieldList(RecordEl,tkend,
msAdvancedRecords in Scanner.CurrentModeSwitches); (msAdvancedRecords in Scanner.CurrentModeSwitches)
and not (Declarations is TProcedureBody)
and (RecordEl.Name<>''));
CheckHint(RecordEl,True); CheckHint(RecordEl,True);
Engine.FinishScope(stTypeDef,RecordEl); Engine.FinishScope(stTypeDef,RecordEl);
end; end;
@ -6344,7 +6346,15 @@ begin
tkClass: tkClass:
begin begin
if Not AllowMethods then if Not AllowMethods then
ParseExc(nErrRecordMethodsNotAllowed,SErrRecordMethodsNotAllowed); begin
NextToken;
case CurToken of
tkConst: ParseExc(nErrRecordConstantsNotAllowed,SErrRecordConstantsNotAllowed);
tkvar: ParseExc(nErrRecordVariablesNotAllowed,SErrRecordVariablesNotAllowed);
else
ParseExc(nErrRecordMethodsNotAllowed,SErrRecordMethodsNotAllowed);
end;
end;
if isClass then if isClass then
ParseExc(nParserTypeSyntaxError,SParserTypeSyntaxError); ParseExc(nParserTypeSyntaxError,SParserTypeSyntaxError);
isClass:=True; isClass:=True;
@ -6437,7 +6447,8 @@ begin
try try
Result.PackMode:=PackMode; Result.PackMode:=PackMode;
NextToken; NextToken;
ParseRecordFieldList(Result,tkEnd,msAdvancedRecords in Scanner.CurrentModeSwitches); ParseRecordFieldList(Result,tkEnd,
(msAdvancedRecords in Scanner.CurrentModeSwitches) and not (Parent is TProcedureBody));
Engine.FinishScope(stTypeDef,Result); Engine.FinishScope(stTypeDef,Result);
ok:=true; ok:=true;
finally finally

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

@ -490,7 +490,10 @@ type
Procedure TestAdvRecord; Procedure TestAdvRecord;
Procedure TestAdvRecord_Private; Procedure TestAdvRecord_Private;
Procedure TestAdvRecord_StrictPrivate; Procedure TestAdvRecord_StrictPrivate;
Procedure TestAdvRecord_MethodImplMissingFail;
Procedure TestAdvRecord_VarConst; Procedure TestAdvRecord_VarConst;
Procedure TestAdvRecord_RecVal_ConstFail;
Procedure TestAdvRecord_RecVal_ClassVarFail;
Procedure TestAdvRecord_LocalForwardType; Procedure TestAdvRecord_LocalForwardType;
Procedure TestAdvRecord_Constructor_NewInstance; Procedure TestAdvRecord_Constructor_NewInstance;
Procedure TestAdvRecord_ConstructorNoParamsFail; Procedure TestAdvRecord_ConstructorNoParamsFail;
@ -504,6 +507,8 @@ type
Procedure TestAdvRecord_RecordAsFuncResult; Procedure TestAdvRecord_RecordAsFuncResult;
Procedure TestAdvRecord_InheritedFail; Procedure TestAdvRecord_InheritedFail;
Procedure TestAdvRecord_ForInEnumerator; Procedure TestAdvRecord_ForInEnumerator;
Procedure TestAdvRecord_InFunctionFail;
Procedure TestAdvRecord_SubClass;
// class // class
Procedure TestClass; Procedure TestClass;
@ -7874,6 +7879,20 @@ begin
CheckResolverException('Can''t access strict private member A',nCantAccessPrivateMember); CheckResolverException('Can''t access strict private member A',nCantAccessPrivateMember);
end; end;
procedure TTestResolver.TestAdvRecord_MethodImplMissingFail;
begin
StartProgram(false);
Add([
'{$modeswitch advancedrecords}',
'type',
' TRec = record',
' procedure SetSize(Value: word);',
' end;',
'begin',
'']);
CheckResolverException(sForwardProcNotResolved,nForwardProcNotResolved);
end;
procedure TTestResolver.TestAdvRecord_VarConst; procedure TTestResolver.TestAdvRecord_VarConst;
begin begin
StartProgram(false); StartProgram(false);
@ -7913,6 +7932,42 @@ begin
ParseProgram; ParseProgram;
end; end;
procedure TTestResolver.TestAdvRecord_RecVal_ConstFail;
begin
StartProgram(false);
Add([
'{$modeswitch advancedrecords}',
'type',
' TRec = record',
' V1: word;',
' const',
' C1 = 3;',
' end;',
'var',
' r: TRec = (V1:2; C1: 4);',
'begin',
'']);
CheckResolverException(sIdentifierXIsNotAnInstanceField,nIdentifierXIsNotAnInstanceField);
end;
procedure TTestResolver.TestAdvRecord_RecVal_ClassVarFail;
begin
StartProgram(false);
Add([
'{$modeswitch advancedrecords}',
'type',
' TRec = record',
' V1: word;',
' class var',
' C1: word;',
' end;',
'var',
' r: TRec = (V1:2; C1: 4);',
'begin',
'']);
CheckResolverException(sIdentifierXIsNotAnInstanceField,nIdentifierXIsNotAnInstanceField);
end;
procedure TTestResolver.TestAdvRecord_LocalForwardType; procedure TTestResolver.TestAdvRecord_LocalForwardType;
begin begin
StartProgram(false); StartProgram(false);
@ -7947,7 +8002,7 @@ begin
'type', 'type',
' TRec = record', ' TRec = record',
' constructor Create(w: word);', ' constructor Create(w: word);',
' class function DoSome: TRec;', ' class function DoSome: TRec; static;',
' end;', ' end;',
'constructor TRec.Create(w: word);', 'constructor TRec.Create(w: word);',
'begin', 'begin',
@ -8027,14 +8082,17 @@ begin
'{$modeswitch advancedrecords}', '{$modeswitch advancedrecords}',
'type', 'type',
' TRec = record', ' TRec = record',
' class procedure {#a}Create;', ' class var w: word;',
' class constructor Create;', ' class procedure {#a}Create; static;',
' class constructor Create; static;',
' end;', ' end;',
'class constructor TRec.Create;', 'class constructor TRec.Create;',
'begin', 'begin',
' w:=w+1;',
'end;', 'end;',
'class procedure TRec.Create;', 'class procedure TRec.Create;',
'begin', 'begin',
' w:=w+1;',
'end;', 'end;',
'begin', 'begin',
' TRec.{@a}Create;', ' TRec.{@a}Create;',
@ -8231,8 +8289,8 @@ begin
'type', 'type',
' {#A}TRec = record', ' {#A}TRec = record',
' {#A_i}i: longint;', ' {#A_i}i: longint;',
' class function {#A_CreateA}Create: TRec;', ' class function {#A_CreateA}Create: TRec; static;',
' class function {#A_CreateB}Create(i: longint): TRec;', ' class function {#A_CreateB}Create(i: longint): TRec; static;',
' end;', ' end;',
'function {#F}F: TRec;', 'function {#F}F: TRec;',
'begin', 'begin',
@ -8313,6 +8371,53 @@ begin
ParseProgram; ParseProgram;
end; end;
procedure TTestResolver.TestAdvRecord_InFunctionFail;
begin
StartProgram(false);
Add([
'{$modeswitch advancedrecords}',
'procedure DoIt;',
'type',
' TBird = record',
' class var i: word;',
' end;',
'var',
' b: TBird;',
'begin',
'end;',
'begin']);
CheckParserException(sErrRecordVariablesNotAllowed,nErrRecordVariablesNotAllowed);
end;
procedure TTestResolver.TestAdvRecord_SubClass;
begin
StartProgram(false);
Add([
'{$modeswitch AdvancedRecords}',
'type',
' TObject = class end;',
' TPoint = record',
' type',
' TBird = class',
' procedure DoIt;',
' class procedure Glob;',
' end;',
' procedure DoIt(b: TBird);',
' end;',
'procedure TPoint.TBird.DoIt;',
'begin',
'end;',
'class procedure TPoint.TBird.Glob;',
'begin',
'end;',
'procedure TPoint.DoIt(b: TBird);',
'begin',
'end;',
'begin',
'']);
ParseProgram;
end;
procedure TTestResolver.TestClass; procedure TTestResolver.TestClass;
begin begin
StartProgram(false); StartProgram(false);