paweld/pas2js
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/pas2js.git synced 2025-08-21 19:29:30 +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 begin
// this proc was already found. This happens when this is the forward // this proc was already found. This happens when this is the forward
// declaration or a previously found implementation. // declaration or a previously found implementation.
Data^.ElScope:=ElScope;
Data^.StartScope:=StartScope;
exit; exit;
end; end;
@ -9290,6 +9288,7 @@ begin
// FoundEl compatible element -> create reference // FoundEl compatible element -> create reference
FoundEl:=FindCallData.Found; FoundEl:=FindCallData.Found;
Ref:=CreateReference(FoundEl,NameExpr,rraRead); Ref:=CreateReference(FoundEl,NameExpr,rraRead);
if FindCallData.StartScope.ClassType=ScopeClass_WithExpr then if FindCallData.StartScope.ClassType=ScopeClass_WithExpr then
Ref.WithExprScope:=TPasWithExprScope(FindCallData.StartScope); Ref.WithExprScope:=TPasWithExprScope(FindCallData.StartScope);
FindData:=Default(TPRFindData); FindData:=Default(TPRFindData);
@ -16870,6 +16869,7 @@ begin
{$IFDEF VerbosePasResolver} {$IFDEF VerbosePasResolver}
writeln('TPasResolver.CreateReference RefEl=',GetObjName(RefEl),' DeclEl=',GetObjName(DeclEl)); writeln('TPasResolver.CreateReference RefEl=',GetObjName(RefEl),' DeclEl=',GetObjName(DeclEl));
{$ENDIF} {$ENDIF}
Result:=TResolvedReference.Create; Result:=TResolvedReference.Create;
if FindData<>nil then if FindData<>nil then
begin begin

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

