diff --git a/.gitattributes b/.gitattributes index bf875d6aa3..dbe86de755 100644 --- a/.gitattributes +++ b/.gitattributes @@ -10910,6 +10910,7 @@ tests/webtbs/tw18123.pp svneol=native#text/pascal tests/webtbs/tw18127.pp svneol=native#text/pascal tests/webtbs/tw18131.pp svneol=native#text/pascal tests/webtbs/tw1820.pp svneol=native#text/plain +tests/webtbs/tw18222.pp svneol=native#text/pascal tests/webtbs/tw1825.pp svneol=native#text/plain tests/webtbs/tw1850.pp svneol=native#text/plain tests/webtbs/tw1851.pp svneol=native#text/plain diff --git a/compiler/pdecl.pas b/compiler/pdecl.pas index 15a3b3620b..69aa1f6704 100644 --- a/compiler/pdecl.pas +++ b/compiler/pdecl.pas @@ -558,6 +558,9 @@ implementation end; include(hdef.defoptions,df_unique); + if (hdef.typ in [pointerdef,classrefdef]) and + (tabstractpointerdef(hdef).pointeddef.typ=forwarddef) then + current_module.checkforwarddefs.add(hdef); end; if not assigned(hdef.typesym) then hdef.typesym:=newtype; diff --git a/compiler/symdef.pas b/compiler/symdef.pas index b57b0709cf..90daabdf81 100644 --- a/compiler/symdef.pas +++ b/compiler/symdef.pas @@ -129,9 +129,10 @@ interface tforwarddef = class(tstoreddef) tosymname : pshortstring; forwardpos : tfileposinfo; - constructor create(const s:string;const pos : tfileposinfo); + constructor create(const s:string;const pos:tfileposinfo); destructor destroy;override; - function GetTypeName:string;override; + function getcopy:tstoreddef;override; + function GetTypeName:string;override; end; tundefineddef = class(tstoreddef) @@ -162,7 +163,7 @@ interface is_far : boolean; constructor create(def:tdef); constructor createfar(def:tdef); - function getcopy : tstoreddef;override; + function getcopy:tstoreddef;override; constructor ppuload(ppufile:tcompilerppufile); procedure ppuwrite(ppufile:tcompilerppufile);override; function GetTypeName:string;override; @@ -333,9 +334,10 @@ interface constructor create(def:tdef); constructor ppuload(ppufile:tcompilerppufile); procedure ppuwrite(ppufile:tcompilerppufile);override; - function GetTypeName:string;override; - function is_publishable : boolean;override; - function rtti_mangledname(rt:trttitype):string;override; + function getcopy:tstoreddef;override; + function GetTypeName:string;override; + function is_publishable : boolean;override; + function rtti_mangledname(rt:trttitype):string;override; procedure register_created_object_type;override; end; @@ -2101,7 +2103,13 @@ implementation function tpointerdef.getcopy : tstoreddef; begin - result:=tpointerdef.create(pointeddef); + { don't use direct pointeddef if it is a forwarddef because in other case + one of them will be destroyed on forward type resolve and the second will + point to garbage } + if pointeddef.typ=forwarddef then + result:=tpointerdef.create(tforwarddef(pointeddef).getcopy) + else + result:=tpointerdef.create(pointeddef); tpointerdef(result).is_far:=is_far; tpointerdef(result).savesize:=savesize; end; @@ -2147,6 +2155,16 @@ implementation end; + function tclassrefdef.getcopy:tstoreddef; + begin + if pointeddef.typ=forwarddef then + result:=tclassrefdef.create(tforwarddef(pointeddef).getcopy) + else + result:=tclassrefdef.create(pointeddef); + tclassrefdef(result).savesize:=savesize; + end; + + function tclassrefdef.GetTypeName : string; begin GetTypeName:='Class Of '+pointeddef.typename; @@ -5236,7 +5254,7 @@ implementation TFORWARDDEF ****************************************************************************} - constructor tforwarddef.create(const s:string;const pos : tfileposinfo); + constructor tforwarddef.create(const s:string;const pos:tfileposinfo); begin inherited create(forwarddef); tosymname:=stringdup(s); @@ -5256,6 +5274,10 @@ implementation inherited destroy; end; + function tforwarddef.getcopy:tstoreddef; + begin + result:=tforwarddef.create(tosymname^, forwardpos); + end; {**************************************************************************** TUNDEFINEDDEF diff --git a/tests/webtbs/tw18222.pp b/tests/webtbs/tw18222.pp new file mode 100644 index 0000000000..db6eb82023 --- /dev/null +++ b/tests/webtbs/tw18222.pp @@ -0,0 +1,128 @@ +{ %norun } +program tw18222; +{$mode objfpc}{$H-} + +uses sysutils; + +type + TFoo = class + public + FooValue: Integer; + end; + + PFoo = ^TFoo; + PFooTyped = type PFoo; + PPFoo = ^PFoo; + + TFooClass = Class of TFoo; + PFooClass = ^TFooClass; + PPFooClass = ^PFooClass; + + TMyAnsiString = AnsiString; + TMyOwnAnsiString = type AnsiString; + + +procedure FooFunc( + ArgAnsiString1: AnsiString; var ArgAnsiString2: AnsiString; const ArgAnsiString3: AnsiString; + ArgPAnsiString1: PAnsiString; var ArgPAnsiString2: PAnsiString; const ArgPAnsiString3: PAnsiString; + + ArgChar1: Char; var ArgChar2: Char; const ArgChar3: Char; + ArgPChar1: PChar; var ArgPChar2: PChar; const ArgPChar3: PChar; + + ArgQW1, ArgQW2: QWord; + + Foo1, Foo1n: TFoo; var Foo2, Foo2n: TFoo; + pFoo1, pFoo1n: PFoo; var pFoo2, pFoo2n: PFoo; + + FooClass1, FooClass1n: TFooClass; var FooClass2, FooClass2n: TFooClass; + pFooClass1, pFooClass1n: PFooClass; var pFooClass2, pFooClass2n: PFooClass +); +var + TestInt: Integer; + TesTShortString: String[10]; + TestAnsiString: AnsiString; + TestMyAnsiString: TMyAnsiString; + TestMyOwnAnsiString: TMyOwnAnsiString; + TestPChar: PChar; + TestQW1: QWord; + TestQW2: QWord; + + TestPPFoo: PPFoo; + //TestPFooTyped: PFooTyped; + TestPPFooClass: PPFooClass; + + function SubFoo(var AVal1: Integer; AVal2: Integer) : Integer; + begin + AVal1 := 2 * AVal2; + Result := AVal2; + inc(AVal2); // First BreakBoint + end; + +begin + TestInt := 3; + TesTShortString := IntToStr(TestInt) + ':'; + TestAnsiString := TesTShortString + ' Foo'; + TestMyAnsiString := TesTShortString + ' FooMy'; + TestMyOwnAnsiString := TesTShortString + ' FooMyOwn'; + TestPChar := @TestAnsiString[2]; + TestQw1 := ArgQw1 + 1; dec(TestQW1); + TestQw2 := ArgQw2 + 1; dec(TestQW2); + TestPPFoo := @pFoo1; + TestPPFooClass := @pFooClass1; + SubFoo(TestInt, 5); + // access all values, so the will not be optimized away + writeln(TestPChar); + // params + writeln(ArgAnsiString1, ArgAnsiString2, ArgAnsiString3, ArgChar1, ArgChar2, ArgChar3); // breakpoint 2 + writeln(ArgQw1, ArgQw1, TestQW1, TestQW2); + if (Foo1 is FooClass1) and (Foo2 is FooClass2) and (Foo1n = Foo2n) and (FooClass1 = FooClass2) then + writeln(Foo1.FooValue + foo2.FooValue); +end; + +var + a1, a2, a3: ansistring; + a2p: PAnsiString; + c1, c2, c3: Char; + c2p: PChar; + f1, f2, fn: TFoo; + f1p, fnp: PFoo; + fc, fcn: TFooclass; + fcp, fcnp: PFooClass; +begin + a1 := 'abc'; a2 := 'def'; a3 := 'ghi'; + a2p := @a2; + c1 := 'X'; c2 := 'Y'; c2 := 'Z'; + c2p := @c2; + + f1 := TFoo.Create; + f2 := TFoo.Create; + fn := nil; + f1p := @f1; + fnp := @fn; + + fc := TFoo; + fcn := nil; + fcp := @fc; + fcnp := @fcp; + + FooFunc( + a1, a2, a3, + @a1, a2p, @a3, + + c1, c2, c3, + @c1, c2p, @c3, + + //ArgQW1, ArgQW2: QWord; + 139784704, 139784871, + + //Foo1, Foo1n: TFoo; var Foo2, Foo2n: TFoo + f1, nil, f2, fn, + f1p, nil, f1p, fnp, + + //FooClass1, FooClass1n: TFooclass; var FooClass2, FooClass2n: TFoo + TFoo, nil, fc, fcn, + fcp, nil, fcp, fcnp + ); + FreeAndNil(f1); + FreeAndNil(f2); +end.