Quellcode durchsuchen

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

florian vor 1 Jahr
Ursprung
Commit
abcced55af
4 geänderte Dateien mit 121 neuen und 5 gelöschten Zeilen
  1. 30 5
      compiler/symtable.pas
  2. 19 0
      tests/webtbs/tw40784.pp
  3. 26 0
      tests/webtbs/uw40784a.pp
  4. 46 0
      tests/webtbs/uw40784b.pp

+ 30 - 5
compiler/symtable.pas

@@ -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 - 0
tests/webtbs/tw40784.pp

@@ -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 - 0
tests/webtbs/uw40784a.pp

@@ -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 - 0
tests/webtbs/uw40784b.pp

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