@ -469,7 +469,7 @@ type
Procedure TestAnonymousProc_Typecast_ObjFPC; Procedure TestAnonymousProc_Typecast_ObjFPC;
Procedure TestAnonymousProc_Typecast_Delphi; Procedure TestAnonymousProc_Typecast_Delphi;
Procedure TestAnonymousProc_TypecastToResultFail; Procedure TestAnonymousProc_TypecastToResultFail;
Procedure TestAnonymousProc_With; Procedure TestAnonymousProc_WithDo;
Procedure TestAnonymousProc_ExceptOn; Procedure TestAnonymousProc_ExceptOn;
Procedure TestAnonymousProc_Nested; Procedure TestAnonymousProc_Nested;
Procedure TestAnonymousProc_ForLoop; Procedure TestAnonymousProc_ForLoop;
@ -479,9 +479,9 @@ type
Procedure TestRecordVariant; Procedure TestRecordVariant;
Procedure TestRecordVariantNested; Procedure TestRecordVariantNested;
Procedure TestRecord_WriteConstParamFail; Procedure TestRecord_WriteConstParamFail;
Procedure TestRecord_WriteConstParam_WithFail; Procedure TestRecord_WriteConstParam_WithDoFail;
Procedure TestRecord_WriteNestedConstParamFail; Procedure TestRecord_WriteNestedConstParamFail;
Procedure TestRecord_WriteNestedConstParamWithFail; Procedure TestRecord_WriteNestedConstParamWithDoFail;
Procedure TestRecord_TypeCast; Procedure TestRecord_TypeCast;
Procedure TestRecord_NewDispose; Procedure TestRecord_NewDispose;
Procedure TestRecord_Const; Procedure TestRecord_Const;
@ -604,7 +604,7 @@ type
Procedure TestClass_ConDestructor_CallInherited; Procedure TestClass_ConDestructor_CallInherited;
Procedure TestClass_Constructor_Inherited; Procedure TestClass_Constructor_Inherited;
Procedure TestClass_SubObject; Procedure TestClass_SubObject;
Procedure TestClass_WithClassInstance; Procedure TestClass_WithDoClassInstance;
Procedure TestClass_ProcedureExternal; Procedure TestClass_ProcedureExternal;
Procedure TestClass_ReintroducePublicVarFail; Procedure TestClass_ReintroducePublicVarFail;
Procedure TestClass_ReintroducePrivateVar; Procedure TestClass_ReintroducePrivateVar;
@ -750,11 +750,11 @@ type
Procedure TestClassInterface_PassTypecastIntfToClassAsVarParamFail; Procedure TestClassInterface_PassTypecastIntfToClassAsVarParamFail;
Procedure TestClassInterface_GUID; Procedure TestClassInterface_GUID;
// with // with-do
Procedure TestWithBlock1; Procedure TestWithDo1;
Procedure TestWithBlock2; Procedure TestWithDo2;
Procedure TestWithBlockFuncResult; Procedure TestWithDoFuncResult;
Procedure TestWithBlockConstructor; Procedure TestWithDoConstructor;
// arrays // arrays
Procedure TestDynArrayOfLongint; Procedure TestDynArrayOfLongint;
@ -908,8 +908,9 @@ type
Procedure TestClassHelper_NestedInheritedParentFail; Procedure TestClassHelper_NestedInheritedParentFail;
Procedure TestClassHelper_AccessFields; Procedure TestClassHelper_AccessFields;
Procedure TestClassHelper_HelperDotClassMethodFail; Procedure TestClassHelper_HelperDotClassMethodFail;
Procedure TestClassHelper_WithHelperFail; Procedure TestClassHelper_WithDoHelperFail;
Procedure TestClassHelper_AsTypeFail; Procedure TestClassHelper_AsTypeFail;
Procedure TestClassHelper_WithDo;
Procedure TestClassHelper_ClassMethod; Procedure TestClassHelper_ClassMethod;
Procedure TestClassHelper_Enumerator; Procedure TestClassHelper_Enumerator;
Procedure TestClassHelper_FromUnitInterface; Procedure TestClassHelper_FromUnitInterface;
@ -7652,7 +7653,7 @@ begin
nIllegalTypeConversionTo); nIllegalTypeConversionTo);
end; end;
procedure TTestResolver.TestAnonymousProc_With; procedure TTestResolver.TestAnonymousProc_WithDo;
begin begin
StartProgram(false); StartProgram(false);
Add([ Add([
@ -7838,7 +7839,7 @@ begin
CheckResolverException(sVariableIdentifierExpected,nVariableIdentifierExpected); CheckResolverException(sVariableIdentifierExpected,nVariableIdentifierExpected);
end; end;
procedure TTestResolver.TestRecord_WriteConstParam_WithFail; procedure TTestResolver.TestRecord_WriteConstParam_WithDoFail;
begin begin
StartProgram(false); StartProgram(false);
Add('type'); Add('type');
@ -7871,7 +7872,7 @@ begin
CheckResolverException(sVariableIdentifierExpected,nVariableIdentifierExpected); CheckResolverException(sVariableIdentifierExpected,nVariableIdentifierExpected);
end; end;
procedure TTestResolver.TestRecord_WriteNestedConstParamWithFail; procedure TTestResolver.TestRecord_WriteNestedConstParamWithDoFail;
begin begin
StartProgram(false); StartProgram(false);
Add('type'); Add('type');
@ -10668,7 +10669,7 @@ begin
ParseProgram; ParseProgram;
end; end;
procedure TTestResolver.TestClass_WithClassInstance; procedure TTestResolver.TestClass_WithDoClassInstance;
var var
aMarker: PSrcMarker; aMarker: PSrcMarker;
Elements: TFPList; Elements: TFPList;
@ -13508,7 +13509,7 @@ begin
CheckResolverException('not readable',nNotReadable); CheckResolverException('not readable',nNotReadable);
end; end;
procedure TTestResolver.TestWithBlock1; procedure TTestResolver.TestWithDo1;
begin begin
StartProgram(false); StartProgram(false);
Add('type'); Add('type');
@ -13525,7 +13526,7 @@ begin
ParseProgram; ParseProgram;
end; end;
procedure TTestResolver.TestWithBlock2; procedure TTestResolver.TestWithDo2;
begin begin
StartProgram(false); StartProgram(false);
Add('type'); Add('type');
@ -13553,7 +13554,7 @@ begin
ParseProgram; ParseProgram;
end; end;
procedure TTestResolver.TestWithBlockFuncResult; procedure TTestResolver.TestWithDoFuncResult;
begin begin
StartProgram(false); StartProgram(false);
Add('type'); Add('type');
@ -13581,7 +13582,7 @@ begin
ParseProgram; ParseProgram;
end; end;
procedure TTestResolver.TestWithBlockConstructor; procedure TTestResolver.TestWithDoConstructor;
begin begin
StartProgram(false); StartProgram(false);
Add('type'); Add('type');
@ -13884,7 +13885,8 @@ begin
Add('begin'); Add('begin');
Add(' doit({#a}getarr[1+1]);'); Add(' doit({#a}getarr[1+1]);');
Add(' doit({#b}getarr()[2+1]);'); Add(' doit({#b}getarr()[2+1]);');
Add(' doit({#b}getarr(7)[3+1]);'); Add(' doit({#c}getarr(7)[3+1]);');
ParseProgram;
aMarker:=FirstSrcMarker; aMarker:=FirstSrcMarker;
while aMarker<>nil do while aMarker<>nil do
begin begin
@ -16755,7 +16757,7 @@ begin
CheckResolverException(sHelpersCannotBeUsedAsTypes,nHelpersCannotBeUsedAsTypes); CheckResolverException(sHelpersCannotBeUsedAsTypes,nHelpersCannotBeUsedAsTypes);
end; end;
procedure TTestResolver.TestClassHelper_WithHelperFail; procedure TTestResolver.TestClassHelper_WithDoHelperFail;
begin begin
StartProgram(false); StartProgram(false);
Add([ Add([
@ -16783,6 +16785,92 @@ begin
CheckResolverException(sHelpersCannotBeUsedAsTypes,nHelpersCannotBeUsedAsTypes); CheckResolverException(sHelpersCannotBeUsedAsTypes,nHelpersCannotBeUsedAsTypes);
end; 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; procedure TTestResolver.TestClassHelper_ClassMethod;
begin begin
StartProgram(false); StartProgram(false);

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

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