diff --git a/packages/fcl-passrc/src/pasresolver.pp b/packages/fcl-passrc/src/pasresolver.pp index c363899313..78c916b2f5 100644 --- a/packages/fcl-passrc/src/pasresolver.pp +++ b/packages/fcl-passrc/src/pasresolver.pp @@ -4864,8 +4864,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; @@ -10774,6 +10772,7 @@ begin // FoundEl compatible element -> create reference Ref:=CreateReference(FoundEl,NameExpr,rraRead); + if FindCallData.StartScope.ClassType=ScopeClass_WithExpr then Ref.WithExprScope:=TPasWithExprScope(FindCallData.StartScope); FindData:=Default(TPRFindData); @@ -21572,6 +21571,7 @@ begin {$IFDEF VerbosePasResolver} writeln('TPasResolver.CreateReference RefEl=',GetObjName(RefEl),' DeclEl=',GetObjName(DeclEl)); {$ENDIF} + Result:=TResolvedReference.Create; if FindData<>nil then begin diff --git a/packages/fcl-passrc/tests/tcresolver.pas b/packages/fcl-passrc/tests/tcresolver.pas index 2bfe241ca8..998bfa7044 100644 --- a/packages/fcl-passrc/tests/tcresolver.pas +++ b/packages/fcl-passrc/tests/tcresolver.pas @@ -475,7 +475,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; @@ -485,9 +485,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; @@ -612,7 +612,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; @@ -765,11 +765,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; @@ -925,8 +925,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; @@ -7866,7 +7867,7 @@ begin nIllegalTypeConversionTo); end; -procedure TTestResolver.TestAnonymousProc_With; +procedure TTestResolver.TestAnonymousProc_WithDo; begin StartProgram(false); Add([ @@ -8052,7 +8053,7 @@ begin CheckResolverException(sVariableIdentifierExpected,nVariableIdentifierExpected); end; -procedure TTestResolver.TestRecord_WriteConstParam_WithFail; +procedure TTestResolver.TestRecord_WriteConstParam_WithDoFail; begin StartProgram(false); Add('type'); @@ -8085,7 +8086,7 @@ begin CheckResolverException(sVariableIdentifierExpected,nVariableIdentifierExpected); end; -procedure TTestResolver.TestRecord_WriteNestedConstParamWithFail; +procedure TTestResolver.TestRecord_WriteNestedConstParamWithDoFail; begin StartProgram(false); Add('type'); @@ -10927,7 +10928,7 @@ begin ParseProgram; end; -procedure TTestResolver.TestClass_WithClassInstance; +procedure TTestResolver.TestClass_WithDoClassInstance; var aMarker: PSrcMarker; Elements: TFPList; @@ -13930,7 +13931,7 @@ begin CheckResolverException('not readable',nNotReadable); end; -procedure TTestResolver.TestWithBlock1; +procedure TTestResolver.TestWithDo1; begin StartProgram(false); Add('type'); @@ -13947,7 +13948,7 @@ begin ParseProgram; end; -procedure TTestResolver.TestWithBlock2; +procedure TTestResolver.TestWithDo2; begin StartProgram(false); Add('type'); @@ -13975,7 +13976,7 @@ begin ParseProgram; end; -procedure TTestResolver.TestWithBlockFuncResult; +procedure TTestResolver.TestWithDoFuncResult; begin StartProgram(false); Add('type'); @@ -14003,7 +14004,7 @@ begin ParseProgram; end; -procedure TTestResolver.TestWithBlockConstructor; +procedure TTestResolver.TestWithDoConstructor; begin StartProgram(false); Add('type'); @@ -14306,7 +14307,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 @@ -17210,7 +17212,7 @@ begin CheckResolverException(sHelpersCannotBeUsedAsTypes,nHelpersCannotBeUsedAsTypes); end; -procedure TTestResolver.TestClassHelper_WithHelperFail; +procedure TTestResolver.TestClassHelper_WithDoHelperFail; begin StartProgram(false); Add([ @@ -17238,6 +17240,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);