From dda3871423cbbdfc549a98034201f2c6e2e0d8ab Mon Sep 17 00:00:00 2001
From: Arnaud Charlet <charlet@gcc.gnu.org>
Date: Wed, 11 Jun 2014 14:29:22 +0200
Subject: [PATCH] [multiple changes]
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.
From-SVN: r211456
---
gcc/ada/ChangeLog | 40 ++++++++++++++++++
gcc/ada/exp_ch3.adb | 99 ++++++++++++++++++++++++++++++--------------
gcc/ada/exp_ch4.adb | 24 ++++++++++-
gcc/ada/i-cstrin.ads | 4 +-
gcc/ada/make.adb | 9 +++-
gcc/ada/sem_aux.adb | 45 ++++++++++++++++++++
gcc/ada/sem_aux.ads | 6 ++-
gcc/ada/sem_ch13.adb | 23 +++++++++-
gcc/ada/sem_ch6.adb | 4 +-
gcc/ada/sem_res.adb | 6 ++-
10 files changed, 220 insertions(+), 40 deletions(-)
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 6575396f96d0..66663a84ee0c 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 6934363a565e..a96f7f4534b8 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 a3213aaeae56..40ac4093dfcf 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 bebf6c02d260..833a69ac6f72 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 e8acb4e604a6..6e07eb184254 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 897d99b4d222..f36c500bd080 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 6a3ebeb7840a..d394d0975c06 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 585a6d6492f9..363572f8e46b 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 d8b70c8238ec..4da9220a3d52 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 c1f9f8c4deb7..7659db7c8126 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;
--
GitLab