From: Arnaud Charlet Date: Thu, 11 Apr 2013 09:34:38 +0000 (+0200) Subject: [multiple changes] X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=8fde064e1ac2202e45e3259304b718fcfff117fe;p=gcc.git [multiple changes] 2013-04-11 Robert Dewar * errout.ads: Minor reformatting. * sem_eval.adb (Why_Not_Static): Now issues continuation messages (Why_Not_Static): Test for aggregates behind string literals. * sem_eval.ads (Why_Not_Static): Now issues continuation messages. 2013-04-11 Robert Dewar * exp_ch4.adb (Expand_Concatenation): Wrap expansion in Expressions_With_Actions. 2013-04-11 Ed Schonberg * sem_ch6.adb (Base_Types_Match): For an actual type in an instance, the base type may itself be a subtype, so find true base type to determine compatibility. From-SVN: r197745 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 9118864486d..d72ad62485d 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,21 @@ +2013-04-11 Robert Dewar + + * errout.ads: Minor reformatting. + * sem_eval.adb (Why_Not_Static): Now issues continuation messages + (Why_Not_Static): Test for aggregates behind string literals. + * sem_eval.ads (Why_Not_Static): Now issues continuation messages. + +2013-04-11 Robert Dewar + + * exp_ch4.adb (Expand_Concatenation): Wrap expansion in + Expressions_With_Actions. + +2013-04-11 Ed Schonberg + + * sem_ch6.adb (Base_Types_Match): For an actual type in an + instance, the base type may itself be a subtype, so find true + base type to determine compatibility. + 2013-04-11 Robert Dewar * s-osprim-mingw.adb, sem_ch3.adb, sem_prag.adb, sem_util.adb. diff --git a/gcc/ada/errout.ads b/gcc/ada/errout.ads index 1dd232bed6e..1e95b173f5a 100644 --- a/gcc/ada/errout.ads +++ b/gcc/ada/errout.ads @@ -242,7 +242,7 @@ package Errout is -- messages starting with the \ insertion character). The effect of the -- use of ! in a parent message automatically applies to all of its -- continuation messages (since we clearly don't want any case in which - -- continuations are separated from the parent message. It is allowable + -- continuations are separated from the main message). It is allowable -- to put ! in continuation messages, and the usual style is to include -- it, since it makes it clear that the continuation is part of an -- unconditional message. diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index f8d37a5530f..c20c8568eaf 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -3017,6 +3017,8 @@ package body Exp_Ch4 is -- Start of processing for Expand_Concatenate + -- Kirtchev + begin -- Choose an appropriate computational type @@ -3233,7 +3235,6 @@ package body Exp_Ch4 is Prefix => Duplicate_Subexpr (Opnd, Name_Req => True), Attribute_Name => Name_First); - Set_Parent (Opnd_Low_Bound (NN), Opnd); -- Capture last operand bounds if result could be null @@ -3244,7 +3245,6 @@ package body Exp_Ch4 is Prefix => Duplicate_Subexpr (Opnd, Name_Req => True), Attribute_Name => Name_First)); - Set_Parent (Last_Opnd_Low_Bound, Opnd); Last_Opnd_High_Bound := Convert_To (Ityp, @@ -3252,7 +3252,6 @@ package body Exp_Ch4 is Prefix => Duplicate_Subexpr (Opnd, Name_Req => True), Attribute_Name => Name_Last)); - Set_Parent (Last_Opnd_High_Bound, Opnd); end if; -- Capture length of operand in entity @@ -5182,6 +5181,10 @@ package body Exp_Ch4 is Desig_Typ := Obj_Typ; end if; + -- Kirtchev J730-020 + + Desig_Typ := Base_Type (Desig_Typ); + -- Generate: -- Ann : access [all] ; @@ -6721,6 +6724,8 @@ package body Exp_Ch4 is -- Node which is to be replaced by the result of concatenating the nodes -- in the list Opnds. + -- Kirtchev + begin -- Ensure validity of both operands @@ -6748,7 +6753,6 @@ package body Exp_Ch4 is -- Now Cnode is the deepest concatenation, and its parents are the -- concatenation nodes above, so now we process bottom up, doing the - -- operations. We gather a string that is as long as possible up to five -- operands. -- The outer loop runs more than once if more than one concatenation @@ -6768,7 +6772,27 @@ package body Exp_Ch4 is Append (Right_Opnd (Cnode), Opnds); end loop Inner; - Expand_Concatenate (Cnode, Opnds); + -- Wrap the node to concatenate into an expression actions node to + -- keep it nicely packaged. This is useful in the case of an assert + -- pragma with a concatenation where we want to be able to delete + -- the concatenation and all its expansion stuff. + + declare + Cnod : constant Node_Id := Relocate_Node (Cnode); + Typ : constant Entity_Id := Base_Type (Etype (Cnode)); + + begin + -- Note: use Rewrite rather than Replace here, so that for example + -- Why_Not_Static can find the original concatenation node OK! + + Rewrite (Cnode, + Make_Expression_With_Actions (Sloc (Cnode), + Actions => New_List (Make_Null_Statement (Sloc (Cnode))), + Expression => Cnod)); + + Expand_Concatenate (Cnod, Opnds); + Analyze_And_Resolve (Cnode, Typ); + end; exit Outer when Cnode = N; Cnode := Parent (Cnode); diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 728e4a7a8d7..7b31ff572e6 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -362,9 +362,7 @@ package body Sem_Ch6 is Analyze (New_Body); Set_Is_Inlined (Prev); - elsif Present (Prev) - and then Comes_From_Source (Prev) - then + elsif Present (Prev) and then Comes_From_Source (Prev) then Set_Has_Completion (Prev, False); -- For navigation purposes, indicate that the function is a body @@ -436,9 +434,9 @@ package body Sem_Ch6 is begin if Nkind (Par) = N_Package_Specification - and then Decls = Visible_Declarations (Par) - and then Present (Private_Declarations (Par)) - and then not Is_Empty_List (Private_Declarations (Par)) + and then Decls = Visible_Declarations (Par) + and then Present (Private_Declarations (Par)) + and then not Is_Empty_List (Private_Declarations (Par)) then Decls := Private_Declarations (Par); end if; @@ -882,7 +880,7 @@ package body Sem_Ch6 is if Present (Expr) - -- Defend against previous errors + -- Defend against previous errors and then Nkind (Expr) /= N_Empty and then Present (Etype (Expr)) @@ -1220,7 +1218,7 @@ package body Sem_Ch6 is begin if (Nkind (Par) = N_Function_Call - and then N = Name (Par)) + and then N = Name (Par)) or else Nkind (Par) = N_Function_Instantiation or else (Nkind (Par) = N_Indexed_Component and then N = Prefix (Par)) @@ -1322,8 +1320,8 @@ package body Sem_Ch6 is -- Special processing for Elab_Spec, Elab_Body and Elab_Subp_Body calls if Nkind (P) = N_Attribute_Reference - and then (Attribute_Name (P) = Name_Elab_Spec or else - Attribute_Name (P) = Name_Elab_Body or else + and then (Attribute_Name (P) = Name_Elab_Spec or else + Attribute_Name (P) = Name_Elab_Body or else Attribute_Name (P) = Name_Elab_Subp_Body) then if Present (Actuals) then @@ -1410,11 +1408,9 @@ package body Sem_Ch6 is -- function, the context will select the operation whose type is Void. elsif Nkind (P) = N_Selected_Component - and then (Ekind (Entity (Selector_Name (P))) = E_Entry - or else - Ekind (Entity (Selector_Name (P))) = E_Procedure - or else - Ekind (Entity (Selector_Name (P))) = E_Function) + and then Ekind_In (Entity (Selector_Name (P)), E_Entry, + E_Procedure, + E_Function) then Analyze_Call_And_Resolve; @@ -1490,8 +1486,8 @@ package body Sem_Ch6 is Returns_Object : constant Boolean := Nkind (N) = N_Extended_Return_Statement or else - (Nkind (N) = N_Simple_Return_Statement - and then Present (Expression (N))); + (Nkind (N) = N_Simple_Return_Statement + and then Present (Expression (N))); -- True if we're returning something; that is, "return ;" -- or "return Result : T [:= ...]". False for "return;". Used for error -- checking: If Returns_Object is True, N should apply to a function @@ -1685,9 +1681,7 @@ package body Sem_Ch6 is -- Unconstrained array as result is not allowed in SPARK - if Is_Array_Type (Typ) - and then not Is_Constrained (Typ) - then + if Is_Array_Type (Typ) and then not Is_Constrained (Typ) then Check_SPARK_Restriction ("returning an unconstrained array is not allowed", Result_Definition (N)); @@ -1703,9 +1697,7 @@ package body Sem_Ch6 is -- right before this, because they don't get applied to types that -- do not come from source. - if Is_Access_Type (Typ) - and then Null_Exclusion_Present (N) - then + if Is_Access_Type (Typ) and then Null_Exclusion_Present (N) then Set_Etype (Designator, Create_Null_Excluding_Itype (T => Typ, @@ -1752,8 +1744,7 @@ package body Sem_Ch6 is elsif Ekind (Typ) = E_Incomplete_Type or else (Is_Class_Wide_Type (Typ) - and then - Ekind (Root_Type (Typ)) = E_Incomplete_Type) + and then Ekind (Root_Type (Typ)) = E_Incomplete_Type) then -- AI05-0151: Tagged incomplete types are allowed in all formal -- parts. Untagged incomplete types are not allowed in bodies. @@ -1952,7 +1943,7 @@ package body Sem_Ch6 is Is_Limited_Record (Designated_Type (Etype (Scop))))) and then Expander_Active - -- Avoid cases with no tasking support + -- Avoid cases with no tasking support and then RTE_Available (RE_Current_Master) and then not Restriction_Active (No_Task_Hierarchy) @@ -2019,14 +2010,14 @@ package body Sem_Ch6 is return Nkind (N) = N_Pragma and then - (Pragma_Name (N) = Name_Inline_Always - or else + (Pragma_Name (N) = Name_Inline_Always + or else (Front_End_Inlining and then Pragma_Name (N) = Name_Inline)) and then - Chars - (Expression (First (Pragma_Argument_Associations (N)))) - = Chars (Body_Id); + Chars + (Expression (First (Pragma_Argument_Associations (N)))) = + Chars (Body_Id); end Is_Inline_Pragma; -- Start of processing for Check_Inline_Pragma @@ -2490,9 +2481,7 @@ package body Sem_Ch6 is -- part of the context of one of its subunits. No need to redo the -- analysis. - elsif Prev_Id = Body_Id - and then Has_Completion (Body_Id) - then + elsif Prev_Id = Body_Id and then Has_Completion (Body_Id) then return; else @@ -2658,8 +2647,8 @@ package body Sem_Ch6 is (Nkind (Original_Node (Spec_Decl)) = N_Subprogram_Renaming_Declaration or else (Present (Corresponding_Body (Spec_Decl)) - and then - Nkind (Unit_Declaration_Node + and then + Nkind (Unit_Declaration_Node (Corresponding_Body (Spec_Decl))) = N_Subprogram_Renaming_Declaration)) then @@ -2821,9 +2810,7 @@ package body Sem_Ch6 is -- is the limited view of a class-wide type and the non-limited view is -- available, update the return type accordingly. - if Ada_Version >= Ada_2005 - and then Comes_From_Source (N) - then + if Ada_Version >= Ada_2005 and then Comes_From_Source (N) then declare Etyp : Entity_Id; Rtyp : Entity_Id; @@ -2834,9 +2821,7 @@ package body Sem_Ch6 is if Ekind (Rtyp) = E_Anonymous_Access_Type then Etyp := Directly_Designated_Type (Rtyp); - if Is_Class_Wide_Type (Etyp) - and then From_With_Type (Etyp) - then + if Is_Class_Wide_Type (Etyp) and then From_With_Type (Etyp) then Set_Directly_Designated_Type (Etype (Current_Scope), Available_View (Etyp)); end if; @@ -2898,7 +2883,7 @@ package body Sem_Ch6 is and then Expander_Active and then (Has_Pragma_Inline_Always (Spec_Id) - or else (Has_Pragma_Inline (Spec_Id) and Front_End_Inlining)) + or else (Has_Pragma_Inline (Spec_Id) and Front_End_Inlining)) then Build_Body_To_Inline (N, Spec_Id); end if; @@ -3373,7 +3358,7 @@ package body Sem_Ch6 is if Is_Interface (Etyp) and then not Is_Abstract_Subprogram (Designator) and then not (Ekind (Designator) = E_Procedure - and then Null_Present (Specification (N))) + and then Null_Present (Specification (N))) then Error_Msg_Name_1 := Chars (Defining_Entity (N)); @@ -3401,10 +3386,9 @@ package body Sem_Ch6 is Set_Kill_Elaboration_Checks (Designator); end if; - if Scop /= Standard_Standard - and then not Is_Child_Unit (Designator) - then + if Scop /= Standard_Standard and then not Is_Child_Unit (Designator) then Set_Categorization_From_Scope (Designator, Scop); + else -- For a compilation unit, check for library-unit pragmas @@ -3890,7 +3874,7 @@ package body Sem_Ch6 is elsif No (Expression (N)) and then Nkind (Parent (Parent (N))) = - N_Extended_Return_Statement + N_Extended_Return_Statement then return OK; @@ -3932,7 +3916,7 @@ package body Sem_Ch6 is return Present (Declarations (N)) and then Present (First (Declarations (N))) and then Chars (Expression (Return_Statement)) = - Chars (Defining_Identifier (First (Declarations (N)))); + Chars (Defining_Identifier (First (Declarations (N)))); end if; end Has_Single_Return; @@ -4809,8 +4793,8 @@ package body Sem_Ch6 is May_Inline : constant Boolean := Has_Pragma_Inline_Always (Spec_Id) or else (Has_Pragma_Inline (Spec_Id) - and then ((Optimization_Level > 0 - and then Ekind (Spec_Id) + and then ((Optimization_Level > 0 + and then Ekind (Spec_Id) = E_Function) or else Front_End_Inlining)); Body_To_Analyze : Node_Id; @@ -5493,10 +5477,9 @@ package body Sem_Ch6 is if Ada_Version >= Ada_2005 and then Ekind (Etype (Old_Type)) = E_Anonymous_Access_Type and then - (Can_Never_Be_Null (Old_Type) - /= Can_Never_Be_Null (New_Type) - or else Is_Access_Constant (Etype (Old_Type)) - /= Is_Access_Constant (Etype (New_Type))) + (Can_Never_Be_Null (Old_Type) /= Can_Never_Be_Null (New_Type) + or else Is_Access_Constant (Etype (Old_Type)) /= + Is_Access_Constant (Etype (New_Type))) then Conformance_Error ("\return type does not match!", New_Id); return; @@ -5519,7 +5502,6 @@ package body Sem_Ch6 is if Ctype >= Subtype_Conformant then if Convention (Old_Id) /= Convention (New_Id) then - if not Is_Frozen (New_Id) then null; @@ -5646,8 +5628,8 @@ package body Sem_Ch6 is Access_Types_Match := Ada_Version >= Ada_2005 - -- Ensure that this rule is only applied when New_Id is a - -- renaming of Old_Id. + -- Ensure that this rule is only applied when New_Id is a + -- renaming of Old_Id. and then Nkind (Parent (Parent (New_Id))) = N_Subprogram_Renaming_Declaration @@ -5655,26 +5637,26 @@ package body Sem_Ch6 is and then Present (Entity (Name (Parent (Parent (New_Id))))) and then Entity (Name (Parent (Parent (New_Id)))) = Old_Id - -- Now handle the allowed access-type case + -- Now handle the allowed access-type case and then Is_Access_Type (Old_Formal_Base) and then Is_Access_Type (New_Formal_Base) - -- The type kinds must match. The only exception occurs with - -- multiple generics of the form: + -- The type kinds must match. The only exception occurs with + -- multiple generics of the form: - -- generic generic - -- type F is private; type A is private; - -- type F_Ptr is access F; type A_Ptr is access A; - -- with proc F_P (X : F_Ptr); with proc A_P (X : A_Ptr); - -- package F_Pack is ... package A_Pack is - -- package F_Inst is - -- new F_Pack (A, A_Ptr, A_P); + -- generic generic + -- type F is private; type A is private; + -- type F_Ptr is access F; type A_Ptr is access A; + -- with proc F_P (X : F_Ptr); with proc A_P (X : A_Ptr); + -- package F_Pack is ... package A_Pack is + -- package F_Inst is + -- new F_Pack (A, A_Ptr, A_P); - -- When checking for conformance between the parameters of A_P - -- and F_P, the type kinds of F_Ptr and A_Ptr will not match - -- because the compiler has transformed A_Ptr into a subtype of - -- F_Ptr. We catch this case in the code below. + -- When checking for conformance between the parameters of A_P + -- and F_P, the type kinds of F_Ptr and A_Ptr will not match + -- because the compiler has transformed A_Ptr into a subtype of + -- F_Ptr. We catch this case in the code below. and then (Ekind (Old_Formal_Base) = Ekind (New_Formal_Base) or else @@ -5684,7 +5666,7 @@ package body Sem_Ch6 is and then Etype (Etype (New_Formal_Base)) = Old_Formal_Base)) and then Directly_Designated_Type (Old_Formal_Base) = - Directly_Designated_Type (New_Formal_Base) + Directly_Designated_Type (New_Formal_Base) and then ((Is_Itype (Old_Formal_Base) and then Can_Never_Be_Null (Old_Formal_Base)) or else @@ -6116,17 +6098,13 @@ package body Sem_Ch6 is -- done for delayed_freeze subprograms because the underlying -- returned type may not be known yet (for private types) - if not Has_Delayed_Freeze (Designator) - and then Expander_Active - then + if not Has_Delayed_Freeze (Designator) and then Expander_Active then declare Typ : constant Entity_Id := Etype (Designator); Utyp : constant Entity_Id := Underlying_Type (Typ); - begin if Is_Immutably_Limited_Type (Typ) then Set_Returns_By_Ref (Designator); - elsif Present (Utyp) and then CW_Or_Has_Controlled_Part (Utyp) then Set_Returns_By_Ref (Designator); end if; @@ -6190,7 +6168,7 @@ package body Sem_Ch6 is -- with partial declaration. if Is_Access_Type (New_Discr_Type) - and then Null_Exclusion_Present (New_Discr) + and then Null_Exclusion_Present (New_Discr) then New_Discr_Type := Create_Null_Excluding_Itype @@ -6678,9 +6656,7 @@ package body Sem_Ch6 is -- sequences (which were the original sequences of statements in -- the exception handlers) and check them. - if Nkind (Last_Stm) = N_Label - and then Exception_Junk (Last_Stm) - then + if Nkind (Last_Stm) = N_Label and then Exception_Junk (Last_Stm) then Stm := Last_Stm; loop Prev (Stm); @@ -6721,7 +6697,7 @@ package body Sem_Ch6 is (Nkind_In (Last_Stm, N_Goto_Statement, N_Label, N_Object_Declaration) - and then Exception_Junk (Last_Stm)) + and then Exception_Junk (Last_Stm)) or else Nkind (Last_Stm) in N_Push_xxx_Label or else Nkind (Last_Stm) in N_Pop_xxx_Label @@ -7511,11 +7487,14 @@ package body Sem_Ch6 is ---------------------- function Base_Types_Match (T1, T2 : Entity_Id) return Boolean is + BT1 : constant Entity_Id := Base_Type (T1); + BT2 : constant Entity_Id := Base_Type (T2); + begin if T1 = T2 then return True; - elsif Base_Type (T1) = Base_Type (T2) then + elsif BT1 = BT2 then -- The following is too permissive. A more precise test should -- check that the generic actual is an ancestor subtype of the @@ -7528,6 +7507,16 @@ package body Sem_Ch6 is or else not Is_Generic_Actual_Type (T2) or else Scope (T1) /= Scope (T2); + -- If T2 is a generic actual type it is declared as the subtype of + -- the actual. If that actual is itself a subtype we need to use + -- its own base type to check for compatibility. + + elsif Ekind (BT2) = Ekind (T2) and then BT1 = Base_Type (BT2) then + return True; + + elsif Ekind (BT1) = Ekind (T1) and then BT2 = Base_Type (BT1) then + return True; + else return False; end if; @@ -7572,14 +7561,10 @@ package body Sem_Ch6 is -- access-to-class-wide type in a formal. Both entities designate the -- same type. - if From_With_Type (T1) - and then T2 = Available_View (T1) - then + if From_With_Type (T1) and then T2 = Available_View (T1) then return True; - elsif From_With_Type (T2) - and then T1 = Available_View (T2) - then + elsif From_With_Type (T2) and then T1 = Available_View (T2) then return True; elsif From_With_Type (T1) @@ -7596,10 +7581,9 @@ package body Sem_Ch6 is -- Start of processing for Conforming_Types begin - -- The context is an instance association for a formal - -- access-to-subprogram type; the formal parameter types require - -- mapping because they may denote other formal parameters of the - -- generic unit. + -- The context is an instance association for a formal access-to- + -- subprogram type; the formal parameter types require mapping because + -- they may denote other formal parameters of the generic unit. if Get_Inst then Type_1 := Get_Instance_Of (T1); @@ -7645,9 +7629,8 @@ package body Sem_Ch6 is Are_Anonymous_Access_To_Subprogram_Types := Ekind (Type_1) = Ekind (Type_2) and then - (Ekind (Type_1) = E_Anonymous_Access_Subprogram_Type - or else - Ekind (Type_1) = E_Anonymous_Access_Protected_Subprogram_Type); + Ekind_In (Type_1, E_Anonymous_Access_Subprogram_Type, + E_Anonymous_Access_Protected_Subprogram_Type); -- Test anonymous access type case. For this case, static subtype -- matching is required for mode conformance (RM 6.3.1(15)). We check @@ -7657,7 +7640,10 @@ package body Sem_Ch6 is if (Ekind (Base_Type (Type_1)) = E_Anonymous_Access_Type and then Ekind (Base_Type (Type_2)) = E_Anonymous_Access_Type) - or else Are_Anonymous_Access_To_Subprogram_Types -- Ada 2005 (AI-254) + + -- Ada 2005 (AI-254) + + or else Are_Anonymous_Access_To_Subprogram_Types then declare Desig_1 : Entity_Id; @@ -7725,8 +7711,8 @@ package body Sem_Ch6 is else return Base_Type (Desig_1) = Base_Type (Desig_2) and then (Ctype = Type_Conformant - or else - Subtypes_Statically_Match (Desig_1, Desig_2)); + or else + Subtypes_Statically_Match (Desig_1, Desig_2)); end if; end; @@ -7736,7 +7722,7 @@ package body Sem_Ch6 is if ((Ekind (Type_1) = E_Anonymous_Access_Type and then Is_Access_Type (Type_2)) or else (Ekind (Type_2) = E_Anonymous_Access_Type - and then Is_Access_Type (Type_1))) + and then Is_Access_Type (Type_1))) and then Conforming_Types (Designated_Type (Type_1), Designated_Type (Type_2), Ctype) @@ -7826,8 +7812,8 @@ package body Sem_Ch6 is -- Start of processing for Create_Extra_Formals begin - -- We never generate extra formals if expansion is not active - -- because we don't need them unless we are generating code. + -- We never generate extra formals if expansion is not active because we + -- don't need them unless we are generating code. if not Expander_Active then return; @@ -7852,9 +7838,7 @@ package body Sem_Ch6 is -- situation may arise for subprogram types created as part of -- dispatching calls (see Expand_Dispatching_Call) - if Present (Last_Extra) and then - Present (Extra_Formal (Last_Extra)) - then + if Present (Last_Extra) and then Present (Extra_Formal (Last_Extra)) then return; end if; @@ -8093,9 +8077,7 @@ package body Sem_Ch6 is -- Chain new entity if front of homonym in current scope, so that -- homonyms are contiguous. - if Present (E) - and then E /= C_E - then + if Present (E) and then E /= C_E then while Homonym (C_E) /= E loop C_E := Homonym (C_E); end loop; @@ -8606,14 +8588,10 @@ package body Sem_Ch6 is return Nkind (Selector_Name (E1)) = N_Character_Literal and then Chars (E2) = Chars (Selector_Name (E1)); - elsif Nkind (E1) in N_Op - and then Nkind (E2) = N_Function_Call - then + elsif Nkind (E1) in N_Op and then Nkind (E2) = N_Function_Call then return FCO (E1, E2); - elsif Nkind (E2) in N_Op - and then Nkind (E1) = N_Function_Call - then + elsif Nkind (E2) in N_Op and then Nkind (E1) = N_Function_Call then return FCO (E2, E1); -- Otherwise we must have the same syntactic entity @@ -9319,8 +9297,8 @@ package body Sem_Ch6 is and then No (N_Formal) and then (Ekind (New_E) /= E_Function or else - Types_Correspond - (Etype (P_Prim), Etype (New_E))) + Types_Correspond + (Etype (P_Prim), Etype (New_E))) then return False; end if; @@ -9615,12 +9593,8 @@ package body Sem_Ch6 is ("abstract subprograms must be visible " & "(RM 3.9.3(10))!", S); - elsif Ekind (S) = E_Function - and then not Is_Overriding - then - if Is_Tagged_Type (T) - and then T = Base_Type (Etype (S)) - then + elsif Ekind (S) = E_Function and then not Is_Overriding then + if Is_Tagged_Type (T) and then T = Base_Type (Etype (S)) then Error_Msg_N ("private function with tagged result must" & " override visible-part function", S); @@ -10038,7 +10012,7 @@ package body Sem_Ch6 is -- interface procedures. elsif (Ekind (Def_Id) = E_Procedure - or else Ekind (Def_Id) = E_Entry) + or else Ekind (Def_Id) = E_Entry) and then Ekind (Subp) = E_Procedure and then Matches_Prefixed_View_Profile (Parameter_Specifications (Parent (Def_Id)), @@ -10059,13 +10033,12 @@ package body Sem_Ch6 is -- routine must be of mode "out", "in out" or -- access-to-variable. - if (Ekind (Candidate) = E_Entry - or else Ekind (Candidate) = E_Procedure) + if Ekind_In (Candidate, E_Entry, E_Procedure) and then Is_Protected_Type (Typ) and then Ekind (Formal) /= E_In_Out_Parameter and then Ekind (Formal) /= E_Out_Parameter - and then Nkind (Parameter_Type (Parent (Formal))) - /= N_Access_Definition + and then Nkind (Parameter_Type (Parent (Formal))) /= + N_Access_Definition then null; @@ -10453,9 +10426,7 @@ package body Sem_Ch6 is begin Prev := First_Entity (Current_Scope); - while Present (Prev) - and then Next_Entity (Prev) /= E - loop + while Present (Prev) and then Next_Entity (Prev) /= E loop Next_Entity (Prev); end loop; @@ -10798,8 +10769,7 @@ package body Sem_Ch6 is end if; return - Ekind (Desig) = E_Incomplete_Type - and then From_With_Type (Desig); + Ekind (Desig) = E_Incomplete_Type and then From_With_Type (Desig); end Designates_From_With_Type; --------------------------- @@ -10842,7 +10812,7 @@ package body Sem_Ch6 is if Is_Incomplete_Type (Formal_Type) or else (Is_Class_Wide_Type (Formal_Type) - and then Is_Incomplete_Type (Root_Type (Formal_Type))) + and then Is_Incomplete_Type (Root_Type (Formal_Type))) then -- Ada 2005 (AI-326): Tagged incomplete types allowed in -- primitive operations, as long as their completion is @@ -12515,9 +12485,7 @@ package body Sem_Ch6 is -- If this is an empty initialization procedure, no need to create -- actual subtypes (small optimization). - if Ekind (Subp) = E_Procedure - and then Is_Null_Init_Proc (Subp) - then + if Ekind (Subp) = E_Procedure and then Is_Null_Init_Proc (Subp) then return; end if; diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb index 0ad0a416571..254f47a9a15 100644 --- a/gcc/ada/sem_eval.adb +++ b/gcc/ada/sem_eval.adb @@ -5495,8 +5495,8 @@ package body Sem_Eval is if Raises_Constraint_Error (Expr) then Error_Msg_N - ("expression raises exception, cannot be static " & - "(RM 4.9(34))!", N); + ("\expression raises exception, cannot be static " & + "(RM 4.9(34))", N); return; end if; @@ -5516,8 +5516,8 @@ package body Sem_Eval is and then not Is_RTE (Typ, RE_Bignum) then Error_Msg_N - ("static expression must have scalar or string type " & - "(RM 4.9(2))!", N); + ("\static expression must have scalar or string type " & + "(RM 4.9(2))", N); return; end if; end if; @@ -5525,6 +5525,9 @@ package body Sem_Eval is -- If we got through those checks, test particular node kind case Nkind (N) is + + -- Entity name + when N_Expanded_Name | N_Identifier | N_Operator_Symbol => E := Entity (N); @@ -5532,30 +5535,84 @@ package body Sem_Eval is null; elsif Ekind (E) = E_Constant then - if not Is_Static_Expression (Constant_Value (E)) then - Error_Msg_NE - ("& is not a static constant (RM 4.9(5))!", N, E); - end if; + + -- One case we can give a metter message is when we have a + -- string literal created by concatenating an aggregate with + -- an others expression. + + Entity_Case : declare + CV : constant Node_Id := Constant_Value (E); + CO : constant Node_Id := Original_Node (CV); + + function Is_Aggregate (N : Node_Id) return Boolean; + -- See if node N came from an others aggregate, if so + -- return True and set Error_Msg_Sloc to aggregate. + + ------------------ + -- Is_Aggregate -- + ------------------ + + function Is_Aggregate (N : Node_Id) return Boolean is + begin + if Nkind (Original_Node (N)) = N_Aggregate then + Error_Msg_Sloc := Sloc (Original_Node (N)); + return True; + elsif Is_Entity_Name (N) + and then Ekind (Entity (N)) = E_Constant + and then + Nkind (Original_Node (Constant_Value (Entity (N)))) = + N_Aggregate + then + Error_Msg_Sloc := + Sloc (Original_Node (Constant_Value (Entity (N)))); + return True; + else + return False; + end if; + end Is_Aggregate; + + -- Start of processing for Entity_Case + + begin + if Is_Aggregate (CV) + or else (Nkind (CO) = N_Op_Concat + and then (Is_Aggregate (Left_Opnd (CO)) + or else + Is_Aggregate (Right_Opnd (CO)))) + then + Error_Msg_N ("\aggregate (#) is never static", N); + + elsif not Is_Static_Expression (CV) then + Error_Msg_NE + ("\& is not a static constant (RM 4.9(5))", N, E); + end if; + end Entity_Case; else Error_Msg_NE - ("& is not static constant or named number " & - "(RM 4.9(5))!", N, E); + ("\& is not static constant or named number " + & "(RM 4.9(5))", N, E); end if; + -- Binary operator + when N_Binary_Op | N_Short_Circuit | N_Membership_Test => if Nkind (N) in N_Op_Shift then Error_Msg_N - ("shift functions are never static (RM 4.9(6,18))!", N); + ("\shift functions are never static (RM 4.9(6,18))", N); else Why_Not_Static (Left_Opnd (N)); Why_Not_Static (Right_Opnd (N)); end if; + -- Unary operator + when N_Unary_Op => Why_Not_Static (Right_Opnd (N)); + -- Attribute reference + when N_Attribute_Reference => Why_Not_Static_List (Expressions (N)); @@ -5569,8 +5626,8 @@ package body Sem_Eval is if Attribute_Name (N) = Name_Size then Error_Msg_N - ("size attribute is only static for static scalar type " & - "(RM 4.9(7,8))", N); + ("\size attribute is only static for static scalar type " + & "(RM 4.9(7,8))", N); -- Flag array cases @@ -5582,15 +5639,15 @@ package body Sem_Eval is Attribute_Name (N) /= Name_Length then Error_Msg_N - ("static array attribute must be Length, First, or Last " & - "(RM 4.9(8))!", N); + ("\static array attribute must be Length, First, or Last " + & "(RM 4.9(8))", N); -- Since we know the expression is not-static (we already -- tested for this, must mean array is not static). else Error_Msg_N - ("prefix is non-static array (RM 4.9(8))!", Prefix (N)); + ("\prefix is non-static array (RM 4.9(8))", Prefix (N)); end if; return; @@ -5603,30 +5660,36 @@ package body Sem_Eval is Is_Generic_Type (E) then Error_Msg_N - ("attribute of generic type is never static " & - "(RM 4.9(7,8))!", N); + ("\attribute of generic type is never static " + & "(RM 4.9(7,8))", N); elsif Is_Static_Subtype (E) then null; elsif Is_Scalar_Type (E) then Error_Msg_N - ("prefix type for attribute is not static scalar subtype " & - "(RM 4.9(7))!", N); + ("\prefix type for attribute is not static scalar subtype " + & "(RM 4.9(7))", N); else Error_Msg_N - ("static attribute must apply to array/scalar type " & - "(RM 4.9(7,8))!", N); + ("\static attribute must apply to array/scalar type " + & "(RM 4.9(7,8))", N); end if; + -- String literal + when N_String_Literal => Error_Msg_N - ("subtype of string literal is non-static (RM 4.9(4))!", N); + ("\subtype of string literal is non-static (RM 4.9(4))", N); + + -- Explicit dereference when N_Explicit_Dereference => Error_Msg_N - ("explicit dereference is never static (RM 4.9)!", N); + ("\explicit dereference is never static (RM 4.9)", N); + + -- Function call when N_Function_Call => Why_Not_Static_List (Parameter_Associations (N)); @@ -5636,44 +5699,59 @@ package body Sem_Eval is -- scalar arithmetic operation. if not Is_RTE (Typ, RE_Bignum) then - Error_Msg_N ("non-static function call (RM 4.9(6,18))!", N); + Error_Msg_N ("\non-static function call (RM 4.9(6,18))", N); end if; + -- Parameter assocation (test actual parameter) + when N_Parameter_Association => Why_Not_Static (Explicit_Actual_Parameter (N)); + -- Indexed component + when N_Indexed_Component => - Error_Msg_N - ("indexed component is never static (RM 4.9)!", N); + Error_Msg_N ("\indexed component is never static (RM 4.9)", N); + + -- Procedure call when N_Procedure_Call_Statement => - Error_Msg_N - ("procedure call is never static (RM 4.9)!", N); + Error_Msg_N ("\procedure call is never static (RM 4.9)", N); + + -- Qualified expression (test expression) when N_Qualified_Expression => Why_Not_Static (Expression (N)); + -- Aggregate + when N_Aggregate | N_Extension_Aggregate => - Error_Msg_N - ("an aggregate is never static (RM 4.9)!", N); + Error_Msg_N ("\an aggregate is never static (RM 4.9)", N); + + -- Range when N_Range => Why_Not_Static (Low_Bound (N)); Why_Not_Static (High_Bound (N)); + -- Range constraint, test range expression + when N_Range_Constraint => Why_Not_Static (Range_Expression (N)); + -- Subtype indication, test constraint + when N_Subtype_Indication => Why_Not_Static (Constraint (N)); + -- Selected component + when N_Selected_Component => - Error_Msg_N - ("selected component is never static (RM 4.9)!", N); + Error_Msg_N ("\selected component is never static (RM 4.9)", N); + + -- Slice when N_Slice => - Error_Msg_N - ("slice is never static (RM 4.9)!", N); + Error_Msg_N ("\slice is never static (RM 4.9)", N); when N_Type_Conversion => Why_Not_Static (Expression (N)); @@ -5682,13 +5760,17 @@ package body Sem_Eval is or else not Is_Static_Subtype (Entity (Subtype_Mark (N))) then Error_Msg_N - ("static conversion requires static scalar subtype result " & - "(RM 4.9(9))!", N); + ("\static conversion requires static scalar subtype result " + & "(RM 4.9(9))", N); end if; + -- Unchecked type conversion + when N_Unchecked_Type_Conversion => Error_Msg_N - ("unchecked type conversion is never static (RM 4.9)!", N); + ("\unchecked type conversion is never static (RM 4.9)", N); + + -- All other cases, no reason to give when others => null; diff --git a/gcc/ada/sem_eval.ads b/gcc/ada/sem_eval.ads index 06607d77897..66a9e3ecc65 100644 --- a/gcc/ada/sem_eval.ads +++ b/gcc/ada/sem_eval.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -417,17 +417,17 @@ package Sem_Eval is procedure Why_Not_Static (Expr : Node_Id); -- This procedure may be called after generating an error message that - -- complains that something is non-static. If it finds good reasons, it - -- generates one or more error messages pointing the appropriate offending - -- component of the expression. If no good reasons can be figured out, then - -- no messages are generated. The expectation here is that the caller has - -- already issued a message complaining that the expression is non-static. - -- Note that this message should be placed using Error_Msg_F or - -- Error_Msg_FE, so that it will sort before any messages placed by this - -- call. Note that it is fine to call Why_Not_Static with something that is - -- not an expression, and usually this has no effect, but in some cases - -- (N_Parameter_Association or N_Range), it makes sense for the internal - -- recursive calls. + -- complains that something is non-static. If it finds good reasons, + -- it generates one or more continuation error messages pointing the + -- appropriate offending component of the expression. If no good reasons + -- can be figured out, then no messages are generated. The expectation here + -- is that the caller has already issued a message complaining that the + -- expression is non-static. Note that this message should be placed using + -- Error_Msg_F or Error_Msg_FE, so that it will sort before any messages + -- placed by this call. Note that it is fine to call Why_Not_Static with + -- something that is not an expression, and usually this has no effect, but + -- in some cases (N_Parameter_Association or N_Range), it makes sense for + -- the internal recursive calls. procedure Initialize; -- Initializes the internal data structures. Must be called before each