diff options
author | charlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4> | 2014-06-11 12:29:22 +0000 |
---|---|---|
committer | charlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4> | 2014-06-11 12:29:22 +0000 |
commit | 48680a09307e648f40f02ba493c743c286666df6 (patch) | |
tree | 31866ba5fbc32c722c467efac24c59f04eeb55e7 /gcc | |
parent | 4ca8deee98c341c966014161c99d78a9aab34ad8 (diff) | |
download | gcc-48680a09307e648f40f02ba493c743c286666df6.tar.gz |
2014-06-11 Ed Schonberg <schonberg@adacore.com>
* sem_ch6.adb (Analyze_Subprogram_Body_Contract): Do not attempt
analysis if error has been posted on subprogram body.
2014-06-11 Ed Schonberg <schonberg@adacore.com>
* sem_ch13.adb (Analyze_Stream_TSS_Definition): Apply legality
rule given in RM 13.1 (8/1) for operational attributes to stream
attributes: the attribute must apply to a first subtype. Fixes
missing errors in ACATS test bdd2004.
2014-06-11 Robert Dewar <dewar@adacore.com>
* exp_ch3.adb (Build_Record_Init_Proc): Don't build for variant
record type if restriction No_Implicit_Conditionals is active.
(Expand_N_Object_Declaration): Don't allow default initialization
for variant record type if restriction No_Implicit_Condition is active.
(Build_Variant_Record_Equality): Don't build for variant
record type if restriction No_Implicit_Conditionals is active.
* exp_ch4.adb (Expand_N_Op_Eq): Error if variant records with
No_Implicit_Conditionals.
* sem_aux.ads, sem_aux.adb (Has_Variant_Part): New function.
2014-06-11 Ramon Fernandez <fernandez@adacore.com>
* i-cstrin.ads: Update comments.
2014-06-11 Ed Schonberg <schonberg@adacore.com>
* sem_res.adb (Resolve_Selected_Component): Handle properly a
selected component whose prefix is overloaded, when none of the
interpretations matches the expected type.
2014-06-11 Bob Duff <duff@adacore.com>
* make.adb (Wait_For_Available_Slot): Give a more
informative error message; if the ALI file is not found, print
the full path of what it's looking for.
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@211456 138bc75d-0d04-0410-961f-82ee72b054a4
Diffstat (limited to 'gcc')
-rw-r--r-- | gcc/ada/ChangeLog | 40 | ||||
-rw-r--r-- | gcc/ada/exp_ch3.adb | 99 | ||||
-rw-r--r-- | gcc/ada/exp_ch4.adb | 24 | ||||
-rw-r--r-- | gcc/ada/i-cstrin.ads | 4 | ||||
-rw-r--r-- | gcc/ada/make.adb | 9 | ||||
-rw-r--r-- | gcc/ada/sem_aux.adb | 45 | ||||
-rw-r--r-- | gcc/ada/sem_aux.ads | 6 | ||||
-rw-r--r-- | gcc/ada/sem_ch13.adb | 23 | ||||
-rw-r--r-- | gcc/ada/sem_ch6.adb | 4 | ||||
-rw-r--r-- | gcc/ada/sem_res.adb | 6 |
10 files changed, 220 insertions, 40 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 6575396f96d..66663a84ee0 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,43 @@ +2014-06-11 Ed Schonberg <schonberg@adacore.com> + + * sem_ch6.adb (Analyze_Subprogram_Body_Contract): Do not attempt + analysis if error has been posted on subprogram body. + +2014-06-11 Ed Schonberg <schonberg@adacore.com> + + * sem_ch13.adb (Analyze_Stream_TSS_Definition): Apply legality + rule given in RM 13.1 (8/1) for operational attributes to stream + attributes: the attribute must apply to a first subtype. Fixes + missing errors in ACATS test bdd2004. + +2014-06-11 Robert Dewar <dewar@adacore.com> + + * exp_ch3.adb (Build_Record_Init_Proc): Don't build for variant + record type if restriction No_Implicit_Conditionals is active. + (Expand_N_Object_Declaration): Don't allow default initialization + for variant record type if restriction No_Implicit_Condition is active. + (Build_Variant_Record_Equality): Don't build for variant + record type if restriction No_Implicit_Conditionals is active. + * exp_ch4.adb (Expand_N_Op_Eq): Error if variant records with + No_Implicit_Conditionals. + * sem_aux.ads, sem_aux.adb (Has_Variant_Part): New function. + +2014-06-11 Ramon Fernandez <fernandez@adacore.com> + + * i-cstrin.ads: Update comments. + +2014-06-11 Ed Schonberg <schonberg@adacore.com> + + * sem_res.adb (Resolve_Selected_Component): Handle properly a + selected component whose prefix is overloaded, when none of the + interpretations matches the expected type. + +2014-06-11 Bob Duff <duff@adacore.com> + + * make.adb (Wait_For_Available_Slot): Give a more + informative error message; if the ALI file is not found, print + the full path of what it's looking for. + 2014-06-11 Sergey Rybin <rybin@adacore.com frybin> * gnat_ugn.texi, vms_data.ads: add description of gnatstub -W<par> diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 6934363a565..a96f7f4534b 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- 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- -- @@ -3484,6 +3484,18 @@ package body Exp_Ch3 is Rec_Type := Underlying_Type (Rec_Type); end if; + -- If we have a variant record with restriction No_Implicit_Conditionals + -- in effect, then we skip building the procedure. This is safe because + -- if we can see the restriction, so can any caller, calls to initialize + -- such records are not allowed for variant records if this restriction + -- is active. + + if Has_Variant_Part (Rec_Type) + and then Restriction_Active (No_Implicit_Conditionals) + then + return; + end if; + -- If there are discriminants, build the discriminant map to replace -- discriminants by their discriminals in complex bound expressions. -- These only arise for the corresponding records of synchronized types. @@ -4316,6 +4328,16 @@ package body Exp_Ch3 is Pspecs : constant List_Id := New_List; begin + -- If we have a variant record with restriction No_Implicit_Conditionals + -- in effect, then we skip building the procedure. This is safe because + -- if we can see the restriction, so can any caller, calls to equality + -- test routines are not allowed for variant records if this restriction + -- is active. + + if Restriction_Active (No_Implicit_Conditionals) then + return; + end if; + -- Derived Unchecked_Union types no longer inherit the equality function -- of their parent. @@ -4431,11 +4453,8 @@ package body Exp_Ch3 is else Append_To (Stmts, - Make_Eq_If (Typ, - Discriminant_Specifications (Def))); - - Append_List_To (Stmts, - Make_Eq_Case (Typ, Comps)); + Make_Eq_If (Typ, Discriminant_Specifications (Def))); + Append_List_To (Stmts, Make_Eq_Case (Typ, Comps)); end if; Append_To (Stmts, @@ -4838,6 +4857,7 @@ package body Exp_Ch3 is Def_Id : constant Entity_Id := Defining_Identifier (N); Expr : constant Node_Id := Expression (N); Loc : constant Source_Ptr := Sloc (N); + Obj_Def : constant Node_Id := Object_Definition (N); Typ : constant Entity_Id := Etype (Def_Id); Base_Typ : constant Entity_Id := Base_Type (Typ); Expr_Q : Node_Id; @@ -4999,7 +5019,7 @@ package body Exp_Ch3 is and then Is_Entity_Name (Expr_Q) and then Ekind (Entity (Expr_Q)) = E_Variable and then OK_To_Rename (Entity (Expr_Q)) - and then Is_Entity_Name (Object_Definition (N)); + and then Is_Entity_Name (Obj_Def); end Rewrite_As_Renaming; -- Start of processing for Expand_N_Object_Declaration @@ -5065,6 +5085,26 @@ package body Exp_Ch3 is if No (Expr) then + -- If we have a type with a variant part, the initialization proc + -- will contain implicit tests of the discriminant values, which + -- counts as a violation of the restriction No_Implicit_Conditionals. + + if Has_Variant_Part (Typ) then + declare + Msg : Boolean; + + begin + Check_Restriction (Msg, No_Implicit_Conditionals, Obj_Def); + + if Msg then + Error_Msg_N + ("\initialization of variant record tests discriminants", + Obj_Def); + return; + end if; + end; + end if; + -- For the default initialization case, if we have a private type -- with invariants, and invariant checks are enabled, then insert an -- invariant check after the object declaration. Note that it is OK @@ -5305,9 +5345,9 @@ package body Exp_Ch3 is -- then we've done it already and must not do it again. and then not - (Nkind (Object_Definition (N)) = N_Identifier + (Nkind (Obj_Def) = N_Identifier and then - Present (Equivalent_Type (Entity (Object_Definition (N))))) + Present (Equivalent_Type (Entity (Obj_Def)))) then pragma Assert (Is_Class_Wide_Type (Typ)); @@ -5416,7 +5456,7 @@ package body Exp_Ch3 is Expand_Subtype_From_Expr (N => N, Unc_Type => Typ, - Subtype_Indic => Object_Definition (N), + Subtype_Indic => Obj_Def, Exp => Expr_N); if not Is_Interface (Etype (Expr_N)) then @@ -5427,7 +5467,7 @@ package body Exp_Ch3 is else New_Expr := - Unchecked_Convert_To (Etype (Object_Definition (N)), + Unchecked_Convert_To (Etype (Obj_Def), Make_Explicit_Dereference (Loc, Unchecked_Convert_To (RTE (RE_Tag_Ptr), Make_Attribute_Reference (Loc, @@ -5442,8 +5482,7 @@ package body Exp_Ch3 is Make_Object_Declaration (Loc, Defining_Identifier => Obj_Id, Object_Definition => - New_Occurrence_Of - (Etype (Object_Definition (N)), Loc), + New_Occurrence_Of (Etype (Obj_Def), Loc), Expression => New_Expr)); -- Rename limited type object since they cannot be copied @@ -5455,11 +5494,10 @@ package body Exp_Ch3 is Make_Object_Renaming_Declaration (Loc, Defining_Identifier => Obj_Id, Subtype_Mark => - New_Occurrence_Of - (Etype (Object_Definition (N)), Loc), + New_Occurrence_Of (Etype (Obj_Def), Loc), Name => Unchecked_Convert_To - (Etype (Object_Definition (N)), New_Expr))); + (Etype (Obj_Def), New_Expr))); end if; -- Dynamically reference the tag associated with the @@ -5744,7 +5782,7 @@ package body Exp_Ch3 is Rewrite (N, Make_Object_Renaming_Declaration (Loc, Defining_Identifier => Defining_Identifier (N), - Subtype_Mark => Object_Definition (N), + Subtype_Mark => Obj_Def, Name => Expr_Q)); -- We do not analyze this renaming declaration, because all its @@ -5778,7 +5816,7 @@ package body Exp_Ch3 is end if; if Nkind (N) = N_Object_Declaration - and then Nkind (Object_Definition (N)) = N_Access_Definition + and then Nkind (Obj_Def) = N_Access_Definition and then not Is_Local_Anonymous_Access (Etype (Def_Id)) then -- An Ada 2012 stand-alone object of an anonymous access type @@ -5810,12 +5848,14 @@ package body Exp_Ch3 is Level_Expr := Dynamic_Accessibility_Level (Expr); end if; - Level_Decl := Make_Object_Declaration (Loc, - Defining_Identifier => Level, - Object_Definition => New_Occurrence_Of (Standard_Natural, Loc), - Expression => Level_Expr, - Constant_Present => Constant_Present (N), - Has_Init_Expression => True); + Level_Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Level, + Object_Definition => + New_Occurrence_Of (Standard_Natural, Loc), + Expression => Level_Expr, + Constant_Present => Constant_Present (N), + Has_Init_Expression => True); Insert_Action_After (Init_After, Level_Decl); @@ -8641,6 +8681,7 @@ package body Exp_Ch3 is if Chars (Discr) = External_Name (Node (Elm)) then return Node (Elm); end if; + Next_Elmt (Elm); end loop; @@ -8676,14 +8717,12 @@ package body Exp_Ch3 is end if; Alt_List := New_List; - while Present (Variant) loop Append_To (Alt_List, Make_Case_Statement_Alternative (Loc, Discrete_Choices => New_Copy_List (Discrete_Choices (Variant)), Statements => Make_Eq_Case (E, Component_List (Variant), Discrs))); - Next_Non_Pragma (Variant); end loop; @@ -8785,7 +8824,7 @@ package body Exp_Ch3 is else return Make_Implicit_If_Statement (E, - Condition => Cond, + Condition => Cond, Then_Statements => New_List ( Make_Simple_Return_Statement (Loc, Expression => New_Occurrence_Of (Standard_False, Loc)))); @@ -8793,9 +8832,9 @@ package body Exp_Ch3 is end if; end Make_Eq_If; - -------------------- - -- Make_Neq_Body -- - -------------------- + ------------------- + -- Make_Neq_Body -- + ------------------- function Make_Neq_Body (Tag_Typ : Entity_Id) return Node_Id is diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index a3213aaeae5..40ac4093dfc 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -6674,6 +6674,8 @@ package body Exp_Ch4 is R_Exp : Node_Id := Relocate_Node (Rhs); begin + -- Adjust operands if necessary to comparison type + if Base_Type (Op_Type) /= Base_Type (A_Typ) and then not Is_Class_Wide_Type (A_Typ) then @@ -6771,8 +6773,7 @@ package body Exp_Ch4 is -- formal is that of the discriminant, with added suffix, -- see Exp_Ch3.Build_Record_Equality for details. - if Is_Unchecked_Union - (Scope (Entity (Selector_Name (Lhs)))) + if Is_Unchecked_Union (Scope (Entity (Selector_Name (Lhs)))) then Discr := First_Discriminant @@ -7074,6 +7075,25 @@ package body Exp_Ch4 is Typl := Base_Type (Typl); + -- Equality between variant records results in a call to a routine + -- that has conditional tests of the discriminant value(s), and hence + -- violates the No_Implicit_Conditionals restriction. + + if Has_Variant_Part (Typl) then + declare + Msg : Boolean; + + begin + Check_Restriction (Msg, No_Implicit_Conditionals, N); + + if Msg then + Error_Msg_N + ("\comparison of variant records tests discriminants", N); + return; + end if; + end; + end if; + -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that -- means we no longer have a comparison operation, we are all done. diff --git a/gcc/ada/i-cstrin.ads b/gcc/ada/i-cstrin.ads index bebf6c02d26..833a69ac6f7 100644 --- a/gcc/ada/i-cstrin.ads +++ b/gcc/ada/i-cstrin.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1993-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1993-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 -- @@ -60,6 +60,8 @@ package Interfaces.C.Strings is function New_String (Str : String) return chars_ptr; procedure Free (Item : in out chars_ptr); + -- When deallocation is prohibited (eg: cert runtimes) this routine + -- will raise Program_Error Dereference_Error : exception; diff --git a/gcc/ada/make.adb b/gcc/ada/make.adb index e8acb4e604a..6e07eb18425 100644 --- a/gcc/ada/make.adb +++ b/gcc/ada/make.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- 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- -- @@ -3728,6 +3728,13 @@ package body Make is Inform (Data.Lib_File, "WARNING: ALI or object file not found after compile"); + + if not Is_Regular_File + (Get_Name_String (Name_Id (Data.Full_Lib_File))) + then + Inform (Data.Full_Lib_File, "not found"); + end if; + Record_Failure (Data.Full_Source_File, Data.Source_Unit); end if; end if; diff --git a/gcc/ada/sem_aux.adb b/gcc/ada/sem_aux.adb index 897d99b4d22..f36c500bd08 100644 --- a/gcc/ada/sem_aux.adb +++ b/gcc/ada/sem_aux.adb @@ -666,6 +666,51 @@ package body Sem_Aux is end if; end Has_Unconstrained_Elements; + ---------------------- + -- Has_Variant_Part -- + ---------------------- + + function Has_Variant_Part (Typ : Entity_Id) return Boolean is + FSTyp : Entity_Id; + Decl : Node_Id; + TDef : Node_Id; + CList : Node_Id; + + begin + if not Is_Type (Typ) then + return False; + end if; + + FSTyp := First_Subtype (Typ); + + if not Has_Discriminants (FSTyp) then + return False; + end if; + + -- Proceed with cautious checks here, return False if tree is not + -- as expected (may be caused by prior errors). + + Decl := Declaration_Node (FSTyp); + + if Nkind (Decl) /= N_Full_Type_Declaration then + return False; + end if; + + TDef := Type_Definition (Decl); + + if Nkind (TDef) /= N_Record_Definition then + return False; + end if; + + CList := Component_List (TDef); + + if Nkind (CList) /= N_Component_List then + return False; + else + return Present (Variant_Part (CList)); + end if; + end Has_Variant_Part; + --------------------- -- In_Generic_Body -- --------------------- diff --git a/gcc/ada/sem_aux.ads b/gcc/ada/sem_aux.ads index 6a3ebeb7840..d394d0975c0 100644 --- a/gcc/ada/sem_aux.ads +++ b/gcc/ada/sem_aux.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- 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- -- @@ -255,6 +255,10 @@ package Sem_Aux is -- True if T has discriminants and is unconstrained, or is an array type -- whose element type Has_Unconstrained_Elements. + function Has_Variant_Part (Typ : Entity_Id) return Boolean; + -- Return True if the first subtype of Typ is a discriminated record type + -- which has a variant part. False otherwise. + function In_Generic_Body (Id : Entity_Id) return Boolean; -- Determine whether entity Id appears inside a generic body diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 585a6d6492f..363572f8e46 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -3132,8 +3132,23 @@ package body Sem_Ch13 is Typ := Etype (Subp); end if; - return Base_Type (Typ) = Base_Type (Ent) - and then No (Next_Formal (F)); + -- Verify that the prefix of the attribute and the local name + -- for the type of the formal match. + + if Base_Type (Typ) /= Base_Type (Ent) + or else Present ((Next_Formal (F))) + then + return False; + + elsif not Is_Scalar_Type (Typ) + and then not Is_First_Subtype (Typ) + and then not Is_Class_Wide_Type (Typ) + then + return False; + + else + return True; + end if; end Has_Good_Profile; -- Start of processing for Analyze_Stream_TSS_Definition @@ -3144,6 +3159,10 @@ package body Sem_Ch13 is if not Is_Type (U_Ent) then Error_Msg_N ("local name must be a subtype", Nam); return; + + elsif not Is_First_Subtype (U_Ent) then + Error_Msg_N ("local name must be a first subtype", Nam); + return; end if; Pnam := TSS (Base_Type (U_Ent), TSS_Nam); diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index d8b70c8238e..4da9220a3d5 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -2040,9 +2040,9 @@ package body Sem_Ch6 is begin -- When a subprogram body declaration is illegal, its defining entity is -- left unanalyzed. There is nothing left to do in this case because the - -- body lacks a contract. + -- body lacks a contract, or even a proper Ekind. - if No (Contract (Body_Id)) then + if Ekind (Body_Id) = E_Void then return; end if; diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index c1f9f8c4deb..7659db7c812 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -9159,7 +9159,7 @@ package body Sem_Res is Comp := First_Entity (T); while Present (Comp) loop if Chars (Comp) = Chars (S) - and then Covers (Etype (Comp), Typ) + and then Covers (Typ, Etype (Comp)) then if not Found then Found := True; @@ -9213,6 +9213,9 @@ package body Sem_Res is Get_Next_Interp (I, It); end loop Search; + -- There must be a legal interpreations at this point. + + pragma Assert (Found); Resolve (P, It1.Typ); Set_Etype (N, Typ); Set_Entity_With_Checks (S, Comp1); @@ -9240,6 +9243,7 @@ package body Sem_Res is if Is_Access_Type (Etype (P)) then T := Designated_Type (Etype (P)); Check_Fully_Declared_Prefix (T, P); + else T := Etype (P); end if; |