function Back_End_Layout return Boolean is
begin
- -- We have back end layout if the back end has made any entries in the
- -- table of GCC expressions, otherwise we have front end layout.
+ -- We have back-end layout if the back end has made any entries in the
+ -- table of GCC expressions, otherwise we have front-end layout.
return Rep_Table.Last > 0;
end Back_End_Layout;
-- Internal recursive procedure to display the layout
procedure List_Structural_Record_Layout
- (Ent : Entity_Id;
- Variant : Node_Id := Empty;
- Indent : Natural := 0);
+ (Ent : Entity_Id;
+ Outer_Ent : Entity_Id;
+ Variant : Node_Id := Empty;
+ Indent : Natural := 0);
-- Internal recursive procedure to display the structural layout
Max_Name_Length : Natural := 0;
Write_Str (Prefix);
Write_Str (Name_Buffer (1 .. Name_Len));
Write_Line (""",");
+ if Ekind (Ent) = E_Discriminant then
+ Spaces (Indent);
+ Write_Str (" ""discriminant"": ");
+ UI_Write (Discriminant_Number (Ent));
+ Write_Line (",");
+ end if;
Spaces (Indent);
Write_Str (" ""Position"": ");
else
else
Write_Val (Esiz, Paren => not List_Representation_Info_To_JSON);
- -- If in front end layout mode, then dynamic size is stored
- -- in storage units, so renormalize for output
+ -- If in front-end layout mode, then dynamic size is stored
+ -- in storage units, so renormalize for output.
if not Back_End_Layout then
Write_Str (" * ");
-----------------------------------
procedure List_Structural_Record_Layout
- (Ent : Entity_Id;
- Variant : Node_Id := Empty;
- Indent : Natural := 0)
+ (Ent : Entity_Id;
+ Outer_Ent : Entity_Id;
+ 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.
+ -- 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.
+
+ ----------------------------
+ -- Derived_Discriminant --
+ ----------------------------
+
+ function Derived_Discriminant (Disc : Entity_Id) return Entity_Id is
+ Corr_Disc, Derived_Disc : Entity_Id;
+
+ begin
+ Derived_Disc := First_Stored_Discriminant (Outer_Ent);
+
+ -- Loop over the discriminants of the extension
+
+ while Present (Derived_Disc) loop
+
+ -- Check if this discriminant constrains another discriminant.
+ -- If so, find the ultimately constrained discriminant and
+ -- compare with the original components in the base type.
+
+ if Present (Corresponding_Discriminant (Derived_Disc)) then
+ Corr_Disc := Corresponding_Discriminant (Derived_Disc);
+
+ while Present (Corresponding_Discriminant (Corr_Disc)) loop
+ Corr_Disc := Corresponding_Discriminant (Corr_Disc);
+ end loop;
+
+ if Original_Record_Component (Corr_Disc)
+ = Original_Record_Component (Disc)
+ then
+ return Derived_Disc;
+ end if;
+ end if;
+
+ Next_Stored_Discriminant (Derived_Disc);
+ end loop;
+
+ -- Disc is not constrained by a discriminant of Outer_Ent
+
+ return Empty;
+ end Derived_Discriminant;
+
+ -- Local declarations
+
Comp : Node_Id;
Comp_List : Node_Id;
Var : Node_Id;
First : Boolean := True;
+ -- Start of processing for List_Structural_Record_Layout
+
begin
-- If we are dealing with a variant, just process the components
Is_Tagged_Type (Ent)
and then
Nkind (Definition) = N_Derived_Type_Definition;
- Disc : Entity_Id;
+ Disc, Listed_Disc : Entity_Id;
+
begin
-- If this is an extension, first list the layout of the parent
-- and then proceed to the extension part, if any.
if Is_Extension then
List_Structural_Record_Layout
- (Base_Type (Parent_Subtype (Ent)), Variant, Indent);
+ (Base_Type (Parent_Subtype (Ent)), Outer_Ent);
if Present (Record_Extension_Part (Definition)) then
Definition := Record_Extension_Part (Definition);
goto Continue_Disc;
end if;
- Get_Decoded_Name_String (Chars (Disc));
+ -- If this is the parent type of an extension, retrieve
+ -- the derived discriminant from the extension, if any.
+
+ if Ent /= Outer_Ent then
+ Listed_Disc := Derived_Discriminant (Disc);
+
+ if No (Listed_Disc) then
+ goto Continue_Disc;
+ end if;
+ else
+ Listed_Disc := Disc;
+ end if;
+
+ Get_Decoded_Name_String (Chars (Listed_Disc));
Set_Casing (Unit_Casing);
if First then
Write_Line (",");
end if;
- List_Component_Layout (Disc, Indent => Indent);
+ List_Component_Layout (Listed_Disc, Indent => Indent);
<<Continue_Disc>>
Next_Stored_Discriminant (Disc);
Spaces (Indent);
Write_Str (" ""record"": [");
- List_Structural_Record_Layout (Ent, Var, Indent + 4);
+ List_Structural_Record_Layout (Ent, Outer_Ent, Var, Indent + 4);
Write_Eol;
Spaces (Indent);
Write_Line (",");
Write_Str (" ""record"": [");
- List_Structural_Record_Layout (Ent);
+ List_Structural_Record_Layout (Ent, Ent);
Write_Eol;
Write_Str (" ]");
-- A component is an object whose members are pairs taken from:
-- "name" : string
+ -- "discriminant" : number
-- "Position" : numerical expression
-- "First_Bit" : number
-- "Size" : numerical expression
- -- The four pairs are present for every component. "name" comes from the
- -- declaration of the component in the record type and its value is the
- -- unqualified Ada name. The other three pairs come from the layout of
- -- the type and their value is that of the eponymous attribute set by
- -- the language.
+ -- "name" is present for every component and comes from the declaration
+ -- of the type; its value is the unqualified Ada name. "discriminant" is
+ -- present only if the component is a discriminant, and its value is the
+ -- ranking of the discriminant in the list of discriminants of the type,
+ -- i.e. an integer index ranging from 1 to the number of discriminants.
+ -- The other three pairs are present for every component and come from
+ -- the layout of the type; their value is the value of the eponymous
+ -- attribute set by the language.
-- A variant is an object whose members are pairs taken from:
projects / gcc.git / commitdiff