* (lsighly, added safety check) patch by Евгений Савин, resolves #40784

This commit is contained in:
florian 2024-06-23 22:06:49 +02:00
parent 4300e2cfcc
commit abcced55af
4 changed files with 121 additions and 5 deletions

View File

@ -3295,6 +3295,31 @@ implementation
end;
function check_strict_protected:boolean;
function is_childof(child, potentialparent: tdef):boolean;
begin
result:=true;
if def_is_related(child, potentialparent) then
exit;
if (child.typ=objectdef) and
(potentialparent.typ=objectdef) and
(tobjectdef(potentialparent).defoptions*[df_generic,df_specialization]=[df_generic]) then
begin
repeat
if tobjectdef(child).genericdef<>nil then
begin
if tobjectdef(child).genericdef.typ<>objectdef then
break;
child:=tobjectdef(child).genericdef as tobjectdef
end
else
child:=tobjectdef(child).childof;
if (child<>nil) and equal_defs(child, potentialparent) then
exit;
until child=nil;
end;
result:=false;
end;
function owner_hierarchy_related(nested,check:tabstractrecorddef):boolean;
var
@ -3302,7 +3327,7 @@ implementation
begin
result:=true;
repeat
if def_is_related(nested,check) then
if is_childof(nested,check) then
exit;
if nested.owner.symtabletype in [recordsymtable,objectsymtable] then
nested:=tabstractrecorddef(nested.owner.defowner)
@ -3329,7 +3354,7 @@ implementation
assigned(contextobjdef) and
assigned(curstruct) and
owner_hierarchy_related(contextobjdef,symownerdef) and
def_is_related(curstruct,contextobjdef)
is_childof(curstruct,contextobjdef)
) or
(
{ access from child class (non-specialization case) }
@ -3340,18 +3365,18 @@ implementation
) and
assigned(curstruct) and
owner_hierarchy_related(orgcontextobjdef,orgsymownerdef) and
def_is_related(curstruct,orgcontextobjdef)
is_childof(curstruct,orgcontextobjdef)
) or
(
{ helpers can access strict protected symbols }
is_objectpascal_helper(contextobjdef) and
def_is_related(tobjectdef(contextobjdef).extendeddef,symownerdef)
is_childof(tobjectdef(contextobjdef).extendeddef,symownerdef)
) or
(
{ same as above, but from context of call node inside
helper method }
is_objectpascal_helper(curstruct) and
def_is_related(tobjectdef(curstruct).extendeddef,symownerdef)
is_childof(tobjectdef(curstruct).extendeddef,symownerdef)
);
end;

19
tests/webtbs/tw40784.pp Normal file
View File

@ -0,0 +1,19 @@
program tw40784;
{$mode delphi}
uses uw40784a, uw40784b;
type
TSmetaUnitsCatalog = class(TCatCatalog<TObject>)
end;
TSmetaUnitsCatalog2 = class(TCatCatalog2<TObject>)
end;
begin
TSmetaUnitsCatalog.Create;
end.

26
tests/webtbs/uw40784a.pp Normal file
View File

@ -0,0 +1,26 @@
unit uw40784a;
{$mode Delphi}
interface
type
{ TGsAbstractObjectList }
TGsAbstractObjectList<T: TObject> = class
protected
function GetTypeTagFromRow(ARow: TObject): Integer; virtual;
end;
implementation
{ TGsAbstractObjectList<T> }
function TGsAbstractObjectList<T>.GetTypeTagFromRow(ARow: TObject): Integer;
begin
Result := 0;
end;
end.

46
tests/webtbs/uw40784b.pp Normal file
View File

@ -0,0 +1,46 @@
unit uw40784b;
{$mode Delphi}
interface
uses
uw40784a;
type
{ TCatCatalog }
TCatCatalog<TItem: TObject> = class(TGsAbstractObjectList<TGsAbstractObjectList<TItem>>)
protected
function GetTypeTagFromRow(ARow: TObject): Integer; override;
end;
TIntermediateList = class(TGsAbstractObjectList<TObject>)
end;
{ TCatCatalog2 }
TCatCatalog2<TItem: TObject> = class(TIntermediateList)
protected
function GetTypeTagFromRow(ARow: TObject): Integer; override;
end;
implementation
{ TCatCatalog }
function TCatCatalog<TItem>.GetTypeTagFromRow(ARow: TObject): Integer;
begin
Result := 1;
end;
{ TCatCatalog2 }
function TCatCatalog2<TItem>.GetTypeTagFromRow(ARow: TObject): Integer;
begin
Result:=1;
end;
end.