diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 44ab1e956eb..eafe2bd30b4 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,45 @@ +2014-01-22 Robert Dewar + + * sem_aux.adb, sem_aux.ads, sem_ch3.adb (Has_Unconstrained_Elements): + Moved to sem_aux.adb. + +2014-01-22 Robert Dewar + + * vms_data.ads: Minor reformatting. + +2014-01-22 Robert Dewar + + * debug.adb: Document messages affected by -gnatd.E including + the new ones that relate to late definition of equality. + * sem_ch6.adb (Check_Untagged_Equality): In Ada 2012 mode, if + debug flag -gnatd.E is set, then generate warnings rather than + errors. + (Check_Untagged_Equality): In earlier versions of Ada, + generate warnings if Warn_On_Ada_2012_Incompatibility flag is set. + +2014-01-22 Robert Dewar + + * sem_prag.adb (Usage_Error): Output additional messages for + unconstrained OUT parameters lacking an input dependency. + +2014-01-22 Robert Dewar + + * sem_ch4.adb: Minor reformatting. + +2014-01-22 Robert Dewar + + * restrict.ads: Minor reformatting. + * sem_res.adb (Resolve_Call): Check for SPARK_05 restriction that + forbids a call from within a subprogram to the same subprogram. + +2014-01-22 Thomas Quinot + + * a-stream.ads (Read_SEA, Write_SEA): New subprograms, optimized + stream attributes for Stream_Element_Array. + * a-stream.adb (Read_SEA, Write_SEA): Bodies for the above. + * rtsfind.adb (Check_CRT): Do not reject a reference to an entity + defined in the current scope. + 2014-01-22 Robert Dewar * debug.adb, exp_ch4.adb, erroutc.adb: Minor reformatting. diff --git a/gcc/ada/a-stream.adb b/gcc/ada/a-stream.adb new file mode 100644 index 00000000000..59f0a3ddbdb --- /dev/null +++ b/gcc/ada/a-stream.adb @@ -0,0 +1,68 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R E A M S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2013, 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 -- +-- apply solely to the contents of the part following the private keyword. -- +-- -- +-- 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- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.IO_Exceptions; + +package body Ada.Streams is + + -------------- + -- Read_SEA -- + -------------- + + procedure Read_SEA + (S : access Root_Stream_Type'Class; + V : out Stream_Element_Array) + is + Last : Stream_Element_Offset; + begin + Read (S.all, V, Last); + if Last /= V'Last then + raise Ada.IO_Exceptions.End_Error; + end if; + end Read_SEA; + + --------------- + -- Write_SEA -- + --------------- + + procedure Write_SEA + (S : access Root_Stream_Type'Class; + V : Stream_Element_Array) + is + begin + Write (S.all, V); + end Write_SEA; + +end Ada.Streams; diff --git a/gcc/ada/a-stream.ads b/gcc/ada/a-stream.ads index a9bb7cdc4e0..75810f3dacd 100644 --- a/gcc/ada/a-stream.ads +++ b/gcc/ada/a-stream.ads @@ -2,11 +2,11 @@ -- -- -- GNAT RUN-TIME COMPONENTS -- -- -- --- A D A . S T R E A M S -- +-- A D A . S T R E A M S -- -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2013, 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 -- @@ -66,4 +66,19 @@ private type Root_Stream_Type is abstract tagged limited null record; + -- Stream attributes for Stream_Element_Array: trivially call the + -- corresponding stream primitive for the whole array, instead of doing + -- so element by element. + + procedure Read_SEA + (S : access Root_Stream_Type'Class; + V : out Stream_Element_Array); + + procedure Write_SEA + (S : access Root_Stream_Type'Class; + V : Stream_Element_Array); + + for Stream_Element_Array'Read use Read_SEA; + for Stream_Element_Array'Write use Write_SEA; + end Ada.Streams; diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb index b1c17f8cd42..251da34e6af 100644 --- a/gcc/ada/debug.adb +++ b/gcc/ada/debug.adb @@ -596,10 +596,16 @@ package body Debug is -- d.E Turn selected errors into warnings. This debug switch causes a -- specific set of error messages into warnings. Setting this switch - -- causes Opt.Error_To_Warning to be set to True. Right now the only - -- error affected is the case of overlapping subprogram parameters - -- which has become illegal in Ada 2012, but only generates a warning - -- in earlier versions of Ada. + -- causes Opt.Error_To_Warning to be set to True. The intention is + -- that this be used for messages representing upwards incompatible + -- changes to Ada 2012 that cause previously correct programs to be + -- treated as illegal now. The following cases are affected: + -- + -- Errors relating to overlapping subprogram parameters for cases + -- other than IN OUT parameters to functions. + -- + -- Errors relating to the new rules about not defining equality + -- too late so that composition of equality can be assured. -- d.F Sets GNATprove_Mode to True. This allows debugging the frontend in -- the special mode used by GNATprove. diff --git a/gcc/ada/restrict.ads b/gcc/ada/restrict.ads index 19439731a37..cef3167ea8e 100644 --- a/gcc/ada/restrict.ads +++ b/gcc/ada/restrict.ads @@ -254,7 +254,7 @@ package Restrict is (Msg : String; N : Node_Id; Force : Boolean := False); - -- Node N represents a construct not allowed in formal mode. If this is + -- Node N represents a construct not allowed in SPARK_05 mode. If this is -- a source node, or if the restriction is forced (Force = True), and -- the SPARK_05 restriction is set, then an error is issued on N. Msg -- is appended to the restriction failure message. diff --git a/gcc/ada/rtsfind.adb b/gcc/ada/rtsfind.adb index 75c4c5a5969..2b25c9fdd95 100644 --- a/gcc/ada/rtsfind.adb +++ b/gcc/ada/rtsfind.adb @@ -225,11 +225,18 @@ package body Rtsfind is -- Entity is available else - -- If in No_Run_Time mode and entity is not in one of the - -- specially permitted units, raise the exception. + -- If in No_Run_Time mode and entity is neither in the current unit + -- nor in one of the specially permitted units, raise the exception. if No_Run_Time_Mode and then not OK_No_Run_Time_Unit (U_Id) + + -- If the entity being referenced is defined in the current scope, + -- using it is always fine as such usage can never introduce any + -- dependency on an additional unit. + -- Why do we need to do this test ??? + + and then Scope (Eid) /= Current_Scope then Entity_Not_Defined (E); raise RE_Not_Available; diff --git a/gcc/ada/sem_aux.adb b/gcc/ada/sem_aux.adb index d95af4f82bb..5098d74f8d1 100644 --- a/gcc/ada/sem_aux.adb +++ b/gcc/ada/sem_aux.adb @@ -624,6 +624,24 @@ package body Sem_Aux is return Present (Get_Rep_Pragma (E, Nam1, Nam2, Check_Parents)); end Has_Rep_Pragma; + -------------------------------- + -- Has_Unconstrained_Elements -- + -------------------------------- + + function Has_Unconstrained_Elements (T : Entity_Id) return Boolean is + U_T : constant Entity_Id := Underlying_Type (T); + begin + if No (U_T) then + return False; + elsif Is_Record_Type (U_T) then + return Has_Discriminants (U_T) and then not Is_Constrained (U_T); + elsif Is_Array_Type (U_T) then + return Has_Unconstrained_Elements (Component_Type (U_T)); + else + return False; + end if; + end Has_Unconstrained_Elements; + --------------------- -- In_Generic_Body -- --------------------- diff --git a/gcc/ada/sem_aux.ads b/gcc/ada/sem_aux.ads index 5d500a3afa3..ed218d712a9 100644 --- a/gcc/ada/sem_aux.ads +++ b/gcc/ada/sem_aux.ads @@ -246,6 +246,10 @@ package Sem_Aux is -- the given names then True is returned, otherwise False indicates that no -- matching entry was found. + function Has_Unconstrained_Elements (T : Entity_Id) return Boolean; + -- True if T has discriminants and is unconstrained, or is an array type + -- whose element type Has_Unconstrained_Elements. + function In_Generic_Body (Id : Entity_Id) return Boolean; -- Determine whether entity Id appears inside a generic body diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 30c37487507..671776ad217 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -2991,11 +2991,6 @@ package body Sem_Ch3 is -- or a variant record type is encountered, Check_Restrictions is called -- indicating the count is unknown. - function Has_Unconstrained_Elements (T : Entity_Id) return Boolean; - -- True if T has discriminants and is unconstrained, or is an array - -- type whose element type Has_Unconstrained_Elements. Shouldn't this - -- be in sem_util??? - ----------------- -- Count_Tasks -- ----------------- @@ -3050,24 +3045,6 @@ package body Sem_Ch3 is end if; end Count_Tasks; - -------------------------------- - -- Has_Unconstrained_Elements -- - -------------------------------- - - function Has_Unconstrained_Elements (T : Entity_Id) return Boolean is - U_T : constant Entity_Id := Underlying_Type (T); - begin - if No (U_T) then - return False; - elsif Is_Record_Type (U_T) then - return Has_Discriminants (U_T) and then not Is_Constrained (U_T); - elsif Is_Array_Type (U_T) then - return Has_Unconstrained_Elements (Component_Type (U_T)); - else - return False; - end if; - end Has_Unconstrained_Elements; - -- Start of processing for Analyze_Object_Declaration begin diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index c2129363845..4bff4df47df 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -1045,14 +1045,14 @@ package body Sem_Ch4 is and then Ekind (Designated_Type (Etype (Nam))) = E_Subprogram_Type and then (not Name_Denotes_Function - or else Nkind (N) = N_Procedure_Call_Statement - or else - (Nkind (Parent (N)) /= N_Explicit_Dereference - and then Is_Entity_Name (Nam) - and then No (First_Formal (Entity (Nam))) - and then not - Is_Array_Type (Etype (Designated_Type (Etype (Nam)))) - and then Present (Actuals))) + or else Nkind (N) = N_Procedure_Call_Statement + or else + (Nkind (Parent (N)) /= N_Explicit_Dereference + and then Is_Entity_Name (Nam) + and then No (First_Formal (Entity (Nam))) + and then not + Is_Array_Type (Etype (Designated_Type (Etype (Nam)))) + and then Present (Actuals))) then Nam_Ent := Designated_Type (Etype (Nam)); Insert_Explicit_Dereference (Nam); diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 7cde5136b4c..9793aa4e188 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -193,7 +193,10 @@ package body Sem_Ch6 is -- must appear before the type is frozen, and have the same visibility as -- that of the type. This procedure checks that this rule is met, and -- otherwise emits an error on the subprogram declaration and a warning - -- on the earlier freeze point if it is easy to locate. + -- on the earlier freeze point if it is easy to locate. In Ada 2012 mode, + -- this routine outputs errors (or warnings if -gnatd.E is set). In earlier + -- versions of Ada, warnings are output if Warn_On_Ada_2012_Incompatibility + -- is set, otherwise the call has no effect. procedure Enter_Overloaded_Entity (S : Entity_Id); -- This procedure makes S, a new overloaded entity, into the first visible @@ -8198,63 +8201,140 @@ package body Sem_Ch6 is Obj_Decl : Node_Id; begin - if Nkind (Decl) = N_Subprogram_Declaration - and then Is_Record_Type (Typ) - and then not Is_Tagged_Type (Typ) + -- This check applies only if we have a subprogram declaration with a + -- non-tagged record type. + + if Nkind (Decl) /= N_Subprogram_Declaration + or else not Is_Record_Type (Typ) + or else Is_Tagged_Type (Typ) then - -- If the type is not declared in a package, or if we are in the - -- body of the package or in some other scope, the new operation is - -- not primitive, and therefore legal, though suspicious. If the - -- type is a generic actual (sub)type, the operation is not primitive - -- either because the base type is declared elsewhere. + return; + end if; - if Is_Frozen (Typ) then - if Ekind (Scope (Typ)) /= E_Package - or else Scope (Typ) /= Current_Scope - then - null; + -- In Ada 2012 case, we will output errors or warnings depending on + -- the setting of debug flag -gnatd.E. - elsif Is_Generic_Actual_Type (Typ) then - null; + if Ada_Version >= Ada_2012 then + Error_Msg_Warn := Debug_Flag_Dot_EE; - elsif In_Package_Body (Scope (Typ)) then + -- In earlier versions of Ada, nothing to do unless we are warning on + -- Ada 2012 incompatibilities (Warn_On_Ada_2012_Incompatibility set). + + else + if not Warn_On_Ada_2012_Compatibility then + return; + end if; + end if; + + -- Cases where the type has already been frozen + + if Is_Frozen (Typ) then + + -- If the type is not declared in a package, or if we are in the body + -- of the package or in some other scope, the new operation is not + -- primitive, and therefore legal, though suspicious. Should we + -- generate a warning in this case ??? + + if Ekind (Scope (Typ)) /= E_Package + or else Scope (Typ) /= Current_Scope + then + return; + + -- If the type is a generic actual (sub)type, the operation is not + -- primitive either because the base type is declared elsewhere. + + elsif Is_Generic_Actual_Type (Typ) then + return; + + -- Here we have a definite error of declaration after freezing + + else + if Ada_Version >= Ada_2012 then Error_Msg_NE - ("equality operator must be declared " - & "before type& is frozen", Eq_Op, Typ); - Error_Msg_N - ("\move declaration to package spec", Eq_Op); + ("equality operator must be declared before type& is " + & "frozen (RM 4.5.2 (9.8)) (Ada 2012)<<", Eq_Op, Typ); + + -- In Ada 2012 mode with error turned to warning, output one + -- more warning to warn that the equality operation may not + -- compose. This is the consequence of ignoring the error. + + if Error_Msg_Warn then + Error_Msg_N ("\equality operation may not compose??", Eq_Op); + end if; else Error_Msg_NE - ("equality operator must be declared " - & "before type& is frozen", Eq_Op, Typ); + ("equality operator must be declared before type& is " + & "frozen (RM 4.5.2 (9.8)) (Ada 2012)?y?", Eq_Op, Typ); + end if; + -- If we are in the package body, we could just move the + -- declaration to the package spec, so add a message saying that. + + if In_Package_Body (Scope (Typ)) then + if Ada_Version >= Ada_2012 then + Error_Msg_N + ("\move declaration to package spec<<", Eq_Op); + else + Error_Msg_N + ("\move declaration to package spec (Ada 2012)?y?", Eq_Op); + end if; + + -- Otherwise try to find the freezing point + + else Obj_Decl := Next (Parent (Typ)); while Present (Obj_Decl) and then Obj_Decl /= Decl loop if Nkind (Obj_Decl) = N_Object_Declaration and then Etype (Defining_Identifier (Obj_Decl)) = Typ then - Error_Msg_NE - ("type& is frozen by declaration??", Obj_Decl, Typ); - Error_Msg_N - ("\an equality operator cannot be declared after this " - & "point (RM 4.5.2 (9.8)) (Ada 2012))??", Obj_Decl); + -- Freezing point, output warnings + + if Ada_Version >= Ada_2012 then + Error_Msg_NE + ("type& is frozen by declaration??", Obj_Decl, Typ); + Error_Msg_N + ("\an equality operator cannot be declared after " + & "this point??", + Obj_Decl); + else + Error_Msg_NE + ("type& is frozen by declaration (Ada 2012)?y?", + Obj_Decl, Typ); + Error_Msg_N + ("\an equality operator cannot be declared after " + & "this point (Ada 2012)?y?", + Obj_Decl); + end if; + exit; end if; Next (Obj_Decl); end loop; end if; - - elsif not In_Same_List (Parent (Typ), Decl) - and then not Is_Limited_Type (Typ) - then - - -- This makes it illegal to have a primitive equality declared in - -- the private part if the type is visible. - - Error_Msg_N ("equality operator appears too late", Eq_Op); end if; + + -- Here if type is not frozen yet. It is illegal to have a primitive + -- equality declared in the private part if the type is visible. + + elsif not In_Same_List (Parent (Typ), Decl) + and then not Is_Limited_Type (Typ) + then + -- Shouldn't we give an RM reference here??? + + if Ada_Version >= Ada_2012 then + Error_Msg_N + ("equality operator appears too late<<", Eq_Op); + else + Error_Msg_N + ("equality operator appears too late (Ada 2012)?y?", Eq_Op); + end if; + + -- No error detected + + else + return; end if; end Check_Untagged_Equality; @@ -10796,10 +10876,7 @@ package body Sem_Ch6 is and then not Is_Dispatching_Operation (S) then Make_Inequality_Operator (S); - - if Ada_Version >= Ada_2012 then - Check_Untagged_Equality (S); - end if; + Check_Untagged_Equality (S); end if; end New_Overloaded_Entity; diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 07ad998b42c..555a7887ff6 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -1114,11 +1114,57 @@ package body Sem_Prag is ----------------- procedure Usage_Error (Item : Node_Id; Item_Id : Entity_Id) is + Typ : constant Entity_Id := Etype (Item_Id); + begin + -- Input case + if Is_Input then Error_Msg_NE ("item & must appear in at least one input list of aspect " & "Depends", Item, Item_Id); + + -- Case of OUT parameter for which Is_Input is set + + if Nkind (Item) = N_Defining_Identifier + and then Ekind (Item) = E_Out_Parameter + then + -- One case is an unconstrained array where the bounds + -- must be read, if we have this case, output a message + -- indicating why the OUT parameter is read. + + if Is_Array_Type (Typ) + and then not Is_Constrained (Typ) + then + Error_Msg_NE + ("\& is an unconstrained array type, so bounds must be " + & "read", Item, Typ); + + -- Another case is an unconstrained discriminated record + -- type where the constrained flag must be read (and if + -- set, the discriminants). Again output a message. + + elsif Is_Record_Type (Typ) + and then Has_Discriminants (Typ) + and then not Is_Constrained (Typ) + then + Error_Msg_NE + ("\& is an unconstrained discriminated record type", + Item, Typ); + Error_Msg_N + ("\constrained flag and possible discriminants must be " + & "read", Item); + + -- Not clear if there are other cases. Anyway, we will + -- simply ignore any other cases. + + else + null; + end if; + end if; + + -- Output case + else Error_Msg_NE ("item & must appear in exactly one output list of aspect " diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index dbc13d34008..9289971d0f8 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -5279,8 +5279,7 @@ package body Sem_Res is is Subp_Alias : constant Entity_Id := Alias (S); begin - return S = E - or else (Present (Subp_Alias) and then Subp_Alias = E); + return S = E or else (Present (Subp_Alias) and then Subp_Alias = E); end Same_Or_Aliased_Subprograms; -- Start of processing for Resolve_Call @@ -5630,6 +5629,16 @@ package body Sem_Res is if Comes_From_Source (N) then Scop := Current_Scope; + -- Check violation of SPARK_05 restriction which does not permit + -- a subprogram body to contain a call to the subprogram directly. + + if Restriction_Check_Required (SPARK_05) + and then Same_Or_Aliased_Subprograms (Nam, Scop) + then + Check_SPARK_Restriction + ("subprogram may not contain direct call to itself", N); + end if; + -- Issue warning for possible infinite recursion in the absence -- of the No_Recursion restriction. diff --git a/gcc/ada/vms_data.ads b/gcc/ada/vms_data.ads index c3ad7565be6..6d81c4811f4 100644 --- a/gcc/ada/vms_data.ads +++ b/gcc/ada/vms_data.ads @@ -3368,7 +3368,8 @@ package VMS_Data is -- switch -gnat??. See below for list of these -- equivalent switch names. -- - -- NOTAG_WARNINGS Turns off warning tag output (default setting). + -- NOTAG_WARNINGS Turns off warning tag output (default + -- setting). -- -- The remaining entries control individual warning categories. If one -- of these options is preceded by NO (e.g. NOAVOID_GAPS), then the