paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-05 23:31:49 +02:00
Code Issues Packages Projects Releases Wiki Activity

* fix #40634: correctly check visibility for child classes in case of a mixture of specializations and non-specializations

Browse Source 
+ added test
This commit is contained in:
Sven/Sarah Barth 2024-02-16 15:26:17 +01:00
parent 59d0af7f65
commit d9903e6e16
4 changed files with 212 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

41
compiler/symtable.pas
View File

@ -3264,6 +3264,8 @@ implementation
end;
var
orgcontextobjdef,
orgsymownerdef,
symownerdef : tabstractrecorddef;
nonlocalst : tsymtable;
isspezproc : boolean;
@ -3275,6 +3277,8 @@ implementation
not (symst.symtabletype in [objectsymtable,recordsymtable]) then
internalerror(200810285);
symownerdef:=tabstractrecorddef(symst.defowner);
orgsymownerdef:=symownerdef;
orgcontextobjdef:=contextobjdef;
{ for specializations we need to check the visibility of the generic,
not the specialization (at least when comparing outside of the
specialization }
@ -3282,12 +3286,14 @@ implementation
begin
if not (symownerdef.genericdef.typ in [objectdef,recorddef]) then
internalerror(2024020901);
orgsymownerdef:=symownerdef;
symownerdef:=tabstractrecorddef(symownerdef.genericdef);
end;
if assigned(contextobjdef) and (df_specialization in contextobjdef.defoptions) then
begin
if not (contextobjdef.genericdef.typ in [objectdef,recorddef]) then
internalerror(2024020902);
orgcontextobjdef:=contextobjdef;
contextobjdef:=tabstractrecorddef(contextobjdef.genericdef);
end;
if assigned(current_structdef) and (df_specialization in current_structdef.defoptions) then
@ -3355,17 +3361,34 @@ implementation
vis_strictprotected :
begin
result:=(
{ access from nested class }
{ access from nested class (specialization case) }
assigned(curstruct) and
is_owned_by(curstruct,symownerdef)
) or
(
{ access from child class }
{ access from nested class (non-specialization case) }
(orgsymownerdef<>symownerdef) and
assigned(curstruct) and
is_owned_by(curstruct,orgsymownerdef)
) or
(
{ access from child class (specialization case) }
assigned(contextobjdef) and
assigned(curstruct) and
def_is_related(contextobjdef,symownerdef) and
def_is_related(curstruct,contextobjdef)
) or
(
{ access from child class (non-specialization case) }
assigned(orgcontextobjdef) and
(
(orgcontextobjdef<>contextobjdef) or
(orgsymownerdef<>symownerdef)
) and
assigned(curstruct) and
def_is_related(orgcontextobjdef,orgsymownerdef) and
def_is_related(curstruct,orgcontextobjdef)
) or
(
{ helpers can access strict protected symbols }
is_objectpascal_helper(contextobjdef) and
@ -3389,11 +3412,25 @@ implementation
is_current_unit(nonlocalst)
) or
(
{ context object is inside the current unit and related to
the symbol owner (specialization case) }
assigned(contextobjdef) and
(contextobjdef.owner.symtabletype in [globalsymtable,staticsymtable,ObjectSymtable,recordsymtable,localsymtable]) and
is_current_unit(contextobjdef.owner) and
def_is_related(contextobjdef,symownerdef)
) or
(
{ context object is inside the current unit and related to
the symbol owner (non-specialization case) }
assigned(orgcontextobjdef) and
(
(orgcontextobjdef<>contextobjdef) or
(orgsymownerdef<>symownerdef)
) and
(orgcontextobjdef.owner.symtabletype in [globalsymtable,staticsymtable,ObjectSymtable,recordsymtable,localsymtable]) and
is_current_unit(orgcontextobjdef.owner) and
def_is_related(orgcontextobjdef,orgsymownerdef)
) or
( // the case of specialize inside the generic declaration and nested types
(nonlocalst.symtabletype in [objectsymtable,recordsymtable]) and
(

24
tests/webtbs/tw40634.pp Normal file
View File

@ -0,0 +1,24 @@
{ %NORUN }
program tw40634;
{$mode objfpc}{$H+}
uses uw40634a, uw40634b;
type
TWatchesSupplier = class(specialize TWatchesSupplierClassTemplate<TObject>, IDbgWatchesSupplierIntf)
//TWatchesSupplier = class(specialize TWatchesSupplierClassTemplate<TObject>)
//TWatchesSupplier = class(TNormalClass, IDbgWatchesSupplierIntf)
protected
procedure DoFoo;
end;
{ TWatchesSupplier }
procedure TWatchesSupplier.DoFoo;
begin
if Monitor <> nil then;
end;
begin
end.

80
tests/webtbs/uw40634a.pp Normal file
View File

@ -0,0 +1,80 @@
{***************************************************************************
* *
* This unit is distributed under the LGPL version 2 *
* *
* Additionally this unit can be used under any newer version (3 or up) *
* of the LGPL *
* *
* Users are also granted the same "linking exception" as defined *
* for the LCL. *
* See the LCL license for details *
* *
* *
***************************************************************************
@author(Martin Friebe)
}
unit uw40634a;
{$mode objfpc}{$H+}
{$INTERFACES CORBA} // no ref counting needed
interface
uses
Classes, SysUtils, uw40634b;
type
TNormalClass = class
strict protected
procedure SetMonitor(AMonitor: IDbgWatchesMonitorIntf); virtual; abstract;
procedure RequestData(AWatchValue: IDbgWatchValueIntf); virtual; abstract;
function Monitor:TObject;virtual; abstract;
end;
{ TInternalDbgSupplierBase }
generic TInternalDbgSupplierBase<
_BASE: TObject;
_SUPPLIER_INTF: IInternalDbgSupplierIntfType;
_MONITOR_INTF //: IInternalDbgMonitorIntfType
>
= class(_BASE)
strict private
FMonitor: _MONITOR_INTF;
// ********************************************************************************
(* "private" is CORRECTLY not working
all others should work, but have different error *)
//private
strict protected
procedure SetMonitor1(AMonitor: _MONITOR_INTF);virtual; abstract;
protected
procedure SetMonitor2(AMonitor: _MONITOR_INTF);virtual; abstract;
public
procedure SetMonitor3(AMonitor: _MONITOR_INTF);virtual; abstract;
// ********************************************************************************
protected
property Monitor: _MONITOR_INTF read FMonitor;
end;
type
{ TWatchesSupplierClassTemplate }
generic TWatchesSupplierClassTemplate<_BASE: TObject> = class(
specialize TInternalDbgSupplierBase<_BASE, IDbgWatchesSupplierIntf, IDbgWatchesMonitorIntf>,
IDbgWatchesSupplierIntf
)
protected
public
procedure RequestData(AWatchValue: IDbgWatchValueIntf); virtual; abstract;
end;
implementation
end.

69
tests/webtbs/uw40634b.pp Normal file
View File

@ -0,0 +1,69 @@
{***************************************************************************
* *
* This unit is distributed under the LGPL version 2 *
* *
* Additionally this unit can be used under any newer version (3 or up) *
* of the LGPL *
* *
* Users are also granted the same "linking exception" as defined *
* for the LCL. *
* See the LCL license for details *
* *
* *
***************************************************************************
@author(Martin Friebe)
}
unit uw40634b;
{$mode objfpc}{$H+}
{$INTERFACES CORBA} // no ref counting needed
interface
uses
Classes, SysUtils, Types;
type
TDBGState = integer;
IDbgWatchValueIntf = interface end;
IDbgWatchDataIntf = interface end;
{$REGION ***** Internal types ***** }
IInternalDbgMonitorIntfType = interface end;
IInternalDbgSupplierIntfType = interface end;
generic IInternalDbgMonitorIntf<_SUPPLIER_INTF> = interface(IInternalDbgMonitorIntfType)
procedure RemoveSupplier(ASupplier: _SUPPLIER_INTF);
end;
generic IInternalDbgSupplierIntf<_MONITOR_INTF> = interface(IInternalDbgSupplierIntfType)
procedure SetMonitor1(AMonitor: _MONITOR_INTF);
procedure SetMonitor2(AMonitor: _MONITOR_INTF);
procedure SetMonitor3(AMonitor: _MONITOR_INTF);
end;
{$ENDREGION}
type
IDbgWatchesSupplierIntf = interface;
IDbgWatchesMonitorIntf = interface(specialize IInternalDbgMonitorIntf<IDbgWatchesSupplierIntf>)
['{42A7069E-D5DD-4350-A592-2000F67DC7E9}']
procedure InvalidateWatchValues;
procedure DoStateChange(const AOldState, ANewState: TDBGState); //deprecated;
end;
IDbgWatchesSupplierIntf = interface(specialize IInternalDbgSupplierIntf<IDbgWatchesMonitorIntf>)
['{F893B607-C295-4A3A-8253-FAB3D03C5AD5}']
procedure RequestData(AWatchValue: IDbgWatchValueIntf);
end;
implementation
end.