From: Arnaud Charlet Date: Wed, 11 Jun 2014 12:42:28 +0000 (+0200) Subject: [multiple changes] X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=40f4dbbe62de4f49d7f7ef803be3001136ca8199;p=gcc.git [multiple changes] 2014-06-11 Hristian Kirtchev * sem_prag.adb (Analyze_Input_Item): Allow formal parameters to appear as input_items in an initialization_list of pragma Initializes. Encapsulation now applies to states and variables only (as it should). Add RM references to key errors. * sem_prag.adb (Set_Imported): Suppress errors about preceding Imports when the pragma does not come from source, which can happen through use of pragma Provide_Shift_Operators. 2014-06-11 Thomas Quinot * sem_ch3.adb: Minor reformatting. * einfo.ads (Full_View): Minor comment update. From-SVN: r211460 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 0bfe92ddb24..126ffbe45b0 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,40 @@ +2014-06-11 Hristian Kirtchev + + * sem_prag.adb (Analyze_Input_Item): Allow formal + parameters to appear as input_items in an initialization_list + of pragma Initializes. Encapsulation now applies to states and + variables only (as it should). Add RM references to key errors. + * sem_prag.adb (Set_Imported): Suppress errors + about preceding Imports when the pragma does not come from source, + which can happen through use of pragma Provide_Shift_Operators. + +2014-06-11 Thomas Quinot + + * sem_ch3.adb: Minor reformatting. + * einfo.ads (Full_View): Minor comment update. + +2014-06-11 Robert Dewar + + * einfo.adb (Is_Independent): New flag. + * einfo.ads (Is_Independent): New flag. + (Has_Independent_Components): Clean up and fix comments. + * sem_prag.adb (Fix_Error): Deal with changing argument + [of] to entity [for]. + (Analyze_Pragma, case Independent): Set Is_Independent flag + (Analyze_Pragma, case Independent_Components): Set Is_Independent flag + in all components of specified record. + +2014-06-11 Thomas Quinot + + * sem_ch12.adb (Analyze_Formal_Decimal_Fixed_Point_Type): + Set proper Etype on bounds of dummy type created for analysis + of the generic. + +2014-06-11 Robert Dewar + + * debug.adb: Minor comment fix (add missing section of dot + numeric flags). + 2014-06-11 Robert Dewar * gnat_rm.texi, switch-c.adb, sem_prag.adb, a-tgdico.ads, par-prag.adb, diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 6a608a54da8..cbe2ea92c8f 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -1336,12 +1336,12 @@ package Einfo is -- Full_View (Node11) -- Defined in all type and subtype entities and in deferred constants. --- References the entity for the corresponding full type declaration. --- For all types other than private and incomplete types, this field --- always contains Empty. If an incomplete type E1 is completed by a --- private type E2 whose full type declaration entity is E3 then the --- full view of E1 is E2, and the full view of E2 is E3. See also --- Underlying_Type. +-- References the entity for the corresponding full type or constant +-- declaration. For all types other than private and incomplete types, +-- this field always contains Empty. If an incomplete type E1 is +-- completed by a private type E2 whose full type declaration entity is +-- E3 then the full view of E1 is E2, and the full view of E2 is E3. See +-- also Underlying_Type. -- Generic_Homonym (Node11) -- Defined in generic packages. The generic homonym is the entity of @@ -1581,9 +1581,11 @@ package Einfo is -- Implicit_Dereference. Set also on the discriminant named in the aspect -- clause, to simplify type resolution. --- Has_Independent_Components (Flag34) --- Defined in objects and types. Set if the aspect Independent_Components --- applies (as set by coresponding pragma or aspect specification). +-- Has_Independent_Components (Flag34) [base type only] +-- Defined in types. Set if the aspect Independent_Components applies +-- (in the base type only), if corresponding pragma or aspect applies. +-- In the case of an object of anonymous array type, the flag is set on +-- the created array type. -- Has_Inheritable_Invariants (Flag248) -- Defined in all type entities. Set in private types from which one @@ -2415,6 +2417,11 @@ package Einfo is -- Is_Incomplete_Type (synthesized) -- Applies to all entities, true for incomplete types and subtypes +-- Is_Independent (Flag268) +-- Defined in record components. Set if a valid pragma or aspect +-- Independent applies to the component, or if a valid pragma or aspect +-- Independent_Components applies to the enclosing record type. + -- Is_Inlined (Flag11) -- Defined in all entities. Set for functions and procedures which are -- to be inlined. For subprograms created during expansion, this flag @@ -4215,7 +4222,7 @@ package Einfo is -- In addition, we define the kind E_Allocator_Type to label allocators. -- This is because special resolution rules apply to this construct. -- Eventually the constructs are labeled with the access type imposed by --- the context. Gigi should never see the type E_Allocator. +-- the context. Gigi should never see types with this Ekind. -- Similarly, the type E_Access_Attribute_Type is used as the initial kind -- associated with an access attribute. After resolution a specific access @@ -4398,8 +4405,8 @@ package Einfo is -- 'Unrestricted_Access and Unchecked_Access) E_Allocator_Type, - -- A special internal type used to label allocators and attribute - -- references using 'Access. This is needed because special resolution + -- A special internal type used to label allocators and references to + -- objects using 'Reference. This is needed because special resolution -- rules apply to these constructs. On the resolution pass, this type -- is always replaced by the actual access type, so Gigi should never -- see types with this Ekind. @@ -5350,6 +5357,7 @@ package Einfo is -- Has_Biased_Representation (Flag139) -- Has_Per_Object_Constraint (Flag154) -- Is_Atomic (Flag85) + -- Is_Independent (Flag268) -- Is_Tag (Flag78) -- Is_Volatile (Flag16) -- Treat_As_Volatile (Flag41) @@ -5379,7 +5387,6 @@ package Einfo is -- Has_Atomic_Components (Flag86) -- Has_Biased_Representation (Flag139) -- Has_Completion (Flag26) (constants only) - -- Has_Independent_Components (Flag34) (base type only) -- Has_Thunks (Flag228) (constants only) -- Has_Size_Clause (Flag29) -- Has_Up_Level_Access (Flag215) @@ -6089,7 +6096,6 @@ package Einfo is -- Has_Alignment_Clause (Flag46) -- Has_Atomic_Components (Flag86) -- Has_Biased_Representation (Flag139) - -- Has_Independent_Components (Flag34) (base type only) -- Has_Initial_Value (Flag219) -- Has_Size_Clause (Flag29) -- Has_Up_Level_Access (Flag215) @@ -6589,6 +6595,7 @@ package Einfo is function Is_Immediately_Visible (Id : E) return B; function Is_Implementation_Defined (Id : E) return B; function Is_Imported (Id : E) return B; + function Is_Independent (Id : E) return B; function Is_Inlined (Id : E) return B; function Is_Instantiated (Id : E) return B; function Is_Interface (Id : E) return B; @@ -7217,6 +7224,7 @@ package Einfo is procedure Set_Is_Immediately_Visible (Id : E; V : B := True); procedure Set_Is_Implementation_Defined (Id : E; V : B := True); procedure Set_Is_Imported (Id : E; V : B := True); + procedure Set_Is_Independent (Id : E; V : B := True); procedure Set_Is_Inlined (Id : E; V : B := True); procedure Set_Is_Instantiated (Id : E; V : B := True); procedure Set_Is_Interface (Id : E; V : B := True); @@ -7979,6 +7987,7 @@ package Einfo is pragma Inline (Is_Imported); pragma Inline (Is_Incomplete_Or_Private_Type); pragma Inline (Is_Incomplete_Type); + pragma Inline (Is_Independent); pragma Inline (Is_Inlined); pragma Inline (Is_Instantiated); pragma Inline (Is_Integer_Type); @@ -8426,6 +8435,7 @@ package Einfo is pragma Inline (Set_Is_Immediately_Visible); pragma Inline (Set_Is_Implementation_Defined); pragma Inline (Set_Is_Imported); + pragma Inline (Set_Is_Independent); pragma Inline (Set_Is_Inlined); pragma Inline (Set_Is_Instantiated); pragma Inline (Set_Is_Interface); diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 763b85afc4e..684b0a4e0c5 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -15508,7 +15508,6 @@ package body Sem_Ch3 is or else No (Full_View (Prev)) or else not Is_Private_Type (Full_View (Prev))) then - -- Indicate that the incomplete declaration has a matching full -- declaration. The defining occurrence of the incomplete -- declaration remains the visible one, and the procedure diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 07468c7ea73..622a2c0be20 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -2583,8 +2583,12 @@ package body Sem_Prag is if Is_Entity_Name (Input) then Input_Id := Entity_Of (Input); - if Ekind_In (Input_Id, E_Abstract_State, E_Variable) then - + if Ekind_In (Input_Id, E_Abstract_State, + E_In_Parameter, + E_In_Out_Parameter, + E_Out_Parameter, + E_Variable) + then -- The input cannot denote states or variables declared -- within the related package. @@ -2610,13 +2614,15 @@ package body Sem_Prag is Add_Item (Input_Id, States_Seen); end if; - if Present (Encapsulating_State (Input_Id)) then + if Ekind_In (Input_Id, E_Abstract_State, E_Variable) + and then Present (Encapsulating_State (Input_Id)) + then Add_Item (Input_Id, Constits_Seen); end if; end if; -- The input references something that is not a state or a - -- variable. + -- variable (SPARK RM 7.1.5(3)). else Error_Msg_N @@ -2624,6 +2630,7 @@ package body Sem_Prag is end if; -- Some form of illegal construct masquerading as a name + -- (SPARK RM 7.1.5(3)). else Error_Msg_N @@ -3219,14 +3226,27 @@ package body Sem_Prag is -- procedure identified by Name, returns it if it exists, otherwise -- errors out and uses Arg as the pragma argument for the message. - procedure Fix_Error (Msg : in out String); - -- This is called prior to issuing an error message. Msg is a string - -- that typically contains the substring "pragma". If the pragma comes - -- from an aspect, each such "pragma" substring is replaced with the - -- characters "aspect", and Error_Msg_Name_1 is set to the name of the - -- aspect (which may be different from the pragma name). If the current - -- pragma results from rewriting another pragma, then Error_Msg_Name_1 - -- is set to the original pragma name. + function Fix_Error (Msg : String) return String; + -- This is called prior to issuing an error message. Msg is the normal + -- error message issued in the pragma case. This routine checks for the + -- case of a pragma coming from an aspect in the source, and returns a + -- message suitable for the aspect case as follows: + -- + -- Each substring "pragma" is replaced by "aspect" + -- + -- If "argument of" is at the start of the error message text, it is + -- replaced by "entity for". + -- + -- If "argument" is at the start of the error message text, it is + -- replaced by "entity". + -- + -- So for example, "argument of pragma X must be discrete type" + -- returns "entity for aspect X must be a discrete type". + + -- Finally Error_Msg_Name_1 is set to the name of the aspect (which may + -- be different from the pragma name). If the current pragma results + -- from rewriting another pragma, then Error_Msg_Name_1 is set to the + -- original pragma name. procedure Gather_Associations (Names : Name_List; @@ -3746,12 +3766,11 @@ package body Sem_Prag is Error_Msg_Name_1 := Pname; declare - Msg : String := + Msg : constant String := "argument for pragma% must be a identifier or " & "static string expression!"; begin - Fix_Error (Msg); - Flag_Non_Static_Expr (Msg, Argx); + Flag_Non_Static_Expr (Fix_Error (Msg), Argx); raise Pragma_Exit; end; end if; @@ -4419,15 +4438,9 @@ package body Sem_Prag is else Error_Msg_Name_1 := Pname; - - declare - Msg : String := - "argument for pragma% must be a static expression!"; - begin - Fix_Error (Msg); - Flag_Non_Static_Expr (Msg, Expr); - end; - + Flag_Non_Static_Expr + (Fix_Error ("argument for pragma% must be a static expression!"), + Expr); raise Pragma_Exit; end if; end Check_Expr_Is_Static_Expression; @@ -5822,11 +5835,9 @@ package body Sem_Prag is ------------------ procedure Error_Pragma (Msg : String) is - MsgF : String := Msg; begin Error_Msg_Name_1 := Pname; - Fix_Error (MsgF); - Error_Msg_N (MsgF, N); + Error_Msg_N (Fix_Error (Msg), N); raise Pragma_Exit; end Error_Pragma; @@ -5835,20 +5846,16 @@ package body Sem_Prag is ---------------------- procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id) is - MsgF : String := Msg; begin Error_Msg_Name_1 := Pname; - Fix_Error (MsgF); - Error_Msg_N (MsgF, Get_Pragma_Arg (Arg)); + Error_Msg_N (Fix_Error (Msg), Get_Pragma_Arg (Arg)); raise Pragma_Exit; end Error_Pragma_Arg; procedure Error_Pragma_Arg (Msg1, Msg2 : String; Arg : Node_Id) is - MsgF : String := Msg1; begin Error_Msg_Name_1 := Pname; - Fix_Error (MsgF); - Error_Msg_N (MsgF, Get_Pragma_Arg (Arg)); + Error_Msg_N (Fix_Error (Msg1), Get_Pragma_Arg (Arg)); Error_Pragma_Arg (Msg2, Arg); end Error_Pragma_Arg; @@ -5857,11 +5864,9 @@ package body Sem_Prag is ---------------------------- procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id) is - MsgF : String := Msg; begin Error_Msg_Name_1 := Pname; - Fix_Error (MsgF); - Error_Msg_N (MsgF, Arg); + Error_Msg_N (Fix_Error (Msg), Arg); raise Pragma_Exit; end Error_Pragma_Arg_Ident; @@ -5870,12 +5875,10 @@ package body Sem_Prag is ---------------------- procedure Error_Pragma_Ref (Msg : String; Ref : Entity_Id) is - MsgF : String := Msg; begin Error_Msg_Name_1 := Pname; - Fix_Error (MsgF); - Error_Msg_Sloc := Sloc (Ref); - Error_Msg_NE (MsgF, N, Ref); + Error_Msg_Sloc := Sloc (Ref); + Error_Msg_NE (Fix_Error (Msg), N, Ref); raise Pragma_Exit; end Error_Pragma_Ref; @@ -6006,7 +6009,11 @@ package body Sem_Prag is -- Fix_Error -- --------------- - procedure Fix_Error (Msg : in out String) is + function Fix_Error (Msg : String) return String is + Res : String (Msg'Range) := Msg; + Res_Last : Natural := Msg'Last; + J : Natural; + begin -- If we have a rewriting of another pragma, go to that pragma @@ -6022,16 +6029,47 @@ package body Sem_Prag is -- Change appearence of "pragma" in message to "aspect" - for J in Msg'First .. Msg'Last - 5 loop - if Msg (J .. J + 5) = "pragma" then - Msg (J .. J + 5) := "aspect"; + J := Res'First; + while J <= Res_Last - 5 loop + if Res (J .. J + 5) = "pragma" then + Res (J .. J + 5) := "aspect"; + J := J + 6; + + else + J := J + 1; end if; end loop; + -- Change "argument of" at start of message to "entity for" + + if Res'Length > 11 + and then Res (Res'First .. Res'First + 10) = "argument of" + then + Res (Res'First .. Res'First + 9) := "entity for"; + Res (Res'First + 10 .. Res_Last - 1) := + Res (Res'First + 11 .. Res_Last); + Res_Last := Res_Last - 1; + end if; + + -- Change "argument" at start of message to "entity" + + if Res'Length > 8 + and then Res (Res'First .. Res'First + 7) = "argument" + then + Res (Res'First .. Res'First + 5) := "entity"; + Res (Res'First + 6 .. Res_Last - 2) := + Res (Res'First + 8 .. Res_Last); + Res_Last := Res_Last - 2; + end if; + -- Get name from corresponding aspect Error_Msg_Name_1 := Original_Aspect_Name (N); end if; + + -- Return possibly modified message + + return Res (Res'First .. Res_Last); end Fix_Error; ------------------------- @@ -9538,6 +9576,12 @@ package body Sem_Prag is elsif Import_Interface_Present (N) then goto OK; + -- OK if the pragma was expanded by the compiler. Can occur when + -- using pragma Provide_Shift_Operators on multiple types. + + elsif not Comes_From_Source (N) then + goto OK; + -- Error if being set Imported twice else @@ -14974,13 +15018,11 @@ package body Sem_Prag is -- Independent -- ----------------- - -- pragma Independent (LOCAL_NAME); + -- pragma Independent (record_component_LOCAL_NAME); when Pragma_Independent => Independent : declare E_Id : Node_Id; E : Entity_Id; - D : Node_Id; - K : Node_Kind; begin Check_Ada_83_Warning; @@ -14995,38 +15037,32 @@ package body Sem_Prag is end if; E := Entity (E_Id); - D := Declaration_Node (E); - K := Nkind (D); + + -- Check we have a record component. We have not yet setup + -- components fully, so identify by syntactic structure. + + if Nkind (Declaration_Node (E)) /= N_Component_Declaration then + Error_Pragma_Arg + ("argument for pragma% must be record component", Arg1); + end if; -- Check duplicate before we chain ourselves Check_Duplicate_Pragma (E); - -- Check appropriate entity + -- Chain pragma - if Is_Type (E) then - if Rep_Item_Too_Early (E, N) - or else - Rep_Item_Too_Late (E, N) - then - return; - else - Check_First_Subtype (Arg1); - end if; - - elsif K = N_Object_Declaration - or else (K = N_Component_Declaration - and then Original_Record_Component (E) = E) + if Rep_Item_Too_Early (E, N) + or else + Rep_Item_Too_Late (E, N) then - if Rep_Item_Too_Late (E, N) then - return; - end if; - - else - Error_Pragma_Arg - ("inappropriate entity for pragma%", Arg1); + return; end if; + -- Set flag in component + + Set_Is_Independent (E); + Independence_Checks.Append ((N, E)); end Independent; @@ -15043,6 +15079,7 @@ package body Sem_Prag is E : Entity_Id; D : Node_Id; K : Node_Kind; + C : Node_Id; begin Check_Ada_83_Warning; @@ -15077,16 +15114,26 @@ package body Sem_Prag is if K = N_Full_Type_Declaration and then (Is_Array_Type (E) or else Is_Record_Type (E)) then - Independence_Checks.Append ((N, E)); + Independence_Checks.Append ((N, Base_Type (E))); Set_Has_Independent_Components (Base_Type (E)); + -- For record type, set all components independent + + if Is_Record_Type (E) then + C := First_Component (E); + while Present (C) loop + Set_Is_Independent (C); + Next_Component (C); + end loop; + end if; + elsif (Ekind (E) = E_Constant or else Ekind (E) = E_Variable) and then Nkind (D) = N_Object_Declaration and then Nkind (Object_Definition (D)) = N_Constrained_Array_Definition then - Independence_Checks.Append ((N, E)); - Set_Has_Independent_Components (E); + Independence_Checks.Append ((N, Base_Type (Etype (E)))); + Set_Has_Independent_Components (Base_Type (Etype (E))); else Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1); @@ -17426,8 +17473,15 @@ package body Sem_Prag is Check_No_Identifiers; Check_Arg_Count (1); Check_Arg_Is_Local_Name (Arg1); - Type_Id := Get_Pragma_Arg (Assoc); + + if not Is_Entity_Name (Type_Id) + or else not Is_Type (Entity (Type_Id)) + then + Error_Pragma_Arg + ("argument for pragma% must be type or subtype", Arg1); + end if; + Find_Type (Type_Id); Typ := Entity (Type_Id); @@ -19650,13 +19704,12 @@ package body Sem_Prag is -------------------------------- procedure Check_Library_Level_Entity (E : Entity_Id) is - MsgF : String := "incorrect placement of pragma%"; + MsgF : constant String := "incorrect placement of pragma%"; begin if not Is_Library_Level_Entity (E) then Error_Msg_Name_1 := Pname; - Fix_Error (MsgF); - Error_Msg_N (MsgF, N); + Error_Msg_N (Fix_Error (MsgF), N); if Ekind_In (E, E_Generic_Package, E_Package,