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

+ added test

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
                         (

tests/webtbs/tw40634.pp

@@ -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.
+

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.

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<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.
+