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

compiler/packages/fcl-passrc/src/pasresolver.pp

@@ -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

compiler/packages/fcl-passrc/tests/tcresolver.pas

@@ -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);

compiler/packages/pastojs/tests/tcmodules.pas

@@ -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;',
     '  };',