From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: by sourceware.org (Postfix, from userid 1914) id CA405398B0EA; Fri, 9 Jul 2021 12:39:08 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org CA405398B0EA MIME-Version: 1.0 Content-Transfer-Encoding: 7bit Content-Type: text/plain; charset="utf-8" From: Pierre-Marie de Rodat To: gcc-cvs@gcc.gnu.org Subject: [gcc r12-2207] [Ada] Fix invalid JSON for derived variant record with -gnatRj X-Act-Checkin: gcc X-Git-Author: Eric Botcazou X-Git-Refname: refs/heads/master X-Git-Oldrev: 06fd120d19d2636a812c9ffe4b8871f3733ae213 X-Git-Newrev: 2390451ede49fa09bc0d9692802651aff66ae8a6 Message-Id: <20210709123908.CA405398B0EA@sourceware.org> Date: Fri, 9 Jul 2021 12:39:08 +0000 (GMT) X-BeenThere: gcc-cvs@gcc.gnu.org X-Mailman-Version: 2.1.29 Precedence: list List-Id: Gcc-cvs mailing list List-Unsubscribe: , List-Archive: List-Help: List-Subscribe: , X-List-Received-Date: Fri, 09 Jul 2021 12:39:08 -0000 https://gcc.gnu.org/g:2390451ede49fa09bc0d9692802651aff66ae8a6 commit r12-2207-g2390451ede49fa09bc0d9692802651aff66ae8a6 Author: Eric Botcazou Date: Fri Jun 11 09:11:13 2021 +0200 [Ada] Fix invalid JSON for derived variant record with -gnatRj gcc/ada/ * repinfo.ads (JSON output format): Document adjusted key name. * repinfo.adb (List_Record_Layout): Use Original_Record_Component if the normalized position of the component is not known. (List_Structural_Record_Layout): Rename Outer_Ent parameter into Ext_End and add Ext_Level parameter. In an extension, if the parent subtype has static discriminants, call List_Record_Layout on it. Output "parent_" prefixes before "variant" according to Ext_Level. Adjust recursive calls throughout the procedure. Diff: --- gcc/ada/repinfo.adb | 55 ++++++++++++++++++++++++++++++++++++++--------------- gcc/ada/repinfo.ads | 7 ++++--- 2 files changed, 44 insertions(+), 18 deletions(-) diff --git a/gcc/ada/repinfo.adb b/gcc/ada/repinfo.adb index 3cc1f939a32..25b52376905 100644 --- a/gcc/ada/repinfo.adb +++ b/gcc/ada/repinfo.adb @@ -963,10 +963,15 @@ package body Repinfo is procedure List_Structural_Record_Layout (Ent : Entity_Id; - Outer_Ent : Entity_Id; + Ext_Ent : Entity_Id; + Ext_Level : Nat := 0; Variant : Node_Id := Empty; Indent : Natural := 0); - -- Internal recursive procedure to display the structural layout + -- Internal recursive procedure to display the structural layout. + -- If Ext_Ent is not equal to Ent, it is an extension of Ent and + -- Ext_Level is the number of successive extensions between them. + -- If Variant is present, it's for a variant in the variant part + -- instead of the common part of Ent. Indent is the indentation. Incomplete_Layout : exception; -- Exception raised if the layout is incomplete in -gnatc mode @@ -1319,7 +1324,12 @@ package body Repinfo is end if; end if; - List_Component_Layout (Comp, + -- The Parent_Subtype in an extension is not back-annotated + + List_Component_Layout ( + (if Known_Normalized_Position (Comp) + then Comp + else Original_Record_Component (Comp)), Starting_Position, Starting_First_Bit, Prefix); end; @@ -1334,15 +1344,16 @@ package body Repinfo is procedure List_Structural_Record_Layout (Ent : Entity_Id; - Outer_Ent : Entity_Id; + Ext_Ent : Entity_Id; + Ext_Level : Nat := 0; Variant : Node_Id := Empty; Indent : Natural := 0) is function Derived_Discriminant (Disc : Entity_Id) return Entity_Id; - -- This function assumes that Outer_Ent is an extension of Ent. + -- This function assumes that Ext_Ent is an extension of Ent. -- Disc is a discriminant of Ent that does not itself constrain a -- discriminant of the parent type of Ent. Return the discriminant - -- of Outer_Ent that ultimately constrains Disc, if any. + -- of Ext_Ent that ultimately constrains Disc, if any. ---------------------------- -- Derived_Discriminant -- @@ -1353,7 +1364,7 @@ package body Repinfo is Derived_Disc : Entity_Id; begin - Derived_Disc := First_Discriminant (Outer_Ent); + Derived_Disc := First_Discriminant (Ext_Ent); -- Loop over the discriminants of the extension @@ -1380,7 +1391,7 @@ package body Repinfo is Next_Discriminant (Derived_Disc); end loop; - -- Disc is not constrained by a discriminant of Outer_Ent + -- Disc is not constrained by a discriminant of Ext_Ent return Empty; end Derived_Discriminant; @@ -1432,12 +1443,21 @@ package body Repinfo is pragma Assert (Present (Parent_Type)); end if; - Parent_Type := Base_Type (Parent_Type); - if not In_Extended_Main_Source_Unit (Parent_Type) then - raise Not_In_Extended_Main; + -- Do not list variants if one of them has been selected + + if Has_Static_Discriminants (Parent_Type) then + List_Record_Layout (Parent_Type); + + else + Parent_Type := Base_Type (Parent_Type); + if not In_Extended_Main_Source_Unit (Parent_Type) then + raise Not_In_Extended_Main; + end if; + + List_Structural_Record_Layout + (Parent_Type, Ext_Ent, Ext_Level + 1); end if; - List_Structural_Record_Layout (Parent_Type, Outer_Ent); First := False; if Present (Record_Extension_Part (Definition)) then @@ -1467,7 +1487,7 @@ package body Repinfo is -- If this is the parent type of an extension, retrieve -- the derived discriminant from the extension, if any. - if Ent /= Outer_Ent then + if Ent /= Ext_Ent then Listed_Disc := Derived_Discriminant (Disc); if No (Listed_Disc) then @@ -1544,7 +1564,11 @@ package body Repinfo is Spaces (Indent); Write_Line (" ],"); Spaces (Indent); - Write_Str (" ""variant"" : ["); + Write_Str (" """); + for J in 1 .. Ext_Level loop + Write_Str ("parent_"); + end loop; + Write_Str ("variant"" : ["); -- Otherwise we recurse on each variant @@ -1567,7 +1591,8 @@ package body Repinfo is Spaces (Indent); Write_Str (" ""record"": ["); - List_Structural_Record_Layout (Ent, Outer_Ent, Var, Indent + 4); + List_Structural_Record_Layout + (Ent, Ext_Ent, Ext_Level, Var, Indent + 4); Write_Eol; Spaces (Indent); diff --git a/gcc/ada/repinfo.ads b/gcc/ada/repinfo.ads index 45eb0abf584..606bba45cd1 100644 --- a/gcc/ada/repinfo.ads +++ b/gcc/ada/repinfo.ads @@ -189,7 +189,7 @@ package Repinfo is -- "name" : string -- "location" : string -- "record" : array of components - -- "variant" : array of variants + -- "[parent_]*variant" : array of variants -- "formal" : array of formal parameters -- "mechanism" : string -- "Size" : numerical expression @@ -209,8 +209,9 @@ package Repinfo is -- fully qualified Ada name. The value of "location" is the expanded -- chain of instantiation locations that contains the entity. -- "record" is present for every record type and its value is the list of - -- components. "variant" is present only if the record type has a variant - -- part and its value is the list of variants. + -- components. "[parent_]*variant" is present only if the record type, or + -- one of its ancestors (parent, grand-parent, etc) if it's an extension, + -- has a variant part and its value is the list of variants. -- "formal" is present for every subprogram and entry, and its value is -- the list of formal parameters. "mechanism" is present for functions -- only and its value is the return mechanim.