paweld/pas2js
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/pas2js.git synced 2025-04-06 02:27:48 +02:00
Code Issues Packages Projects Releases Wiki Activity

fcl-passrc: fixed resolving with-do x, where x is in helper and class

Browse Source
This commit is contained in:
mattias 2020-03-30 12:09:35 +00:00
parent f106f3ef5b
commit 738fe0d771
3 changed files with 116 additions and 24 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
compiler/packages/fcl-passrc/src/pasresolver.pp
View File

@ -4367,8 +4367,6 @@ begin
begin
// this proc was already found. This happens when this is the forward
// declaration or a previously found implementation.
Data^.ElScope:=ElScope;
Data^.StartScope:=StartScope;
exit;
end;
@ -9290,6 +9288,7 @@ begin
// FoundEl compatible element -> create reference
FoundEl:=FindCallData.Found;
Ref:=CreateReference(FoundEl,NameExpr,rraRead);
if FindCallData.StartScope.ClassType=ScopeClass_WithExpr then
Ref.WithExprScope:=TPasWithExprScope(FindCallData.StartScope);
FindData:=Default(TPRFindData);
@ -16870,6 +16869,7 @@ begin
{$IFDEF VerbosePasResolver}
writeln('TPasResolver.CreateReference RefEl=',GetObjName(RefEl),' DeclEl=',GetObjName(DeclEl));
{$ENDIF}
Result:=TResolvedReference.Create;
if FindData<>nil then
begin

128
compiler/packages/fcl-passrc/tests/tcresolver.pas
View File

