diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 632da87f745..51c2bf8eea3 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,17 @@ +2014-07-18 Robert Dewar + + * par_sco.adb, a-reatim.ads, exp_attr.adb, sem_util.adb: Minor + reformatting. + +2014-07-18 Robert Dewar + + * einfo.ads, einfo.adb (Has_Out_Or_In_Out_Parameter): New flag and + function. + (Set_Has_Out_Or_In_Out_Parameter): New procedure. + * sem_ch6.adb (Set_Formal_Mode): Set Has_Out_Or_In_Out_Parameter flag. + * sem_res.adb (Resolve_Call): Error if call of Ada 2012 function + with OUT or IN OUT from earlier Ada mode (e.g. Ada 2005) + 2014-07-18 Robert Dewar * bcheck.adb (Check_Consistent_Restrictions): diff --git a/gcc/ada/a-reatim.ads b/gcc/ada/a-reatim.ads index 2c86289a614..084c1ef0593 100644 --- a/gcc/ada/a-reatim.ads +++ b/gcc/ada/a-reatim.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -90,10 +90,9 @@ package Ada.Real_Time is function Minutes (M : Integer) return Time_Span; pragma Ada_05 (Minutes); - -- Seconds_Count needs 64 bits, since Time has the full range of - -- Duration. The delta of Duration is 10 ** (-9), so the maximum - -- number of seconds is 2**63/10**9 = 8*10**9 which does not quite - -- fit in 32 bits. + -- Seconds_Count needs 64 bits, since Time has the full range of Duration. + -- The delta of Duration is 10 ** (-9), so the maximum number of seconds is + -- 2**63/10**9 = 8*10**9 which does not quite fit in 32 bits. type Seconds_Count is range -2 ** 63 .. 2 ** 63 - 1; @@ -121,8 +120,8 @@ private Time_Span (System.Task_Primitives.Operations.RT_Resolution); -- Time and Time_Span are represented in 64-bit Duration value in - -- in nanoseconds. For example, 1 second and 1 nanosecond is - -- represented as the stored integer 1_000_000_001. + -- nanoseconds. For example, 1 second and 1 nanosecond is represented + -- as the stored integer 1_000_000_001. pragma Import (Intrinsic, "<"); pragma Import (Intrinsic, "<="); diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index 13349e18c6c..9fc6760ba25 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -384,6 +384,7 @@ package body Einfo is -- Is_Private_Composite Flag107 -- Default_Expressions_Processed Flag108 -- Is_Non_Static_Subtype Flag109 + -- Has_Out_Or_In_Out_Parameter Flag110 -- Is_Formal_Subprogram Flag111 -- Is_Renaming_Of_Object Flag112 @@ -563,8 +564,6 @@ package body Einfo is -- (unused) Flag2 -- (unused) Flag3 - -- (unused) Flag110 - -- (unused) Flag269 -- (unused) Flag270 @@ -1532,6 +1531,12 @@ package body Einfo is return Flag172 (Id); end Has_Object_Size_Clause; + function Has_Out_Or_In_Out_Parameter (Id : E) return B is + begin + pragma Assert (Ekind_In (Id, E_Function, E_Generic_Function)); + return Flag110 (Id); + end Has_Out_Or_In_Out_Parameter; + function Has_Per_Object_Constraint (Id : E) return B is begin return Flag154 (Id); @@ -4241,6 +4246,12 @@ package body Einfo is Set_Flag172 (Id, V); end Set_Has_Object_Size_Clause; + procedure Set_Has_Out_Or_In_Out_Parameter (Id : E; V : B := True) is + begin + pragma Assert (Ekind_In (Id, E_Function, E_Generic_Function)); + Set_Flag110 (Id, V); + end Set_Has_Out_Or_In_Out_Parameter; + procedure Set_Has_Per_Object_Constraint (Id : E; V : B := True) is begin Set_Flag154 (Id, V); @@ -8192,6 +8203,7 @@ package body Einfo is W ("Has_Missing_Return", Flag142 (Id)); W ("Has_Nested_Block_With_Handler", Flag101 (Id)); W ("Has_Non_Standard_Rep", Flag75 (Id)); + W ("Has_Out_Or_In_Out_Parameter", Flag110 (Id)); W ("Has_Object_Size_Clause", Flag172 (Id)); W ("Has_Per_Object_Constraint", Flag154 (Id)); W ("Has_Postconditions", Flag240 (Id)); diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 40243732869..011e10ca324 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -1670,6 +1670,10 @@ package Einfo is -- clause has been processed for the type Used to prevent multiple -- Object_Size clauses for a given entity. +-- Has_Out_Or_In_Out_Parameter (Flag110) +-- Present in function and generic function entities. Set if the function +-- has at least one OUT or IN OUT parameter (allowed only in Ada 2012). + -- Has_Per_Object_Constraint (Flag154) -- Defined in E_Component entities. Set if the subtype of the component -- has a per object constraint. Per object constraints result from the @@ -5577,6 +5581,7 @@ package Einfo is -- Has_Master_Entity (Flag21) -- Has_Missing_Return (Flag142) -- Has_Nested_Block_With_Handler (Flag101) + -- Has_Out_Or_In_Out_Parameter (Flag110) -- Has_Postconditions (Flag240) -- Has_Recursive_Call (Flag143) -- Is_Abstract_Subprogram (Flag19) (non-generic case only) @@ -6498,6 +6503,7 @@ package Einfo is function Has_Nested_Block_With_Handler (Id : E) return B; function Has_Non_Standard_Rep (Id : E) return B; function Has_Object_Size_Clause (Id : E) return B; + function Has_Out_Or_In_Out_Parameter (Id : E) return B; function Has_Per_Object_Constraint (Id : E) return B; function Has_Postconditions (Id : E) return B; function Has_Pragma_Controlled (Id : E) return B; @@ -7122,6 +7128,7 @@ package Einfo is procedure Set_Has_Nested_Block_With_Handler (Id : E; V : B := True); procedure Set_Has_Non_Standard_Rep (Id : E; V : B := True); procedure Set_Has_Object_Size_Clause (Id : E; V : B := True); + procedure Set_Has_Out_Or_In_Out_Parameter (Id : E; V : B := True); procedure Set_Has_Per_Object_Constraint (Id : E; V : B := True); procedure Set_Has_Postconditions (Id : E; V : B := True); procedure Set_Has_Pragma_Controlled (Id : E; V : B := True); @@ -7860,6 +7867,7 @@ package Einfo is pragma Inline (Has_Nested_Block_With_Handler); pragma Inline (Has_Non_Standard_Rep); pragma Inline (Has_Object_Size_Clause); + pragma Inline (Has_Out_Or_In_Out_Parameter); pragma Inline (Has_Per_Object_Constraint); pragma Inline (Has_Postconditions); pragma Inline (Has_Pragma_Controlled); @@ -8332,6 +8340,7 @@ package Einfo is pragma Inline (Set_Has_Nested_Block_With_Handler); pragma Inline (Set_Has_Non_Standard_Rep); pragma Inline (Set_Has_Object_Size_Clause); + pragma Inline (Set_Has_Out_Or_In_Out_Parameter); pragma Inline (Set_Has_Per_Object_Constraint); pragma Inline (Set_Has_Postconditions); pragma Inline (Set_Has_Pragma_Controlled); diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index 1585b7d4a09..544a9232f35 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -800,8 +800,8 @@ package body Exp_Attr is else pragma Assert (Nkind (Parent (Loop_Stmt)) = N_Handled_Sequence_Of_Statements - and then Nkind (Parent (Parent (Loop_Stmt))) = - N_Block_Statement); + and then + Nkind (Parent (Parent (Loop_Stmt))) = N_Block_Statement); Decls := Declarations (Parent (Parent (Loop_Stmt))); end if; diff --git a/gcc/ada/par_sco.adb b/gcc/ada/par_sco.adb index 8712ba627a4..6fe803d9e80 100644 --- a/gcc/ada/par_sco.adb +++ b/gcc/ada/par_sco.adb @@ -102,8 +102,8 @@ package body Par_SCO is function Is_Logical_Operator (N : Node_Id) return Boolean; -- N is the node for a subexpression. This procedure just tests N to see -- if it is a logical operator (including short circuit conditions, but - -- excluding OR and AND) and returns True if so, False otherwise, it does - -- no other processing. + -- excluding OR and AND) and returns True if so. It also returns True for + -- an if expression. False in all other cases, no other processing is done. function To_Source_Location (S : Source_Ptr) return Source_Location; -- Converts Source_Ptr value to Source_Location (line/col) format diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index ce4c8b9b8b4..bd9e4ec52ee 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -2040,6 +2040,11 @@ package body Sem_Ch6 is Spec_Id : Entity_Id; begin + -- Due to the timing of contract analysis, delayed pragmas may be + -- subject to the wrong SPARK_Mode, usually that of the enclosing + -- context. To remedy this, restore the original SPARK_Mode of the + -- related subprogram body. + Save_SPARK_Mode_And_Set (Body_Id, Mode); -- When a subprogram body declaration is illegal, its defining entity is @@ -2116,6 +2121,9 @@ package body Sem_Ch6 is end if; end if; + -- Restore the SPARK_Mode of the enclosing context after all delayed + -- pragmas have been analyzed. + Restore_SPARK_Mode (Mode); end Analyze_Subprogram_Body_Contract; @@ -3693,6 +3701,11 @@ package body Sem_Ch6 is Seen_In_Post : Boolean := False; begin + -- Due to the timing of contract analysis, delayed pragmas may be + -- subject to the wrong SPARK_Mode, usually that of the enclosing + -- context. To remedy this, restore the original SPARK_Mode of the + -- related subprogram body. + Save_SPARK_Mode_And_Set (Subp, Mode); if Present (Items) then @@ -3817,6 +3830,9 @@ package body Sem_Ch6 is end if; end if; + -- Restore the SPARK_Mode of the enclosing context after all delayed + -- pragmas have been analyzed. + Restore_SPARK_Mode (Mode); end Analyze_Subprogram_Contract; @@ -11832,9 +11848,8 @@ package body Sem_Ch6 is -- point of the call. if Out_Present (Spec) then - if Ekind (Scope (Formal_Id)) = E_Function - or else Ekind (Scope (Formal_Id)) = E_Generic_Function - then + if Ekind_In (Scope (Formal_Id), E_Function, E_Generic_Function) then + -- [IN] OUT parameters allowed for functions in Ada 2012 if Ada_Version >= Ada_2012 then @@ -11851,6 +11866,8 @@ package body Sem_Ch6 is Set_Ekind (Formal_Id, E_Out_Parameter); end if; + Set_Has_Out_Or_In_Out_Parameter (Scope (Formal_Id), True); + -- But not in earlier versions of Ada else diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index dfb3fe5e188..97a11d19591 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -5605,9 +5605,8 @@ package body Sem_Res is Index_Node := Make_Indexed_Component (Loc, - Prefix => - Make_Function_Call (Loc, - Name => New_Subp), + Prefix => + Make_Function_Call (Loc, Name => New_Subp), Expressions => Parameter_Associations (N)); else -- An Ada 2005 prefixed call to a primitive operation @@ -5618,9 +5617,9 @@ package body Sem_Res is Index_Node := Make_Indexed_Component (Loc, - Prefix => + Prefix => Make_Function_Call (Loc, - Name => New_Subp, + Name => New_Subp, Parameter_Associations => New_List (Remove_Head (Parameter_Associations (N)))), @@ -5749,9 +5748,8 @@ package body Sem_Res is begin P := Prev (N); while Present (P) loop - if not Nkind_In (P, - N_Assignment_Statement, - N_Raise_Constraint_Error) + if not Nkind_In (P, N_Assignment_Statement, + N_Raise_Constraint_Error) then exit Scope_Loop; end if; @@ -6103,6 +6101,18 @@ package body Sem_Res is end; end if; + -- Check for calling a function with OUT or IN OUT parameter when the + -- calling context (us right now) is not Ada 2012, so does not allow + -- OUT or IN OUT parameters in function calls. + + if Ada_Version < Ada_2012 + and then Ekind (Nam) = E_Function + and then Has_Out_Or_In_Out_Parameter (Nam) + then + Error_Msg_NE ("& has at least one OUT or `IN OUT` parameter", N, Nam); + Error_Msg_N ("\call to this function only allowed in Ada 2012", N); + end if; + -- Check the dimensions of the actuals in the call. For function calls, -- propagate the dimensions from the returned type to N. diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index faf43338807..f05d084ce24 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -1205,7 +1205,6 @@ package body Sem_Util is if Denotes_Discriminant (Node (D)) then D_Val := New_Occurrence_Of (Discriminal (Entity (Node (D))), Loc); - else D_Val := New_Copy_Tree (Node (D)); end if; @@ -1223,7 +1222,8 @@ package body Sem_Util is if Ekind (T) = E_Array_Subtype then Id := First_Index (T); while Present (Id) loop - if Denotes_Discriminant (Type_Low_Bound (Etype (Id))) or else + if Denotes_Discriminant (Type_Low_Bound (Etype (Id))) + or else Denotes_Discriminant (Type_High_Bound (Etype (Id))) then return Build_Component_Subtype @@ -1493,7 +1493,8 @@ package body Sem_Util is N_Op_Rem => if Do_Division_Check (Expr) - or else Do_Overflow_Check (Expr) + or else + Do_Overflow_Check (Expr) then return False; else @@ -1636,12 +1637,13 @@ package body Sem_Util is and then not Comes_From_Source (T) and then Nkind (N) = N_Object_Declaration then - Error_Msg_NE ("type of& has incomplete component", N, - Defining_Identifier (N)); - + Error_Msg_NE + ("type of& has incomplete component", + N, Defining_Identifier (N)); else Error_Msg_NE - ("premature usage of incomplete}", N, First_Subtype (T)); + ("premature usage of incomplete}", + N, First_Subtype (T)); end if; end if; end Check_Fully_Declared; @@ -1754,6 +1756,7 @@ package body Sem_Util is end if; Append_Elmt (N, Writable_Actuals_List); + else if Identifiers_List = No_Elist then Identifiers_List := New_Elmt_List; @@ -1809,9 +1812,7 @@ package body Sem_Util is return; end if; - if Nkind (N) in N_Subexpr - and then Is_Static_Expression (N) - then + if Nkind (N) in N_Subexpr and then Is_Static_Expression (N) then return; end if; @@ -1902,6 +1903,7 @@ package body Sem_Util is when N_Op | N_Membership_Test => declare Expr : Node_Id; + begin Collect_Identifiers (Left_Opnd (N)); @@ -2018,7 +2020,8 @@ package body Sem_Util is and then Present (Aggregate_Bounds (N)) and then Compile_Time_Known_Bounds (Etype (N)) and then Expr_Value (High_Bound (Aggregate_Bounds (N))) - > Expr_Value (Low_Bound (Aggregate_Bounds (N))) + > + Expr_Value (Low_Bound (Aggregate_Bounds (N))) then declare Count_Components : Uint := Uint_0;