From 311014705a3cf42caf7446caa95f4e4a34fce9be Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Thu, 12 Nov 2015 12:38:28 +0100 Subject: [PATCH] [multiple changes] 2015-11-12 Gary Dismukes * exp_ch5.adb, sem_ch3.adb, exp_util.ads, inline.adb, freeze.adb, sem_util.adb, sem_util.ads, par-ch6.adb, sem_elab.adb: Minor reformatting and a typo fix. 2015-11-12 Ed Schonberg * sem_ch12.adb (Preanalyze_Actuals): Add guard on use of Incomplete_Actuals, which are only stored for a package instantiation, in order to place the instance in the body of the enclosing unit. 2015-11-12 Ed Schonberg * exp_intr.adb: Add legality checks on calls to a Generic_Dispatching_Constructor: the given tag must be defined, it cannot be the tag of an abstract type, and its accessibility level must not be greater than that of the constructor. 2015-11-12 Ed Schonberg * sem_ch4.adb (Try_Container_Indexing, Constant_Indexing_OK): If the context is an overloaded call, assume that Constant_Indexing is not OK if an interpretation has an assignable parameter corresponding to the indexing expression. 2015-11-12 Jerome Lambourg * init.c (__gnat_error_handler): Force the SPE bit of the MSR when executing on e500v2 CPU. 2015-11-12 Hristian Kirtchev * sem_prag.adb (Analyze_Constituent): Stop the analysis after detecting a misplaced constituent as this is a critical error. From-SVN: r230239 --- gcc/ada/ChangeLog | 38 ++++++++++++++++++++++++++++++++++++++ gcc/ada/exp_ch5.adb | 2 +- gcc/ada/exp_intr.adb | 44 +++++++++++++++++++++++++++++++++++++++++++- gcc/ada/exp_util.ads | 2 +- gcc/ada/freeze.adb | 2 +- gcc/ada/init.c | 4 ++-- gcc/ada/inline.adb | 2 +- gcc/ada/par-ch6.adb | 2 +- gcc/ada/rtsfind.ads | 2 ++ gcc/ada/sem_ch12.adb | 5 +++++ gcc/ada/sem_ch3.adb | 6 +++--- gcc/ada/sem_ch4.adb | 37 +++++++++++++++++++++++++++++++++++-- gcc/ada/sem_elab.adb | 8 ++++---- gcc/ada/sem_prag.adb | 8 ++++++++ gcc/ada/sem_util.adb | 12 ++++++------ gcc/ada/sem_util.ads | 6 +++--- 16 files changed, 154 insertions(+), 26 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 66cde7f47bd..646d8d15acf 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,41 @@ +2015-11-12 Gary Dismukes + + * exp_ch5.adb, sem_ch3.adb, exp_util.ads, inline.adb, freeze.adb, + sem_util.adb, sem_util.ads, par-ch6.adb, sem_elab.adb: Minor + reformatting and a typo fix. + +2015-11-12 Ed Schonberg + + * sem_ch12.adb (Preanalyze_Actuals): Add guard on use of + Incomplete_Actuals, which are only stored for a package + instantiation, in order to place the instance in the body of + the enclosing unit. + +2015-11-12 Ed Schonberg + + * exp_intr.adb: Add legality checks on calls to a + Generic_Dispatching_Constructor: the given tag must be defined, + it cannot be the tag of an abstract type, and its accessibility + level must not be greater than that of the constructor. + +2015-11-12 Ed Schonberg + + * sem_ch4.adb (Try_Container_Indexing, Constant_Indexing_OK): If + the context is an overloaded call, assume that Constant_Indexing + is not OK if an interpretation has an assignable parameter + corresponding to the indexing expression. + +2015-11-12 Jerome Lambourg + + * init.c (__gnat_error_handler): Force the SPE bit of the MSR + when executing on e500v2 CPU. + +2015-11-12 Hristian Kirtchev + + * sem_prag.adb (Analyze_Constituent): Stop the + analysis after detecting a misplaced constituent as this is a + critical error. + 2015-11-12 Hristian Kirtchev * sem_ch10.adb, atree.adb: Minor reformatting. diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index dbefc051d47..f7433225f3b 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -4285,7 +4285,7 @@ package body Exp_Ch5 is -- with element iterators, where debug information must be generated -- for the temporary that holds the element value. These temporaries -- are created within a transient block whose local declarations are - -- transferred to the loop, which now has non-trivial local objects. + -- transferred to the loop, which now has nontrivial local objects. if Nkind (N) = N_Loop_Statement and then Present (Identifier (N)) diff --git a/gcc/ada/exp_intr.adb b/gcc/ada/exp_intr.adb index bbdcf774c6a..a76486b4432 100644 --- a/gcc/ada/exp_intr.adb +++ b/gcc/ada/exp_intr.adb @@ -311,6 +311,31 @@ package body Exp_Intr is Remove_Side_Effects (Tag_Arg); + -- Check that we have a proper tag + + Insert_Action (N, + Make_Implicit_If_Statement (N, + Condition => Make_Op_Eq (Loc, + Left_Opnd => New_Copy_Tree (Tag_Arg), + Right_Opnd => New_Occurrence_Of (RTE (RE_No_Tag), Loc)), + + Then_Statements => New_List ( + Make_Raise_Statement (Loc, + New_Occurrence_Of (RTE (RE_Tag_Error), Loc))))); + + -- Check that it is not the tag of an abstract type + + Insert_Action (N, + Make_Implicit_If_Statement (N, + Condition => Make_Function_Call (Loc, + Name => + New_Occurrence_Of (RTE (RE_Type_Is_Abstract), Loc), + Parameter_Associations => New_List (New_Copy_Tree (Tag_Arg))), + + Then_Statements => New_List ( + Make_Raise_Statement (Loc, + New_Occurrence_Of (RTE (RE_Tag_Error), Loc))))); + -- The subprogram is the third actual in the instantiation, and is -- retrieved from the corresponding renaming declaration. However, -- freeze nodes may appear before, so we retrieve the declaration @@ -324,6 +349,22 @@ package body Exp_Intr is Act_Constr := Entity (Name (Act_Rename)); Result_Typ := Class_Wide_Type (Etype (Act_Constr)); + -- Check that the accessibility level of the tag is no deeper than that + -- of the constructor function. + + Insert_Action (N, + Make_Implicit_If_Statement (N, + Condition => + Make_Op_Gt (Loc, + Left_Opnd => + Build_Get_Access_Level (Loc, New_Copy_Tree (Tag_Arg)), + Right_Opnd => + Make_Integer_Literal (Loc, Scope_Depth (Act_Constr))), + + Then_Statements => New_List ( + Make_Raise_Statement (Loc, + New_Occurrence_Of (RTE (RE_Tag_Error), Loc))))); + if Is_Interface (Etype (Act_Constr)) then -- If the result type is not known to be a parent of Tag_Arg then we @@ -390,7 +431,6 @@ package body Exp_Intr is -- conversion of the call to the actual constructor. Rewrite (N, Convert_To (Result_Typ, Cnstr_Call)); - Analyze_And_Resolve (N, Etype (Act_Constr)); -- Do not generate a run-time check on the built object if tag -- checks are suppressed for the result type or tagged type expansion @@ -458,6 +498,8 @@ package body Exp_Intr is Make_Raise_Statement (Loc, Name => New_Occurrence_Of (RTE (RE_Tag_Error), Loc))))); end if; + + Analyze_And_Resolve (N, Etype (Act_Constr)); end Expand_Dispatching_Constructor_Call; --------------------------- diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads index b6cf41d3b59..41503c6c82f 100644 --- a/gcc/ada/exp_util.ads +++ b/gcc/ada/exp_util.ads @@ -806,7 +806,7 @@ package Exp_Util is (Decl : Node_Id; Typ : Entity_Id) return Boolean; -- Check whether the expression in an address clause is restricted to - -- consist of constants, when the object has a non-trivial initialization + -- consist of constants, when the object has a nontrivial initialization -- or is controlled. function Needs_Finalization (T : Entity_Id) return Boolean; diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index 7c56b1fb9a8..93fd53cc377 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -1452,7 +1452,7 @@ package body Freeze is return; end if; - -- The situation that is non trivial is something like + -- The situation that is nontrivial is something like: -- subtype x1 is integer range -10 .. +10; -- subtype x2 is x1 range 0 .. V1; diff --git a/gcc/ada/init.c b/gcc/ada/init.c index 243f3b80d57..0ce64235b51 100644 --- a/gcc/ada/init.c +++ b/gcc/ada/init.c @@ -1919,11 +1919,11 @@ __gnat_error_handler (int sig, siginfo_t *si, void *sc) { sigset_t mask; - /* VxWorks 7 on e500v2 clears the SPE bit of the MSR when entering CPU + /* VxWorks on e500v2 clears the SPE bit of the MSR when entering CPU exception state. To allow the handler and exception to work properly when they contain SPE instructions, we need to set it back before doing anything else. */ -#if (CPU == PPCE500V2) && (_WRS_VXWORKS_MAJOR == 7) +#if (CPU == PPCE500V2) || (CPU == PPC85XX) register unsigned msr; /* Read the MSR value */ asm volatile ("mfmsr %0" : "=r" (msr)); diff --git a/gcc/ada/inline.adb b/gcc/ada/inline.adb index 1330df9b918..bc7bc32416d 100644 --- a/gcc/ada/inline.adb +++ b/gcc/ada/inline.adb @@ -193,7 +193,7 @@ package body Inline is function Has_Initialized_Type (E : Entity_Id) return Boolean; -- If a candidate for inlining contains type declarations for types with - -- non-trivial initialization procedures, they are not worth inlining. + -- nontrivial initialization procedures, they are not worth inlining. function Has_Single_Return (N : Node_Id) return Boolean; -- In general we cannot inline functions that return unconstrained type. diff --git a/gcc/ada/par-ch6.adb b/gcc/ada/par-ch6.adb index 627e657cfb6..73a0066c0a1 100644 --- a/gcc/ada/par-ch6.adb +++ b/gcc/ada/par-ch6.adb @@ -1878,7 +1878,7 @@ package body Ch6 is Scan; -- past ; Ret_Node := New_Node (N_Simple_Return_Statement, Ret_Sloc); - -- Non-trivial case + -- Nontrivial case else -- Simple_return_statement with expression diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads index d320639f655..1d8cd89cc4c 100644 --- a/gcc/ada/rtsfind.ads +++ b/gcc/ada/rtsfind.ads @@ -640,6 +640,7 @@ package Rtsfind is RE_Max_Predef_Prims, -- Ada.Tags RE_Needs_Finalization, -- Ada.Tags RE_No_Dispatch_Table_Wrapper, -- Ada.Tags + RE_No_Tag, -- Ada.Tags RE_NDT_Prims_Ptr, -- Ada.Tags RE_NDT_TSD, -- Ada.Tags RE_Num_Prims, -- Ada.Tags @@ -1871,6 +1872,7 @@ package Rtsfind is RE_Max_Predef_Prims => Ada_Tags, RE_Needs_Finalization => Ada_Tags, RE_No_Dispatch_Table_Wrapper => Ada_Tags, + RE_No_Tag => Ada_Tags, RE_NDT_Prims_Ptr => Ada_Tags, RE_NDT_TSD => Ada_Tags, RE_Num_Prims => Ada_Tags, diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 61803ed290e..4dfdac958bb 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -13434,9 +13434,14 @@ package body Sem_Ch12 is elsif Nkind (Act) /= N_Operator_Symbol then Analyze (Act); + -- Within a package instance, mark actuals that are limited + -- views, so their use can be moved to the body of the + -- enclosing unit. + if Is_Entity_Name (Act) and then Is_Type (Entity (Act)) and then From_Limited_With (Entity (Act)) + and then Present (Inst) then Append_Elmt (Entity (Act), Incomplete_Actuals (Inst)); end if; diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 0c01cebb944..a82385e45fc 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -3051,9 +3051,9 @@ package body Sem_Ch3 is End_Scope; end if; - -- If the type has discriminants, non-trivial subtypes may be - -- declared before the full view of the type. The full views of those - -- subtypes will be built after the full view of the type. + -- If the type has discriminants, nontrivial subtypes may be declared + -- before the full view of the type. The full views of those subtypes + -- will be built after the full view of the type. Set_Private_Dependents (T, New_Elmt_List); Set_Is_Pure (T, F); diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 394029cc87b..55a41f1c156 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -7190,10 +7190,43 @@ package body Sem_Ch4 is begin -- We should look for an interpretation with the proper -- number of formals, and determine whether it is an - -- In_Parameter, but for now assume that in the overloaded - -- case constant indexing is legal. To be improved ??? + -- In_Parameter, but for now we examine the formal that + -- corresponds to the indexing, and assume that variable + -- indexing is required if some interpretation has an + -- assignable formal at that position. Still does not + -- cover the most complex cases ??? if Is_Overloaded (Name (Parent (Par))) then + declare + Proc : constant Node_Id := Name (Parent (Par)); + A : Node_Id; + F : Entity_Id; + I : Interp_Index; + It : Interp; + + begin + Get_First_Interp (Proc, I, It); + while Present (It.Nam) loop + F := First_Formal (It.Nam); + A := First (Parameter_Associations (Parent (Par))); + + while Present (F) and then Present (A) loop + if A = Par then + if Ekind (F) /= E_In_Parameter then + return False; + else + exit; -- interpretation is safe + end if; + end if; + + Next_Formal (F); + Next_Actual (A); + end loop; + + Get_Next_Interp (I, It); + end loop; + end; + return True; else diff --git a/gcc/ada/sem_elab.adb b/gcc/ada/sem_elab.adb index bab845d359e..cd9d5b6a2f6 100644 --- a/gcc/ada/sem_elab.adb +++ b/gcc/ada/sem_elab.adb @@ -599,7 +599,7 @@ package body Sem_Elab is Is_DIC_Proc : Boolean := False; -- Flag set when the call denotes the Default_Initial_Condition - -- procedure of a private type which wraps a non-trivila assertion + -- procedure of a private type that wraps a nontrivial assertion -- expression. Issue_In_SPARK : Boolean; @@ -971,13 +971,13 @@ package body Sem_Elab is return; end if; - Is_DIC_Proc := Is_Non_Trivial_Default_Init_Cond_Procedure (Ent); + Is_DIC_Proc := Is_Nontrivial_Default_Init_Cond_Procedure (Ent); -- Elaboration issues in SPARK are reported only for source constructs - -- and for non-trivial Default_Initial_Condition procedures. The latter + -- and for nontrivial Default_Initial_Condition procedures. The latter -- must be checked because the default initialization of an object of a -- private type triggers the evaluation of the Default_Initial_Condition - -- expression which in turn may have side effects. + -- expression, which in turn may have side effects. Issue_In_SPARK := SPARK_Mode = On and (Comes_From_Source (Ent) or Is_DIC_Proc); diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 96e099cde02..a2b4442db8d 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -25408,6 +25408,14 @@ package body Sem_Prag is SPARK_Msg_N ("\all constituents must be declared before body #", N); + + -- A misplaced constituent is a critical error because + -- pragma Refined_Depends or Refined_Global depends on + -- the proper link between a state and a constituent. + -- Stop the compilation, as this leads to a multitude + -- of misleading cascaded errors. + + raise Program_Error; end if; -- The constituent is a valid state or object diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index f9206ac6c73..3512a0a9e3b 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -12362,11 +12362,11 @@ package body Sem_Util is end if; end Is_Local_Variable_Reference; - ------------------------------------------------ - -- Is_Non_Trivial_Default_Init_Cond_Procedure -- - ------------------------------------------------ + ----------------------------------------------- + -- Is_Nontrivial_Default_Init_Cond_Procedure -- + ----------------------------------------------- - function Is_Non_Trivial_Default_Init_Cond_Procedure + function Is_Nontrivial_Default_Init_Cond_Procedure (Id : Entity_Id) return Boolean is Body_Decl : Node_Id; @@ -12386,7 +12386,7 @@ package body Sem_Util is pragma Assert (Present (Handled_Statement_Sequence (Body_Decl))); - -- To qualify as non-trivial, the first statement of the procedure + -- To qualify as nontrivial, the first statement of the procedure -- must be a check in the form of an if statement. If the original -- Default_Initial_Condition expression was folded, then the first -- statement is not a check. @@ -12399,7 +12399,7 @@ package body Sem_Util is end if; return False; - end Is_Non_Trivial_Default_Init_Cond_Procedure; + end Is_Nontrivial_Default_Init_Cond_Procedure; ------------------------- -- Is_Object_Reference -- diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 1aa29e65958..838546b91dc 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -1433,11 +1433,11 @@ package Sem_Util is -- parameter of the current enclosing subprogram. -- Why are OUT parameters not considered here ??? - function Is_Non_Trivial_Default_Init_Cond_Procedure + function Is_Nontrivial_Default_Init_Cond_Procedure (Id : Entity_Id) return Boolean; - -- Determine whether entity Id denotes the procedure which verifies the + -- Determine whether entity Id denotes the procedure that verifies the -- assertion expression of pragma Default_Initial_Condition and if it does, - -- the encapsulated expression is non-trivial. + -- the encapsulated expression is nontrivial. function Is_Object_Reference (N : Node_Id) return Boolean; -- Determines if the tree referenced by N represents an object. Both -- 2.30.2