From 0289a8d7ef1288cc9b2be36b3080981c9fac839e Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Thu, 12 Jan 2017 15:42:42 +0100 Subject: [PATCH] [multiple changes] 2017-01-12 Ed Schonberg * sem_attr.adb (Analyze_Attribute_Reference, case Loop_Entry): Hnadle properly the attribute reference when it appears as part of an expression in another loop aspect. 2017-01-12 Ed Schonberg * exp_ch3.adb (Check_Predicated_Discriminant): New procedure, subsidiary of Build_Initialization_Call, to complete generation of predicate checks on discriminants whose (sub)types have predicates, and to add checks on variants that do not have an others clause. * sem_util.adb (Gather_Components): A missing Others alternative is not an error when the type of the discriminant is a static predicate (and coverage has been checked when analyzing the case statement). A runtime check is generated to verify that a given discriminant satisfies the predicate (RM 3.8.1. (21.1/2)). 2017-01-12 Yannick Moy * gnat1drv.adb (Adjust_Global_Switches): Only perform checking of exception mechanism when generating code. 2017-01-12 Justin Squirek * exp_ch7.adb (Add_Type_Invariants, Process_Array_Component): Remove handling of access component with invariant. (Build_Invariant_Procedure_Declaration): Remove return on class wide type. * freeze.adb (Freeze_Array_Type, Freeze_Record_Type): Remove conditional exception for component or array so Has_Own_Invariants flag is not falsly set. * sem_ch3.adb (Make_Class_Wide_Type): Initialize copy of class wide type to have no invariant flags. From-SVN: r244366 --- gcc/ada/ChangeLog | 36 ++++++++++++ gcc/ada/exp_ch3.adb | 126 +++++++++++++++++++++++++++++++++++++++--- gcc/ada/exp_ch7.adb | 127 +------------------------------------------ gcc/ada/freeze.adb | 14 +---- gcc/ada/gnat1drv.adb | 51 +++++++++-------- gcc/ada/sem_attr.adb | 18 +++++- gcc/ada/sem_ch3.adb | 6 +- gcc/ada/sem_util.adb | 15 ++++- 8 files changed, 218 insertions(+), 175 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 233582fbd57..7d56374a095 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,39 @@ +2017-01-12 Ed Schonberg + + * sem_attr.adb (Analyze_Attribute_Reference, case Loop_Entry): + Hnadle properly the attribute reference when it appears as part + of an expression in another loop aspect. + +2017-01-12 Ed Schonberg + + * exp_ch3.adb (Check_Predicated_Discriminant): New procedure, + subsidiary of Build_Initialization_Call, to complete generation + of predicate checks on discriminants whose (sub)types have + predicates, and to add checks on variants that do not have an + others clause. + * sem_util.adb (Gather_Components): A missing Others alternative is + not an error when the type of the discriminant is a static predicate + (and coverage has been checked when analyzing the case statement). A + runtime check is generated to verify that a given discriminant + satisfies the predicate (RM 3.8.1. (21.1/2)). + +2017-01-12 Yannick Moy + + * gnat1drv.adb (Adjust_Global_Switches): Only + perform checking of exception mechanism when generating code. + +2017-01-12 Justin Squirek + + * exp_ch7.adb (Add_Type_Invariants, Process_Array_Component): + Remove handling of access component with invariant. + (Build_Invariant_Procedure_Declaration): Remove return on class + wide type. + * freeze.adb (Freeze_Array_Type, Freeze_Record_Type): Remove + conditional exception for component or array so Has_Own_Invariants + flag is not falsly set. + * sem_ch3.adb (Make_Class_Wide_Type): Initialize copy of class + wide type to have no invariant flags. + 2017-01-12 Hristian Kirtchev * exp_ch9.adb, sem_prag.adb, s-tassta.adb, sem_util.adb, s-tarest.adb, diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 068674dbfe2..c1039c5b53f 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -1286,7 +1286,118 @@ package body Exp_Ch3 is With_Default_Init : Boolean := False; Constructor_Ref : Node_Id := Empty) return List_Id is - Res : constant List_Id := New_List; + Res : constant List_Id := New_List; + + Full_Type : Entity_Id; + + procedure Check_Predicated_Discriminant + (Val : Node_Id; + Discr : Entity_Id); + -- Discriminants whose subtypes have predicates are checked in two + -- cases: + -- a) When an object is default-initialized and assertions are enabled + -- we check that the value of the discriminant obeys the predicate. + + -- b) In all cases, if the discriminant controls a variant and the + -- variant has no others_choice, Constraint_Error must be raised if + -- the predicate is violated, because there is no variant covered + -- by the illegal discriminant value. + + ----------------------------------- + -- Check_Predicated_Discriminant -- + ----------------------------------- + + procedure Check_Predicated_Discriminant + (Val : Node_Id; + Discr : Entity_Id) + is + Typ : constant Entity_Id := Etype (Discr); + + procedure Check_Missing_Others (V : Node_Id); + -- ??? + + -------------------------- + -- Check_Missing_Others -- + -------------------------- + + procedure Check_Missing_Others (V : Node_Id) is + Alt : Node_Id; + Choice : Node_Id; + Last_Var : Node_Id; + + begin + Last_Var := Last_Non_Pragma (Variants (V)); + Choice := First (Discrete_Choices (Last_Var)); + + -- An others_choice is added during expansion for gcc use, but + -- does not cover the illegality. + + if Entity (Name (V)) = Discr then + if Present (Choice) + and then (Nkind (Choice) /= N_Others_Choice + or else not Comes_From_Source (Choice)) + then + Check_Expression_Against_Static_Predicate (Val, Typ); + + if not Is_Static_Expression (Val) then + Prepend_To (Res, + Make_Raise_Constraint_Error (Loc, + Condition => + Make_Op_Not (Loc, + Right_Opnd => Make_Predicate_Call (Typ, Val)), + Reason => CE_Invalid_Data)); + end if; + end if; + end if; + + -- Check whether some nested variant is ruled by the predicated + -- discriminant. + + Alt := First (Variants (V)); + while Present (Alt) loop + if Nkind (Alt) = N_Variant + and then Present (Variant_Part (Component_List (Alt))) + then + Check_Missing_Others + (Variant_Part (Component_List (Alt))); + end if; + + Next (Alt); + end loop; + end Check_Missing_Others; + + -- Local variables + + Def : Node_Id; + + -- Start of processing for Check_Predicated_Discriminant + + begin + if Ekind (Base_Type (Full_Type)) = E_Record_Type then + Def := Type_Definition (Parent (Base_Type (Full_Type))); + else + return; + end if; + + if Policy_In_Effect (Name_Assert) = Name_Check + and then not Predicates_Ignored (Etype (Discr)) + then + Prepend_To (Res, Make_Predicate_Check (Typ, Val)); + end if; + + -- If discriminant controls a variant, verify that predicate is + -- obeyed or else an Others_Choice is present. + + if Nkind (Def) = N_Record_Definition + and then Present (Variant_Part (Component_List (Def))) + and then Policy_In_Effect (Name_Assert) = Name_Ignore + then + Check_Missing_Others (Variant_Part (Component_List (Def))); + end if; + end Check_Predicated_Discriminant; + + -- Local variables + Arg : Node_Id; Args : List_Id; Decls : List_Id; @@ -1294,11 +1405,12 @@ package body Exp_Ch3 is Discr : Entity_Id; First_Arg : Node_Id; Full_Init_Type : Entity_Id; - Full_Type : Entity_Id; Init_Call : Node_Id; Init_Type : Entity_Id; Proc : Entity_Id; + -- Start of processing for Build_Initialization_Call + begin pragma Assert (Constructor_Ref = Empty or else Is_CPP_Constructor_Call (Constructor_Ref)); @@ -1490,14 +1602,10 @@ package body Exp_Ch3 is -- of the discriminant, insert it ahead of the call. Arg := New_Copy_Tree (Arg, New_Sloc => Loc); + end if; - if Has_Predicates (Etype (Discr)) - and then not Predicate_Checks_Suppressed (Empty) - and then not Predicates_Ignored (Etype (Discr)) - then - Prepend_To (Res, - Make_Predicate_Check (Etype (Discr), Arg)); - end if; + if Has_Predicates (Etype (Discr)) then + Check_Predicated_Discriminant (Arg, Discr); end if; end if; diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index b4caa367b48..9c5cb468c2c 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -3605,60 +3605,6 @@ package body Exp_Ch7 is Produced_Check := True; end if; - - -- In a rare case the designated type of an access component may - -- have an invariant. In this case verify the dereference of the - -- component. - - if Is_Access_Type (Comp_Typ) - and then Has_Invariants (Designated_Type (Comp_Typ)) - then - Proc_Id := - Invariant_Procedure (Base_Type (Designated_Type (Comp_Typ))); - - -- The designated type should have an invariant procedure if it - -- has invariants of its own or inherits class-wide invariants - -- from parent or interface types. - - pragma Assert (Present (Proc_Id)); - - -- Generate: - -- if _object () /= null then - -- Invariant (_object ().all); - -- end if; - - -- Note that the invariant procedure may have a null body if - -- assertions are disabled or Assertion_Polity Ignore is in - -- effect. - - if not Has_Null_Body (Proc_Id) then - Append_New_To (Comp_Checks, - Make_If_Statement (Loc, - Condition => - Make_Op_Ne (Loc, - Left_Opnd => - Make_Indexed_Component (Loc, - Prefix => New_Occurrence_Of (Obj_Id, Loc), - Expressions => New_Copy_List (Indices)), - Right_Opnd => Make_Null (Loc)), - - Then_Statements => New_List ( - Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of (Proc_Id, Loc), - - Parameter_Associations => New_List ( - Make_Explicit_Dereference (Loc, - Prefix => - Make_Indexed_Component (Loc, - Prefix => - New_Occurrence_Of (Obj_Id, Loc), - Expressions => - New_Copy_List (Indices)))))))); - end if; - - Produced_Check := True; - end if; end Process_Array_Component; --------------------------- @@ -4001,65 +3947,6 @@ package body Exp_Ch7 is Produced_Component_Check := True; end if; - -- In a rare case the designated type of an access component may - -- have a invariant. In this case verify the dereference of the - -- component. - - if Is_Access_Type (Comp_Typ) - and then Has_Invariants (Designated_Type (Comp_Typ)) - then - Proc_Id := - Invariant_Procedure (Base_Type (Designated_Type (Comp_Typ))); - - -- The designated type should have an invariant procedure if it - -- has invariants of its own or inherits class-wide invariants - -- from parent or interface types. - - pragma Assert (Present (Proc_Id)); - - -- Generate: - -- if T (_object). /= null then - -- Invariant (T (_object)..all); - -- end if; - - -- Note that the invariant procedure may have a null body if - -- assertions are disabled or Assertion_Polity Ignore is in - -- effect. - - if not Has_Null_Body (Proc_Id) then - Append_New_To (Comp_Checks, - Make_If_Statement (Loc, - Condition => - Make_Op_Ne (Loc, - Left_Opnd => - Make_Selected_Component (Loc, - Prefix => - Unchecked_Convert_To - (T, New_Occurrence_Of (Obj_Id, Loc)), - Selector_Name => - New_Occurrence_Of (Comp_Id, Loc)), - Right_Opnd => Make_Null (Loc)), - - Then_Statements => New_List ( - Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of (Proc_Id, Loc), - - Parameter_Associations => New_List ( - Make_Explicit_Dereference (Loc, - Prefix => - Make_Selected_Component (Loc, - Prefix => - Unchecked_Convert_To - (T, New_Occurrence_Of (Obj_Id, Loc)), - Selector_Name => - New_Occurrence_Of (Comp_Id, Loc)))))))); - end if; - - Produced_Check := True; - Produced_Component_Check := True; - end if; - if Produced_Component_Check and then Has_Unchecked_Union (T) then Error_Msg_NE ("invariants cannot be checked on components of " @@ -4525,15 +4412,10 @@ package body Exp_Ch7 is pragma Assert (Has_Invariants (Work_Typ)); - -- ??? invariants of class-wide types are not properly implemented - - if Is_Class_Wide_Type (Work_Typ) then - return; - -- Nothing to do for interface types as their class-wide invariants are -- inherited by implementing types. - elsif Is_Interface (Work_Typ) then + if Is_Interface (Work_Typ) then return; end if; @@ -4849,15 +4731,10 @@ package body Exp_Ch7 is pragma Assert (Has_Invariants (Work_Typ)); - -- ??? invariants of class-wide types are not properly implemented - - if Is_Class_Wide_Type (Work_Typ) then - return; - -- Nothing to do for interface types as their class-wide invariants are -- inherited by implementing types. - elsif Is_Interface (Work_Typ) then + if Is_Interface (Work_Typ) then return; -- Nothing to do if the type already has a "partial" invariant procedure diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index f3bdf247733..6c90bd39537 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -2377,12 +2377,7 @@ package body Freeze is -- The array type requires its own invariant procedure in order to -- verify the component invariant over all elements. - if Has_Invariants (Component_Type (Arr)) - or else - (Is_Access_Type (Component_Type (Arr)) - and then Has_Invariants - (Designated_Type (Component_Type (Arr)))) - then + if Has_Invariants (Component_Type (Arr)) then Set_Has_Own_Invariants (Arr); -- The array type is an implementation base type. Propagate the @@ -4305,12 +4300,7 @@ package body Freeze is -- parent class-wide invariants are always inherited. if Comes_From_Source (Comp) - and then - (Has_Invariants (Etype (Comp)) - or else - (Is_Access_Type (Etype (Comp)) - and then Has_Invariants - (Designated_Type (Etype (Comp))))) + and then Has_Invariants (Etype (Comp)) then Set_Has_Own_Invariants (Rec); end if; diff --git a/gcc/ada/gnat1drv.adb b/gcc/ada/gnat1drv.adb index 929bfcc316d..8582b93277e 100644 --- a/gcc/ada/gnat1drv.adb +++ b/gcc/ada/gnat1drv.adb @@ -521,28 +521,35 @@ procedure Gnat1drv is Targparm.Frontend_Layout_On_Target := True; end if; - -- Set and check exception mechanism - - case Targparm.Frontend_Exceptions_On_Target is - when True => - case Targparm.ZCX_By_Default_On_Target is - when True => - Write_Line - ("Run-time library configured incorrectly"); - Write_Line - ("(requesting support for Frontend ZCX exceptions)"); - raise Unrecoverable_Error; - when False => - Exception_Mechanism := Front_End_SJLJ; - end case; - when False => - case Targparm.ZCX_By_Default_On_Target is - when True => - Exception_Mechanism := Back_End_ZCX; - when False => - Exception_Mechanism := Back_End_SJLJ; - end case; - end case; + -- Set and check exception mechanism. This is only meaningful when + -- compiling, and in particular not meaningful for special modes used + -- for program analysis rather than compilation: ASIS mode, CodePeer + -- mode and GNATprove mode. + + if Operating_Mode = Generate_Code + and then not (ASIS_Mode or CodePeer_Mode or GNATprove_Mode) + then + case Targparm.Frontend_Exceptions_On_Target is + when True => + case Targparm.ZCX_By_Default_On_Target is + when True => + Write_Line + ("Run-time library configured incorrectly"); + Write_Line + ("(requesting support for Frontend ZCX exceptions)"); + raise Unrecoverable_Error; + when False => + Exception_Mechanism := Front_End_SJLJ; + end case; + when False => + case Targparm.ZCX_By_Default_On_Target is + when True => + Exception_Mechanism := Back_End_ZCX; + when False => + Exception_Mechanism := Back_End_SJLJ; + end case; + end case; + end if; -- Set proper status for overflow check mechanism diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index d7c768330f6..494579ac9f8 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -4465,7 +4465,17 @@ package body Sem_Attr is -- purpose if they appear in an appropriate location in a loop, -- which was already checked by the top level pragma circuit). - if No (Enclosing_Pragma) then + -- Loop_Entry also denotes a value and as such can appear within an + -- expression that is an argument for another loop aspect. In that + -- case it will have been expanded into the corresponding assignment. + + if Expander_Active + and then Nkind (Parent (N)) = N_Assignment_Statement + and then not Comes_From_Source (Parent (N)) + then + null; + + elsif No (Enclosing_Pragma) then Error_Attr ("attribute% must appear within appropriate pragma", N); end if; @@ -4519,7 +4529,9 @@ package body Sem_Attr is -- early transformation also avoids the generation of a useless loop -- entry constant. - if Is_Ignored (Enclosing_Pragma) then + if Present (Enclosing_Pragma) + and then Is_Ignored (Enclosing_Pragma) + then Rewrite (N, Relocate_Node (P)); Preanalyze_And_Resolve (N); @@ -11039,7 +11051,7 @@ package body Sem_Attr is if Is_Entity_Name (P) and then (Attr_Id = Attribute_Unrestricted_Access - or else Is_Subprogram (Entity (P))) + or else Is_Subprogram (Entity (P))) then Set_Address_Taken (Entity (P)); end if; diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index e0520a96d16..512615fe4b9 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -18307,7 +18307,8 @@ package body Sem_Ch3 is Set_Freeze_Node (CW_Type, Empty); -- Customize the class-wide type: It has no prim. op., it cannot be - -- abstract and its Etype points back to the specific root type. + -- abstract, its Etype points back to the specific root type, and it + -- cannot have any invariants. Set_Ekind (CW_Type, E_Class_Wide_Type); Set_Is_Tagged_Type (CW_Type, True); @@ -18316,6 +18317,9 @@ package body Sem_Ch3 is Set_Is_Constrained (CW_Type, False); Set_Is_First_Subtype (CW_Type, Is_First_Subtype (T)); Set_Default_SSO (CW_Type); + Set_Has_Inheritable_Invariants (CW_Type, False); + Set_Has_Inherited_Invariants (CW_Type, False); + Set_Has_Own_Invariants (CW_Type, False); if Ekind (T) = E_Class_Wide_Subtype then Set_Etype (CW_Type, Etype (Base_Type (T))); diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 33266b3e90c..ead3efdd8db 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -7572,7 +7572,14 @@ package body Sem_Util is end loop Find_Discrete_Value; end Search_For_Discriminant_Value; - if No (Variant) then + -- The case statement must include a variant that corresponds to the + -- value of the discriminant, unless the discriminant type has a + -- static predicate. In that case the absence of an others_choice that + -- would cover this value becomes a run-time error (3.8,1 (21.1/2)). + + if No (Variant) + and then not Has_Static_Predicate (Etype (Discrim_Name)) + then Error_Msg_NE ("value of discriminant & is out of range", Discrim_Value, Discrim); Report_Errors := True; @@ -7583,8 +7590,10 @@ package body Sem_Util is -- components to the Into list. The nested components are part of -- the same record type. - Gather_Components - (Typ, Component_List (Variant), Governed_By, Into, Report_Errors); + if Present (Variant) then + Gather_Components + (Typ, Component_List (Variant), Governed_By, Into, Report_Errors); + end if; end Gather_Components; ------------------------ -- 2.30.2