diff --git a/compiler/symtable.pas b/compiler/symtable.pas index 25597f38ca..5bbbe1ce10 100644 --- a/compiler/symtable.pas +++ b/compiler/symtable.pas @@ -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 ( diff --git a/tests/webtbs/tw40634.pp b/tests/webtbs/tw40634.pp new file mode 100644 index 0000000000..40221763bc --- /dev/null +++ b/tests/webtbs/tw40634.pp @@ -0,0 +1,24 @@ +{ %NORUN } + +program tw40634; +{$mode objfpc}{$H+} +uses uw40634a, uw40634b; + +type + TWatchesSupplier = class(specialize TWatchesSupplierClassTemplate, IDbgWatchesSupplierIntf) + //TWatchesSupplier = class(specialize TWatchesSupplierClassTemplate) + //TWatchesSupplier = class(TNormalClass, IDbgWatchesSupplierIntf) + protected + procedure DoFoo; + end; + +{ TWatchesSupplier } + +procedure TWatchesSupplier.DoFoo; +begin + if Monitor <> nil then; +end; + +begin +end. + diff --git a/tests/webtbs/uw40634a.pp b/tests/webtbs/uw40634a.pp new file mode 100644 index 0000000000..7f8ade3364 --- /dev/null +++ b/tests/webtbs/uw40634a.pp @@ -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. diff --git a/tests/webtbs/uw40634b.pp b/tests/webtbs/uw40634b.pp new file mode 100644 index 0000000000..13449f26b5 --- /dev/null +++ b/tests/webtbs/uw40634b.pp @@ -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) + ['{42A7069E-D5DD-4350-A592-2000F67DC7E9}'] + procedure InvalidateWatchValues; + procedure DoStateChange(const AOldState, ANewState: TDBGState); //deprecated; + end; + + IDbgWatchesSupplierIntf = interface(specialize IInternalDbgSupplierIntf) + ['{F893B607-C295-4A3A-8253-FAB3D03C5AD5}'] + procedure RequestData(AWatchValue: IDbgWatchValueIntf); + end; + + + +implementation + + +end. +