@ -469,7 +469,7 @@ type
Procedure TestAnonymousProc_Typecast_ObjFPC;
Procedure TestAnonymousProc_Typecast_Delphi;
Procedure TestAnonymousProc_TypecastToResultFail;
Procedure TestAnonymousProc_With;
Procedure TestAnonymousProc_WithDo;
Procedure TestAnonymousProc_ExceptOn;
Procedure TestAnonymousProc_Nested;
Procedure TestAnonymousProc_ForLoop;
@ -479,9 +479,9 @@ type
Procedure TestRecordVariant;
Procedure TestRecordVariantNested;
Procedure TestRecord_WriteConstParamFail;
Procedure TestRecord_WriteConstParam_WithFail;
Procedure TestRecord_WriteConstParam_WithDoFail;
Procedure TestRecord_WriteNestedConstParamFail;
Procedure TestRecord_WriteNestedConstParamWithFail;
Procedure TestRecord_WriteNestedConstParamWithDoFail;
Procedure TestRecord_TypeCast;
Procedure TestRecord_NewDispose;
Procedure TestRecord_Const;
@ -604,7 +604,7 @@ type
Procedure TestClass_ConDestructor_CallInherited;
Procedure TestClass_Constructor_Inherited;
Procedure TestClass_SubObject;
Procedure TestClass_WithClassInstance;
Procedure TestClass_WithDoClassInstance;
Procedure TestClass_ProcedureExternal;
Procedure TestClass_ReintroducePublicVarFail;
Procedure TestClass_ReintroducePrivateVar;
@ -750,11 +750,11 @@ type
Procedure TestClassInterface_PassTypecastIntfToClassAsVarParamFail;
Procedure TestClassInterface_GUID;
// with
Procedure TestWithBlock1;
Procedure TestWithBlock2;
Procedure TestWithBlockFuncResult;
Procedure TestWithBlockConstructor;
// with-do
Procedure TestWithDo1;
Procedure TestWithDo2;
Procedure TestWithDoFuncResult;
Procedure TestWithDoConstructor;
// arrays
Procedure TestDynArrayOfLongint;
@ -908,8 +908,9 @@ type
Procedure TestClassHelper_NestedInheritedParentFail;
Procedure TestClassHelper_AccessFields;
Procedure TestClassHelper_HelperDotClassMethodFail;
Procedure TestClassHelper_WithHelperFail;
Procedure TestClassHelper_WithDoHelperFail;
Procedure TestClassHelper_AsTypeFail;
Procedure TestClassHelper_WithDo;
Procedure TestClassHelper_ClassMethod;
Procedure TestClassHelper_Enumerator;
Procedure TestClassHelper_FromUnitInterface;
@ -7652,7 +7653,7 @@ begin
nIllegalTypeConversionTo);
end;
procedure TTestResolver.TestAnonymousProc_With;
procedure TTestResolver.TestAnonymousProc_WithDo;
begin
StartProgram(false);
Add([
@ -7838,7 +7839,7 @@ begin
CheckResolverException(sVariableIdentifierExpected,nVariableIdentifierExpected);
end;
procedure TTestResolver.TestRecord_WriteConstParam_WithFail;
procedure TTestResolver.TestRecord_WriteConstParam_WithDoFail;
begin
StartProgram(false);
Add('type');
@ -7871,7 +7872,7 @@ begin
CheckResolverException(sVariableIdentifierExpected,nVariableIdentifierExpected);
end;
procedure TTestResolver.TestRecord_WriteNestedConstParamWithFail;
procedure TTestResolver.TestRecord_WriteNestedConstParamWithDoFail;
begin
StartProgram(false);
Add('type');
@ -10668,7 +10669,7 @@ begin
ParseProgram;
end;
procedure TTestResolver.TestClass_WithClassInstance;
procedure TTestResolver.TestClass_WithDoClassInstance;
var
aMarker: PSrcMarker;
Elements: TFPList;
@ -13508,7 +13509,7 @@ begin
CheckResolverException('not readable',nNotReadable);
end;
procedure TTestResolver.TestWithBlock1;
procedure TTestResolver.TestWithDo1;
begin
StartProgram(false);
Add('type');
@ -13525,7 +13526,7 @@ begin
ParseProgram;
end;
procedure TTestResolver.TestWithBlock2;
procedure TTestResolver.TestWithDo2;
begin
StartProgram(false);
Add('type');
@ -13553,7 +13554,7 @@ begin
ParseProgram;
end;
procedure TTestResolver.TestWithBlockFuncResult;
procedure TTestResolver.TestWithDoFuncResult;
begin
StartProgram(false);
Add('type');
@ -13581,7 +13582,7 @@ begin
ParseProgram;
end;
procedure TTestResolver.TestWithBlockConstructor;
procedure TTestResolver.TestWithDoConstructor;
begin
StartProgram(false);
Add('type');
@ -13884,7 +13885,8 @@ begin
Add('begin');
Add(' doit({#a}getarr[1+1]);');
Add(' doit({#b}getarr()[2+1]);');
Add(' doit({#b}getarr(7)[3+1]);');
Add(' doit({#c}getarr(7)[3+1]);');
ParseProgram;
aMarker:=FirstSrcMarker;
while aMarker<>nil do
begin
@ -16755,7 +16757,7 @@ begin
CheckResolverException(sHelpersCannotBeUsedAsTypes,nHelpersCannotBeUsedAsTypes);
end;
procedure TTestResolver.TestClassHelper_WithHelperFail;
procedure TTestResolver.TestClassHelper_WithDoHelperFail;
begin
StartProgram(false);
Add([
@ -16783,6 +16785,92 @@ begin
CheckResolverException(sHelpersCannotBeUsedAsTypes,nHelpersCannotBeUsedAsTypes);
end;
procedure TTestResolver.TestClassHelper_WithDo;
var
aMarker: PSrcMarker;
Elements: TFPList;
ActualWith, ExpectedWith: Boolean;
i: Integer;
El: TPasElement;
Ref: TResolvedReference;
begin
StartProgram(false);
Add([
'type',
' TObject = class end;',
' TBird = class',
' procedure Run;',
' end;',
' THelper = class helper for TBird',
' procedure Foo(w: word = 1);',
' end;',
'procedure TBird.Run;',
'var b: TBird;',
'begin',
' b.{#a1_not}Foo;',
' b.{#b1_not}Foo();',
' b.{#c1_not}Foo(2);',
' with b do begin',
' {#d1_with}Foo;',
' {#e1_with}Foo();',
' {#f1_with}Foo(3);',
' end;',
'end;',
'procedure THelper.Foo(w: word);',
'var b: TBird;',
'begin',
' b.{#a2_not}Foo;',
' b.{#b2_not}Foo();',
' b.{#c2_not}Foo(2);',
' with b do begin',
' {#d2_with}Foo;',
' {#e2_with}Foo();',
' {#f2_with}Foo(3);',
' end;',
'end;',
'var b: TBird;',
'begin',
' b.{#a3_not}Foo;',
' b.{#b3_not}Foo();',
' b.{#c3_not}Foo(4);',
' with b do begin',
' {#d3_with}Foo;',
' {#e3_with}Foo();',
' {#f3_with}Foo(5);',
' end;',
'']);
ParseProgram;
aMarker:=FirstSrcMarker;
while aMarker<>nil do
begin
//writeln('TTestResolver.TestClassHelper_WithDo ',aMarker^.Identifier,' ',aMarker^.StartCol,' ',aMarker^.EndCol);
Elements:=FindElementsAt(aMarker);
try
ActualWith:=false;
for i:=0 to Elements.Count-1 do
begin
El:=TPasElement(Elements[i]);
writeln('TTestResolver.TestClassHelper_WithDo ',aMarker^.Identifier,' ',i,'/',Elements.Count,' El=',GetObjName(El),' ',GetObjName(El.CustomData));
if not (El.CustomData is TResolvedReference) then continue;
Ref:=TResolvedReference(El.CustomData);
if Ref.WithExprScope<>nil then
ActualWith:=true;
break;
end;
ExpectedWith:=RightStr(aMarker^.Identifier,5)='_with';
if ActualWith<>ExpectedWith then
if ExpectedWith then
RaiseErrorAtSrcMarker('expected Ref.WithExprScope<>nil at "#'+aMarker^.Identifier+'"',aMarker)
else
RaiseErrorAtSrcMarker('expected Ref.WithExprScope=nil at "#'+aMarker^.Identifier+'"',aMarker);
finally
Elements.Free;
end;
aMarker:=aMarker^.Next;
end;
end;
procedure TTestResolver.TestClassHelper_ClassMethod;
begin
StartProgram(false);

8
compiler/packages/pastojs/tests/tcmodules.pas
View File

@ -19552,6 +19552,7 @@ begin
' function Foo(w: word = 1): word;',
' end;',
'procedure TObject.Run(w: word);',
'var o: TObject;',
'begin',
' Foo;',
' Foo();',
@ -19564,6 +19565,7 @@ begin
' Foo();',
' Foo(4);',
' end;',
' with o do Foo(5);',
'end;',
'function THelper.foo(w: word): word;',
'begin',
@ -19602,6 +19604,7 @@ begin
' this.$final = function () {',
' };',
' this.Run = function (w) {',
' var o = null;',
' $mod.THelper.Foo.call(this, 1);',
' $mod.THelper.Foo.call(this, 1);',
' $mod.THelper.Foo.call(this, 2);',
@ -19611,6 +19614,7 @@ begin
' $mod.THelper.Foo.call(this, 1);',
' $mod.THelper.Foo.call(this, 1);',
' $mod.THelper.Foo.call(this, 4);',
' $mod.THelper.Foo.call(o, 5);',
' };',
'});',
'rtl.createHelper($mod, "THelper", null, function () {',
@ -19703,7 +19707,7 @@ begin
' $mod.THelper.Foo.call(Self, 1);',
' $mod.THelper.Foo.call(Self, 1);',
' $mod.THelper.Foo.call(Self, 1);',
' $mod.THelper.Foo.call($Self, 1);',
' $mod.THelper.Foo.call(Self, 1);',
' };',
' };',
'});',
@ -19719,7 +19723,7 @@ begin
' $mod.THelper.Foo.call(Self, 1);',
' $mod.THelper.Foo.call(Self, 1);',
' $mod.THelper.Foo.call(Self, 1);',
' $mod.THelper.Foo.call($Self, 1);',
' $mod.THelper.Foo.call(Self, 1);',
' };',
' return Result;',
' };',