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

fcl-passrc: resolver: type helper constructors

Browse Source 
git-svn-id: trunk@41075 -
This commit is contained in:
Mattias Gaertner 2019-01-26 08:28:52 +00:00
parent 76871bc215
commit 3eca2b9c5e
4 changed files with 561 additions and 161 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1122,6 +1122,11 @@ type
procedure WriteIdentifiers(Prefix: string); override;
end;
{ TPasDotHelperScope }
TPasDotHelperScope = class(TPasDotBaseScope)
end;
TResolvedReferenceFlag = (
rrfDotScope, // found reference via a dot scope (TPasDotBaseScope)
rrfImplicitCallWithoutParams, // a TPrimitiveExpr is an implicit call without params
@ -1466,7 +1471,7 @@ type
procedure ResolveArrayParamsArgs(Params: TParamsExpr;
const ResolvedValue: TPasResolverResult; Access: TResolvedRefAccess); virtual;
function ResolveBracketOperatorClassOrRec(Params: TParamsExpr;
const ResolvedValue: TPasResolverResult; ClassOrRecScope: TPasClassOrRecordScope;
const ResolvedValue: TPasResolverResult;
Access: TResolvedRefAccess): boolean; virtual;
procedure ResolveSetParamsExpr(Params: TParamsExpr); virtual;
procedure ResolveArrayValues(El: TArrayValues); virtual;
@ -1966,7 +1971,7 @@ type
function GetPathStart(El: TPasExpr): TPasExpr;
function GetNewInstanceExpr(El: TPasExpr): TPasExpr;
function ParentNeedsExprResult(El: TPasExpr): boolean;
function GetReference_ConstructorType(Ref: TResolvedReference): TPasMembersType;
function GetReference_ConstructorType(Ref: TResolvedReference; Expr: TPasExpr): TPasResolverResult;
function GetParamsValueRef(Params: TParamsExpr): TResolvedReference;
function IsDynArray(TypeEl: TPasType; OptionalOpenArray: boolean = true): boolean;
function IsOpenArray(TypeEl: TPasType): boolean;
@ -8883,7 +8888,7 @@ begin
end;
end;
// default: search for type helpers
DotScope:=PushHelperDotScope(LTypeEl);
DotScope:=PushHelperDotScope(LeftResolved.HiTypeEl);
if DotScope<>nil then
begin
if LeftResolved.IdentEl is TPasType then
@ -9376,9 +9381,9 @@ procedure TPasResolver.ResolveArrayParamsArgs(Params: TParamsExpr;
var
PropEl: TPasProperty;
ClassOrRecScope: TPasClassOrRecordScope;
i: Integer;
TypeEl: TPasType;
C: TClass;
begin
if ResolvedValue.BaseType in btAllStrings then
begin
@ -9402,13 +9407,15 @@ begin
else if ResolvedValue.BaseType=btContext then
begin
TypeEl:=ResolvedValue.LoTypeEl;
if TypeEl is TPasMembersType then
C:=TypeEl.ClassType;
if (C=TPasClassType)
or (C=TPasRecordType)
or (C=TPasClassOfType) then
begin
ClassOrRecScope:=NoNil(TypeEl.CustomData) as TPasClassOrRecordScope;
if ResolveBracketOperatorClassOrRec(Params,ResolvedValue,ClassOrRecScope,Access) then
if ResolveBracketOperatorClassOrRec(Params,ResolvedValue,Access) then
exit;
end
else if TypeEl.ClassType=TPasArrayType then
else if C=TPasArrayType then
begin
if ResolvedValue.IdentEl is TPasType then
RaiseMsg(20170216152215,nIllegalQualifierAfter,sIllegalQualifierAfter,
@ -9418,7 +9425,7 @@ begin
AccessExpr(Params.Params[i],rraRead);
exit;
end
else if TypeEl.ClassType=TPasPointerType then
else if C=TPasPointerType then
begin
if CheckStringOrPointerIndex(false) then exit;
end;
@ -9428,28 +9435,46 @@ begin
end;
function TPasResolver.ResolveBracketOperatorClassOrRec(Params: TParamsExpr;
const ResolvedValue: TPasResolverResult;
ClassOrRecScope: TPasClassOrRecordScope; Access: TResolvedRefAccess): boolean;
const ResolvedValue: TPasResolverResult; Access: TResolvedRefAccess): boolean;
var
PropEl: TPasProperty;
Value: TPasExpr;
Group: TPasGroupScope;
i: Integer;
Scope: TPasIdentifierScope;
TypeEl: TPasType;
IsClassOf: Boolean;
begin
PropEl:=ClassOrRecScope.DefaultProperty;
if PropEl<>nil then
TypeEl:=ResolvedValue.LoTypeEl;
IsClassOf:=TypeEl.ClassType=TPasClassOfType;
if IsClassOf then
TypeEl:=ResolveAliasType(TPasClassOfType(TypeEl).DestType);
Group:=CreateGroupScope(TypeEl);
PropEl:=nil;
for i:=0 to Group.Count-1 do
begin
// class has default property
if (ResolvedValue.IdentEl is TPasType) and (not PropEl.IsClass) then
RaiseMsg(20170216152213,nIllegalQualifierAfter,sIllegalQualifierAfter,
['[',GetResolverResultDescription(ResolvedValue,true)],Params);
Value:=Params.Value;
if Value.CustomData is TResolvedReference then
SetResolvedRefAccess(Value,TResolvedReference(Value.CustomData),rraRead);
CreateReference(PropEl,Params,Access);
CheckCallPropertyCompatibility(PropEl,Params,true);
FinishPropertyParamAccess(Params,PropEl);
exit(true);
Scope:=Group.Scopes[i];
if Scope is TPasClassOrRecordScope then
begin
PropEl:=TPasClassOrRecordScope(Scope).DefaultProperty;
if PropEl<>nil then break;
end;
end;
Result:=false;
Group.Free;
if PropEl=nil then exit(false);
// class/record/interface has default property
if (IsClassOf or (ResolvedValue.IdentEl is TPasType)) and (not PropEl.IsClass) then
RaiseMsg(20170216152213,nIllegalQualifierAfter,sIllegalQualifierAfter,
['[',GetResolverResultDescription(ResolvedValue,true)],Params);
Value:=Params.Value;
if Value.CustomData is TResolvedReference then
SetResolvedRefAccess(Value,TResolvedReference(Value.CustomData),rraRead);
CreateReference(PropEl,Params,Access);
CheckCallPropertyCompatibility(PropEl,Params,true);
FinishPropertyParamAccess(Params,PropEl);
Result:=true;
end;
procedure TPasResolver.ResolveSetParamsExpr(Params: TParamsExpr);
@ -11223,11 +11248,11 @@ procedure TPasResolver.ComputeArrayParams(Params: TParamsExpr; out
var
TypeEl: TPasType;
ClassScope: TPasClassScope;
ArrayEl: TPasArrayType;
ArgNo: Integer;
OrigResolved: TPasResolverResult;
ClassOrRecordScope: TPasClassOrRecordScope;
Ref: TResolvedReference;
begin
ComputeElement(Params.Value,ResolvedEl,
Flags-[rcNoImplicitProc,rcNoImplicitProcType],StartEl);
@ -11271,21 +11296,21 @@ begin
begin
TypeEl:=ResolvedEl.LoTypeEl;
if (TypeEl.ClassType=TPasClassType)
or (TypeEl.ClassType=TPasRecordType) then
or (TypeEl.ClassType=TPasRecordType)
or (TypeEl.ClassType=TPasClassOfType) then
begin
ClassOrRecordScope:=NoNil(TypeEl.CustomData) as TPasClassOrRecordScope;
if ClassOrRecordScope.DefaultProperty<>nil then
ComputeIndexProperty(ClassOrRecordScope.DefaultProperty)
else
if not (Params.CustomData is TResolvedReference) then
RaiseNotYetImplemented(20190125143203,Params,GetObjName(Params.CustomData));
Ref:=TResolvedReference(Params.CustomData);
if Ref.Declaration is TPasProperty then
ComputeIndexProperty(TPasProperty(Ref.Declaration))
else if TypeEl is TPasMembersType then
begin
ClassOrRecordScope:=NoNil(TypeEl.CustomData) as TPasClassOrRecordScope;
ComputeArrayParams_Class(Params,ResolvedEl,ClassOrRecordScope,Flags,StartEl);
end
else if TypeEl.ClassType=TPasClassOfType then
begin
ClassScope:=ResolveAliasType(TPasClassOfType(TypeEl).DestType).CustomData as TPasClassScope;
if ClassScope.DefaultProperty<>nil then
ComputeIndexProperty(ClassScope.DefaultProperty)
end
else
RaiseInternalError(20161010174916);
RaiseNotYetImplemented(20161010174916,Params);
end
else if TypeEl.ClassType=TPasArrayType then
begin
@ -11333,7 +11358,7 @@ procedure TPasResolver.ComputeArrayParams_Class(Params: TParamsExpr;
var ResolvedEl: TPasResolverResult; ClassOrRecScope: TPasClassOrRecordScope;
Flags: TPasResolverComputeFlags; StartEl: TPasElement);
begin
RaiseInternalError(20161010174916);
RaiseNotYetImplemented(20190125142240,Params);
if Params=nil then ;
if ClassOrRecScope=nil then ;
if Flags=[] then ;
@ -11352,7 +11377,6 @@ var
Ref: TResolvedReference;
DeclType: TPasType;
Param0: TPasExpr;
ClassOrRec: TPasMembersType;
begin
Ref:=GetParamsValueRef(Params);
if Ref=nil then
@ -11410,8 +11434,7 @@ begin
else if (Proc.ClassType=TPasConstructor) then
begin
// constructor -> return value of type class
ClassOrRec:=GetReference_ConstructorType(Ref);
SetResolverValueExpr(ResolvedEl,btContext,ClassOrRec,ClassOrRec,Params.Value,[rrfReadable]);
ResolvedEl:=GetReference_ConstructorType(Ref,Params.Value);
end
else
// procedure call, result is neither readable nor writable
@ -15706,31 +15729,46 @@ begin
if Ref.Context<>nil then
RaiseInternalError(20170131141936);
Ref.Context:=TResolvedRefCtxConstructor.Create;
TypeEl:=nil;
ClassRecScope:=nil;
C:=StartScope.ClassType;
if C.InheritsFrom(TPasDotClassOrRecordScope) then
ClassRecScope:=TPasDotClassOrRecordScope(StartScope).ClassRecScope
else if C.InheritsFrom(TPasWithExprScope) then
ClassRecScope:=TPasWithExprScope(StartScope).ClassRecScope
else if C.InheritsFrom(TPasProcedureScope) then
else if C=ScopeClass_WithExpr then
begin
ClassRecScope:=TPasWithExprScope(StartScope).ClassRecScope;
if ClassRecScope=nil then
TypeEl:=TPasWithExprScope(StartScope).Scope.Element as TPasType;
end
else if C=ScopeClass_Procedure then
ClassRecScope:=TPasProcedureScope(StartScope).ClassRecScope
else if C=TPasDotHelperScope then
TypeEl:=NoNil(TPasDotHelperScope(StartScope).Element) as TPasType
else
RaiseInternalError(20170131150855,GetObjName(StartScope));
if ClassRecScope=nil then
RaiseInternalError(20190123120156,GetObjName(StartScope));
TypeEl:=ClassRecScope.Element as TPasType;
TResolvedRefCtxConstructor(Ref.Context).Typ:=TypeEl;
if OnlyTypeMembers and (ClassRecScope is TPasClassScope) then
if TypeEl<>nil then
TResolvedRefCtxConstructor(Ref.Context).Typ:=TypeEl
else
begin
AbstractProcs:=TPasClassScope(ClassRecScope).AbstractProcs;
if (length(AbstractProcs)>0) then
if ClassRecScope=nil then
RaiseInternalError(20190123120156,GetObjName(StartScope));
TypeEl:=ClassRecScope.Element as TPasType;
if (TypeEl.ClassType=TPasClassType) and (TPasClassType(TypeEl).HelperForType<>nil) then
TypeEl:=ResolveAliasType(TPasClassType(TypeEl).HelperForType);
TResolvedRefCtxConstructor(Ref.Context).Typ:=TypeEl;
if OnlyTypeMembers and (ClassRecScope is TPasClassScope) then
begin
if IsClassOf then
// aClass.Create: do not warn
else
for i:=0 to length(AbstractProcs)-1 do
LogMsg(20171227110746,mtWarning,nConstructingClassXWithAbstractMethodY,
sConstructingClassXWithAbstractMethodY,
[TypeEl.Name,AbstractProcs[i].Name],FindData.ErrorPosEl);
AbstractProcs:=TPasClassScope(ClassRecScope).AbstractProcs;
if (length(AbstractProcs)>0) then
begin
if IsClassOf then
// aClass.Create: do not warn
else
for i:=0 to length(AbstractProcs)-1 do
LogMsg(20171227110746,mtWarning,nConstructingClassXWithAbstractMethodY,
sConstructingClassXWithAbstractMethodY,
[TypeEl.Name,AbstractProcs[i].Name],FindData.ErrorPosEl);
end;
end;
end;
end;
@ -16482,6 +16520,7 @@ var
AncestorScope, HelperScope: TPasClassScope;
C: TClass;
begin
TypeEl:=ResolveAliasType(TypeEl);
IsClass:=TypeEl.ClassType=TPasClassType;
if IsClass and (TPasClassType(TypeEl).HelperForType<>nil) then
begin
@ -16705,7 +16744,8 @@ begin
Group.Free;
exit(nil);
end;
Result:=TPasDotBaseScope.Create;
Result:=TPasDotHelperScope.Create;
Result.Element:=TypeEl;
Result.Owner:=Self;
Result.GroupScope:=Group;
PushScope(Result);
@ -16897,15 +16937,14 @@ begin
NewEntry.HelperForType:=HelperForType;
NewEntry.Added:=length(List);
// keep list sorted for 1. HelperForType and 2. Added
for i:=0 to length(List)-1 do
i:=0;
while i<length(List) do
begin
Entry:=List[i];
if ComparePRHelperEntries(NewEntry,Entry)<=0 then continue;
Insert(NewEntry,List,i);
exit;
if ComparePRHelperEntries(NewEntry,Entry)<=0 then break;
inc(i);
end;
// append
Insert(NewEntry,List,length(List));
Insert(NewEntry,List,i);
end;
procedure TPasResolver.AddActiveHelper(Helper: TPasClassType);
@ -17000,6 +17039,9 @@ end;
procedure TPasResolver.RaiseInternalError(id: TMaxPrecInt; const Msg: string);
begin
{$IFDEF VerbosePasResolver}
writeln('TPasResolver.RaiseInternalError [',id,'] ',Msg);
{$ENDIF}
raise Exception.Create('Internal error: ['+IntToStr(id)+'] '+Msg);
end;
@ -20884,7 +20926,6 @@ procedure TPasResolver.ComputeElement(El: TPasElement; out
Ref: TResolvedReference;
Proc: TPasProcedure;
ProcType: TPasProcedureType;
ClassOrRec: TPasMembersType;
begin
Ref:=TResolvedReference(Expr.CustomData);
ComputeElement(Ref.Declaration,ResolvedEl,Flags+[rcNoImplicitProc],StartEl);
@ -20929,9 +20970,7 @@ procedure TPasResolver.ComputeElement(El: TPasElement; out
else if (ResolvedEl.IdentEl.ClassType=TPasConstructor) then
begin
// constructor -> return value of type class
ClassOrRec:=GetReference_ConstructorType(Ref);
SetResolverValueExpr(ResolvedEl,btContext,ClassOrRec,ClassOrRec,
TPrimitiveExpr(Expr),[rrfReadable]);
ResolvedEl:=GetReference_ConstructorType(Ref,Expr);
end
else if ParentNeedsExprResult(Expr) then
begin
@ -20982,7 +21021,6 @@ procedure TPasResolver.ComputeElement(El: TPasElement; out
Proc: TPasProcedure;
TypeEl: TPasProcedureType;
HasName: Boolean;
ClassOrRec: TPasMembersType;
begin
// "inherited;"
Ref:=TResolvedReference(El.CustomData);
@ -21007,8 +21045,7 @@ procedure TPasResolver.ComputeElement(El: TPasElement; out
and (rrfNewInstance in Ref.Flags) then
begin
// new instance constructor -> return value of type class
ClassOrRec:=GetReference_ConstructorType(Ref);
SetResolverValueExpr(ResolvedEl,btContext,ClassOrRec,ClassOrRec,Expr,[rrfReadable]);
ResolvedEl:=GetReference_ConstructorType(Ref,Expr);
end
else if ParentNeedsExprResult(Expr) then
begin
@ -21687,10 +21724,25 @@ begin
Result:=(TPasImplRaise(P).ExceptAddr=El);
end;
function TPasResolver.GetReference_ConstructorType(Ref: TResolvedReference
): TPasMembersType;
function TPasResolver.GetReference_ConstructorType(Ref: TResolvedReference;
Expr: TPasExpr): TPasResolverResult;
var
TypeEl: TPasType;
begin
Result:=(Ref.Context as TResolvedRefCtxConstructor).Typ as TPasMembersType;
TypeEl:=(Ref.Context as TResolvedRefCtxConstructor).Typ;
if TypeEl=nil then
RaiseNotYetImplemented(20190125205339,Expr)
else if TypeEl is TPasMembersType then
SetResolverValueExpr(Result,btContext,TypeEl,TypeEl,Expr,[rrfReadable])
else
begin
writeln('AAA1 TPasResolver.GetReference_ConstructorType ',GetObjName(TypeEl));
ComputeElement(TypeEl,Result,[rcType]);
writeln('AAA2 TPasResolver.GetReference_ConstructorType ',GetResolverResultDbg(Result));
Result.ExprEl:=Expr;
Result.Flags:=[rrfReadable];
writeln('AAA3 TPasResolver.GetReference_ConstructorType ',GetResolverResultDbg(Result));
end;
end;
function TPasResolver.GetParamsValueRef(Params: TParamsExpr): TResolvedReference;

6
packages/fcl-passrc/src/pscanner.pp
View File

@ -1119,7 +1119,7 @@ const
const
// all mode switches supported by FPC
msAllFPCModeSwitches = [low(TModeSwitch)..High(TModeSwitch)];
msAllModeSwitches = [low(TModeSwitch)..High(TModeSwitch)];
DelphiModeSwitches = [msDelphi,msClass,msObjpas,msResult,msStringPchar,
msPointer2Procedure,msAutoDeref,msTPProcVar,msInitFinal,msDefaultAnsistring,
@ -1130,7 +1130,7 @@ const
DelphiUnicodeModeSwitches = delphimodeswitches + [msSystemCodePage,msDefaultUnicodestring];
// mode switches of $mode FPC, don't confuse with msAllFPCModeSwitches
// mode switches of $mode FPC, don't confuse with msAllModeSwitches
FPCModeSwitches = [msFpc,msStringPchar,msNestedComment,msRepeatForward,
msCVarSupport,msInitFinal,msHintDirective,msProperty,msDefaultInline];
//FPCBoolSwitches bsObjectChecks
@ -2665,7 +2665,7 @@ begin
FMaxIncludeStackDepth:=DefaultMaxIncludeStackDepth;
FCurrentModeSwitches:=FPCModeSwitches;
FAllowedModeSwitches:=msAllFPCModeSwitches;
FAllowedModeSwitches:=msAllModeSwitches;
FCurrentBoolSwitches:=bsFPCMode;
FAllowedBoolSwitches:=bsAll;
FAllowedValueSwitches:=vsAllValueSwitches;

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

@ -867,37 +867,39 @@ type
Procedure TestHint_Garbage;
// helpers
Procedure ClassHelper;
Procedure ClassHelper_AncestorIsNotHelperForDescendantFail;
Procedure ClassHelper_HelperForParentFail;
Procedure ClassHelper_ForInterfaceFail;
Procedure ClassHelper_FieldFail;
Procedure ClassHelper_AbstractFail;
Procedure ClassHelper_VirtualObjFPCFail;
Procedure ClassHelper_VirtualDelphiFail;
Procedure ClassHelper_DestructorFail;
Procedure ClassHelper_ClassRefersToTypeHelperOfAncestor;
Procedure ClassHelper_InheritedObjFPC;
Procedure ClassHelper_InheritedObjFPC2;
Procedure ClassHelper_InheritedObjFPCStrictPrivateFail;
Procedure ClassHelper_InheritedDelphi;
Procedure ClassHelper_NestedInheritedParentFail;
Procedure ClassHelper_AccessFields;
Procedure ClassHelper_CallClassMethodFail;
Procedure ClassHelper_AsTypeFail;
Procedure ClassHelper_Enumerator;
Procedure ClassHelper_FromUnitInterface;
// ToDo ClassHelper_Constructor
// ToDo ClassHelper_DefaultProperty
// ToDo ClassHelper_MultiScopeHelpers
Procedure RecordHelper;
// RecordHelper_Constructor
Procedure TypeHelper;
Procedure TypeHelper_HelperForProcTypeFail;
Procedure TypeHelper_DefaultPropertyFail;
Procedure TypeHelper_Enum;
Procedure TypeHelper_Enumerator;
// TypeHelper_Constructor
Procedure TestClassHelper;
Procedure TestClassHelper_AncestorIsNotHelperForDescendantFail;
Procedure TestClassHelper_HelperForParentFail;
Procedure TestClassHelper_ForInterfaceFail;
Procedure TestClassHelper_FieldFail;
Procedure TestClassHelper_AbstractFail;
Procedure TestClassHelper_VirtualObjFPCFail;
Procedure TestClassHelper_VirtualDelphiFail;
Procedure TestClassHelper_DestructorFail;
Procedure TestClassHelper_ClassRefersToTypeHelperOfAncestor;
Procedure TestClassHelper_InheritedObjFPC;
Procedure TestClassHelper_InheritedObjFPC2;
Procedure TestClassHelper_InheritedObjFPCStrictPrivateFail;
Procedure TestClassHelper_InheritedDelphi;
Procedure TestClassHelper_NestedInheritedParentFail;
Procedure TestClassHelper_AccessFields;
Procedure TestClassHelper_CallClassMethodFail;
Procedure TestClassHelper_AsTypeFail;
Procedure TestClassHelper_Enumerator;
Procedure TestClassHelper_FromUnitInterface;
Procedure TestClassHelper_Constructor_NewInstance;
Procedure TestClassHelper_DefaultProperty;
Procedure TestClassHelper_DefaultClassProperty;
Procedure TestClassHelper_MultipleScopeHelpers;
Procedure TestRecordHelper;
Procedure TestRecordHelper_Constructor_NewInstance;
Procedure TestTypeHelper;
Procedure TestTypeHelper_HelperForProcTypeFail;
Procedure TestTypeHelper_DefaultPropertyFail;
Procedure TestTypeHelper_Enum;
Procedure TestTypeHelper_Enumerator;
Procedure TestTypeHelper_Constructor_NewInstance;
// Todo: warn hides method
// attributes
Procedure TestAttributes_Ignore;
@ -8080,8 +8082,16 @@ begin
'begin',
' TRec.{#p}Create(4); // new object',
' r:=TRec.{#q}Create(5); // new object',
' r.{#r}Create(6); // normal call',
' r:=r.{#s}Create(7); // normal call',
' with TRec do begin',
' {#r}Create(6); // new object',
' r:={#s}Create(7); // new object',
' end;',
' r.{#t}Create(8); // normal call',
' r:=r.{#u}Create(9); // normal call',
' with r do begin',
' {#v}Create(10); // normal call',
' r:={#w}Create(11); // normal call',
' end;',
'']);
ParseProgram;
aMarker:=FirstSrcMarker;
@ -8106,7 +8116,7 @@ begin
break;
end;
case aMarker^.Identifier of
'a','r','s':// should be normal call
'a','t','u','v','w':// should be normal call
if ActualNewInstance then
RaiseErrorAtSrcMarker('expected normal call at "#'+aMarker^.Identifier+', but got newinstance"',aMarker);
else // should be newinstance
@ -12169,25 +12179,26 @@ end;
procedure TTestResolver.TestDefaultProperty;
begin
StartProgram(false);
Add('type');
Add(' TObject = class');
Add(' function GetB(Index: longint): longint;');
Add(' procedure SetB(Index: longint; Value: longint);');
Add(' property B[Index: longint]: longint read GetB write SetB; default;');
Add(' end;');
Add('function TObject.GetB(Index: longint): longint;');
Add('begin');
Add('end;');
Add('procedure TObject.SetB(Index: longint; Value: longint);');
Add('begin');
Add(' if Value=Self[Index] then ;');
Add(' Self[Index]:=Value;');
Add('end;');
Add('var o: TObject;');
Add('begin');
Add(' o[3]:=4;');
Add(' if o[5]=6 then;');
Add(' if 7=o[8] then;');
Add([
'type',
' TObject = class',
' function GetB(Index: longint): longint;',
' procedure SetB(Index: longint; Value: longint);',
' property B[Index: longint]: longint read GetB write SetB; default;',
' end;',
'function TObject.GetB(Index: longint): longint;',
'begin',
'end;',
'procedure TObject.SetB(Index: longint; Value: longint);',
'begin',
' if Value=Self[Index] then ;',
' Self[Index]:=Value;',
'end;',
'var o: TObject;',
'begin',
' o[3]:=4;',
' if o[5]=6 then;',
' if 7=o[8] then;']);
ParseProgram;
end;
@ -15640,7 +15651,7 @@ begin
CheckResolverUnexpectedHints(true);
end;
procedure TTestResolver.ClassHelper;
procedure TTestResolver.TestClassHelper;
begin
StartProgram(false);
Add([
@ -15667,7 +15678,7 @@ begin
ParseProgram;
end;
procedure TTestResolver.ClassHelper_AncestorIsNotHelperForDescendantFail;
procedure TTestResolver.TestClassHelper_AncestorIsNotHelperForDescendantFail;
begin
StartProgram(false);
Add([
@ -15688,7 +15699,7 @@ begin
nDerivedXMustExtendASubClassY);
end;
procedure TTestResolver.ClassHelper_HelperForParentFail;
procedure TTestResolver.TestClassHelper_HelperForParentFail;
begin
StartProgram(false);
Add([
@ -15706,7 +15717,7 @@ begin
nTypeXIsNotYetCompletelyDefined);
end;
procedure TTestResolver.ClassHelper_ForInterfaceFail;
procedure TTestResolver.TestClassHelper_ForInterfaceFail;
begin
StartProgram(false);
Add([
@ -15722,7 +15733,7 @@ begin
nXExpectedButYFound);
end;
procedure TTestResolver.ClassHelper_FieldFail;
procedure TTestResolver.TestClassHelper_FieldFail;
begin
StartProgram(false);
Add([
@ -15738,7 +15749,7 @@ begin
nParserNoFieldsAllowed);
end;
procedure TTestResolver.ClassHelper_AbstractFail;
procedure TTestResolver.TestClassHelper_AbstractFail;
begin
StartProgram(false);
Add([
@ -15755,7 +15766,7 @@ begin
nInvalidXModifierY);
end;
procedure TTestResolver.ClassHelper_VirtualObjFPCFail;
procedure TTestResolver.TestClassHelper_VirtualObjFPCFail;
begin
StartProgram(false);
Add([
@ -15773,7 +15784,7 @@ begin
nInvalidXModifierY);
end;
procedure TTestResolver.ClassHelper_VirtualDelphiFail;
procedure TTestResolver.TestClassHelper_VirtualDelphiFail;
begin
StartProgram(false);
Add([
@ -15792,7 +15803,7 @@ begin
nInvalidXModifierY);
end;
procedure TTestResolver.ClassHelper_DestructorFail;
procedure TTestResolver.TestClassHelper_DestructorFail;
begin
StartProgram(false);
Add([
@ -15810,7 +15821,7 @@ begin
nParserXNotAllowedInY);
end;
procedure TTestResolver.ClassHelper_ClassRefersToTypeHelperOfAncestor;
procedure TTestResolver.TestClassHelper_ClassRefersToTypeHelperOfAncestor;
begin
StartProgram(false);
Add([
@ -15837,7 +15848,7 @@ begin
ParseProgram;
end;
procedure TTestResolver.ClassHelper_InheritedObjFPC;
procedure TTestResolver.TestClassHelper_InheritedObjFPC;
begin
StartProgram(false);
Add([
@ -15896,7 +15907,7 @@ begin
ParseProgram;
end;
procedure TTestResolver.ClassHelper_InheritedObjFPC2;
procedure TTestResolver.TestClassHelper_InheritedObjFPC2;
begin
StartProgram(false);
Add([
@ -15944,7 +15955,7 @@ begin
ParseProgram;
end;
procedure TTestResolver.ClassHelper_InheritedObjFPCStrictPrivateFail;
procedure TTestResolver.TestClassHelper_InheritedObjFPCStrictPrivateFail;
begin
StartProgram(false);
Add([
@ -15960,7 +15971,7 @@ begin
CheckResolverException('Can''t access strict private member i',nCantAccessXMember);
end;
procedure TTestResolver.ClassHelper_InheritedDelphi;
procedure TTestResolver.TestClassHelper_InheritedDelphi;
begin
StartProgram(false);
Add([
@ -16020,7 +16031,7 @@ begin
ParseProgram;
end;
procedure TTestResolver.ClassHelper_NestedInheritedParentFail;
procedure TTestResolver.TestClassHelper_NestedInheritedParentFail;
begin
StartProgram(false);
Add([
@ -16046,7 +16057,7 @@ begin
CheckResolverException('identifier not found "Fly"',nIdentifierNotFound);
end;
procedure TTestResolver.ClassHelper_AccessFields;
procedure TTestResolver.TestClassHelper_AccessFields;
begin
StartProgram(false);
Add([
@ -16073,7 +16084,7 @@ begin
ParseProgram;
end;
procedure TTestResolver.ClassHelper_CallClassMethodFail;
procedure TTestResolver.TestClassHelper_CallClassMethodFail;
begin
StartProgram(false);
Add([
@ -16091,7 +16102,7 @@ begin
CheckResolverException(sHelpersCannotBeUsedAsTypes,nHelpersCannotBeUsedAsTypes);
end;
procedure TTestResolver.ClassHelper_AsTypeFail;
procedure TTestResolver.TestClassHelper_AsTypeFail;
begin
StartProgram(false);
Add([
@ -16105,7 +16116,7 @@ begin
CheckResolverException(sHelpersCannotBeUsedAsTypes,nHelpersCannotBeUsedAsTypes);
end;
procedure TTestResolver.ClassHelper_Enumerator;
procedure TTestResolver.TestClassHelper_Enumerator;
begin
StartProgram(false);
Add([
@ -16140,7 +16151,7 @@ begin
ParseProgram;
end;
procedure TTestResolver.ClassHelper_FromUnitInterface;
procedure TTestResolver.TestClassHelper_FromUnitInterface;
begin
AddModuleWithIntfImplSrc('unit2.pas',
LinesToStr([
@ -16172,7 +16183,187 @@ begin
ParseProgram;
end;
procedure TTestResolver.RecordHelper;
procedure TTestResolver.TestClassHelper_Constructor_NewInstance;
var
aMarker: PSrcMarker;
Elements: TFPList;
i: Integer;
El: TPasElement;
Ref: TResolvedReference;
ActualNewInstance, ActualImplicitCallWithoutParams: Boolean;
begin
StartProgram(false);
Add([
'type',
' TObject = class',
' end;',
' THelper = class helper for TObject',
' constructor Create;',
' class function DoSome: TObject;',
' end;',
'constructor THelper.Create;',
'begin',
' {#a}Create; // normal call',
' TObject.{#b}Create; // new instance',
'end;',
'class function THelper.DoSome: TObject;',
'begin',
' Result:={#c}Create; // new instance',
'end;',
'var',
' o: TObject;',
'begin',
' TObject.{#p}Create; // new object',
' o:=TObject.{#q}Create; // new object',
' with TObject do begin',
' {#r}Create; // new object',
' o:={#s}Create; // new object',
' end;',
' o.{#t}Create; // normal call',
' o:=o.{#u}Create; // normal call',
' with o do begin',
' {#v}Create; // normal call',
' o:={#w}Create; // normal call',
' end;',
'']);
ParseProgram;
aMarker:=FirstSrcMarker;
while aMarker<>nil do
begin
//writeln('TTestResolver.TestClassHelper_Constructor_NewInstance ',aMarker^.Identifier,' ',aMarker^.StartCol,' ',aMarker^.EndCol);
Elements:=FindElementsAt(aMarker);
try
ActualNewInstance:=false;
ActualImplicitCallWithoutParams:=false;
for i:=0 to Elements.Count-1 do
begin
El:=TPasElement(Elements[i]);
//writeln('TTestResolver.TestClassHelper_Constructor_NewInstance ',aMarker^.Identifier,' ',i,'/',Elements.Count,' El=',GetObjName(El),' ',GetObjName(El.CustomData));
if not (El.CustomData is TResolvedReference) then continue;
Ref:=TResolvedReference(El.CustomData);
if not (Ref.Declaration is TPasProcedure) then continue;
//writeln('TTestResolver.TestClassHelper_Constructor_NewInstance ',GetObjName(Ref.Declaration),' rrfNewInstance=',rrfNewInstance in Ref.Flags);
if (Ref.Declaration is TPasConstructor) then
ActualNewInstance:=rrfNewInstance in Ref.Flags;
ActualImplicitCallWithoutParams:=rrfImplicitCallWithoutParams in Ref.Flags;
break;
end;
if not ActualImplicitCallWithoutParams then
RaiseErrorAtSrcMarker('expected implicit call at "#'+aMarker^.Identifier+', but got function ref"',aMarker);
case aMarker^.Identifier of
'a','t','u','v','w':// should be normal call
if ActualNewInstance then
RaiseErrorAtSrcMarker('expected normal call at "#'+aMarker^.Identifier+', but got newinstance"',aMarker);
else // should be newinstance
if not ActualNewInstance then
RaiseErrorAtSrcMarker('expected newinstance at "#'+aMarker^.Identifier+', but got normal call"',aMarker);
end;
finally
Elements.Free;
end;
aMarker:=aMarker^.Next;
end;
end;
procedure TTestResolver.TestClassHelper_DefaultProperty;
begin
StartProgram(false);
Add([
'type',
' TObject = class',
' function GetB(Index: longint): longint;',
' procedure SetB(Index: longint; Value: longint);',
' end;',
' THelper = class helper for TObject',
' property B[Index: longint]: longint read GetB write SetB; default;',
' end;',
'function TObject.GetB(Index: longint): longint;',
'begin',
'end;',
'procedure TObject.SetB(Index: longint; Value: longint);',
'begin',
' if Value=Self[Index] then ;',
' Self[Index]:=Value;',
'end;',
'var o: TObject;',
'begin',
' o[3]:=4;',
' if o[5]=6 then;',
' if 7=o[8] then;',
'']);
ParseProgram;
end;
procedure TTestResolver.TestClassHelper_DefaultClassProperty;
begin
StartProgram(false);
Add([
'type',
' TClass = class of TObject;',
' TObject = class',
' class function GetB(Index: longint): longint; static;',
' class procedure SetB(Index: longint; Value: longint); static;',
' end;',
' THelper = class helper for TObject',
' class property B[Index: longint]: longint read GetB write SetB; default;',
' end;',
'class function TObject.GetB(Index: longint): longint;',
'begin',
'end;',
'class procedure TObject.SetB(Index: longint; Value: longint);',
'begin',
' if Value=TObject[Index] then ;',
' TObject[Index]:=Value;',
'end;',
'var c: TClass;',
'begin',
' c[3]:=4;',
' if c[5]=6 then;',
' if 7=c[8] then;',
'']);
ParseProgram;
end;
procedure TTestResolver.TestClassHelper_MultipleScopeHelpers;
begin
StartProgram(false);
Add([
'{$modeswitch multiplescopehelpers}',
'type',
' TObject = class',
' end;',
' TFlyHelper = class helper for TObject',
' procedure {#Fly}Fly;',
' procedure {#FlyMove}Move;',
' end;',
' TRunHelper = class helper for TObject',
' procedure {#Run}Run;',
' procedure {#RunMove}Move;',
' procedure {#RunBack}Back;',
' end;',
' TSwimHelper = class helper for TObject',
' procedure {#Swim}Swim;',
' procedure {#SwimBack}Back;',
' end;',
'procedure TFlyHelper.Fly; begin end;',
'procedure TFlyHelper.Move; begin end;',
'procedure TRunHelper.Run; begin end;',
'procedure TRunHelper.Move; begin end;',
'procedure TRunHelper.Back; begin end;',
'procedure TSwimHelper.Swim; begin end;',
'procedure TSwimHelper.Back; begin end;',
'var o: TObject;',
'begin',
' o.{@Fly}Fly;',
' o.{@Run}Run;',
' o.{@Swim}Swim;',
' o.{@RunMove}Move;',
' o.{@SwimBack}Back;',
'']);
ParseProgram;
end;
procedure TTestResolver.TestRecordHelper;
begin
StartProgram(false);
Add([
@ -16207,7 +16398,87 @@ begin
ParseProgram;
end;
procedure TTestResolver.TypeHelper;
procedure TTestResolver.TestRecordHelper_Constructor_NewInstance;
var
aMarker: PSrcMarker;
Elements: TFPList;
ActualNewInstance: Boolean;
i: Integer;
El: TPasElement;
Ref: TResolvedReference;
begin
StartProgram(false);
Add([
'{$modeswitch advancedrecords}',
'{$modeswitch typehelpers}',
'type',
' TRec = record',
' constructor Create(w: word);',
' class function DoSome: TRec; static;',
' end;',
'constructor TRec.Create(w: word);',
'begin',
' {#a}Create(1); // normal call',
' TRec.{#b}Create(2); // new instance',
'end;',
'class function TRec.DoSome: TRec;',
'begin',
' Result:={#c}Create(3); // new instance',
'end;',
'var',
' r: TRec;',
'begin',
' TRec.{#p}Create(4); // new object',
' r:=TRec.{#q}Create(5); // new object',
' with TRec do begin',
' {#r}Create(6); // new object',
' r:={#s}Create(7); // new object',
' end;',
' r.{#t}Create(8); // normal call',
' r:=r.{#u}Create(9); // normal call',
' with r do begin',
' {#v}Create(10); // normal call',
' r:={#w}Create(11); // normal call',
' end;',
'']);
ParseProgram;
aMarker:=FirstSrcMarker;
while aMarker<>nil do
begin
//writeln('TTestResolver.TestAdvRecord_Constructor_NewInstance ',aMarker^.Identifier,' ',aMarker^.StartCol,' ',aMarker^.EndCol);
Elements:=FindElementsAt(aMarker);
try
ActualNewInstance:=false;
for i:=0 to Elements.Count-1 do
begin
El:=TPasElement(Elements[i]);
//writeln('TTestResolver.TestAdvRecord_Constructor_NewInstance ',aMarker^.Identifier,' ',i,'/',Elements.Count,' El=',GetObjName(El),' ',GetObjName(El.CustomData));
if not (El.CustomData is TResolvedReference) then continue;
Ref:=TResolvedReference(El.CustomData);
if not (Ref.Declaration is TPasProcedure) then continue;
//writeln('TTestResolver.TestAdvRecord_Constructor_NewInstance ',GetObjName(Ref.Declaration),' rrfNewInstance=',rrfNewInstance in Ref.Flags);
if (Ref.Declaration is TPasConstructor) then
ActualNewInstance:=rrfNewInstance in Ref.Flags;
if rrfImplicitCallWithoutParams in Ref.Flags then
RaiseErrorAtSrcMarker('unexpected implicit call at "#'+aMarker^.Identifier+' ref"',aMarker);
break;
end;
case aMarker^.Identifier of
'a','t','u','v','w':// should be normal call
if ActualNewInstance then
RaiseErrorAtSrcMarker('expected normal call at "#'+aMarker^.Identifier+', but got newinstance"',aMarker);
else // should be newinstance
if not ActualNewInstance then
RaiseErrorAtSrcMarker('expected newinstance at "#'+aMarker^.Identifier+', but got normal call"',aMarker);
end;
finally
Elements.Free;
end;
aMarker:=aMarker^.Next;
end;
end;
procedure TTestResolver.TestTypeHelper;
begin
StartProgram(false);
Add([
@ -16223,7 +16494,7 @@ begin
ParseProgram;
end;
procedure TTestResolver.TypeHelper_HelperForProcTypeFail;
procedure TTestResolver.TestTypeHelper_HelperForProcTypeFail;
begin
StartProgram(false);
Add([
@ -16238,7 +16509,7 @@ begin
nTypeXCannotBeExtendedByATypeHelper);
end;
procedure TTestResolver.TypeHelper_DefaultPropertyFail;
procedure TTestResolver.TestTypeHelper_DefaultPropertyFail;
begin
StartProgram(false);
Add([
@ -16258,7 +16529,7 @@ begin
nDefaultPropertyNotAllowedInHelperForX);
end;
procedure TTestResolver.TypeHelper_Enum;
procedure TTestResolver.TestTypeHelper_Enum;
begin
StartProgram(false);
Add([
@ -16282,7 +16553,7 @@ begin
ParseProgram;
end;
procedure TTestResolver.TypeHelper_Enumerator;
procedure TTestResolver.TestTypeHelper_Enumerator;
begin
StartProgram(false);
Add([
@ -16316,6 +16587,86 @@ begin
ParseProgram;
end;
procedure TTestResolver.TestTypeHelper_Constructor_NewInstance;
var
aMarker: PSrcMarker;
Elements: TFPList;
ActualNewInstance: Boolean;
i: Integer;
El: TPasElement;
Ref: TResolvedReference;
begin
StartProgram(false);
Add([
'{$modeswitch typehelpers}',
'type',
' TInt = type word;',
' THelper = type helper for TInt',
' constructor Create(w: TInt);',
' class function DoSome: TInt; static;',
' end;',
'constructor THelper.Create(w: TInt);',
'begin',
' {#a}Create(1); // normal call',
' TInt.{#b}Create(2); // new instance',
'end;',
'class function THelper.DoSome: TInt;',
'begin',
' Result:={#c}Create(3); // new instance',
'end;',
'var',
' r: TInt;',
'begin',
' TInt.{#p}Create(4); // new object',
' r:=TInt.{#q}Create(5); // new object',
' with TInt do begin',
' {#r}Create(6); // new object',
' r:={#s}Create(7); // new object',
' end;',
' r.{#t}Create(8); // normal call',
' r:=r.{#u}Create(9); // normal call',
' with r do begin',
' {#v}Create(10); // normal call',
' r:={#w}Create(11); // normal call',
' end;',
'']);
ParseProgram;
aMarker:=FirstSrcMarker;
while aMarker<>nil do
begin
//writeln('TTestResolver.TestAdvRecord_Constructor_NewInstance ',aMarker^.Identifier,' ',aMarker^.StartCol,' ',aMarker^.EndCol);
Elements:=FindElementsAt(aMarker);
try
ActualNewInstance:=false;
for i:=0 to Elements.Count-1 do
begin
El:=TPasElement(Elements[i]);
//writeln('TTestResolver.TestAdvRecord_Constructor_NewInstance ',aMarker^.Identifier,' ',i,'/',Elements.Count,' El=',GetObjName(El),' ',GetObjName(El.CustomData));
if not (El.CustomData is TResolvedReference) then continue;
Ref:=TResolvedReference(El.CustomData);
if not (Ref.Declaration is TPasProcedure) then continue;
//writeln('TTestResolver.TestAdvRecord_Constructor_NewInstance ',GetObjName(Ref.Declaration),' rrfNewInstance=',rrfNewInstance in Ref.Flags);
if (Ref.Declaration is TPasConstructor) then
ActualNewInstance:=rrfNewInstance in Ref.Flags;
if rrfImplicitCallWithoutParams in Ref.Flags then
RaiseErrorAtSrcMarker('unexpected implicit call at "#'+aMarker^.Identifier+' ref"',aMarker);
break;
end;
case aMarker^.Identifier of
'a','t','u','v','w':// should be normal call
if ActualNewInstance then
RaiseErrorAtSrcMarker('expected normal call at "#'+aMarker^.Identifier+', but got newinstance"',aMarker);
else // should be newinstance
if not ActualNewInstance then
RaiseErrorAtSrcMarker('expected newinstance at "#'+aMarker^.Identifier+', but got normal call"',aMarker);
end;
finally
Elements.Free;
end;
aMarker:=aMarker^.Next;
end;
end;
procedure TTestResolver.TestAttributes_Ignore;
begin
StartProgram(false);

3
packages/pastojs/src/pas2jscompiler.pp
View File

@ -688,9 +688,6 @@ type
property PostProcessorSupport: TPas2JSPostProcessorSupport Read FPostProcessorSupport Write FPostProcessorSupport;
end;
function GetCompiledDate: string;
function GetCompiledVersion: string;
function GetCompiledTargetOS: string;