From: Arnaud Charlet Date: Tue, 6 Jan 2015 09:18:13 +0000 (+0100) Subject: [multiple changes] X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=a921e83c12b6b3ea5027113af94c2b105533ba14;p=gcc.git [multiple changes] 2015-01-06 Robert Dewar * exp_util.adb: Change name Name_Table_Boolean to Name_Table_Boolean1. * namet.adb: Change name Name_Table_Boolean to Name_Table_Boolean1 Introduce Name_Table_Boolean2/3. * namet.ads: Change name Name_Table_Boolean to Name_Table_Boolean1 Introduce Name_Table_Boolean2/3. * par-ch13.adb: Change name Name_Table_Boolean to Name_Table_Boolean1. 2015-01-06 Bob Duff * gnat_rm.texi: Improve documentation regarding No_Task_Termination. 2015-01-06 Ed Schonberg * sem_aggr.adb (Resolve_Record_Aggregte, Get_Value): For an others choice that covers multiple components, analyze each copy with the type of the component even in compile-only mode, to detect potential accessibility errors. 2015-01-06 Hristian Kirtchev * sem_res.adb (Is_Assignment_Or_Object_Expression): New routine. (Resolve_Actuals): An effectively volatile out parameter cannot act as an in or in out actual in a call. (Resolve_Entity_Name): An effectively volatile out parameter cannot be read. 2015-01-06 Ed Schonberg * sem_ch6.adb (Analyze_Subprogram_Body_Helper): If the body is the expansion of an expression function it may be pre-analyzed if a 'access attribute is applied to the function, in which case last_entity may have been assigned already. 2015-01-06 Ed Schonberg * sem_ch4.adb (Analyze_One_Call): If formal has an incomplete type and actual has the corresponding full view, there is no error, but a case of use of incomplete type in a predicate or invariant expression. 2015-01-06 Vincent Celier * makeutl.adb (Insert_No_Roots): Make sure that the same source in two different project tree is checked in both trees, if they are sources of two different projects, extended or not. 2015-01-06 Arnaud Charlet * gnat1drv.adb: Minor code clean up. (Adjust_Global_Switches): Ignore gnatprove_mode in codepeer_mode. 2015-01-06 Bob Duff * osint.adb (Read_Source_File): Don't print out file name unless T = Source. 2015-01-06 Ed Schonberg * sem_util.adb (Is_Variable, Is_OK_Variable_For_Out_Formal): recognize improper uses of constant_reference types as actuals for in-out parameters. (Check_Function_Call): Do not collect identifiers if function name is missing because of previous error. From-SVN: r219231 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index c67edc5d4fb..dde69e595a2 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,71 @@ +2015-01-06 Robert Dewar + + * exp_util.adb: Change name Name_Table_Boolean to + Name_Table_Boolean1. + * namet.adb: Change name Name_Table_Boolean to Name_Table_Boolean1 + Introduce Name_Table_Boolean2/3. + * namet.ads: Change name Name_Table_Boolean to Name_Table_Boolean1 + Introduce Name_Table_Boolean2/3. + * par-ch13.adb: Change name Name_Table_Boolean to + Name_Table_Boolean1. + +2015-01-06 Bob Duff + + * gnat_rm.texi: Improve documentation regarding No_Task_Termination. + +2015-01-06 Ed Schonberg + + * sem_aggr.adb (Resolve_Record_Aggregte, Get_Value): For an + others choice that covers multiple components, analyze each + copy with the type of the component even in compile-only mode, + to detect potential accessibility errors. + +2015-01-06 Hristian Kirtchev + + * sem_res.adb (Is_Assignment_Or_Object_Expression): New routine. + (Resolve_Actuals): An effectively volatile out + parameter cannot act as an in or in out actual in a call. + (Resolve_Entity_Name): An effectively volatile out parameter + cannot be read. + +2015-01-06 Ed Schonberg + + * sem_ch6.adb (Analyze_Subprogram_Body_Helper): If the body is + the expansion of an expression function it may be pre-analyzed + if a 'access attribute is applied to the function, in which case + last_entity may have been assigned already. + +2015-01-06 Ed Schonberg + + * sem_ch4.adb (Analyze_One_Call): If formal has an incomplete + type and actual has the corresponding full view, there is no + error, but a case of use of incomplete type in a predicate or + invariant expression. + +2015-01-06 Vincent Celier + + * makeutl.adb (Insert_No_Roots): Make sure that the same source + in two different project tree is checked in both trees, if they + are sources of two different projects, extended or not. + +2015-01-06 Arnaud Charlet + + * gnat1drv.adb: Minor code clean up. + (Adjust_Global_Switches): Ignore gnatprove_mode in codepeer_mode. + +2015-01-06 Bob Duff + + * osint.adb (Read_Source_File): Don't print out + file name unless T = Source. + +2015-01-06 Ed Schonberg + + * sem_util.adb (Is_Variable, Is_OK_Variable_For_Out_Formal): + recognize improper uses of constant_reference types as actuals + for in-out parameters. + (Check_Function_Call): Do not collect identifiers if function + name is missing because of previous error. + 2015-01-06 Robert Dewar * ali-util.adb, sem_prag.adb, rtsfind.adb, sem_util.adb, sem_res.adb, diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index f1f6b5290cd..47acc6f668c 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -2963,7 +2963,7 @@ package body Exp_Util is -- If parser detected no address clause for the identifier in question, -- then the answer is a quick NO, without the need for a search. - if not Get_Name_Table_Boolean (Chars (Id)) then + if not Get_Name_Table_Boolean1 (Chars (Id)) then return Empty; end if; diff --git a/gcc/ada/gnat1drv.adb b/gcc/ada/gnat1drv.adb index 81eb6397e5c..b4e74f4fcc0 100644 --- a/gcc/ada/gnat1drv.adb +++ b/gcc/ada/gnat1drv.adb @@ -182,6 +182,11 @@ procedure Gnat1drv is if CodePeer_Mode then + -- Turn off gnatprove mode (if set via e.g. -gnatd.F), not compatible + -- with CodePeer mode. + + GNATprove_Mode := False; + -- Turn off inlining, confuses CodePeer output and gains nothing Front_End_Inlining := False; diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi index 6bf94620be6..b78bc51206f 100644 --- a/gcc/ada/gnat_rm.texi +++ b/gcc/ada/gnat_rm.texi @@ -10972,7 +10972,7 @@ directly on the environment task of the partition. @node No_Task_Termination @unnumberedsubsec No_Task_Termination @findex No_Task_Termination -[RM D.7] Tasks which terminate are erroneous. +[RM D.7] Tasks that terminate are erroneous. @node No_Tasking @unnumberedsubsec No_Tasking @@ -14315,6 +14315,16 @@ allocation. See D.7(8). The only operation that implicitly requires heap storage allocation is task creation. +@sp 1 +@item +@cartouche +@noindent +What happens when a task terminates in the presence of +pragma @code{No_Task_Termination}. See D.7(15). +@end cartouche +@noindent +Execution is erroneous in that case. + @sp 1 @item @cartouche diff --git a/gcc/ada/makeutl.adb b/gcc/ada/makeutl.adb index cbfd01e49d3..5960d3e19d6 100644 --- a/gcc/ada/makeutl.adb +++ b/gcc/ada/makeutl.adb @@ -2557,8 +2557,11 @@ package body Makeutl is for J in 1 .. Q.Last loop if Source.Id.Path.Name = Q.Table (J).Info.Id.Path.Name and then Source.Id.Index = Q.Table (J).Info.Id.Index - and then Source.Id.Project.Path.Name = - Q.Table (J).Info.Id.Project.Path.Name + and then + Ultimate_Extending_Project_Of (Source.Id.Project).Path.Name + = + Ultimate_Extending_Project_Of (Q.Table (J).Info.Id.Project). + Path.Name then -- No need to insert this source in the queue, but still -- return True as we may need to insert its roots. diff --git a/gcc/ada/namet.adb b/gcc/ada/namet.adb index d0dfee27f43..0eab3a1d851 100644 --- a/gcc/ada/namet.adb +++ b/gcc/ada/namet.adb @@ -705,15 +705,35 @@ package body Namet is end loop; end Get_Name_String_And_Append; - ---------------------------- - -- Get_Name_Table_Boolean -- - ---------------------------- + ----------------------------- + -- Get_Name_Table_Boolean1 -- + ----------------------------- + + function Get_Name_Table_Boolean1 (Id : Name_Id) return Boolean is + begin + pragma Assert (Id in Name_Entries.First .. Name_Entries.Last); + return Name_Entries.Table (Id).Boolean1_Info; + end Get_Name_Table_Boolean1; + + ----------------------------- + -- Get_Name_Table_Boolean2 -- + ----------------------------- + + function Get_Name_Table_Boolean2 (Id : Name_Id) return Boolean is + begin + pragma Assert (Id in Name_Entries.First .. Name_Entries.Last); + return Name_Entries.Table (Id).Boolean2_Info; + end Get_Name_Table_Boolean2; + + ----------------------------- + -- Get_Name_Table_Boolean3 -- + ----------------------------- - function Get_Name_Table_Boolean (Id : Name_Id) return Boolean is + function Get_Name_Table_Boolean3 (Id : Name_Id) return Boolean is begin pragma Assert (Id in Name_Entries.First .. Name_Entries.Last); - return Name_Entries.Table (Id).Boolean_Info; - end Get_Name_Table_Boolean; + return Name_Entries.Table (Id).Boolean3_Info; + end Get_Name_Table_Boolean3; ------------------------- -- Get_Name_Table_Byte -- @@ -933,7 +953,9 @@ package body Namet is Name_Len => Short (Name_Len), Byte_Info => 0, Int_Info => 0, - Boolean_Info => False, + Boolean1_Info => False, + Boolean2_Info => False, + Boolean3_Info => False, Name_Has_No_Encodings => False, Hash_Link => No_Name)); @@ -1037,7 +1059,9 @@ package body Namet is Name_Has_No_Encodings => False, Int_Info => 0, Byte_Info => 0, - Boolean_Info => False)); + Boolean1_Info => False, + Boolean2_Info => False, + Boolean3_Info => False)); -- Set corresponding string entry in the Name_Chars table @@ -1262,7 +1286,9 @@ package body Namet is Name_Len => 1, Byte_Info => 0, Int_Info => 0, - Boolean_Info => False, + Boolean1_Info => False, + Boolean2_Info => False, + Boolean3_Info => False, Name_Has_No_Encodings => True, Hash_Link => No_Name)); @@ -1300,15 +1326,35 @@ package body Namet is Store_Encoded_Character (C); end Set_Character_Literal_Name; - ---------------------------- - -- Set_Name_Table_Boolean -- - ---------------------------- + ----------------------------- + -- Set_Name_Table_Boolean1 -- + ----------------------------- + + procedure Set_Name_Table_Boolean1 (Id : Name_Id; Val : Boolean) is + begin + pragma Assert (Id in Name_Entries.First .. Name_Entries.Last); + Name_Entries.Table (Id).Boolean1_Info := Val; + end Set_Name_Table_Boolean1; + + ----------------------------- + -- Set_Name_Table_Boolean2 -- + ----------------------------- + + procedure Set_Name_Table_Boolean2 (Id : Name_Id; Val : Boolean) is + begin + pragma Assert (Id in Name_Entries.First .. Name_Entries.Last); + Name_Entries.Table (Id).Boolean2_Info := Val; + end Set_Name_Table_Boolean2; + + ----------------------------- + -- Set_Name_Table_Boolean3 -- + ----------------------------- - procedure Set_Name_Table_Boolean (Id : Name_Id; Val : Boolean) is + procedure Set_Name_Table_Boolean3 (Id : Name_Id; Val : Boolean) is begin pragma Assert (Id in Name_Entries.First .. Name_Entries.Last); - Name_Entries.Table (Id).Boolean_Info := Val; - end Set_Name_Table_Boolean; + Name_Entries.Table (Id).Boolean3_Info := Val; + end Set_Name_Table_Boolean3; ------------------------- -- Set_Name_Table_Byte -- diff --git a/gcc/ada/namet.ads b/gcc/ada/namet.ads index 4e025c7b0cb..b4b68788dc5 100644 --- a/gcc/ada/namet.ads +++ b/gcc/ada/namet.ads @@ -115,7 +115,7 @@ package Namet is -- character lower case letters in the range a-z, and these names are created -- and initialized by the Initialize procedure. --- Three values, one of type Int, one of type Byte, and one of type Boolean, +-- Five values, one of type Int, one of type Byte, and three of type Boolean, -- are stored with each names table entry and subprograms are provided for -- setting and retrieving these associated values. The usage of these values -- is up to the client: @@ -128,9 +128,11 @@ package Namet is -- The Byte field is used to hold the Token_Type value for reserved words -- (see Sem for details). --- The Boolean field is used to mark address clauses to optimize the +-- The Boolean1 field is used to mark address clauses to optimize the -- performance of the Exp_Util.Following_Address_Clause function. +-- The Boolean2/Boolean3 fields are not used + -- In the binder, we have the following uses: -- The Int field is used in various ways depending on the name involved, @@ -367,8 +369,10 @@ package Namet is pragma Inline (Get_Name_Table_Int); -- Fetches the Int value associated with the given name - function Get_Name_Table_Boolean (Id : Name_Id) return Boolean; - -- Fetches the Boolean value associated with the given name + function Get_Name_Table_Boolean1 (Id : Name_Id) return Boolean; + function Get_Name_Table_Boolean2 (Id : Name_Id) return Boolean; + function Get_Name_Table_Boolean3 (Id : Name_Id) return Boolean; + -- Fetches the Boolean values associated with the given name function Is_Operator_Name (Id : Name_Id) return Boolean; -- Returns True if name given is of the form of an operator (that @@ -504,7 +508,9 @@ package Namet is pragma Inline (Set_Name_Table_Byte); -- Sets the Byte value associated with the given name - procedure Set_Name_Table_Boolean (Id : Name_Id; Val : Boolean); + procedure Set_Name_Table_Boolean1 (Id : Name_Id; Val : Boolean); + procedure Set_Name_Table_Boolean2 (Id : Name_Id; Val : Boolean); + procedure Set_Name_Table_Boolean3 (Id : Name_Id; Val : Boolean); -- Sets the Boolean value associated with the given name procedure Store_Encoded_Character (C : Char_Code); @@ -644,8 +650,10 @@ private Byte_Info : Byte; -- Byte value associated with this name - Boolean_Info : Boolean; - -- Boolean value associated with the name + Boolean1_Info : Boolean; + Boolean2_Info : Boolean; + Boolean3_Info : Boolean; + -- Boolean values associated with the name Name_Has_No_Encodings : Boolean; -- This flag is set True if the name entry is known not to contain any @@ -665,8 +673,10 @@ private Name_Chars_Index at 0 range 0 .. 31; Name_Len at 4 range 0 .. 15; Byte_Info at 6 range 0 .. 7; - Boolean_Info at 7 range 0 .. 0; - Name_Has_No_Encodings at 7 range 1 .. 7; + Boolean1_Info at 7 range 0 .. 0; + Boolean2_Info at 7 range 1 .. 1; + Boolean3_Info at 7 range 2 .. 2; + Name_Has_No_Encodings at 7 range 3 .. 7; Hash_Link at 8 range 0 .. 31; Int_Info at 12 range 0 .. 31; end record; diff --git a/gcc/ada/osint.adb b/gcc/ada/osint.adb index 9ba18083fea..f78a8ea8ffd 100644 --- a/gcc/ada/osint.adb +++ b/gcc/ada/osint.adb @@ -2642,31 +2642,33 @@ package body Osint is return; end if; - -- Print out the file name, if requested, and if it's not part of the - -- runtimes, store it in File_Name_Chars. + -- If it's a Source file, print out the file name, if requested, and if + -- it's not part of the runtimes, store it in File_Name_Chars. We don't + -- want to print non-Source files, like GNAT-TEMP-000001.TMP used to + -- pass information from gprbuild to gcc. We don't want to save runtime + -- file names, because we don't want users to send them in bug reports. - declare - Name : String renames Name_Buffer (1 .. Name_Len); - Inc : String renames Include_Dir_Default_Prefix.all; - - begin - if Debug.Debug_Flag_Dot_N then - Write_Line (Name); - end if; + if T = Source then + declare + Name : String renames Name_Buffer (1 .. Name_Len); + Inc : String renames Include_Dir_Default_Prefix.all; - if Inc /= "" - and then Inc'Length < Name_Len - and then Name_Buffer (1 .. Inc'Length) = Inc - then - -- Part of runtimes, so ignore it + Part_Of_Runtimes : constant Boolean := + Inc /= "" + and then Inc'Length < Name_Len + and then Name_Buffer (1 .. Inc'Length) = Inc; - null; + begin + if Debug.Debug_Flag_Dot_N then + Write_Line (Name); + end if; - else - File_Name_Chars.Append_All (File_Name_Chars.Table_Type (Name)); - File_Name_Chars.Append (ASCII.LF); - end if; - end; + if not Part_Of_Runtimes then + File_Name_Chars.Append_All (File_Name_Chars.Table_Type (Name)); + File_Name_Chars.Append (ASCII.LF); + end if; + end; + end if; -- Prepare to read data from the file diff --git a/gcc/ada/par-ch13.adb b/gcc/ada/par-ch13.adb index 0bbca433935..5d4f7d2e03c 100644 --- a/gcc/ada/par-ch13.adb +++ b/gcc/ada/par-ch13.adb @@ -741,7 +741,7 @@ package body Ch13 is if Attr_Name = Name_Address and then Nkind (Prefix_Node) = N_Identifier then - Set_Name_Table_Boolean (Chars (Prefix_Node), True); + Set_Name_Table_Boolean1 (Chars (Prefix_Node), True); end if; end loop; @@ -771,7 +771,7 @@ package body Ch13 is -- Mark occurrence of address clause (used to optimize performance -- of Exp_Util.Following_Address_Clause). - Set_Name_Table_Boolean (Chars (Identifier_Node), True); + Set_Name_Table_Boolean1 (Chars (Identifier_Node), True); -- RECORD follows USE (Record Representation Clause) diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb index 82d6ce09430..f6c0bd7c5b5 100644 --- a/gcc/ada/sem_aggr.adb +++ b/gcc/ada/sem_aggr.adb @@ -3227,17 +3227,36 @@ package body Sem_Aggr is if Present (Others_Etype) and then Base_Type (Others_Etype) /= Base_Type (Typ) then - Error_Msg_N - ("components in OTHERS choice must " - & "have same type", Selector_Name); + -- If the components are of an anonymous access + -- type they are distinct, but this is legal in + -- Ada 2012 as long as designated types match. + + if (Ekind (Typ) = E_Anonymous_Access_Type + or else Ekind (Typ) = + E_Anonymous_Access_Subprogram_Type) + and then Designated_Type (Typ) = + Designated_Type (Others_Etype) + then + null; + else + Error_Msg_N + ("components in OTHERS choice must " + & "have same type", Selector_Name); + end if; end if; Others_Etype := Typ; - if Expander_Active then + -- Copy expression so that it is resolved + -- independently for each component, This is needed + -- for accessibility checks on compoents of anonymous + -- access types, even in compile_only mode. + + if not Inside_A_Generic then return New_Copy_Tree_And_Copy_Dimensions (Expression (Assoc)); + else return Expression (Assoc); end if; diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 0167f90565d..8ddced82947 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -3195,6 +3195,18 @@ package body Sem_Ch4 is Next_Actual (Actual); Next_Formal (Formal); + -- For an Ada 2012 predicate or invariant, a call may mention + -- an incomplete type, while resolution of the corresponding + -- predicate function may see the full view, as a consequence + -- of the delayed resolution of the corresponding expressions. + + elsif Ekind (Etype (Formal)) = E_Incomplete_Type + and then Full_View (Etype (Formal)) = Etype (Actual) + then + Set_Etype (Formal, Etype (Actual)); + Next_Actual (Actual); + Next_Formal (Formal); + else if Debug_Flag_E then Write_Str (" type checking fails in call "); diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 946f217ce3b..89620797d2b 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -3950,8 +3950,17 @@ package body Sem_Ch6 is -- Case where there are no spec entities, in this case there can be -- no body entities either, so just move everything. + -- If the body is generated for an expression function, it may have + -- been preanalyzed already, if 'access was applied to it. + else - pragma Assert (No (Last_Entity (Body_Id))); + if Nkind (Original_Node (Unit_Declaration_Node (Spec_Id))) /= + N_Expression_Function + then + pragma Assert (No (Last_Entity (Body_Id))); + null; + end if; + Set_First_Entity (Body_Id, First_Entity (Spec_Id)); Set_Last_Entity (Body_Id, Last_Entity (Spec_Id)); Set_First_Entity (Spec_Id, Empty); diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 336b186fffe..445ded40210 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -4250,14 +4250,25 @@ package body Sem_Res is end if; -- In Ada 83 we cannot pass an OUT parameter as an IN or IN OUT - -- actual to a nested call, since this is case of reading an - -- out parameter, which is not allowed. + -- actual to a nested call, since this constitutes a reading of + -- the parameter, which is not allowed. - if Ada_Version = Ada_83 - and then Is_Entity_Name (A) + if Is_Entity_Name (A) and then Ekind (Entity (A)) = E_Out_Parameter then - Error_Msg_N ("(Ada 83) illegal reading of out parameter", A); + if Ada_Version = Ada_83 then + Error_Msg_N + ("(Ada 83) illegal reading of out parameter", A); + + -- An effectively volatile OUT parameter cannot act as IN or + -- IN OUT actual in a call (SPARK RM 7.1.3(11)). + + elsif SPARK_Mode = On + and then Is_Effectively_Volatile (Entity (A)) + then + Error_Msg_N + ("illegal reading of volatile OUT parameter", A); + end if; end if; end if; @@ -5444,8 +5455,8 @@ package body Sem_Res is N_Unchecked_Type_Conversion) then Error_Msg_N - ("(Ada 83) fixed-point operation " - & "needs explicit conversion", N); + ("(Ada 83) fixed-point operation needs explicit " + & "conversion", N); end if; -- The expected type is "any real type" in contexts like @@ -6886,6 +6897,12 @@ package body Sem_Res is -- Used to resolve identifiers and expanded names procedure Resolve_Entity_Name (N : Node_Id; Typ : Entity_Id) is + function Is_Assignment_Or_Object_Expression + (Context : Node_Id; + Expr : Node_Id) return Boolean; + -- Determine whether node Context denotes an assignment statement or an + -- object declaration whose expression is node Expr. + function Is_OK_Volatile_Context (Context : Node_Id; Obj_Ref : Node_Id) return Boolean; @@ -6893,6 +6910,48 @@ package body Sem_Res is -- (as defined in SPARK RM 7.1.3(13)) where volatile reference Obj_Ref -- can safely reside. + ---------------------------------------- + -- Is_Assignment_Or_Object_Expression -- + ---------------------------------------- + + function Is_Assignment_Or_Object_Expression + (Context : Node_Id; + Expr : Node_Id) return Boolean + is + begin + if Nkind_In (Context, N_Assignment_Statement, + N_Object_Declaration) + and then Expression (Context) = Expr + then + return True; + + -- Check whether a construct that yields a name is the expression of + -- an assignment statement or an object declaration. + + elsif (Nkind_In (Context, N_Attribute_Reference, + N_Explicit_Dereference, + N_Indexed_Component, + N_Selected_Component, + N_Slice) + and then Prefix (Context) = Expr) + or else + (Nkind_In (Context, N_Type_Conversion, + N_Unchecked_Type_Conversion) + and then Expression (Context) = Expr) + then + return + Is_Assignment_Or_Object_Expression + (Context => Parent (Context), + Expr => Context); + + -- Otherwise the context is not an assignment statement or an object + -- declaration. + + else + return False; + end if; + end Is_Assignment_Or_Object_Expression; + ---------------------------- -- Is_OK_Volatile_Context -- ---------------------------- @@ -6992,6 +7051,7 @@ package body Sem_Res is -- in a non-interfering context. elsif Nkind_In (Context, N_Attribute_Reference, + N_Explicit_Dereference, N_Indexed_Component, N_Selected_Component, N_Slice) @@ -7107,14 +7167,26 @@ package body Sem_Res is elsif Ekind (E) = E_Generic_Function then Error_Msg_N ("illegal use of generic function", N); + -- In Ada 83 an OUT parameter cannot be read + elsif Ekind (E) = E_Out_Parameter - and then Ada_Version = Ada_83 and then (Nkind (Parent (N)) in N_Op - or else (Nkind (Parent (N)) = N_Assignment_Statement - and then N = Expression (Parent (N))) - or else Nkind (Parent (N)) = N_Explicit_Dereference) + or else Nkind (Parent (N)) = N_Explicit_Dereference + or else Is_Assignment_Or_Object_Expression + (Context => Parent (N), + Expr => N)) then - Error_Msg_N ("(Ada 83) illegal reading of out parameter", N); + if Ada_Version = Ada_83 then + Error_Msg_N ("(Ada 83) illegal reading of out parameter", N); + + -- An effectively volatile OUT parameter cannot be read + -- (SPARK RM 7.1.3(11)). + + elsif SPARK_Mode = On + and then Is_Effectively_Volatile (E) + then + Error_Msg_N ("illegal reading of volatile OUT parameter", N); + end if; -- In all other cases, just do the possible static evaluation diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 65f33430e4e..a93139e3d1a 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -2133,6 +2133,12 @@ package body Sem_Util is begin Id := Get_Function_Id (Call); + -- In case of previous error, no check is posible. + + if No (Id) then + return Abandon; + end if; + Formal := First_Formal (Id); Actual := First_Actual (Call); while Present (Actual) and then Present (Formal) loop @@ -11621,6 +11627,18 @@ package body Sem_Util is elsif Is_Variable (AV) then return True; + -- Generalized indexing operations are rewritten as explicit + -- dereferences, and it is only during resolution that we can + -- check whether the context requires an access_to_variable type. + + elsif Nkind (AV) = N_Explicit_Dereference + and then Ada_Version >= Ada_2012 + and then Nkind (Original_Node (AV)) = N_Indexed_Component + and then Present (Etype (Original_Node (AV))) + and then Has_Implicit_Dereference (Etype (Original_Node (AV))) + then + return not Is_Access_Constant (Etype (Prefix (AV))); + -- Unchecked conversions are allowed only if they come from the -- generated code, which sometimes uses unchecked conversions for out -- parameters in cases where code generation is unaffected. We tell @@ -12857,9 +12875,8 @@ package body Sem_Util is and then Present (Etype (Orig_Node)) and then Ada_Version >= Ada_2012 and then Has_Implicit_Dereference (Etype (Orig_Node)) - and then not Is_Access_Constant (Etype (Prefix (N))) then - return True; + return not Is_Access_Constant (Etype (Prefix (N))); -- A function call is never a variable