This patch updates the implementation of Ada2020 delta aggregatesa to conform to the latest version of AI12-0127. this patch adds checks to reject statically delta aggregates that specify values for components that appear in different variants of a record type.
Compiling test2.adb in Ada2020 mode must yield: test2.adb:31:51: "F3" and "F4" appear in different variants test2.adb:32:51: "F3" and "F2" appear in different variants test2.adb:33:39: "F3" and "F2" appear in different variants test2.adb:34:39: type subtype of "T" has no component with this name --- procedure Test2 is type T (Disc1, Disc2 : Boolean := True) is record F1 : Integer; case Disc1 is when False => F4 : Float; case Disc2 is when False => null; when True => F2 : Integer; end case; when True => case Disc2 is when False => null; when True => F3 : Integer; end case; end case; end record; procedure Munge (X : in out T) is begin -- illegal aggregate; F2 and F3 are declared within (albeit not -- immediately within) different variants of the same variant -- part. X := (X with delta F2 => 123, F1 => 456); -- OK X := (X with delta F2 => 123, F4 => 3.14); -- OK X := (X with delta F4 => 3.14, F2 => 444, F3 => 0); -- ERROR X := (X with delta F2 => 314, F4 => 4.44, F3 => 0); -- ERROR X := (X with delta F2 => 123, F3 => 456); -- ERROR X := (X with delta F2 => 123, F5 => 456); -- ERROR end Munge; X : T; begin Munge (X); end Test2; Tested on x86_64-pc-linux-gnu, committed on trunk 2017-11-08 Ed Schonberg <schonb...@adacore.com> * sem_aggr.adb (Resolve_Delta_Aggregate): Divide into the following separate procedures. (Resolve_Delta_Array_Aggregate): Previous code form Resolve_Delta_Aggregate. (Resolve_Delta_Record_Aggregate): Extend previous code to cover latest ARG decisions on the legality rules for delta aggregates for records: in the case of a variant record, components from different variants cannot be specified in the delta aggregate, and this must be checked statically.
Index: sem_aggr.adb =================================================================== --- sem_aggr.adb (revision 254542) +++ sem_aggr.adb (working copy) @@ -418,6 +418,13 @@ -- array of characters is expected. This procedure simply rewrites the -- string as an aggregate, prior to resolution. + --------------------------------- + -- Delta aggregate processing -- + --------------------------------- + + procedure Resolve_Delta_Array_Aggregate (N : Node_Id; Typ : Entity_Id); + procedure Resolve_Delta_Record_Aggregate (N : Node_Id; Typ : Entity_Id); + ------------------------ -- Array_Aggr_Subtype -- ------------------------ @@ -2759,143 +2766,278 @@ procedure Resolve_Delta_Aggregate (N : Node_Id; Typ : Entity_Id) is Base : constant Node_Id := Expression (N); + + begin + if not Is_Composite_Type (Typ) then + Error_Msg_N ("not a composite type", N); + end if; + + Analyze_And_Resolve (Base, Typ); + + if Is_Array_Type (Typ) then + Resolve_Delta_Array_Aggregate (N, Typ); + else + Resolve_Delta_Record_Aggregate (N, Typ); + end if; + + Set_Etype (N, Typ); + end Resolve_Delta_Aggregate; + + ----------------------------------- + -- Resolve_Delta_Array_Aggregate -- + ----------------------------------- + + procedure Resolve_Delta_Array_Aggregate (N : Node_Id; Typ : Entity_Id) is Deltas : constant List_Id := Component_Associations (N); + Assoc : Node_Id; + Choice : Node_Id; + Index_Type : Entity_Id; - function Get_Component_Type (Nam : Node_Id) return Entity_Id; + begin + Index_Type := Etype (First_Index (Typ)); + Assoc := First (Deltas); + while Present (Assoc) loop + if Nkind (Assoc) = N_Iterated_Component_Association then + Choice := First (Choice_List (Assoc)); + while Present (Choice) loop + if Nkind (Choice) = N_Others_Choice then + Error_Msg_N + ("others not allowed in delta aggregate", Choice); - ------------------------ - -- Get_Component_Type -- - ------------------------ + else + Analyze_And_Resolve (Choice, Index_Type); + end if; - function Get_Component_Type (Nam : Node_Id) return Entity_Id is - Comp : Entity_Id; + Next (Choice); + end loop; - begin - Comp := First_Entity (Typ); + declare + Id : constant Entity_Id := Defining_Identifier (Assoc); + Ent : constant Entity_Id := + New_Internal_Entity + (E_Loop, Current_Scope, Sloc (Assoc), 'L'); - while Present (Comp) loop - if Chars (Comp) = Chars (Nam) then - if Ekind (Comp) = E_Discriminant then - Error_Msg_N ("delta cannot apply to discriminant", Nam); + begin + Set_Etype (Ent, Standard_Void_Type); + Set_Parent (Ent, Assoc); + + if No (Scope (Id)) then + Enter_Name (Id); + Set_Etype (Id, Index_Type); + Set_Ekind (Id, E_Variable); + Set_Scope (Id, Ent); end if; - return Etype (Comp); - end if; + Push_Scope (Ent); + Analyze_And_Resolve + (New_Copy_Tree (Expression (Assoc)), Component_Type (Typ)); + End_Scope; + end; - Comp := Next_Entity (Comp); - end loop; + else + Choice := First (Choice_List (Assoc)); + while Present (Choice) loop + if Nkind (Choice) = N_Others_Choice then + Error_Msg_N + ("others not allowed in delta aggregate", Choice); - Error_Msg_NE ("type& has no component with this name", Nam, Typ); - return Any_Type; - end Get_Component_Type; + else + Analyze (Choice); + if Is_Entity_Name (Choice) + and then Is_Type (Entity (Choice)) + then + -- Choice covers a range of values. + if Base_Type (Entity (Choice)) /= + Base_Type (Index_Type) + then + Error_Msg_NE + ("choice does mat match index type of", + Choice, Typ); + end if; + else + Resolve (Choice, Index_Type); + end if; + end if; - -- Local variables + Next (Choice); + end loop; + Analyze_And_Resolve (Expression (Assoc), Component_Type (Typ)); + end if; + + Next (Assoc); + end loop; + end Resolve_Delta_Array_Aggregate; + + ------------------------------------ + -- Resolve_Delta_Record_Aggregate -- + ------------------------------------ + + procedure Resolve_Delta_Record_Aggregate (N : Node_Id; Typ : Entity_Id) is + Deltas : constant List_Id := Component_Associations (N); Assoc : Node_Id; Choice : Node_Id; Comp_Type : Entity_Id; - Index_Type : Entity_Id; - -- Start of processing for Resolve_Delta_Aggregate + -- Variables used to verify that discriminant-dependent components + -- appear in the same variant. - begin - if not Is_Composite_Type (Typ) then - Error_Msg_N ("not a composite type", N); - end if; + Variant : Node_Id; + Comp_Ref : Entity_Id; - Analyze_And_Resolve (Base, Typ); + procedure Check_Variant (Id : Entity_Id); + -- If a given component of the delta aggregate appears in a variant + -- part, verify that it is within the same variant as that of previous + -- specified variant components of the delta. - if Is_Array_Type (Typ) then - Index_Type := Etype (First_Index (Typ)); - Assoc := First (Deltas); - while Present (Assoc) loop - if Nkind (Assoc) = N_Iterated_Component_Association then - Choice := First (Choice_List (Assoc)); - while Present (Choice) loop - if Nkind (Choice) = N_Others_Choice then - Error_Msg_N - ("others not allowed in delta aggregate", Choice); + function Nested_In (V1, V2 : Node_Id) return Boolean; + -- Determine whether variant V1 is within variant V2. - else - Analyze_And_Resolve (Choice, Index_Type); - end if; + function Get_Component_Type (Nam : Node_Id) return Entity_Id; + -- Locate component with a given name and return its type. If none + -- found report error. - Next (Choice); - end loop; + function Variant_Depth (N : Node_Id) return Integer; + -- Determine the distance of a variant to the enclosing type + -- declaration. + -------------------- + -- Check_Variant -- + -------------------- + + procedure Check_Variant (Id : Entity_Id) is + Comp : Entity_Id; + Comp_Variant : Node_Id; + + begin + if not Has_Discriminants (Typ) then + return; + end if; + + Comp := First_Entity (Typ); + while Present (Comp) loop + exit when Chars (Comp) = Chars (Id); + Next_Component (Comp); + end loop; + + -- Find the variant, if any, whose component list includes the + -- component declaration. + + Comp_Variant := Parent (Parent (List_Containing (Parent (Comp)))); + if Nkind (Comp_Variant) = N_Variant then + if No (Variant) then + Variant := Comp_Variant; + Comp_Ref := Comp; + + elsif Variant /= Comp_Variant then declare - Id : constant Entity_Id := Defining_Identifier (Assoc); - Ent : constant Entity_Id := - New_Internal_Entity - (E_Loop, Current_Scope, Sloc (Assoc), 'L'); + D1 : constant Integer := Variant_Depth (Variant); + D2 : constant Integer := Variant_Depth (Comp_Variant); begin - Set_Etype (Ent, Standard_Void_Type); - Set_Parent (Ent, Assoc); + if D1 = D2 + or else + (D1 > D2 and then not Nested_In (Variant, Comp_Variant)) + or else + (D2 > D1 and then not Nested_In (Comp_Variant, Variant)) + then + Error_Msg_Node_2 := Comp_Ref; + Error_Msg_NE + ("& and & appear in different variants", Id, Comp); - if No (Scope (Id)) then - Enter_Name (Id); - Set_Etype (Id, Index_Type); - Set_Ekind (Id, E_Variable); - Set_Scope (Id, Ent); + -- Otherwise retain the deeper variant for subsequent tests + + elsif D2 > D1 then + Variant := Comp_Variant; end if; - - Push_Scope (Ent); - Analyze_And_Resolve - (New_Copy_Tree (Expression (Assoc)), Component_Type (Typ)); - End_Scope; end; + end if; + end if; + end Check_Variant; - else - Choice := First (Choice_List (Assoc)); - while Present (Choice) loop - if Nkind (Choice) = N_Others_Choice then - Error_Msg_N - ("others not allowed in delta aggregate", Choice); + --------------- + -- Nested_In -- + --------------- - else - Analyze (Choice); - if Is_Entity_Name (Choice) - and then Is_Type (Entity (Choice)) - then - -- Choice covers a range of values. - if Base_Type (Entity (Choice)) /= - Base_Type (Index_Type) - then - Error_Msg_NE - ("choice does mat match index type of", - Choice, Typ); - end if; - else - Resolve (Choice, Index_Type); - end if; - end if; + function Nested_In (V1, V2 : Node_Id) return Boolean is + Par : Node_Id; + begin + Par := Parent (V1); + while Nkind (Par) /= N_Full_Type_Declaration loop + if Par = V2 then + return True; + end if; + Par := Parent (Par); + end loop; - Next (Choice); - end loop; + return False; + end Nested_In; - Analyze_And_Resolve (Expression (Assoc), Component_Type (Typ)); + ------------------- + -- Variant_Depth -- + ------------------- + + function Variant_Depth (N : Node_Id) return Integer is + Depth : Integer; + Par : Node_Id; + begin + Depth := 0; + Par := Parent (N); + while Nkind (Par) /= N_Full_Type_Declaration loop + Depth := Depth + 1; + Par := Parent (Par); + end loop; + + return Depth; + end Variant_Depth; + + ------------------------ + -- Get_Component_Type -- + ------------------------ + + function Get_Component_Type (Nam : Node_Id) return Entity_Id is + Comp : Entity_Id; + + begin + Comp := First_Entity (Typ); + + while Present (Comp) loop + if Chars (Comp) = Chars (Nam) then + if Ekind (Comp) = E_Discriminant then + Error_Msg_N ("delta cannot apply to discriminant", Nam); + end if; + + return Etype (Comp); end if; - Next (Assoc); + Comp := Next_Entity (Comp); end loop; - else - Assoc := First (Deltas); - while Present (Assoc) loop - Choice := First (Choice_List (Assoc)); - while Present (Choice) loop - Comp_Type := Get_Component_Type (Choice); - Next (Choice); - end loop; + Error_Msg_NE ("type& has no component with this name", Nam, Typ); + return Any_Type; + end Get_Component_Type; - Analyze_And_Resolve (Expression (Assoc), Comp_Type); - Next (Assoc); + -- Start of processing for Resolve_Delta_Record_Aggregate + + begin + Variant := Empty; + Assoc := First (Deltas); + + while Present (Assoc) loop + Choice := First (Choice_List (Assoc)); + while Present (Choice) loop + Comp_Type := Get_Component_Type (Choice); + if Comp_Type /= Any_Type then + Check_Variant (Choice); + end if; + + Next (Choice); end loop; - end if; - Set_Etype (N, Typ); - end Resolve_Delta_Aggregate; + Analyze_And_Resolve (Expression (Assoc), Comp_Type); + Next (Assoc); + end loop; + end Resolve_Delta_Record_Aggregate; --------------------------------- -- Resolve_Extension_Aggregate --