From d403cfad2f90edf5fd8d8f6040177487ae9e167a Mon Sep 17 00:00:00 2001 From: Bob Duff Date: Mon, 19 Aug 2019 08:36:35 +0000 Subject: [PATCH] [Ada] Process type extensions for -gnatw.h This patch enables gap detection in type extensions. With the -gnatw.h switch, on 64-bit machines, the following test should get warnings: gcc -c gaps.ads -gnatw.h gaps.ads:16:07: warning: 48-bit gap before component "Comp2" gaps.ads:17:07: warning: 8-bit gap before component "Comp3" package Gaps is type Integer_16 is mod 2**16; type TestGap is tagged record Comp1 : Integer_16; end record; for TestGap use record Comp1 at 0 + 8 range 0..15; end record; type TestGap2 is new TestGap with record Comp2 : Integer_16; Comp3 : Integer_16; end record; for TestGap2 use record Comp2 at 08 + 8 range 0..15; Comp3 at 11 + 8 range 0..15; end record; end Gaps; 2019-08-19 Bob Duff gcc/ada/ * sem_ch13.adb (Record_Hole_Check): Procedure to check for holes that incudes processing type extensions. A type extension is processed by first calling Record_Hole_Check recursively on the parent type to compute the bit number after the last component of the parent. From-SVN: r274653 --- gcc/ada/ChangeLog | 8 + gcc/ada/sem_ch13.adb | 419 ++++++++++++++++++++++++------------------- 2 files changed, 243 insertions(+), 184 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 6f31df16ac8..f6e00851384 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,11 @@ +2019-08-19 Bob Duff + + * sem_ch13.adb (Record_Hole_Check): Procedure to check for holes + that incudes processing type extensions. A type extension is + processed by first calling Record_Hole_Check recursively on the + parent type to compute the bit number after the last component + of the parent. + 2019-08-19 Gary Dismukes * checks.adb (Length_Mismatch_Info_Message): New function in diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 92e308ae0d9..a3a7be728f0 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -10122,6 +10122,14 @@ package body Sem_Ch13 is -- issued, since the message was already given. Comp is also set to -- Empty if the current "component clause" is in fact a pragma. + procedure Record_Hole_Check + (Rectype : Entity_Id; After_Last : out Uint; Warn : Boolean); + -- Checks for gaps in the given Rectype. Compute After_Last, the bit + -- number after the last component. Warn is True on the initial call, + -- and warnings are given for gaps. For a type extension, this is called + -- recursively to compute After_Last for the parent type; in this case + -- Warn is False and the warnings are suppressed. + ----------------------------- -- Check_Component_Overlap -- ----------------------------- @@ -10233,6 +10241,225 @@ package body Sem_Ch13 is end if; end Find_Component; + ----------------------- + -- Record_Hole_Check -- + ----------------------- + + procedure Record_Hole_Check + (Rectype : Entity_Id; After_Last : out Uint; Warn : Boolean) + is + Decl : constant Node_Id := Declaration_Node (Base_Type (Rectype)); + -- Full declaration of record type + + procedure Check_Component_List + (DS : List_Id; + CL : Node_Id; + Sbit : Uint; + Abit : out Uint); + -- Check component list CL for holes. DS is a list of discriminant + -- specifications to be included in the consideration of components. + -- Sbit is the starting bit, which is zero if there are no preceding + -- components (before a variant part, or a parent type, or a tag + -- field). If there are preceding components, Sbit is the bit just + -- after the last such component. Abit is set to the bit just after + -- the last component of DS and CL. + + -------------------------- + -- Check_Component_List -- + -------------------------- + + procedure Check_Component_List + (DS : List_Id; + CL : Node_Id; + Sbit : Uint; + Abit : out Uint) + is + Compl : Integer; + + begin + Compl := Integer (List_Length (Component_Items (CL))); + + if DS /= No_List then + Compl := Compl + Integer (List_Length (DS)); + end if; + + declare + Comps : array (Natural range 0 .. Compl) of Entity_Id; + -- Gather components (zero entry is for sort routine) + + Ncomps : Natural := 0; + -- Number of entries stored in Comps (starting at Comps (1)) + + Citem : Node_Id; + -- One component item or discriminant specification + + Nbit : Uint; + -- Starting bit for next component + + CEnt : Entity_Id; + -- Component entity + + Variant : Node_Id; + -- One variant + + function Lt (Op1, Op2 : Natural) return Boolean; + -- Compare routine for Sort + + procedure Move (From : Natural; To : Natural); + -- Move routine for Sort + + package Sorting is new GNAT.Heap_Sort_G (Move, Lt); + + -------- + -- Lt -- + -------- + + function Lt (Op1, Op2 : Natural) return Boolean is + begin + return Component_Bit_Offset (Comps (Op1)) + < Component_Bit_Offset (Comps (Op2)); + end Lt; + + ---------- + -- Move -- + ---------- + + procedure Move (From : Natural; To : Natural) is + begin + Comps (To) := Comps (From); + end Move; + + begin + -- Gather discriminants into Comp + + if DS /= No_List then + Citem := First (DS); + while Present (Citem) loop + if Nkind (Citem) = N_Discriminant_Specification then + declare + Ent : constant Entity_Id := + Defining_Identifier (Citem); + begin + if Ekind (Ent) = E_Discriminant then + Ncomps := Ncomps + 1; + Comps (Ncomps) := Ent; + end if; + end; + end if; + + Next (Citem); + end loop; + end if; + + -- Gather component entities into Comp + + Citem := First (Component_Items (CL)); + while Present (Citem) loop + if Nkind (Citem) = N_Component_Declaration then + Ncomps := Ncomps + 1; + Comps (Ncomps) := Defining_Identifier (Citem); + end if; + + Next (Citem); + end loop; + + -- Now sort the component entities based on the first bit. + -- Note we already know there are no overlapping components. + + Sorting.Sort (Ncomps); + + -- Loop through entries checking for holes + + Nbit := Sbit; + for J in 1 .. Ncomps loop + CEnt := Comps (J); + + declare + CBO : constant Uint := Component_Bit_Offset (CEnt); + + begin + -- Skip components with unknown offsets + + if CBO /= No_Uint and then CBO >= 0 then + Error_Msg_Uint_1 := CBO - Nbit; + + if Warn and then Error_Msg_Uint_1 > 0 then + Error_Msg_NE + ("?H?^-bit gap before component&", + Component_Name (Component_Clause (CEnt)), + CEnt); + end if; + + Nbit := CBO + Esize (CEnt); + end if; + end; + end loop; + + -- Set Abit to just after the last nonvariant component + + Abit := Nbit; + + -- Process variant parts recursively if present. Set Abit to + -- the maximum for all variant parts. + + if Present (Variant_Part (CL)) then + declare + Var_Start : constant Uint := Nbit; + begin + Variant := First (Variants (Variant_Part (CL))); + while Present (Variant) loop + Check_Component_List + (No_List, Component_List (Variant), Var_Start, Nbit); + Next (Variant); + if Nbit > Abit then + Abit := Nbit; + end if; + end loop; + end; + end if; + end; + end Check_Component_List; + + Sbit : Uint; + -- Starting bit for call to Check_Component_List. Zero for an + -- untagged type. The size of the Tag for a nonderived tagged + -- type. Parent size for a type extension. + + Record_Definition : Node_Id; + -- Record_Definition containing Component_List to pass to + -- Check_Component_List. + + -- Start of processing for Record_Hole_Check + + begin + if Is_Tagged_Type (Rectype) then + Sbit := UI_From_Int (System_Address_Size); + else + Sbit := Uint_0; + end if; + + if Nkind (Decl) = N_Full_Type_Declaration then + Record_Definition := Type_Definition (Decl); + + -- If we have a record extension, set Sbit to point after the last + -- component of the parent type, by calling Record_Hole_Check + -- recursively. + + if Nkind (Record_Definition) = N_Derived_Type_Definition then + Record_Definition := Record_Extension_Part (Record_Definition); + Record_Hole_Check (Underlying_Type (Parent_Subtype (Rectype)), + After_Last => Sbit, Warn => False); + end if; + + if Nkind (Record_Definition) = N_Record_Definition then + Check_Component_List + (Discriminant_Specifications (Decl), + Component_List (Record_Definition), + Sbit, After_Last); + end if; + end if; + end Record_Hole_Check; + -- Start of processing for Check_Record_Representation_Clause begin @@ -10589,192 +10816,16 @@ package body Sem_Ch13 is end Overlap_Check2; end if; - -- The following circuit deals with warning on record holes (gaps). We - -- skip this check if overlap was detected, since it makes sense for the - -- programmer to fix this illegality before worrying about warnings. - - if not Overlap_Detected and Warn_On_Record_Holes then - Record_Hole_Check : declare - Decl : constant Node_Id := Declaration_Node (Base_Type (Rectype)); - -- Full declaration of record type - - procedure Check_Component_List - (CL : Node_Id; - Sbit : Uint; - DS : List_Id); - -- Check component list CL for holes. The starting bit should be - -- Sbit. which is zero for the main record component list and set - -- appropriately for recursive calls for variants. DS is set to - -- a list of discriminant specifications to be included in the - -- consideration of components. It is No_List if none to consider. - - -------------------------- - -- Check_Component_List -- - -------------------------- - - procedure Check_Component_List - (CL : Node_Id; - Sbit : Uint; - DS : List_Id) - is - Compl : Integer; - - begin - Compl := Integer (List_Length (Component_Items (CL))); - - if DS /= No_List then - Compl := Compl + Integer (List_Length (DS)); - end if; - - declare - Comps : array (Natural range 0 .. Compl) of Entity_Id; - -- Gather components (zero entry is for sort routine) - - Ncomps : Natural := 0; - -- Number of entries stored in Comps (starting at Comps (1)) - - Citem : Node_Id; - -- One component item or discriminant specification - - Nbit : Uint; - -- Starting bit for next component - - CEnt : Entity_Id; - -- Component entity - - Variant : Node_Id; - -- One variant - - function Lt (Op1, Op2 : Natural) return Boolean; - -- Compare routine for Sort - - procedure Move (From : Natural; To : Natural); - -- Move routine for Sort - - package Sorting is new GNAT.Heap_Sort_G (Move, Lt); - - -------- - -- Lt -- - -------- - - function Lt (Op1, Op2 : Natural) return Boolean is - begin - return Component_Bit_Offset (Comps (Op1)) - < - Component_Bit_Offset (Comps (Op2)); - end Lt; - - ---------- - -- Move -- - ---------- - - procedure Move (From : Natural; To : Natural) is - begin - Comps (To) := Comps (From); - end Move; - - begin - -- Gather discriminants into Comp - - if DS /= No_List then - Citem := First (DS); - while Present (Citem) loop - if Nkind (Citem) = N_Discriminant_Specification then - declare - Ent : constant Entity_Id := - Defining_Identifier (Citem); - begin - if Ekind (Ent) = E_Discriminant then - Ncomps := Ncomps + 1; - Comps (Ncomps) := Ent; - end if; - end; - end if; - - Next (Citem); - end loop; - end if; - - -- Gather component entities into Comp - - Citem := First (Component_Items (CL)); - while Present (Citem) loop - if Nkind (Citem) = N_Component_Declaration then - Ncomps := Ncomps + 1; - Comps (Ncomps) := Defining_Identifier (Citem); - end if; - - Next (Citem); - end loop; - - -- Now sort the component entities based on the first bit. - -- Note we already know there are no overlapping components. - - Sorting.Sort (Ncomps); - - -- Loop through entries checking for holes - - Nbit := Sbit; - for J in 1 .. Ncomps loop - CEnt := Comps (J); - - declare - CBO : constant Uint := Component_Bit_Offset (CEnt); - - begin - -- Skip components with unknown offsets - - if CBO /= No_Uint and then CBO >= 0 then - Error_Msg_Uint_1 := CBO - Nbit; - - if Error_Msg_Uint_1 > 0 then - Error_Msg_NE - ("?H?^-bit gap before component&", - Component_Name (Component_Clause (CEnt)), - CEnt); - end if; - - Nbit := CBO + Esize (CEnt); - end if; - end; - end loop; - - -- Process variant parts recursively if present - - if Present (Variant_Part (CL)) then - Variant := First (Variants (Variant_Part (CL))); - while Present (Variant) loop - Check_Component_List - (Component_List (Variant), Nbit, No_List); - Next (Variant); - end loop; - end if; - end; - end Check_Component_List; - - -- Start of processing for Record_Hole_Check + -- Check for record holes (gaps). We skip this check if overlap was + -- detected, since it makes sense for the programmer to fix this + -- error before worrying about warnings. + if Warn_On_Record_Holes and not Overlap_Detected then + declare + Ignore : Uint; begin - declare - Sbit : Uint; - - begin - if Is_Tagged_Type (Rectype) then - Sbit := UI_From_Int (System_Address_Size); - else - Sbit := Uint_0; - end if; - - if Nkind (Decl) = N_Full_Type_Declaration - and then Nkind (Type_Definition (Decl)) = N_Record_Definition - then - Check_Component_List - (Component_List (Type_Definition (Decl)), - Sbit, - Discriminant_Specifications (Decl)); - end if; - end; - end Record_Hole_Check; + Record_Hole_Check (Rectype, After_Last => Ignore, Warn => True); + end; end if; -- For records that have component clauses for all components, and whose -- 2.30.2