mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-09-05 15:30:52 +02:00
fcl-passrc: parser: fixed parsing record consts
git-svn-id: trunk@40659 -
This commit is contained in:
Mattias Gaertner
parent
e28dff523a
commit
337fd5abb8
@ -1041,19 +1041,28 @@ type
|
||||
procedure WriteIdentifiers(Prefix: string); override;
|
||||
end;
|
||||
|
||||
{ TPasDotRecordScope - used for aRecord.subidentifier }
|
||||
|
||||
TPasDotRecordScope = Class(TPasDotIdentifierScope)
|
||||
end;
|
||||
|
||||
{ TPasDotEnumTypeScope - used for EnumType.EnumValue }
|
||||
|
||||
TPasDotEnumTypeScope = Class(TPasDotIdentifierScope)
|
||||
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 = Class(TPasDotIdentifierScope)
|
||||
TPasDotClassScope = Class(TPasDotClassOrRecordScope)
|
||||
private
|
||||
FClassScope: TPasClassScope;
|
||||
procedure SetClassScope(AValue: TPasClassScope);
|
||||
@ -1418,7 +1427,8 @@ type
|
||||
procedure FinishUsesClause; virtual;
|
||||
procedure FinishSection(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 FinishEnumType(El: TPasEnumType); virtual;
|
||||
procedure FinishSetType(El: TPasSetType); virtual;
|
||||
@ -3107,6 +3117,13 @@ begin
|
||||
AncestorScope.WriteIdentifiers(Prefix+'AS ');
|
||||
end;
|
||||
|
||||
{ TPasDotRecordScope }
|
||||
|
||||
function TPasDotRecordScope.GetRecordScope: TPasRecordScope;
|
||||
begin
|
||||
Result:=TPasRecordScope(IdentifierScope);
|
||||
end;
|
||||
|
||||
{ TPasDotClassScope }
|
||||
|
||||
procedure TPasDotClassScope.SetClassScope(AValue: TPasClassScope);
|
||||
@ -4794,7 +4811,35 @@ begin
|
||||
if Section=nil then ;
|
||||
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;
|
||||
const DestName: string; MustExist: boolean; ErrorEl: TPasElement
|
||||
@ -4839,81 +4884,74 @@ procedure TPasResolver.FinishTypeSection(El: TPasDeclarations);
|
||||
end;
|
||||
|
||||
var
|
||||
i: Integer;
|
||||
Decl: TPasElement;
|
||||
C: TClass;
|
||||
ClassOfEl: TPasClassOfType;
|
||||
TypeEl: TPasType;
|
||||
UnresolvedEl: TUnresolvedPendingRef;
|
||||
OldClassType: TPasClassType;
|
||||
TypeEl: TPasType;
|
||||
C: TClass;
|
||||
PtrType: TPasPointerType;
|
||||
begin
|
||||
// resolve pending forwards
|
||||
for i:=0 to El.Declarations.Count-1 do
|
||||
C:=El.ClassType;
|
||||
if C.InheritsFrom(TPasClassType) then
|
||||
begin
|
||||
Decl:=TPasElement(El.Declarations[i]);
|
||||
C:=Decl.ClassType;
|
||||
if C.InheritsFrom(TPasClassType) then
|
||||
if TPasClassType(El).IsForward and (TPasClassType(El).CustomData=nil) then
|
||||
RaiseMsg(20170216151534,nForwardTypeNotResolved,sForwardTypeNotResolved,[El.Name],El);
|
||||
end
|
||||
else if (C=TPasClassOfType) then
|
||||
begin
|
||||
ClassOfEl:=TPasClassOfType(El);
|
||||
TypeEl:=ResolveAliasType(ClassOfEl.DestType);
|
||||
if (TypeEl.ClassType=TUnresolvedPendingRef) then
|
||||
begin
|
||||
if TPasClassType(Decl).IsForward and (TPasClassType(Decl).CustomData=nil) then
|
||||
RaiseMsg(20170216151534,nForwardTypeNotResolved,sForwardTypeNotResolved,[Decl.Name],Decl);
|
||||
// forward class-of -> resolve now
|
||||
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
|
||||
else if (C=TPasClassOfType) then
|
||||
else if TypeEl.ClassType=TPasClassType then
|
||||
begin
|
||||
ClassOfEl:=TPasClassOfType(Decl);
|
||||
TypeEl:=ResolveAliasType(ClassOfEl.DestType);
|
||||
if (TypeEl.ClassType=TUnresolvedPendingRef) then
|
||||
begin
|
||||
// forward class-of -> resolve now
|
||||
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
|
||||
else if TypeEl.ClassType=TPasClassType then
|
||||
begin
|
||||
// class-of has found a type
|
||||
// another later in the same type section has priority -> check
|
||||
OldClassType:=TypeEl as TPasClassType;
|
||||
if OldClassType.Parent=ClassOfEl.Parent then
|
||||
continue; // class in same type section -> ok
|
||||
// class not in same type section -> check
|
||||
{$IFDEF VerbosePasResolver}
|
||||
writeln('TPasResolver.FinishTypeSection improving "',ClassOfEl.Name,'" = class of resolved "',TypeEl.Name,'"');
|
||||
{$ENDIF}
|
||||
ReplaceDestType(ClassOfEl,ClassOfEl.DestType,ClassOfEl.DestType.Name,false,ClassOfEl
|
||||
{$IFDEF CheckPasTreeRefCount},'TPasAliasType.DestType'{$ENDIF});
|
||||
end;
|
||||
// class-of has found a type
|
||||
// another later in the same type section has priority -> check
|
||||
OldClassType:=TypeEl as TPasClassType;
|
||||
if OldClassType.Parent=ClassOfEl.Parent then
|
||||
exit; // class in same type section -> ok
|
||||
// class not in same type section -> check
|
||||
{$IFDEF VerbosePasResolver}
|
||||
writeln('TPasResolver.FinishTypeSection improving "',ClassOfEl.Name,'" = class of resolved "',TypeEl.Name,'"');
|
||||
{$ENDIF}
|
||||
ReplaceDestType(ClassOfEl,ClassOfEl.DestType,ClassOfEl.DestType.Name,false,ClassOfEl
|
||||
{$IFDEF CheckPasTreeRefCount},'TPasAliasType.DestType'{$ENDIF});
|
||||
end;
|
||||
end
|
||||
else if C=TPasPointerType then
|
||||
begin
|
||||
PtrType:=TPasPointerType(El);
|
||||
TypeEl:=ResolveAliasType(PtrType.DestType);
|
||||
if (TypeEl.ClassType=TUnresolvedPendingRef) then
|
||||
begin
|
||||
// forward pointer -> resolve now
|
||||
UnresolvedEl:=TUnresolvedPendingRef(TypeEl);
|
||||
{$IFDEF VerbosePasResolver}
|
||||
writeln('TPasResolver.FinishTypeSection resolving "',PtrType.Name,'" = pointer of unresolved "',TypeEl.Name,'"');
|
||||
{$ENDIF}
|
||||
ReplaceDestType(PtrType,PtrType.DestType,TypeEl.Name,true,UnresolvedEl
|
||||
{$IFDEF CheckPasTreeRefCount},'TPasPointerType.DestType'{$ENDIF});
|
||||
end
|
||||
else if C=TPasPointerType then
|
||||
else
|
||||
begin
|
||||
PtrType:=TPasPointerType(Decl);
|
||||
TypeEl:=ResolveAliasType(PtrType.DestType);
|
||||
if (TypeEl.ClassType=TUnresolvedPendingRef) then
|
||||
begin
|
||||
// forward pointer -> resolve now
|
||||
UnresolvedEl:=TUnresolvedPendingRef(TypeEl);
|
||||
{$IFDEF VerbosePasResolver}
|
||||
writeln('TPasResolver.FinishTypeSection resolving "',PtrType.Name,'" = pointer of unresolved "',TypeEl.Name,'"');
|
||||
{$ENDIF}
|
||||
ReplaceDestType(PtrType,PtrType.DestType,TypeEl.Name,true,UnresolvedEl
|
||||
{$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;
|
||||
// pointer-of has found a type
|
||||
// another later in the same type section has priority -> check
|
||||
if TypeEl.Parent=PtrType.Parent then
|
||||
exit; // 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;
|
||||
@ -5782,8 +5820,11 @@ begin
|
||||
SelfArg:=TPasArgument.Create('Self',DeclProc);
|
||||
ImplProcScope.SelfArg:=SelfArg;
|
||||
{$IFDEF CheckPasTreeRefCount}SelfArg.RefIds.Add('TPasProcedureScope.SelfArg');{$ENDIF}
|
||||
SelfArg.Access:=argConst;
|
||||
SelfArg.ArgType:=ClassRecType;
|
||||
if ClassRecType is TPasRecordType then
|
||||
SelfArg.Access:=argDefault
|
||||
else
|
||||
SelfArg.Access:=argConst;
|
||||
ClassRecType.AddRef{$IFDEF CheckPasTreeRefCount}('TPasArgument.ArgType'){$ENDIF};
|
||||
AddIdentifier(ImplProcScope,'Self',SelfArg,pikSimple);
|
||||
end;
|
||||
@ -14761,6 +14802,25 @@ procedure TPasResolver.CheckFoundElement(
|
||||
const FindData: TPRFindData; Ref: TResolvedReference);
|
||||
// check visibility rules
|
||||
// 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
|
||||
Proc: TPasProcedure;
|
||||
Context: TPasElement;
|
||||
@ -14784,7 +14844,8 @@ begin
|
||||
if Ref<>nil then
|
||||
begin
|
||||
Include(Ref.Flags,rrfDotScope);
|
||||
if TPasDotIdentifierScope(StartScope).ConstParent then
|
||||
if TPasDotIdentifierScope(StartScope).ConstParent
|
||||
and IsFieldInheritingConst(Ref) then
|
||||
Include(Ref.Flags,rrfConstInherited);
|
||||
end;
|
||||
end
|
||||
@ -14795,7 +14856,8 @@ begin
|
||||
if Ref<>nil then
|
||||
begin
|
||||
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);
|
||||
end;
|
||||
end
|
||||
@ -14838,21 +14900,21 @@ begin
|
||||
and TPasClassType(TPasDotClassScope(StartScope).ClassScope.Element).IsExternal then
|
||||
begin
|
||||
// found member in external class instance
|
||||
C:=FindData.Found.ClassType;
|
||||
if (C=TPasProcedure) or (C=TPasFunction) then
|
||||
// ok
|
||||
else if (C=TPasConst) then
|
||||
// ok
|
||||
else if C.InheritsFrom(TPasVariable)
|
||||
and (not (vmClass in TPasVariable(FindData.Found).VarModifiers)) then
|
||||
// ok
|
||||
else
|
||||
begin
|
||||
RaiseMsg(20170331184224,nExternalClassInstanceCannotAccessStaticX,
|
||||
sExternalClassInstanceCannotAccessStaticX,
|
||||
[GetElementTypeName(FindData.Found)+' '+FindData.Found.Name],
|
||||
FindData.ErrorPosEl);
|
||||
end;
|
||||
C:=FindData.Found.ClassType;
|
||||
if (C=TPasProcedure) or (C=TPasFunction) then
|
||||
// ok
|
||||
else if (C=TPasConst) then
|
||||
// ok
|
||||
else if C.InheritsFrom(TPasVariable)
|
||||
and (not (vmClass in TPasVariable(FindData.Found).VarModifiers)) then
|
||||
// ok
|
||||
else
|
||||
begin
|
||||
RaiseMsg(20170331184224,nExternalClassInstanceCannotAccessStaticX,
|
||||
sExternalClassInstanceCannotAccessStaticX,
|
||||
[GetElementTypeName(FindData.Found)+' '+FindData.Found.Name],
|
||||
FindData.ErrorPosEl);
|
||||
end;
|
||||
end;
|
||||
|
||||
if (FindData.Found is TPasProcedure) then
|
||||
@ -14877,7 +14939,7 @@ begin
|
||||
end;
|
||||
|
||||
// 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)
|
||||
and OnlyTypeMembers
|
||||
and (Ref<>nil) then
|
||||
@ -14887,8 +14949,8 @@ begin
|
||||
if Ref.Context<>nil then
|
||||
RaiseInternalError(20170131141936);
|
||||
Ref.Context:=TResolvedRefCtxConstructor.Create;
|
||||
if StartScope is TPasDotClassScope then
|
||||
ClassRecScope:=TPasDotClassScope(StartScope).ClassScope
|
||||
if StartScope is TPasDotClassOrRecordScope then
|
||||
ClassRecScope:=TPasClassOrRecordScope(TPasDotClassOrRecordScope(StartScope).IdentifierScope)
|
||||
else if (StartScope is TPasWithExprScope)
|
||||
and (TPasWithExprScope(StartScope).Scope is TPasClassOrRecordScope) then
|
||||
ClassRecScope:=TPasClassOrRecordScope(TPasWithExprScope(StartScope).Scope)
|
||||
@ -15030,7 +15092,7 @@ begin
|
||||
case ScopeType of
|
||||
stModule: FinishModule(El as TPasModule);
|
||||
stUsesClause: FinishUsesClause;
|
||||
stTypeSection: FinishTypeSection(El as TPasDeclarations);
|
||||
stTypeSection: FinishTypeSection(El);
|
||||
stTypeDef: FinishTypeDef(El as TPasType);
|
||||
stResourceString: FinishResourcestring(El as TPasResString);
|
||||
stProcedure: FinishProcedure(El as TPasProcedure);
|
||||
|
||||
@ -81,7 +81,7 @@ const
|
||||
nErrRecordConstantsNotAllowed = 2035;
|
||||
nErrRecordMethodsNotAllowed = 2036;
|
||||
nErrRecordPropertiesNotAllowed = 2037;
|
||||
// free , was nErrRecordVisibilityNotAllowed = 2038;
|
||||
nErrRecordTypesNotAllowed = 2038;
|
||||
nParserTypeNotAllowedHere = 2039;
|
||||
nParserNotAnOperand = 2040;
|
||||
nParserArrayPropertiesCannotHaveDefaultValue = 2041;
|
||||
@ -142,7 +142,7 @@ resourcestring
|
||||
SErrRecordVariablesNotAllowed = 'Record variables not allowed at this location.';
|
||||
SErrRecordMethodsNotAllowed = 'Record methods 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';
|
||||
SParserNotAnOperand = 'Not an operand: (%d : %s)';
|
||||
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;
|
||||
procedure HandleProcedureModifier(Parent: TPasElement; pm : TProcedureModifier);
|
||||
procedure HandleProcedureTypeModifier(ProcType: TPasProcedureType; ptm : TProcTypeModifier);
|
||||
procedure ParseClassLocalConsts(AType: TPasClassType; AVisibility: TPasMemberVisibility);
|
||||
procedure ParseClassLocalTypes(AType: TPasClassType; AVisibility: TPasMemberVisibility);
|
||||
procedure ParseMembersLocalConsts(AType: TPasMembersType; AVisibility: TPasMemberVisibility);
|
||||
procedure ParseMembersLocalTypes(AType: TPasMembersType; AVisibility: TPasMemberVisibility);
|
||||
procedure ParseVarList(Parent: TPasElement; VarList: TFPList; AVisibility: TPasMemberVisibility; Full: Boolean);
|
||||
procedure SetOptions(AValue: TPOptions);
|
||||
procedure OnScannerModeChanged(Sender: TObject; NewMode: TModeSwitch;
|
||||
@ -1252,7 +1252,10 @@ begin
|
||||
end
|
||||
else if Parent is TPasRecordType then
|
||||
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;
|
||||
Parent:=Parent.Parent;
|
||||
end;
|
||||
@ -1310,7 +1313,7 @@ begin
|
||||
end;
|
||||
end;
|
||||
Until Not Found;
|
||||
UnGetToken;
|
||||
UngetToken;
|
||||
If Assigned(Element) then
|
||||
Element.Hints:=Result;
|
||||
if ExpectSemiColon then
|
||||
@ -2829,7 +2832,7 @@ begin
|
||||
end;
|
||||
|
||||
// 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.
|
||||
function TPasParser.CheckIfOverloaded(AParent: TPasElement; const AName: String): TPasElement;
|
||||
var
|
||||
@ -2838,15 +2841,14 @@ var
|
||||
|
||||
begin
|
||||
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
|
||||
OverloadedProc:=CheckOverLoadList(TPasClassType(AParent).Members,AName,Member);
|
||||
OverloadedProc:=CheckOverLoadList(TPasMembersType(AParent).Members,AName,Member);
|
||||
If (OverloadedProc<>Nil) then
|
||||
Result:=OverloadedProc;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure TPasParser.ParseMain(var Module: TPasModule);
|
||||
begin
|
||||
Module:=nil;
|
||||
@ -3397,7 +3399,7 @@ begin
|
||||
SetBlock(declThreadVar);
|
||||
tkProperty:
|
||||
SetBlock(declProperty);
|
||||
tkProcedure, tkFunction, tkConstructor, tkDestructor,tkOperator:
|
||||
tkProcedure, tkFunction, tkConstructor, tkDestructor, tkOperator:
|
||||
begin
|
||||
SetBlock(declNone);
|
||||
SaveComments;
|
||||
@ -3409,7 +3411,7 @@ begin
|
||||
SetBlock(declNone);
|
||||
SaveComments;
|
||||
NextToken;
|
||||
If CurToken in [tkprocedure,tkFunction,tkConstructor, tkDestructor] then
|
||||
If CurToken in [tkprocedure,tkFunction,tkConstructor,tkDestructor] then
|
||||
begin
|
||||
pt:=GetProcTypeFromToken(CurToken,True);
|
||||
AddProcOrFunction(Declarations,ParseProcedureOrFunctionDecl(Declarations, pt));
|
||||
@ -3554,7 +3556,8 @@ begin
|
||||
Declarations.Classes.Add(RecordEl);
|
||||
RecordEl.SetGenericTemplates(List);
|
||||
NextToken;
|
||||
ParseRecordFieldList(RecordEl,tkend,true);
|
||||
ParseRecordFieldList(RecordEl,tkend,
|
||||
msAdvancedRecords in Scanner.CurrentModeSwitches);
|
||||
CheckHint(RecordEl,True);
|
||||
Engine.FinishScope(stTypeDef,RecordEl);
|
||||
end;
|
||||
@ -3794,7 +3797,7 @@ var
|
||||
begin
|
||||
SaveComments;
|
||||
Result := TPasConst(CreateElement(TPasConst, CurTokenString, Parent));
|
||||
if Parent is TPasClassType then
|
||||
if Parent is TPasMembersType then
|
||||
Include(Result.VarModifiers,vmClass);
|
||||
ok:=false;
|
||||
try
|
||||
@ -3874,7 +3877,7 @@ begin
|
||||
else
|
||||
CheckToken(tkEqual);
|
||||
UngetToken;
|
||||
CheckHint(Result,True);
|
||||
CheckHint(Result,not (Parent is TPasMembersType));
|
||||
ok:=true;
|
||||
finally
|
||||
if not ok then
|
||||
@ -4355,7 +4358,7 @@ begin
|
||||
|
||||
// Note: external members are allowed for non external classes too
|
||||
ExternalStruct:=(msExternalClass in CurrentModeSwitches)
|
||||
and ((Parent is TPasClassType) or (Parent is TPasRecordType));
|
||||
and (Parent is TPasMembersType);
|
||||
|
||||
H:=H+CheckHint(Nil,False);
|
||||
if Full or ExternalStruct then
|
||||
@ -4750,7 +4753,7 @@ begin
|
||||
NextToken;
|
||||
If not CurTokenIsIdentifier('name') then
|
||||
begin
|
||||
if P.Parent is TPasClassType then
|
||||
if P.Parent is TPasMembersType then
|
||||
begin
|
||||
// public section starts
|
||||
UngetToken;
|
||||
@ -4903,7 +4906,7 @@ begin
|
||||
ResultEl:=TPasFunctionType(Element).ResultEl;
|
||||
ResultEl.ResultType := ParseType(ResultEl,CurSourcePos);
|
||||
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
|
||||
// We actually check if the function exists in the interface section.
|
||||
else if (not IsAnonymous)
|
||||
@ -6150,7 +6153,6 @@ var
|
||||
PC : TPTreeElement;
|
||||
Ot : TOperatorType;
|
||||
IsTokenBased , ok: Boolean;
|
||||
|
||||
begin
|
||||
case ProcType of
|
||||
ptOperator,ptClassOperator:
|
||||
@ -6293,11 +6295,10 @@ procedure TPasParser.ParseRecordFieldList(ARec: TPasRecordType;
|
||||
|
||||
Var
|
||||
VariantName : String;
|
||||
v : TPasmemberVisibility;
|
||||
v : TPasMemberVisibility;
|
||||
Proc: TPasProcedure;
|
||||
ProcType: TProcType;
|
||||
Prop : TPasProperty;
|
||||
Cons : TPasConst;
|
||||
isClass : Boolean;
|
||||
NamePos: TPasSourcePos;
|
||||
OldCount, i: Integer;
|
||||
@ -6308,15 +6309,19 @@ begin
|
||||
begin
|
||||
SaveComments;
|
||||
Case CurToken of
|
||||
tkType:
|
||||
begin
|
||||
if Not AllowMethods then
|
||||
ParseExc(nErrRecordTypesNotAllowed,SErrRecordTypesNotAllowed);
|
||||
ExpectToken(tkIdentifier);
|
||||
ParseMembersLocalTypes(ARec,v);
|
||||
end;
|
||||
tkConst:
|
||||
begin
|
||||
if Not AllowMethods then
|
||||
ParseExc(nErrRecordConstantsNotAllowed,SErrRecordConstantsNotAllowed);
|
||||
ExpectToken(tkIdentifier);
|
||||
Cons:=ParseConstDecl(ARec);
|
||||
Cons.Visibility:=v;
|
||||
ARec.members.Add(Cons);
|
||||
Engine.FinishScope(stDeclaration,Cons);
|
||||
ParseMembersLocalConsts(ARec,v);
|
||||
end;
|
||||
tkVar:
|
||||
begin
|
||||
@ -6365,6 +6370,8 @@ begin
|
||||
else
|
||||
ARec.Members.Add(Proc);
|
||||
end;
|
||||
tkDestructor:
|
||||
ParseExc(nParserNoConstructorAllowed,SParserNoConstructorAllowed);
|
||||
tkGeneric, // Counts as field name
|
||||
tkIdentifier :
|
||||
begin
|
||||
@ -6549,40 +6556,46 @@ begin
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TPasParser.ParseClassLocalTypes(AType: TPasClassType; AVisibility : TPasMemberVisibility);
|
||||
procedure TPasParser.ParseMembersLocalTypes(AType: TPasMembersType;
|
||||
AVisibility: TPasMemberVisibility);
|
||||
|
||||
Var
|
||||
T : TPasType;
|
||||
Done : Boolean;
|
||||
begin
|
||||
// Writeln('Parsing local types');
|
||||
// Writeln('Parsing local types');
|
||||
Repeat
|
||||
T:=ParseTypeDecl(AType);
|
||||
T.Visibility:=AVisibility;
|
||||
AType.Members.Add(t);
|
||||
// Writeln(CurtokenString,' ',TokenInfos[Curtoken]);
|
||||
// Writeln(CurtokenString,' ',TokenInfos[Curtoken]);
|
||||
NextToken;
|
||||
Done:=(Curtoken<>tkIdentifier) or CheckVisibility(CurtokenString,AVisibility);
|
||||
Done:=(Curtoken<>tkIdentifier) or CheckVisibility(CurTokenString,AVisibility);
|
||||
if Done then
|
||||
UngetToken;
|
||||
Until Done;
|
||||
Engine.FinishScope(stTypeSection,AType);
|
||||
end;
|
||||
|
||||
procedure TPasParser.ParseClassLocalConsts(AType: TPasClassType; AVisibility : TPasMemberVisibility);
|
||||
procedure TPasParser.ParseMembersLocalConsts(AType: TPasMembersType;
|
||||
AVisibility: TPasMemberVisibility);
|
||||
|
||||
Var
|
||||
C : TPasConst;
|
||||
Done : Boolean;
|
||||
begin
|
||||
// Writeln('Parsing local consts');
|
||||
// Writeln('Parsing local consts');
|
||||
Repeat
|
||||
C:=ParseConstDecl(AType);
|
||||
C.Visibility:=AVisibility;
|
||||
AType.Members.Add(C);
|
||||
Engine.FinishScope(stDeclaration,C);
|
||||
// Writeln(CurtokenString,' ',TokenInfos[Curtoken]);
|
||||
//Writeln('TPasParser.ParseMembersLocalConsts ',CurtokenString,' ',TokenInfos[CurToken]);
|
||||
NextToken;
|
||||
Done:=(Curtoken<>tkIdentifier) or CheckVisibility(CurtokenString,AVisibility);
|
||||
if CurToken<>tkSemicolon then
|
||||
exit;
|
||||
NextToken;
|
||||
Done:=(CurToken<>tkIdentifier) or CheckVisibility(CurTokenString,AVisibility);
|
||||
if Done then
|
||||
UngetToken;
|
||||
Until Done;
|
||||
@ -6658,9 +6671,9 @@ begin
|
||||
SaveComments;
|
||||
Case CurSection of
|
||||
stType:
|
||||
ParseClassLocalTypes(AType,CurVisibility);
|
||||
ParseMembersLocalTypes(AType,CurVisibility);
|
||||
stConst :
|
||||
ParseClassLocalConsts(AType,CurVisibility);
|
||||
ParseMembersLocalConsts(AType,CurVisibility);
|
||||
stNone,
|
||||
stVar,
|
||||
stClassVar:
|
||||
|
||||
@ -489,17 +489,12 @@ type
|
||||
// advanced record
|
||||
Procedure TestAdvRecord;
|
||||
Procedure TestAdvRecord_Private;
|
||||
Procedure TestAdvRecord_StrictPrivate; // ToDo
|
||||
// ToDo: public, private, strict private
|
||||
// ToDo: TestAdvRecordPublishedFail
|
||||
// ToDo: TestAdvRecord_VirtualFail
|
||||
// ToDo: TestAdvRecord_OverrideFail
|
||||
// ToDo: constructor, destructor
|
||||
Procedure TestAdvRecord_StrictPrivate;
|
||||
Procedure TestAdvRecord_VarConst;
|
||||
Procedure TestAdvRecord_LocalForwardType;
|
||||
// ToDo: constructor
|
||||
// ToDo: class function/procedure
|
||||
// ToDo: nested record type
|
||||
// ToDo: const
|
||||
// todo: var
|
||||
// todo: class var
|
||||
// todo: property
|
||||
// todo: class property
|
||||
// todo: TestRecordAsFuncResult
|
||||
@ -515,6 +510,7 @@ type
|
||||
Procedure TestClassForwardAsAncestorFail;
|
||||
Procedure TestClassForwardNotResolved;
|
||||
Procedure TestClassForwardDuplicateFail;
|
||||
// ToDo: local forward sub class
|
||||
Procedure TestClass_Method;
|
||||
Procedure TestClass_ConstructorMissingDotFail;
|
||||
Procedure TestClass_MethodImplDuplicateFail;
|
||||
@ -7859,7 +7855,6 @@ end;
|
||||
|
||||
procedure TTestResolver.TestAdvRecord_StrictPrivate;
|
||||
begin
|
||||
exit;
|
||||
StartProgram(false);
|
||||
Add([
|
||||
'{$modeswitch advancedrecords}',
|
||||
@ -7872,7 +7867,65 @@ begin
|
||||
' r: TRec;',
|
||||
'begin',
|
||||
' 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;
|
||||
|
||||
procedure TTestResolver.TestClass;
|
||||
|
||||
@ -197,7 +197,7 @@ type
|
||||
Procedure DoParseRecord;
|
||||
Procedure TestFields(Const Fields : Array of string; AHint : String; HaveVariant : Boolean = False);
|
||||
procedure AssertVariantSelector(AName, AType: string);
|
||||
procedure AssertConst1(Hints: TPasMemberHints);
|
||||
procedure AssertConst1(Hints: TPasMemberHints; Index: integer = 1);
|
||||
procedure AssertField1(Hints: TPasMemberHints);
|
||||
procedure AssertField2(Hints: TPasMemberHints);
|
||||
procedure AssertMethod2(Hints: TPasMemberHints; isClass : Boolean = False);
|
||||
@ -257,7 +257,6 @@ type
|
||||
Procedure TestOnePlatformField;
|
||||
Procedure TestOnePlatformFieldDeprecated;
|
||||
Procedure TestOnePlatformFieldPlatform;
|
||||
Procedure TestOneConstOneField;
|
||||
Procedure TestOneGenericField;
|
||||
Procedure TestTwoFields;
|
||||
procedure TestTwoFieldProtected;
|
||||
@ -351,10 +350,16 @@ type
|
||||
Procedure TestVariantNestedVariantBothDeprecatedPlatform;
|
||||
Procedure TestOperatorField;
|
||||
Procedure TestPropertyFail;
|
||||
Procedure TestAdvRec_TwoConst;
|
||||
Procedure TestAdvRec_Property;
|
||||
Procedure TestAdvRec_PropertyImplementsFail;
|
||||
Procedure TestAdvRec_PropertyNoTypeFail;
|
||||
Procedure TestAdvRec_ForwardFail;
|
||||
Procedure TestAdvRec_PublishedFail;
|
||||
Procedure TestAdvRec_ProcVirtualFail;
|
||||
Procedure TestAdvRec_ProcOverrideFail;
|
||||
Procedure TestAdvRec_ProcMessageFail;
|
||||
Procedure TestAdvRec_DestructorFail;
|
||||
end;
|
||||
|
||||
{ TTestProcedureTypeParser }
|
||||
@ -1365,15 +1370,15 @@ begin
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TTestRecordTypeParser.AssertConst1(Hints: TPasMemberHints);
|
||||
procedure TTestRecordTypeParser.AssertConst1(Hints: TPasMemberHints;
|
||||
Index: integer);
|
||||
begin
|
||||
if Hints=[] then ;
|
||||
AssertEquals('Member 1 type',TPasConst,TObject(TheRecord.Members[0]).ClassType);
|
||||
AssertEquals('Const 1 name','x',Const1.Name);
|
||||
AssertNotNull('Have 1 const expr',Const1.Expr);
|
||||
AssertEquals('Member '+IntToStr(Index+1)+' type',TPasConst,TObject(TheRecord.Members[Index]).ClassType);
|
||||
AssertEquals('Const '+IntToStr(Index+1)+' name','x',Const1.Name);
|
||||
AssertNotNull('Have '+IntToStr(Index+1)+' const expr',Const1.Expr);
|
||||
end;
|
||||
|
||||
|
||||
procedure TTestRecordTypeParser.DoTestEmpty(const AHint: String);
|
||||
begin
|
||||
TestFields([],AHint);
|
||||
@ -1386,7 +1391,6 @@ begin
|
||||
AssertVariant1(Hints,['0']);
|
||||
end;
|
||||
|
||||
|
||||
procedure TTestRecordTypeParser.AssertVariant1(Hints: TPasMemberHints;
|
||||
VariantLabels: array of string);
|
||||
|
||||
@ -1902,15 +1906,6 @@ begin
|
||||
AssertOneIntegerField([hplatform]);
|
||||
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;
|
||||
begin
|
||||
TestFields(['Generic : Integer;'],'',False);
|
||||
@ -2532,6 +2527,21 @@ begin
|
||||
ParseRecordFail(SErrRecordPropertiesNotAllowed,nErrRecordPropertiesNotAllowed);
|
||||
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;
|
||||
begin
|
||||
StartRecord(true);
|
||||
@ -2560,6 +2570,42 @@ begin
|
||||
ParseRecordFail('Syntax error in type',nParserTypeSyntaxError);
|
||||
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 }
|
||||
|
||||
Function TBaseTestTypeParser.ParseType(ASource: String; ATypeClass: TClass;
|
||||
|
||||
Loading…
Reference in New Issue
Block a user