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

fcl-passrc: parser: fixed parsing record consts

Browse Source 
git-svn-id: trunk@40659 -
This commit is contained in:
Mattias Gaertner 2018-12-26 21:37:06 +00:00
parent e28dff523a
commit 337fd5abb8
4 changed files with 331 additions and 157 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1041,19 +1041,28 @@ type
procedure WriteIdentifiers(Prefix: string); override; procedure WriteIdentifiers(Prefix: string); override;
end; end;
{ TPasDotRecordScope - used for aRecord.subidentifier }
TPasDotRecordScope = Class(TPasDotIdentifierScope)
end;
{ TPasDotEnumTypeScope - used for EnumType.EnumValue } { TPasDotEnumTypeScope - used for EnumType.EnumValue }
TPasDotEnumTypeScope = Class(TPasDotIdentifierScope) TPasDotEnumTypeScope = Class(TPasDotIdentifierScope)
end; end;
{ TPasDotClassOrRecordScope }
TPasDotClassOrRecordScope = Class(TPasDotIdentifierScope)
end;
{ TPasDotRecordScope - used for aRecord.subidentifier }
TPasDotRecordScope = Class(TPasDotClassOrRecordScope)
private
function GetRecordScope: TPasRecordScope;
public
property RecordScope: TPasRecordScope read GetRecordScope;
end;
{ TPasDotClassScope - used for aClass.subidentifier } { TPasDotClassScope - used for aClass.subidentifier }
TPasDotClassScope = Class(TPasDotIdentifierScope) TPasDotClassScope = Class(TPasDotClassOrRecordScope)
private private
FClassScope: TPasClassScope; FClassScope: TPasClassScope;
procedure SetClassScope(AValue: TPasClassScope); procedure SetClassScope(AValue: TPasClassScope);
@ -1418,7 +1427,8 @@ type
procedure FinishUsesClause; virtual; procedure FinishUsesClause; virtual;
procedure FinishSection(Section: TPasSection); virtual; procedure FinishSection(Section: TPasSection); virtual;
procedure FinishInterfaceSection(Section: TPasSection); virtual; procedure FinishInterfaceSection(Section: TPasSection); virtual;
procedure FinishTypeSection(El: TPasDeclarations); virtual; procedure FinishTypeSection(El: TPasElement); virtual;
procedure FinishTypeSectionEl(El: TPasType); virtual;
procedure FinishTypeDef(El: TPasType); virtual; procedure FinishTypeDef(El: TPasType); virtual;
procedure FinishEnumType(El: TPasEnumType); virtual; procedure FinishEnumType(El: TPasEnumType); virtual;
procedure FinishSetType(El: TPasSetType); virtual; procedure FinishSetType(El: TPasSetType); virtual;
@ -3107,6 +3117,13 @@ begin
AncestorScope.WriteIdentifiers(Prefix+'AS '); AncestorScope.WriteIdentifiers(Prefix+'AS ');
end; end;
{ TPasDotRecordScope }
function TPasDotRecordScope.GetRecordScope: TPasRecordScope;
begin
Result:=TPasRecordScope(IdentifierScope);
end;
{ TPasDotClassScope } { TPasDotClassScope }
procedure TPasDotClassScope.SetClassScope(AValue: TPasClassScope); procedure TPasDotClassScope.SetClassScope(AValue: TPasClassScope);
@ -4794,7 +4811,35 @@ begin
if Section=nil then ; if Section=nil then ;
end; end;
procedure TPasResolver.FinishTypeSection(El: TPasDeclarations); procedure TPasResolver.FinishTypeSection(El: TPasElement);
var
i: Integer;
Decl: TPasElement;
begin
// resolve pending forwards
if El is TPasDeclarations then
begin
for i:=0 to TPasDeclarations(El).Declarations.Count-1 do
begin
Decl:=TPasElement(TPasDeclarations(El).Declarations[i]);
if Decl is TPasType then
FinishTypeSectionEl(TPasType(Decl));
end;
end
else if El is TPasMembersType then
begin
for i:=0 to TPasMembersType(El).Members.Count-1 do
begin
Decl:=TPasElement(TPasMembersType(El).Members[i]);
if Decl is TPasType then
FinishTypeSectionEl(TPasType(Decl));
end;
end
else
RaiseNotYetImplemented(20181226105933,El);
end;
procedure TPasResolver.FinishTypeSectionEl(El: TPasType);
function ReplaceDestType(Decl: TPasType; var DestType: TPasType; function ReplaceDestType(Decl: TPasType; var DestType: TPasType;
const DestName: string; MustExist: boolean; ErrorEl: TPasElement const DestName: string; MustExist: boolean; ErrorEl: TPasElement
@ -4839,81 +4884,74 @@ procedure TPasResolver.FinishTypeSection(El: TPasDeclarations);
end; end;
var var
i: Integer; C: TClass;
Decl: TPasElement;
ClassOfEl: TPasClassOfType; ClassOfEl: TPasClassOfType;
TypeEl: TPasType;
UnresolvedEl: TUnresolvedPendingRef; UnresolvedEl: TUnresolvedPendingRef;
OldClassType: TPasClassType; OldClassType: TPasClassType;
TypeEl: TPasType;
C: TClass;
PtrType: TPasPointerType; PtrType: TPasPointerType;
begin begin
// resolve pending forwards C:=El.ClassType;
for i:=0 to El.Declarations.Count-1 do if C.InheritsFrom(TPasClassType) then
begin begin
Decl:=TPasElement(El.Declarations[i]); if TPasClassType(El).IsForward and (TPasClassType(El).CustomData=nil) then
C:=Decl.ClassType; RaiseMsg(20170216151534,nForwardTypeNotResolved,sForwardTypeNotResolved,[El.Name],El);
if C.InheritsFrom(TPasClassType) then end
else if (C=TPasClassOfType) then
begin
ClassOfEl:=TPasClassOfType(El);
TypeEl:=ResolveAliasType(ClassOfEl.DestType);
if (TypeEl.ClassType=TUnresolvedPendingRef) then
begin begin
if TPasClassType(Decl).IsForward and (TPasClassType(Decl).CustomData=nil) then // forward class-of -> resolve now
RaiseMsg(20170216151534,nForwardTypeNotResolved,sForwardTypeNotResolved,[Decl.Name],Decl); UnresolvedEl:=TUnresolvedPendingRef(TypeEl);
{$IFDEF VerbosePasResolver}
writeln('TPasResolver.FinishTypeSection resolving "',ClassOfEl.Name,'" = class of unresolved "',TypeEl.Name,'"');
{$ENDIF}
ReplaceDestType(ClassOfEl,ClassOfEl.DestType,TypeEl.Name,true,UnresolvedEl
{$IFDEF CheckPasTreeRefCount},'TPasAliasType.DestType'{$ENDIF});
end end
else if (C=TPasClassOfType) then else if TypeEl.ClassType=TPasClassType then
begin begin
ClassOfEl:=TPasClassOfType(Decl); // class-of has found a type
TypeEl:=ResolveAliasType(ClassOfEl.DestType); // another later in the same type section has priority -> check
if (TypeEl.ClassType=TUnresolvedPendingRef) then OldClassType:=TypeEl as TPasClassType;
begin if OldClassType.Parent=ClassOfEl.Parent then
// forward class-of -> resolve now exit; // class in same type section -> ok
UnresolvedEl:=TUnresolvedPendingRef(TypeEl); // class not in same type section -> check
{$IFDEF VerbosePasResolver} {$IFDEF VerbosePasResolver}
writeln('TPasResolver.FinishTypeSection resolving "',ClassOfEl.Name,'" = class of unresolved "',TypeEl.Name,'"'); writeln('TPasResolver.FinishTypeSection improving "',ClassOfEl.Name,'" = class of resolved "',TypeEl.Name,'"');
{$ENDIF} {$ENDIF}
ReplaceDestType(ClassOfEl,ClassOfEl.DestType,TypeEl.Name,true,UnresolvedEl ReplaceDestType(ClassOfEl,ClassOfEl.DestType,ClassOfEl.DestType.Name,false,ClassOfEl
{$IFDEF CheckPasTreeRefCount},'TPasAliasType.DestType'{$ENDIF}); {$IFDEF CheckPasTreeRefCount},'TPasAliasType.DestType'{$ENDIF});
end end;
else if TypeEl.ClassType=TPasClassType then end
begin else if C=TPasPointerType then
// class-of has found a type begin
// another later in the same type section has priority -> check PtrType:=TPasPointerType(El);
OldClassType:=TypeEl as TPasClassType; TypeEl:=ResolveAliasType(PtrType.DestType);
if OldClassType.Parent=ClassOfEl.Parent then if (TypeEl.ClassType=TUnresolvedPendingRef) then
continue; // class in same type section -> ok begin
// class not in same type section -> check // forward pointer -> resolve now
{$IFDEF VerbosePasResolver} UnresolvedEl:=TUnresolvedPendingRef(TypeEl);
writeln('TPasResolver.FinishTypeSection improving "',ClassOfEl.Name,'" = class of resolved "',TypeEl.Name,'"'); {$IFDEF VerbosePasResolver}
{$ENDIF} writeln('TPasResolver.FinishTypeSection resolving "',PtrType.Name,'" = pointer of unresolved "',TypeEl.Name,'"');
ReplaceDestType(ClassOfEl,ClassOfEl.DestType,ClassOfEl.DestType.Name,false,ClassOfEl {$ENDIF}
{$IFDEF CheckPasTreeRefCount},'TPasAliasType.DestType'{$ENDIF}); ReplaceDestType(PtrType,PtrType.DestType,TypeEl.Name,true,UnresolvedEl
end; {$IFDEF CheckPasTreeRefCount},'TPasPointerType.DestType'{$ENDIF});
end end
else if C=TPasPointerType then else
begin begin
PtrType:=TPasPointerType(Decl); // pointer-of has found a type
TypeEl:=ResolveAliasType(PtrType.DestType); // another later in the same type section has priority -> check
if (TypeEl.ClassType=TUnresolvedPendingRef) then if TypeEl.Parent=PtrType.Parent then
begin exit; // class in same type section -> ok
// forward pointer -> resolve now // dest not in same type section -> check
UnresolvedEl:=TUnresolvedPendingRef(TypeEl); {$IFDEF VerbosePasResolver}
{$IFDEF VerbosePasResolver} writeln('TPasResolver.FinishTypeSection improving "',PtrType.Name,'" = pointer of resolved "',TypeEl.Name,'"');
writeln('TPasResolver.FinishTypeSection resolving "',PtrType.Name,'" = pointer of unresolved "',TypeEl.Name,'"'); {$ENDIF}
{$ENDIF} ReplaceDestType(PtrType,PtrType.DestType,TypeEl.Name,false,PtrType
ReplaceDestType(PtrType,PtrType.DestType,TypeEl.Name,true,UnresolvedEl {$IFDEF CheckPasTreeRefCount},'TPasPointerType.DestType'{$ENDIF});
{$IFDEF CheckPasTreeRefCount},'TPasPointerType.DestType'{$ENDIF});
end
else
begin
// pointer-of has found a type
// another later in the same type section has priority -> check
if TypeEl.Parent=Decl.Parent then
continue; // class in same type section -> ok
// dest not in same type section -> check
{$IFDEF VerbosePasResolver}
writeln('TPasResolver.FinishTypeSection improving "',PtrType.Name,'" = pointer of resolved "',TypeEl.Name,'"');
{$ENDIF}
ReplaceDestType(PtrType,PtrType.DestType,TypeEl.Name,false,PtrType
{$IFDEF CheckPasTreeRefCount},'TPasPointerType.DestType'{$ENDIF});
end;
end; end;
end; end;
end; end;
@ -5782,8 +5820,11 @@ begin
SelfArg:=TPasArgument.Create('Self',DeclProc); SelfArg:=TPasArgument.Create('Self',DeclProc);
ImplProcScope.SelfArg:=SelfArg; ImplProcScope.SelfArg:=SelfArg;
{$IFDEF CheckPasTreeRefCount}SelfArg.RefIds.Add('TPasProcedureScope.SelfArg');{$ENDIF} {$IFDEF CheckPasTreeRefCount}SelfArg.RefIds.Add('TPasProcedureScope.SelfArg');{$ENDIF}
SelfArg.Access:=argConst;
SelfArg.ArgType:=ClassRecType; SelfArg.ArgType:=ClassRecType;
if ClassRecType is TPasRecordType then
SelfArg.Access:=argDefault
else
SelfArg.Access:=argConst;
ClassRecType.AddRef{$IFDEF CheckPasTreeRefCount}('TPasArgument.ArgType'){$ENDIF}; ClassRecType.AddRef{$IFDEF CheckPasTreeRefCount}('TPasArgument.ArgType'){$ENDIF};
AddIdentifier(ImplProcScope,'Self',SelfArg,pikSimple); AddIdentifier(ImplProcScope,'Self',SelfArg,pikSimple);
end; end;
@ -14761,6 +14802,25 @@ procedure TPasResolver.CheckFoundElement(
const FindData: TPRFindData; Ref: TResolvedReference); const FindData: TPRFindData; Ref: TResolvedReference);
// check visibility rules // check visibility rules
// Call this method after finding an element by searching the scopes. // Call this method after finding an element by searching the scopes.
function IsFieldInheritingConst(aRef: TResolvedReference): boolean;
// returns true of aRef is a TPasVariable that inherits its const from parent.
// For example
// type TRecord = record
// a: word; // inherits const
// const b: word = 3; // does not inherit const
// class var c: word; // does not inherit const
// end;
// procedure DoIt(const r:TRecord)
var
El: TPasElement;
begin
El:=aRef.Declaration;
Result:=(El.ClassType=TPasVariable)
and (TPasVariable(El).VarModifiers*[vmClass, vmStatic]=[]);
//writeln('IsFieldInheritingConst ',GetObjName(El),' ',Result,' vmClass=',vmClass in TPasVariable(El).VarModifiers);
end;
var var
Proc: TPasProcedure; Proc: TPasProcedure;
Context: TPasElement; Context: TPasElement;
@ -14784,7 +14844,8 @@ begin
if Ref<>nil then if Ref<>nil then
begin begin
Include(Ref.Flags,rrfDotScope); Include(Ref.Flags,rrfDotScope);
if TPasDotIdentifierScope(StartScope).ConstParent then if TPasDotIdentifierScope(StartScope).ConstParent
and IsFieldInheritingConst(Ref) then
Include(Ref.Flags,rrfConstInherited); Include(Ref.Flags,rrfConstInherited);
end; end;
end end
@ -14795,7 +14856,8 @@ begin
if Ref<>nil then if Ref<>nil then
begin begin
Include(Ref.Flags,rrfDotScope); Include(Ref.Flags,rrfDotScope);
if wesfConstParent in TPasWithExprScope(StartScope).Flags then if (wesfConstParent in TPasWithExprScope(StartScope).Flags)
and IsFieldInheritingConst(Ref) then
Include(Ref.Flags,rrfConstInherited); Include(Ref.Flags,rrfConstInherited);
end; end;
end end
@ -14838,21 +14900,21 @@ begin
and TPasClassType(TPasDotClassScope(StartScope).ClassScope.Element).IsExternal then and TPasClassType(TPasDotClassScope(StartScope).ClassScope.Element).IsExternal then
begin begin
// found member in external class instance // found member in external class instance
C:=FindData.Found.ClassType; C:=FindData.Found.ClassType;
if (C=TPasProcedure) or (C=TPasFunction) then if (C=TPasProcedure) or (C=TPasFunction) then
// ok // ok
else if (C=TPasConst) then else if (C=TPasConst) then
// ok // ok
else if C.InheritsFrom(TPasVariable) else if C.InheritsFrom(TPasVariable)
and (not (vmClass in TPasVariable(FindData.Found).VarModifiers)) then and (not (vmClass in TPasVariable(FindData.Found).VarModifiers)) then
// ok // ok
else else
begin begin
RaiseMsg(20170331184224,nExternalClassInstanceCannotAccessStaticX, RaiseMsg(20170331184224,nExternalClassInstanceCannotAccessStaticX,
sExternalClassInstanceCannotAccessStaticX, sExternalClassInstanceCannotAccessStaticX,
[GetElementTypeName(FindData.Found)+' '+FindData.Found.Name], [GetElementTypeName(FindData.Found)+' '+FindData.Found.Name],
FindData.ErrorPosEl); FindData.ErrorPosEl);
end; end;
end; end;
if (FindData.Found is TPasProcedure) then if (FindData.Found is TPasProcedure) then
@ -14877,7 +14939,7 @@ begin
end; end;
// constructor: NewInstance or normal call // constructor: NewInstance or normal call
// it is a NewInstance iff the scope is a class, e.g. TObject.Create // it is a NewInstance iff the scope is a class/record, e.g. TObject.Create
if (Proc.ClassType=TPasConstructor) if (Proc.ClassType=TPasConstructor)
and OnlyTypeMembers and OnlyTypeMembers
and (Ref<>nil) then and (Ref<>nil) then
@ -14887,8 +14949,8 @@ begin
if Ref.Context<>nil then if Ref.Context<>nil then
RaiseInternalError(20170131141936); RaiseInternalError(20170131141936);
Ref.Context:=TResolvedRefCtxConstructor.Create; Ref.Context:=TResolvedRefCtxConstructor.Create;
if StartScope is TPasDotClassScope then if StartScope is TPasDotClassOrRecordScope then
ClassRecScope:=TPasDotClassScope(StartScope).ClassScope ClassRecScope:=TPasClassOrRecordScope(TPasDotClassOrRecordScope(StartScope).IdentifierScope)
else if (StartScope is TPasWithExprScope) else if (StartScope is TPasWithExprScope)
and (TPasWithExprScope(StartScope).Scope is TPasClassOrRecordScope) then and (TPasWithExprScope(StartScope).Scope is TPasClassOrRecordScope) then
ClassRecScope:=TPasClassOrRecordScope(TPasWithExprScope(StartScope).Scope) ClassRecScope:=TPasClassOrRecordScope(TPasWithExprScope(StartScope).Scope)
@ -15030,7 +15092,7 @@ begin
case ScopeType of case ScopeType of
stModule: FinishModule(El as TPasModule); stModule: FinishModule(El as TPasModule);
stUsesClause: FinishUsesClause; stUsesClause: FinishUsesClause;
stTypeSection: FinishTypeSection(El as TPasDeclarations); stTypeSection: FinishTypeSection(El);
stTypeDef: FinishTypeDef(El as TPasType); stTypeDef: FinishTypeDef(El as TPasType);
stResourceString: FinishResourcestring(El as TPasResString); stResourceString: FinishResourcestring(El as TPasResString);
stProcedure: FinishProcedure(El as TPasProcedure); stProcedure: FinishProcedure(El as TPasProcedure);

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

@ -81,7 +81,7 @@ const
nErrRecordConstantsNotAllowed = 2035; nErrRecordConstantsNotAllowed = 2035;
nErrRecordMethodsNotAllowed = 2036; nErrRecordMethodsNotAllowed = 2036;
nErrRecordPropertiesNotAllowed = 2037; nErrRecordPropertiesNotAllowed = 2037;
// free , was nErrRecordVisibilityNotAllowed = 2038; nErrRecordTypesNotAllowed = 2038;
nParserTypeNotAllowedHere = 2039; nParserTypeNotAllowedHere = 2039;
nParserNotAnOperand = 2040; nParserNotAnOperand = 2040;
nParserArrayPropertiesCannotHaveDefaultValue = 2041; nParserArrayPropertiesCannotHaveDefaultValue = 2041;
@ -142,7 +142,7 @@ resourcestring
SErrRecordVariablesNotAllowed = 'Record variables not allowed at this location.'; SErrRecordVariablesNotAllowed = 'Record variables not allowed at this location.';
SErrRecordMethodsNotAllowed = 'Record methods not allowed at this location.'; SErrRecordMethodsNotAllowed = 'Record methods not allowed at this location.';
SErrRecordPropertiesNotAllowed = 'Record properties not allowed at this location.'; SErrRecordPropertiesNotAllowed = 'Record properties not allowed at this location.';
// free, was SErrRecordVisibilityNotAllowed = 'Record visibilities not allowed at this location.'; SErrRecordTypesNotAllowed = 'Record types not allowed at this location.';
SParserTypeNotAllowedHere = 'Type "%s" not allowed here'; SParserTypeNotAllowedHere = 'Type "%s" not allowed here';
SParserNotAnOperand = 'Not an operand: (%d : %s)'; SParserNotAnOperand = 'Not an operand: (%d : %s)';
SParserArrayPropertiesCannotHaveDefaultValue = 'Array properties cannot have default value'; SParserArrayPropertiesCannotHaveDefaultValue = 'Array properties cannot have default value';
@ -297,8 +297,8 @@ type
function GetVariableValueAndLocation(Parent : TPasElement; Out Value: TPasExpr; Out AbsoluteExpr: TPasExpr; Out Location: String): Boolean; function GetVariableValueAndLocation(Parent : TPasElement; Out Value: TPasExpr; Out AbsoluteExpr: TPasExpr; Out Location: String): Boolean;
procedure HandleProcedureModifier(Parent: TPasElement; pm : TProcedureModifier); procedure HandleProcedureModifier(Parent: TPasElement; pm : TProcedureModifier);
procedure HandleProcedureTypeModifier(ProcType: TPasProcedureType; ptm : TProcTypeModifier); procedure HandleProcedureTypeModifier(ProcType: TPasProcedureType; ptm : TProcTypeModifier);
procedure ParseClassLocalConsts(AType: TPasClassType; AVisibility: TPasMemberVisibility); procedure ParseMembersLocalConsts(AType: TPasMembersType; AVisibility: TPasMemberVisibility);
procedure ParseClassLocalTypes(AType: TPasClassType; AVisibility: TPasMemberVisibility); procedure ParseMembersLocalTypes(AType: TPasMembersType; AVisibility: TPasMemberVisibility);
procedure ParseVarList(Parent: TPasElement; VarList: TFPList; AVisibility: TPasMemberVisibility; Full: Boolean); procedure ParseVarList(Parent: TPasElement; VarList: TFPList; AVisibility: TPasMemberVisibility; Full: Boolean);
procedure SetOptions(AValue: TPOptions); procedure SetOptions(AValue: TPOptions);
procedure OnScannerModeChanged(Sender: TObject; NewMode: TModeSwitch; procedure OnScannerModeChanged(Sender: TObject; NewMode: TModeSwitch;
@ -1252,7 +1252,10 @@ begin
end end
else if Parent is TPasRecordType then else if Parent is TPasRecordType then
begin begin
if PM in [pmVirtual,pmPublic,pmForward] then exit(false); if not (PM in [pmOverload,
pmInline, pmAssembler, pmPublic,
pmExternal,
pmNoReturn, pmFar, pmFinal]) then exit(false);
end; end;
Parent:=Parent.Parent; Parent:=Parent.Parent;
end; end;
@ -1310,7 +1313,7 @@ begin
end; end;
end; end;
Until Not Found; Until Not Found;
UnGetToken; UngetToken;
If Assigned(Element) then If Assigned(Element) then
Element.Hints:=Result; Element.Hints:=Result;
if ExpectSemiColon then if ExpectSemiColon then
@ -2829,7 +2832,7 @@ begin
end; end;
// Return the parent of a function declaration. This is AParent, // Return the parent of a function declaration. This is AParent,
// except when AParent is a class, and the function is overloaded. // except when AParent is a class/record and the function is overloaded.
// Then the parent is the overload object. // Then the parent is the overload object.
function TPasParser.CheckIfOverloaded(AParent: TPasElement; const AName: String): TPasElement; function TPasParser.CheckIfOverloaded(AParent: TPasElement; const AName: String): TPasElement;
var var
@ -2838,15 +2841,14 @@ var
begin begin
Result:=AParent; Result:=AParent;
If (not (po_nooverloadedprocs in Options)) and (AParent is TPasClassType) then If (not (po_nooverloadedprocs in Options)) and (AParent is TPasMembersType) then
begin begin
OverloadedProc:=CheckOverLoadList(TPasClassType(AParent).Members,AName,Member); OverloadedProc:=CheckOverLoadList(TPasMembersType(AParent).Members,AName,Member);
If (OverloadedProc<>Nil) then If (OverloadedProc<>Nil) then
Result:=OverloadedProc; Result:=OverloadedProc;
end; end;
end; end;
procedure TPasParser.ParseMain(var Module: TPasModule); procedure TPasParser.ParseMain(var Module: TPasModule);
begin begin
Module:=nil; Module:=nil;
@ -3397,7 +3399,7 @@ begin
SetBlock(declThreadVar); SetBlock(declThreadVar);
tkProperty: tkProperty:
SetBlock(declProperty); SetBlock(declProperty);
tkProcedure, tkFunction, tkConstructor, tkDestructor,tkOperator: tkProcedure, tkFunction, tkConstructor, tkDestructor, tkOperator:
begin begin
SetBlock(declNone); SetBlock(declNone);
SaveComments; SaveComments;
@ -3409,7 +3411,7 @@ begin
SetBlock(declNone); SetBlock(declNone);
SaveComments; SaveComments;
NextToken; NextToken;
If CurToken in [tkprocedure,tkFunction,tkConstructor, tkDestructor] then If CurToken in [tkprocedure,tkFunction,tkConstructor,tkDestructor] then
begin begin
pt:=GetProcTypeFromToken(CurToken,True); pt:=GetProcTypeFromToken(CurToken,True);
AddProcOrFunction(Declarations,ParseProcedureOrFunctionDecl(Declarations, pt)); AddProcOrFunction(Declarations,ParseProcedureOrFunctionDecl(Declarations, pt));
@ -3554,7 +3556,8 @@ begin
Declarations.Classes.Add(RecordEl); Declarations.Classes.Add(RecordEl);
RecordEl.SetGenericTemplates(List); RecordEl.SetGenericTemplates(List);
NextToken; NextToken;
ParseRecordFieldList(RecordEl,tkend,true); ParseRecordFieldList(RecordEl,tkend,
msAdvancedRecords in Scanner.CurrentModeSwitches);
CheckHint(RecordEl,True); CheckHint(RecordEl,True);
Engine.FinishScope(stTypeDef,RecordEl); Engine.FinishScope(stTypeDef,RecordEl);
end; end;
@ -3794,7 +3797,7 @@ var
begin begin
SaveComments; SaveComments;
Result := TPasConst(CreateElement(TPasConst, CurTokenString, Parent)); Result := TPasConst(CreateElement(TPasConst, CurTokenString, Parent));
if Parent is TPasClassType then if Parent is TPasMembersType then
Include(Result.VarModifiers,vmClass); Include(Result.VarModifiers,vmClass);
ok:=false; ok:=false;
try try
@ -3874,7 +3877,7 @@ begin
else else
CheckToken(tkEqual); CheckToken(tkEqual);
UngetToken; UngetToken;
CheckHint(Result,True); CheckHint(Result,not (Parent is TPasMembersType));
ok:=true; ok:=true;
finally finally
if not ok then if not ok then
@ -4355,7 +4358,7 @@ begin
// Note: external members are allowed for non external classes too // Note: external members are allowed for non external classes too
ExternalStruct:=(msExternalClass in CurrentModeSwitches) ExternalStruct:=(msExternalClass in CurrentModeSwitches)
and ((Parent is TPasClassType) or (Parent is TPasRecordType)); and (Parent is TPasMembersType);
H:=H+CheckHint(Nil,False); H:=H+CheckHint(Nil,False);
if Full or ExternalStruct then if Full or ExternalStruct then
@ -4750,7 +4753,7 @@ begin
NextToken; NextToken;
If not CurTokenIsIdentifier('name') then If not CurTokenIsIdentifier('name') then
begin begin
if P.Parent is TPasClassType then if P.Parent is TPasMembersType then
begin begin
// public section starts // public section starts
UngetToken; UngetToken;
@ -4903,7 +4906,7 @@ begin
ResultEl:=TPasFunctionType(Element).ResultEl; ResultEl:=TPasFunctionType(Element).ResultEl;
ResultEl.ResultType := ParseType(ResultEl,CurSourcePos); ResultEl.ResultType := ParseType(ResultEl,CurSourcePos);
end end
// In Delphi mode, the implementation in the implementation section can be // In Delphi mode, the signature in the implementation section can be
// without result as it was declared // without result as it was declared
// We actually check if the function exists in the interface section. // We actually check if the function exists in the interface section.
else if (not IsAnonymous) else if (not IsAnonymous)
@ -6150,7 +6153,6 @@ var
PC : TPTreeElement; PC : TPTreeElement;
Ot : TOperatorType; Ot : TOperatorType;
IsTokenBased , ok: Boolean; IsTokenBased , ok: Boolean;
begin begin
case ProcType of case ProcType of
ptOperator,ptClassOperator: ptOperator,ptClassOperator:
@ -6293,11 +6295,10 @@ procedure TPasParser.ParseRecordFieldList(ARec: TPasRecordType;
Var Var
VariantName : String; VariantName : String;
v : TPasmemberVisibility; v : TPasMemberVisibility;
Proc: TPasProcedure; Proc: TPasProcedure;
ProcType: TProcType; ProcType: TProcType;
Prop : TPasProperty; Prop : TPasProperty;
Cons : TPasConst;
isClass : Boolean; isClass : Boolean;
NamePos: TPasSourcePos; NamePos: TPasSourcePos;
OldCount, i: Integer; OldCount, i: Integer;
@ -6308,15 +6309,19 @@ begin
begin begin
SaveComments; SaveComments;
Case CurToken of Case CurToken of
tkType:
begin
if Not AllowMethods then
ParseExc(nErrRecordTypesNotAllowed,SErrRecordTypesNotAllowed);
ExpectToken(tkIdentifier);
ParseMembersLocalTypes(ARec,v);
end;
tkConst: tkConst:
begin begin
if Not AllowMethods then if Not AllowMethods then
ParseExc(nErrRecordConstantsNotAllowed,SErrRecordConstantsNotAllowed); ParseExc(nErrRecordConstantsNotAllowed,SErrRecordConstantsNotAllowed);
ExpectToken(tkIdentifier); ExpectToken(tkIdentifier);
Cons:=ParseConstDecl(ARec); ParseMembersLocalConsts(ARec,v);
Cons.Visibility:=v;
ARec.members.Add(Cons);
Engine.FinishScope(stDeclaration,Cons);
end; end;
tkVar: tkVar:
begin begin
@ -6365,6 +6370,8 @@ begin
else else
ARec.Members.Add(Proc); ARec.Members.Add(Proc);
end; end;
tkDestructor:
ParseExc(nParserNoConstructorAllowed,SParserNoConstructorAllowed);
tkGeneric, // Counts as field name tkGeneric, // Counts as field name
tkIdentifier : tkIdentifier :
begin begin
@ -6549,40 +6556,46 @@ begin
end; end;
end; end;
procedure TPasParser.ParseClassLocalTypes(AType: TPasClassType; AVisibility : TPasMemberVisibility); procedure TPasParser.ParseMembersLocalTypes(AType: TPasMembersType;
AVisibility: TPasMemberVisibility);
Var Var
T : TPasType; T : TPasType;
Done : Boolean; Done : Boolean;
begin begin
// Writeln('Parsing local types'); // Writeln('Parsing local types');
Repeat Repeat
T:=ParseTypeDecl(AType); T:=ParseTypeDecl(AType);
T.Visibility:=AVisibility; T.Visibility:=AVisibility;
AType.Members.Add(t); AType.Members.Add(t);
// Writeln(CurtokenString,' ',TokenInfos[Curtoken]); // Writeln(CurtokenString,' ',TokenInfos[Curtoken]);
NextToken; NextToken;
Done:=(Curtoken<>tkIdentifier) or CheckVisibility(CurtokenString,AVisibility); Done:=(Curtoken<>tkIdentifier) or CheckVisibility(CurTokenString,AVisibility);
if Done then if Done then
UngetToken; UngetToken;
Until Done; Until Done;
Engine.FinishScope(stTypeSection,AType);
end; end;
procedure TPasParser.ParseClassLocalConsts(AType: TPasClassType; AVisibility : TPasMemberVisibility); procedure TPasParser.ParseMembersLocalConsts(AType: TPasMembersType;
AVisibility: TPasMemberVisibility);
Var Var
C : TPasConst; C : TPasConst;
Done : Boolean; Done : Boolean;
begin begin
// Writeln('Parsing local consts'); // Writeln('Parsing local consts');
Repeat Repeat
C:=ParseConstDecl(AType); C:=ParseConstDecl(AType);
C.Visibility:=AVisibility; C.Visibility:=AVisibility;
AType.Members.Add(C); AType.Members.Add(C);
Engine.FinishScope(stDeclaration,C); Engine.FinishScope(stDeclaration,C);
// Writeln(CurtokenString,' ',TokenInfos[Curtoken]); //Writeln('TPasParser.ParseMembersLocalConsts ',CurtokenString,' ',TokenInfos[CurToken]);
NextToken; NextToken;
Done:=(Curtoken<>tkIdentifier) or CheckVisibility(CurtokenString,AVisibility); if CurToken<>tkSemicolon then
exit;
NextToken;
Done:=(CurToken<>tkIdentifier) or CheckVisibility(CurTokenString,AVisibility);
if Done then if Done then
UngetToken; UngetToken;
Until Done; Until Done;
@ -6658,9 +6671,9 @@ begin
SaveComments; SaveComments;
Case CurSection of Case CurSection of
stType: stType:
ParseClassLocalTypes(AType,CurVisibility); ParseMembersLocalTypes(AType,CurVisibility);
stConst : stConst :
ParseClassLocalConsts(AType,CurVisibility); ParseMembersLocalConsts(AType,CurVisibility);
stNone, stNone,
stVar, stVar,
stClassVar: stClassVar:

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

@ -489,17 +489,12 @@ type
// advanced record // advanced record
Procedure TestAdvRecord; Procedure TestAdvRecord;
Procedure TestAdvRecord_Private; Procedure TestAdvRecord_Private;
Procedure TestAdvRecord_StrictPrivate; // ToDo Procedure TestAdvRecord_StrictPrivate;
// ToDo: public, private, strict private Procedure TestAdvRecord_VarConst;
// ToDo: TestAdvRecordPublishedFail Procedure TestAdvRecord_LocalForwardType;
// ToDo: TestAdvRecord_VirtualFail // ToDo: constructor
// ToDo: TestAdvRecord_OverrideFail
// ToDo: constructor, destructor
// ToDo: class function/procedure // ToDo: class function/procedure
// ToDo: nested record type // ToDo: nested record type
// ToDo: const
// todo: var
// todo: class var
// todo: property // todo: property
// todo: class property // todo: class property
// todo: TestRecordAsFuncResult // todo: TestRecordAsFuncResult
@ -515,6 +510,7 @@ type
Procedure TestClassForwardAsAncestorFail; Procedure TestClassForwardAsAncestorFail;
Procedure TestClassForwardNotResolved; Procedure TestClassForwardNotResolved;
Procedure TestClassForwardDuplicateFail; Procedure TestClassForwardDuplicateFail;
// ToDo: local forward sub class
Procedure TestClass_Method; Procedure TestClass_Method;
Procedure TestClass_ConstructorMissingDotFail; Procedure TestClass_ConstructorMissingDotFail;
Procedure TestClass_MethodImplDuplicateFail; Procedure TestClass_MethodImplDuplicateFail;
@ -7859,7 +7855,6 @@ end;
procedure TTestResolver.TestAdvRecord_StrictPrivate; procedure TTestResolver.TestAdvRecord_StrictPrivate;
begin begin
exit;
StartProgram(false); StartProgram(false);
Add([ Add([
'{$modeswitch advancedrecords}', '{$modeswitch advancedrecords}',
@ -7872,7 +7867,65 @@ begin
' r: TRec;', ' r: TRec;',
'begin', 'begin',
' r.a:=r.a;']); ' r.a:=r.a;']);
CheckResolverException('aaa',123); CheckResolverException('Can''t access strict private member A',nCantAccessPrivateMember);
end;
procedure TTestResolver.TestAdvRecord_VarConst;
begin
StartProgram(false);
Add([
'{$modeswitch advancedrecords}',
'type',
' TRec = record',
' type TInt = word;',
' const',
' C1 = 3;',
' C2: TInt = 4;',
' var',
' V1: TInt;',
' V2: TInt;',
' class var',
' VC: TInt;',
' CA: array[1..C1] of TInt;',
' procedure DoIt;',
' end;',
'procedure TRec.DoIt;',
'begin',
' C2:=Self.C2;',
' V1:=VC;',
' Self.V1:=Self.VC;',
' VC:=V1;',
' Self.VC:=Self.V1;',
'end;',
'var',
' r: TRec;',
'begin',
' trec.C2:=trec.C2;',
' r.V1:=r.VC;',
' r.V1:=trec.VC;',
' r.VC:=r.V1;',
' trec.VC:=trec.c1;',
'']);
ParseProgram;
end;
procedure TTestResolver.TestAdvRecord_LocalForwardType;
begin
StartProgram(false);
Add([
'{$modeswitch advancedrecords}',
'type',
' TRec = record',
' type',
' PInt = ^TInt;',
' TInt = word;',
' var i: PInt;',
' end;',
'var',
' r: TRec;',
'begin',
'']);
ParseProgram;
end; end;
procedure TTestResolver.TestClass; procedure TTestResolver.TestClass;

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

@ -197,7 +197,7 @@ type
Procedure DoParseRecord; Procedure DoParseRecord;
Procedure TestFields(Const Fields : Array of string; AHint : String; HaveVariant : Boolean = False); Procedure TestFields(Const Fields : Array of string; AHint : String; HaveVariant : Boolean = False);
procedure AssertVariantSelector(AName, AType: string); procedure AssertVariantSelector(AName, AType: string);
procedure AssertConst1(Hints: TPasMemberHints); procedure AssertConst1(Hints: TPasMemberHints; Index: integer = 1);
procedure AssertField1(Hints: TPasMemberHints); procedure AssertField1(Hints: TPasMemberHints);
procedure AssertField2(Hints: TPasMemberHints); procedure AssertField2(Hints: TPasMemberHints);
procedure AssertMethod2(Hints: TPasMemberHints; isClass : Boolean = False); procedure AssertMethod2(Hints: TPasMemberHints; isClass : Boolean = False);
@ -257,7 +257,6 @@ type
Procedure TestOnePlatformField; Procedure TestOnePlatformField;
Procedure TestOnePlatformFieldDeprecated; Procedure TestOnePlatformFieldDeprecated;
Procedure TestOnePlatformFieldPlatform; Procedure TestOnePlatformFieldPlatform;
Procedure TestOneConstOneField;
Procedure TestOneGenericField; Procedure TestOneGenericField;
Procedure TestTwoFields; Procedure TestTwoFields;
procedure TestTwoFieldProtected; procedure TestTwoFieldProtected;
@ -351,10 +350,16 @@ type
Procedure TestVariantNestedVariantBothDeprecatedPlatform; Procedure TestVariantNestedVariantBothDeprecatedPlatform;
Procedure TestOperatorField; Procedure TestOperatorField;
Procedure TestPropertyFail; Procedure TestPropertyFail;
Procedure TestAdvRec_TwoConst;
Procedure TestAdvRec_Property; Procedure TestAdvRec_Property;
Procedure TestAdvRec_PropertyImplementsFail; Procedure TestAdvRec_PropertyImplementsFail;
Procedure TestAdvRec_PropertyNoTypeFail; Procedure TestAdvRec_PropertyNoTypeFail;
Procedure TestAdvRec_ForwardFail; Procedure TestAdvRec_ForwardFail;
Procedure TestAdvRec_PublishedFail;
Procedure TestAdvRec_ProcVirtualFail;
Procedure TestAdvRec_ProcOverrideFail;
Procedure TestAdvRec_ProcMessageFail;
Procedure TestAdvRec_DestructorFail;
end; end;
{ TTestProcedureTypeParser } { TTestProcedureTypeParser }
@ -1365,15 +1370,15 @@ begin
end; end;
end; end;
procedure TTestRecordTypeParser.AssertConst1(Hints: TPasMemberHints); procedure TTestRecordTypeParser.AssertConst1(Hints: TPasMemberHints;
Index: integer);
begin begin
if Hints=[] then ; if Hints=[] then ;
AssertEquals('Member 1 type',TPasConst,TObject(TheRecord.Members[0]).ClassType); AssertEquals('Member '+IntToStr(Index+1)+' type',TPasConst,TObject(TheRecord.Members[Index]).ClassType);
AssertEquals('Const 1 name','x',Const1.Name); AssertEquals('Const '+IntToStr(Index+1)+' name','x',Const1.Name);
AssertNotNull('Have 1 const expr',Const1.Expr); AssertNotNull('Have '+IntToStr(Index+1)+' const expr',Const1.Expr);
end; end;
procedure TTestRecordTypeParser.DoTestEmpty(const AHint: String); procedure TTestRecordTypeParser.DoTestEmpty(const AHint: String);
begin begin
TestFields([],AHint); TestFields([],AHint);
@ -1386,7 +1391,6 @@ begin
AssertVariant1(Hints,['0']); AssertVariant1(Hints,['0']);
end; end;
procedure TTestRecordTypeParser.AssertVariant1(Hints: TPasMemberHints; procedure TTestRecordTypeParser.AssertVariant1(Hints: TPasMemberHints;
VariantLabels: array of string); VariantLabels: array of string);
@ -1902,15 +1906,6 @@ begin
AssertOneIntegerField([hplatform]); AssertOneIntegerField([hplatform]);
end; end;
procedure TTestRecordTypeParser.TestOneConstOneField;
begin
Scanner.Options:=[po_Delphi];
TestFields(['public','Const x =123;','y : integer'],'',False);
AssertConst1([]);
AssertEquals('Correct visibility',visPublic,TPasConst(TheRecord.Members[0]).Visibility);
AssertField2([]);
end;
procedure TTestRecordTypeParser.TestOneGenericField; procedure TTestRecordTypeParser.TestOneGenericField;
begin begin
TestFields(['Generic : Integer;'],'',False); TestFields(['Generic : Integer;'],'',False);
@ -2532,6 +2527,21 @@ begin
ParseRecordFail(SErrRecordPropertiesNotAllowed,nErrRecordPropertiesNotAllowed); ParseRecordFail(SErrRecordPropertiesNotAllowed,nErrRecordPropertiesNotAllowed);
end; end;
procedure TTestRecordTypeParser.TestAdvRec_TwoConst;
var
aConst: TPasConst;
begin
Scanner.Options:=[po_Delphi];
TestFields(['public','Const x =123;','y : integer = 456'],'',False);
AssertEquals('Two Const',2,TheRecord.Members.Count);
AssertConst1([]);
AssertEquals('Correct visibility',visPublic,TPasConst(TheRecord.Members[0]).Visibility);
AssertEquals('Member 2 type',TPasConst,TObject(TheRecord.Members[1]).ClassType);
aConst:=TPasConst(TheRecord.Members[1]);
AssertEquals('Const 2 name','y',aConst.Name);
AssertNotNull('Have 2 const expr',aConst.Expr);
end;
procedure TTestRecordTypeParser.TestAdvRec_Property; procedure TTestRecordTypeParser.TestAdvRec_Property;
begin begin
StartRecord(true); StartRecord(true);
@ -2560,6 +2570,42 @@ begin
ParseRecordFail('Syntax error in type',nParserTypeSyntaxError); ParseRecordFail('Syntax error in type',nParserTypeSyntaxError);
end; end;
procedure TTestRecordTypeParser.TestAdvRec_PublishedFail;
begin
StartRecord(true);
AddMember('published');
AddMember('A: word;');
ParseRecordFail(SParserInvalidRecordVisibility,nParserInvalidRecordVisibility);
end;
procedure TTestRecordTypeParser.TestAdvRec_ProcVirtualFail;
begin
StartRecord(true);
AddMember('procedure DoIt; virtual;');
ParseRecordFail(SParserExpectedCommaColon,nParserExpectedCommaColon);
end;
procedure TTestRecordTypeParser.TestAdvRec_ProcOverrideFail;
begin
StartRecord(true);
AddMember('procedure DoIt; override;');
ParseRecordFail(SParserExpectedCommaColon,nParserExpectedCommaColon);
end;
procedure TTestRecordTypeParser.TestAdvRec_ProcMessageFail;
begin
StartRecord(true);
AddMember('procedure DoIt; message 2;');
ParseRecordFail(SParserExpectedCommaColon,nParserExpectedCommaColon);
end;
procedure TTestRecordTypeParser.TestAdvRec_DestructorFail;
begin
StartRecord(true);
AddMember('destructor Free;');
ParseRecordFail(SParserNoConstructorAllowed,nParserNoConstructorAllowed);
end;
{ TBaseTestTypeParser } { TBaseTestTypeParser }
Function TBaseTestTypeParser.ParseType(ASource: String; ATypeClass: TClass; Function TBaseTestTypeParser.ParseType(ASource: String; ATypeClass: TClass;