mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-21 13:49:29 +02:00
* (lsighly, added safety check) patch by Евгений Савин, resolves #40784
This commit is contained in:
parent
4300e2cfcc
commit
abcced55af
@ -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
19
tests/webtbs/tw40784.pp
Normal 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
26
tests/webtbs/uw40784a.pp
Normal 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
46
tests/webtbs/uw40784b.pp
Normal 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.
|
Loading…
Reference in New Issue
Block a user