From: Robert Dewar Date: Fri, 22 Oct 2010 14:35:39 +0000 (+0000) Subject: sem_case.adb, [...] (Bad_Predicated_Subtype_Use): Change order of parameters. X-Git-Tag: upstream/12.2.0~89127 X-Git-Url: http://review.tizen.org/git/?a=commitdiff_plain;h=ed00f4727ba26dd7b6cb3900162729d26de9ecdb;p=platform%2Fupstream%2Fgcc.git sem_case.adb, [...] (Bad_Predicated_Subtype_Use): Change order of parameters. 2010-10-22 Robert Dewar * sem_case.adb, sem_attr.adb (Bad_Predicated_Subtype_Use): Change order of parameters. * sem_ch13.adb (Build_Predicate_Function): Don't give inheritance messages for generic actual subtypes. * sem_ch9.adb, sem_res.adb, sem_util.adb, sem_util.ads, sem_ch3.adb (Bad_Predicated_Subtype_Use): Use this procedure. 2010-10-22 Robert Dewar * sem_ch5.adb: Minor reformatting. From-SVN: r165829 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index e5274a7..79b81ca 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,5 +1,18 @@ 2010-10-22 Robert Dewar + * sem_case.adb, sem_attr.adb (Bad_Predicated_Subtype_Use): Change order + of parameters. + * sem_ch13.adb (Build_Predicate_Function): Don't give inheritance + messages for generic actual subtypes. + * sem_ch9.adb, sem_res.adb, sem_util.adb, sem_util.ads, sem_ch3.adb + (Bad_Predicated_Subtype_Use): Use this procedure. + +2010-10-22 Robert Dewar + + * sem_ch5.adb: Minor reformatting. + +2010-10-22 Robert Dewar + * a-except-2005.adb (Rmsg_18): New message text. * a-except.adb (Rmsg_18): New message text. * atree.adb (List25): New function diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index 20a7829..6b3be0f 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -842,7 +842,7 @@ package body Sem_Attr is if Comes_From_Source (N) then Error_Msg_Name_1 := Aname; Bad_Predicated_Subtype_Use - (P_Type, N, "type& has predicates, attribute % not allowed"); + ("type& has predicates, attribute % not allowed", N, P_Type); end if; end Bad_Attribute_For_Predicate; diff --git a/gcc/ada/sem_case.adb b/gcc/ada/sem_case.adb index 216d709..10781c9 100644 --- a/gcc/ada/sem_case.adb +++ b/gcc/ada/sem_case.adb @@ -866,9 +866,8 @@ package body Sem_Case is or else No (Static_Predicate (E)) then Bad_Predicated_Subtype_Use - (E, N, - "cannot use subtype& with non-static " - & "predicate as case alternative"); + ("cannot use subtype& with non-static " + & "predicate as case alternative", N, E); -- Static predicate case diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 909fe8f..ec6212e 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -3888,9 +3888,13 @@ package body Sem_Ch13 is Right_Opnd => Exp); end if; - -- Output info message on inheritance if required + -- Output info message on inheritance if required. Note we do not + -- give this information for generic actual types, since it is + -- unwelcome noise in that case in instantiations. - if Opt.List_Inherited_Aspects then + if Opt.List_Inherited_Aspects + and then not Is_Generic_Actual_Type (Typ) + then Error_Msg_Sloc := Sloc (Predicate_Function (T)); Error_Msg_Node_2 := T; Error_Msg_N ("?info: & inherits predicate from & #", Typ); @@ -4087,9 +4091,10 @@ package body Sem_Ch13 is function Hi_Val (N : Node_Id) return Uint is begin - if Nkind (N) = N_Identifier then + if Is_Static_Expression (N) then return Expr_Value (N); else + pragma Assert (Nkind (N) = N_Range); return Expr_Value (High_Bound (N)); end if; end Hi_Val; @@ -4100,9 +4105,10 @@ package body Sem_Ch13 is function Lo_Val (N : Node_Id) return Uint is begin - if Nkind (N) = N_Identifier then + if Is_Static_Expression (N) then return Expr_Value (N); else + pragma Assert (Nkind (N) = N_Range); return Expr_Value (Low_Bound (N)); end if; end Lo_Val; @@ -4124,19 +4130,19 @@ package body Sem_Ch13 is SHi := Hi_Val (N); end if; - -- Identifier case + -- Static expression case - else pragma Assert (Nkind (N) = N_Identifier); + elsif Is_Static_Expression (N) then + SLo := Lo_Val (N); + SHi := Hi_Val (N); - -- Static expression case + -- Identifier (other than static expression) case - if Is_Static_Expression (N) then - SLo := Lo_Val (N); - SHi := Hi_Val (N); + else pragma Assert (Nkind (N) = N_Identifier); -- Type case - elsif Is_Type (Entity (N)) then + if Is_Type (Entity (N)) then -- If type has static predicates, process them recursively diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 9371952..68f74b9 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -4429,11 +4429,9 @@ package body Sem_Ch3 is -- Check error of subtype with predicate for index type - if Has_Predicates (Etype (Index)) then - Error_Msg_NE - ("subtype& has predicate, not allowed as index subtype", - Index, Etype (Index)); - end if; + Bad_Predicated_Subtype_Use + ("subtype& has predicate, not allowed as index subtype", + Index, Etype (Index)); -- Move to next index @@ -11402,9 +11400,9 @@ package body Sem_Ch3 is -- Check error of subtype with predicate in index constraint - elsif Has_Predicates (Entity (S)) then - Error_Msg_NE - ("subtype& has predicate, not allowed in index consraint", + else + Bad_Predicated_Subtype_Use + ("subtype& has predicate, not allowed in index constraint", S, Entity (S)); end if; diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index 79ff1d2..eceb281 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -1734,204 +1734,207 @@ package body Sem_Ch5 is if No (N) then return; + end if; - else - declare - Cond : constant Node_Id := Condition (N); + -- Iteration scheme is present - begin - -- For WHILE loop, verify that the condition is a Boolean - -- expression and resolve and check it. + declare + Cond : constant Node_Id := Condition (N); - if Present (Cond) then - Analyze_And_Resolve (Cond, Any_Boolean); - Check_Unset_Reference (Cond); - Set_Current_Value_Condition (N); - return; + begin + -- For WHILE loop, verify that the condition is a Boolean + -- expression and resolve and check it. - elsif Present (Iterator_Specification (N)) then - Analyze_Iterator_Specification (Iterator_Specification (N)); + if Present (Cond) then + Analyze_And_Resolve (Cond, Any_Boolean); + Check_Unset_Reference (Cond); + Set_Current_Value_Condition (N); + return; - -- Else we have a FOR loop + elsif Present (Iterator_Specification (N)) then + Analyze_Iterator_Specification (Iterator_Specification (N)); - else - declare - LP : constant Node_Id := Loop_Parameter_Specification (N); - Id : constant Entity_Id := Defining_Identifier (LP); - DS : constant Node_Id := Discrete_Subtype_Definition (LP); + -- Else we have a FOR loop - begin - Enter_Name (Id); - - -- We always consider the loop variable to be referenced, - -- since the loop may be used just for counting purposes. + else + declare + LP : constant Node_Id := Loop_Parameter_Specification (N); + Id : constant Entity_Id := Defining_Identifier (LP); + DS : constant Node_Id := Discrete_Subtype_Definition (LP); - Generate_Reference (Id, N, ' '); + begin + Enter_Name (Id); - -- Check for case of loop variable hiding a local - -- variable (used later on to give a nice warning - -- if the hidden variable is never assigned). + -- We always consider the loop variable to be referenced, + -- since the loop may be used just for counting purposes. - declare - H : constant Entity_Id := Homonym (Id); - begin - if Present (H) - and then Enclosing_Dynamic_Scope (H) = - Enclosing_Dynamic_Scope (Id) - and then Ekind (H) = E_Variable - and then Is_Discrete_Type (Etype (H)) - then - Set_Hiding_Loop_Variable (H, Id); - end if; - end; + Generate_Reference (Id, N, ' '); - -- Now analyze the subtype definition. If it is - -- a range, create temporaries for bounds. + -- Check for the case of loop variable hiding a local variable + -- (used later on to give a nice warning if the hidden variable + -- is never assigned). - if Nkind (DS) = N_Range - and then Expander_Active + declare + H : constant Entity_Id := Homonym (Id); + begin + if Present (H) + and then Enclosing_Dynamic_Scope (H) = + Enclosing_Dynamic_Scope (Id) + and then Ekind (H) = E_Variable + and then Is_Discrete_Type (Etype (H)) then - Process_Bounds (DS); - else - Analyze (DS); + Set_Hiding_Loop_Variable (H, Id); + end if; + end; - if Nkind (DS) = N_Function_Call - or else - (Is_Entity_Name (DS) - and then not Is_Type (Entity (DS))) - then - -- This is an iterator specification. Rewrite as such - -- and analyze. + -- Now analyze the subtype definition. If it is a range, create + -- temporaries for bounds. - declare - I_Spec : constant Node_Id := - Make_Iterator_Specification (Sloc (LP), - Defining_Identifier => - Relocate_Node (Id), - Name => - Relocate_Node (DS), - Subtype_Indication => - Empty, - Reverse_Present => - Reverse_Present (LP)); - begin - Set_Iterator_Specification (N, I_Spec); - Set_Loop_Parameter_Specification (N, Empty); - Analyze_Iterator_Specification (I_Spec); - return; - end; - end if; - end if; + if Nkind (DS) = N_Range + and then Expander_Active + then + Process_Bounds (DS); - if DS = Error then - return; - end if; + -- Not a range or expander not active (is that right???) - -- The subtype indication may denote the completion of an - -- incomplete type declaration. + else + Analyze (DS); - if Is_Entity_Name (DS) - and then Present (Entity (DS)) - and then Is_Type (Entity (DS)) - and then Ekind (Entity (DS)) = E_Incomplete_Type + if Nkind (DS) = N_Function_Call + or else + (Is_Entity_Name (DS) + and then not Is_Type (Entity (DS))) then - Set_Entity (DS, Get_Full_View (Entity (DS))); - Set_Etype (DS, Entity (DS)); - end if; + -- This is an iterator specification. Rewrite as such + -- and analyze. - if not Is_Discrete_Type (Etype (DS)) then - Wrong_Type (DS, Any_Discrete); - Set_Etype (DS, Any_Type); + declare + I_Spec : constant Node_Id := + Make_Iterator_Specification (Sloc (LP), + Defining_Identifier => + Relocate_Node (Id), + Name => + Relocate_Node (DS), + Subtype_Indication => + Empty, + Reverse_Present => + Reverse_Present (LP)); + begin + Set_Iterator_Specification (N, I_Spec); + Set_Loop_Parameter_Specification (N, Empty); + Analyze_Iterator_Specification (I_Spec); + return; + end; end if; + end if; - Check_Controlled_Array_Attribute (DS); + if DS = Error then + return; + end if; - Make_Index (DS, LP); + -- The subtype indication may denote the completion of an + -- incomplete type declaration. - Set_Ekind (Id, E_Loop_Parameter); - Set_Etype (Id, Etype (DS)); + if Is_Entity_Name (DS) + and then Present (Entity (DS)) + and then Is_Type (Entity (DS)) + and then Ekind (Entity (DS)) = E_Incomplete_Type + then + Set_Entity (DS, Get_Full_View (Entity (DS))); + Set_Etype (DS, Entity (DS)); + end if; - -- Treat a range as an implicit reference to the type, to - -- inhibit spurious warnings. + if not Is_Discrete_Type (Etype (DS)) then + Wrong_Type (DS, Any_Discrete); + Set_Etype (DS, Any_Type); + end if; - Generate_Reference (Base_Type (Etype (DS)), N, ' '); - Set_Is_Known_Valid (Id, True); + Check_Controlled_Array_Attribute (DS); - -- The loop is not a declarative part, so the only entity - -- declared "within" must be frozen explicitly. + Make_Index (DS, LP); - declare - Flist : constant List_Id := Freeze_Entity (Id, N); - begin - if Is_Non_Empty_List (Flist) then - Insert_Actions (N, Flist); - end if; - end; + Set_Ekind (Id, E_Loop_Parameter); + Set_Etype (Id, Etype (DS)); - -- Check for null or possibly null range and issue warning. - -- We suppress such messages in generic templates and - -- instances, because in practice they tend to be dubious - -- in these cases. + -- Treat a range as an implicit reference to the type, to + -- inhibit spurious warnings. - if Nkind (DS) = N_Range and then Comes_From_Source (N) then - declare - L : constant Node_Id := Low_Bound (DS); - H : constant Node_Id := High_Bound (DS); + Generate_Reference (Base_Type (Etype (DS)), N, ' '); + Set_Is_Known_Valid (Id, True); - begin - -- If range of loop is null, issue warning + -- The loop is not a declarative part, so the only entity + -- declared "within" must be frozen explicitly. + + declare + Flist : constant List_Id := Freeze_Entity (Id, N); + begin + if Is_Non_Empty_List (Flist) then + Insert_Actions (N, Flist); + end if; + end; + + -- Check for null or possibly null range and issue warning. We + -- suppress such messages in generic templates and instances, + -- because in practice they tend to be dubious in these cases. + + if Nkind (DS) = N_Range and then Comes_From_Source (N) then + declare + L : constant Node_Id := Low_Bound (DS); + H : constant Node_Id := High_Bound (DS); + + begin + -- If range of loop is null, issue warning + + if Compile_Time_Compare + (L, H, Assume_Valid => True) = GT + then + -- Suppress the warning if inside a generic template + -- or instance, since in practice they tend to be + -- dubious in these cases since they can result from + -- intended parametrization. - if Compile_Time_Compare - (L, H, Assume_Valid => True) = GT + if not Inside_A_Generic + and then not In_Instance then - -- Suppress the warning if inside a generic - -- template or instance, since in practice they - -- tend to be dubious in these cases since they can - -- result from intended parametrization. + -- Specialize msg if invalid values could make + -- the loop non-null after all. - if not Inside_A_Generic - and then not In_Instance + if Compile_Time_Compare + (L, H, Assume_Valid => False) = GT then - -- Specialize msg if invalid values could make - -- the loop non-null after all. - - if Compile_Time_Compare - (L, H, Assume_Valid => False) = GT - then - Error_Msg_N - ("?loop range is null, " - & "loop will not execute", - DS); + Error_Msg_N + ("?loop range is null, loop will not execute", + DS); - -- Since we know the range of the loop is - -- null, set the appropriate flag to remove - -- the loop entirely during expansion. + -- Since we know the range of the loop is + -- null, set the appropriate flag to remove + -- the loop entirely during expansion. - Set_Is_Null_Loop (Parent (N)); + Set_Is_Null_Loop (Parent (N)); -- Here is where the loop could execute because -- of invalid values, so issue appropriate -- message and in this case we do not set the -- Is_Null_Loop flag since the loop may execute. - else - Error_Msg_N - ("?loop range may be null, " - & "loop may not execute", - DS); - Error_Msg_N - ("?can only execute if invalid values " - & "are present", - DS); - end if; + else + Error_Msg_N + ("?loop range may be null, " + & "loop may not execute", + DS); + Error_Msg_N + ("?can only execute if invalid values " + & "are present", + DS); end if; + end if; - -- In either case, suppress warnings in the body of - -- the loop, since it is likely that these warnings - -- will be inappropriate if the loop never actually - -- executes, which is likely. + -- In either case, suppress warnings in the body of + -- the loop, since it is likely that these warnings + -- will be inappropriate if the loop never actually + -- executes, which is likely. - Set_Suppress_Loop_Warnings (Parent (N)); + Set_Suppress_Loop_Warnings (Parent (N)); -- The other case for a warning is a reverse loop -- where the upper bound is the integer literal zero @@ -1944,22 +1947,21 @@ package body Sem_Ch5 is -- In practice, this is very likely to be a case of -- reversing the bounds incorrectly in the range. - elsif Reverse_Present (LP) - and then Nkind (Original_Node (H)) = - N_Integer_Literal - and then (Intval (Original_Node (H)) = Uint_0 - or else + elsif Reverse_Present (LP) + and then Nkind (Original_Node (H)) = + N_Integer_Literal + and then (Intval (Original_Node (H)) = Uint_0 + or else Intval (Original_Node (H)) = Uint_1) - then - Error_Msg_N ("?loop range may be null", DS); - Error_Msg_N ("\?bounds may be wrong way round", DS); - end if; - end; - end if; - end; - end if; - end; - end if; + then + Error_Msg_N ("?loop range may be null", DS); + Error_Msg_N ("\?bounds may be wrong way round", DS); + end if; + end; + end if; + end; + end if; + end; end Analyze_Iteration_Scheme; ------------------------------------- diff --git a/gcc/ada/sem_ch9.adb b/gcc/ada/sem_ch9.adb index 42297a1..a88b2d8 100644 --- a/gcc/ada/sem_ch9.adb +++ b/gcc/ada/sem_ch9.adb @@ -894,11 +894,9 @@ package body Sem_Ch9 is -- Check subtype with predicate in entry family - if Has_Predicates (Etype (D_Sdef)) then - Error_Msg_NE - ("subtype& has predicate, not allowed in entry family", - D_Sdef, Etype (D_Sdef)); - end if; + Bad_Predicated_Subtype_Use + ("subtype& has predicate, not allowed in entry family", + D_Sdef, Etype (D_Sdef)); end if; -- Decorate Def_Id diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 6df4741..de83fa2 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -8481,7 +8481,7 @@ package body Sem_Res is -- Check bad use of type with predicates if Has_Predicates (Etype (Drange)) then - Error_Msg_NE + Bad_Predicated_Subtype_Use ("subtype& has predicate, not allowed in slice", Drange, Etype (Drange)); diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index ed34826..f3a0b13 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -334,21 +334,21 @@ package body Sem_Util is -------------------------------- procedure Bad_Predicated_Subtype_Use - (Typ : Entity_Id; + (Msg : String; N : Node_Id; - Msg : String) + Typ : Entity_Id) is begin if Has_Predicates (Typ) then if Is_Generic_Actual_Type (Typ) then - Error_Msg_F (Msg & '?', Typ); - Error_Msg_F ("\Program_Error will be raised at run time?", Typ); + Error_Msg_FE (Msg & '?', N, Typ); + Error_Msg_F ("\Program_Error will be raised at run time?", N); Insert_Action (N, Make_Raise_Program_Error (Sloc (N), Reason => PE_Bad_Predicated_Generic_Type)); else - Error_Msg_F (Msg, Typ); + Error_Msg_FE (Msg, N, Typ); end if; end if; end Bad_Predicated_Subtype_Use; diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 4031b24..935b410 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -94,18 +94,19 @@ package Sem_Util is -- whether an error or warning is given. procedure Bad_Predicated_Subtype_Use - (Typ : Entity_Id; + (Msg : String; N : Node_Id; - Msg : String); + Typ : Entity_Id); -- This is called when Typ, a predicated subtype, is used in a context - -- which does not allow the use of a predicated subtype. Msg will be - -- passed to Error_Msg_F to output an appropriate message. The caller - -- should set up any insertions other than the & for the type itself. - -- Note that if Typ is a generic actual type, then the message will be - -- output as a warning, and a raise Program_Error is inserted using - -- Insert_Action with node N as the insertion point. Node N also supplies - -- the source location for construction of the raise node. If Typ is NOT a - -- type with predicates this call has no effect. + -- which does not allow the use of a predicated subtype. Msg is passed + -- to Error_Msg_FE to output an appropriate message using N as the + -- location, and Typ as the entity. The caller must set up any insertions + -- other than the & for the type itself. Note that if Typ is a generic + -- actual type, then the message will be output as a warning, and a + -- raise Program_Error is inserted using Insert_Action with node N as + -- the insertion point. Node N also supplies the source location for + -- construction of the raise node. If Typ is NOT a type with predicates + -- this call has no effect. function Build_Actual_Subtype (T : Entity_Id;