From 77d3568815aaad6487a295a42e0fce17c1c71b19 Mon Sep 17 00:00:00 2001
From: bstarynk <bstarynk@138bc75d-0d04-0410-961f-82ee72b054a4>
Date: Mon, 11 Oct 2010 21:44:44 +0000
Subject: 2010-10-11 Basile Starynkevitch <basile@starynkevitch.net>
MELT branch merged with trunk rev 165329
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/branches/melt-branch@165333 138bc75d-0d04-0410-961f-82ee72b054a4
---
gcc/ada/sem_res.adb | 86 ++++++++++++++++++++++++++++++++---------------------
1 file changed, 52 insertions(+), 34 deletions(-)
(limited to 'gcc/ada/sem_res.adb')
diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb
index ecc1dfbb0d2..5955070260a 100644
--- a/gcc/ada/sem_res.adb
+++ b/gcc/ada/sem_res.adb
@@ -301,7 +301,7 @@ package body Sem_Res is
-- Include Wide_Wide_Character in Ada 2005 mode
- if Ada_Version >= Ada_05 then
+ if Ada_Version >= Ada_2005 then
Error_Msg_N ("\\possible interpretation: Wide_Wide_Character!", C);
end if;
@@ -708,7 +708,7 @@ package body Sem_Res is
-- are handled by Analyze_Access_Attribute, Analyze_Assignment,
-- Analyze_Object_Renaming, and Freeze_Entity.
- elsif Ada_Version >= Ada_05
+ elsif Ada_Version >= Ada_2005
and then Is_Entity_Name (Pref)
and then Is_Access_Type (Etype (Pref))
and then Ekind (Directly_Designated_Type (Etype (Pref))) =
@@ -1372,7 +1372,7 @@ package body Sem_Res is
-- Ada 2005 AI-420: Predefined equality on Universal_Access is
-- available.
- elsif Ada_Version >= Ada_05
+ elsif Ada_Version >= Ada_2005
and then (Op_Name = Name_Op_Eq or else Op_Name = Name_Op_Ne)
and then Ekind (Etype (Act1)) = E_Anonymous_Access_Type
then
@@ -2045,7 +2045,7 @@ package body Sem_Res is
-- type against which we are resolving is the same as the
-- type of the interpretation.
- if Ada_Version >= Ada_05
+ if Ada_Version >= Ada_2005
and then It.Typ = Typ
and then Typ /= Universal_Integer
and then Typ /= Universal_Real
@@ -3351,7 +3351,7 @@ package body Sem_Res is
(Etype (Expression (A)));
begin
if Comes_From_Source (A)
- and then Ada_Version >= Ada_05
+ and then Ada_Version >= Ada_2005
and then
((Is_Private_Type (Comp_Type)
and then not Is_Generic_Type (Comp_Type))
@@ -3674,18 +3674,28 @@ package body Sem_Res is
Apply_Range_Check (A, F_Typ);
end if;
- -- Ada 2005 (AI-231)
+ -- Ada 2005 (AI-231): Note that the controlling parameter case
+ -- already existed in Ada 95, which is partially checked
+ -- elsewhere (see Checks), and we don't want the warning
+ -- message to differ.
- if Ada_Version >= Ada_05
- and then Is_Access_Type (F_Typ)
+ if Is_Access_Type (F_Typ)
and then Can_Never_Be_Null (F_Typ)
and then Known_Null (A)
then
- Apply_Compile_Time_Constraint_Error
- (N => A,
- Msg => "(Ada 2005) null not allowed in "
- & "null-excluding formal?",
- Reason => CE_Null_Not_Allowed);
+ if Is_Controlling_Formal (F) then
+ Apply_Compile_Time_Constraint_Error
+ (N => A,
+ Msg => "null value not allowed here?",
+ Reason => CE_Access_Check_Failed);
+
+ elsif Ada_Version >= Ada_2005 then
+ Apply_Compile_Time_Constraint_Error
+ (N => A,
+ Msg => "(Ada 2005) null not allowed in "
+ & "null-excluding formal?",
+ Reason => CE_Null_Not_Allowed);
+ end if;
end if;
end if;
@@ -4259,7 +4269,7 @@ package body Sem_Res is
-- the case of an initialized allocator with a class-wide argument (see
-- Expand_Allocator_Expression).
- if Ada_Version >= Ada_05
+ if Ada_Version >= Ada_2005
and then Is_Class_Wide_Type (Designated_Type (Typ))
then
declare
@@ -5047,7 +5057,7 @@ package body Sem_Res is
and then Nkind (N) /= N_Entry_Call_Statement
and then Entry_Call_Statement (Parent (N)) = N
then
- if Ada_Version < Ada_05 then
+ if Ada_Version < Ada_2005 then
Error_Msg_N ("entry call required in select statement", N);
-- Ada 2005 (AI-345): If a procedure_call_statement is used
@@ -5527,10 +5537,10 @@ package body Sem_Res is
then
Generate_Reference (Nam, Subp, 'R');
- -- Normal case, not a dispatching call
+ -- Normal case, not a dispatching call. Generate a call reference.
else
- Generate_Reference (Nam, Subp);
+ Generate_Reference (Nam, Subp, 's');
end if;
if Is_Intrinsic_Subprogram (Nam) then
@@ -6328,7 +6338,10 @@ package body Sem_Res is
end if;
Resolve_Actuals (N, Nam);
- Generate_Reference (Nam, Entry_Name);
+
+ -- Create a call reference to the entry
+
+ Generate_Reference (Nam, Entry_Name, 's');
if Ekind_In (Nam, E_Entry, E_Entry_Family) then
Check_Potentially_Blocking_Operation (N);
@@ -7140,7 +7153,7 @@ package body Sem_Res is
-- In this case we have nothing else to do. The membership test will be
-- done at run time.
- elsif Ada_Version >= Ada_05
+ elsif Ada_Version >= Ada_2005
and then Is_Class_Wide_Type (Etype (L))
and then Is_Interface (Etype (L))
and then Is_Class_Wide_Type (Etype (R))
@@ -7196,7 +7209,7 @@ package body Sem_Res is
-- Ada 2005 (AI-231): Remove restriction
- if Ada_Version < Ada_05
+ if Ada_Version < Ada_2005
and then not Debug_Flag_J
and then Ekind (Typ) = E_Anonymous_Access_Type
and then Comes_From_Source (N)
@@ -7221,7 +7234,7 @@ package body Sem_Res is
-- Ada 2005 (AI-231): Generate the null-excluding check in case of
-- assignment to a null-excluding object
- if Ada_Version >= Ada_05
+ if Ada_Version >= Ada_2005
and then Can_Never_Be_Null (Typ)
and then Nkind (Parent (N)) = N_Assignment_Statement
then
@@ -8362,23 +8375,28 @@ package body Sem_Res is
Index := First_Index (Array_Type);
Resolve (Drange, Base_Type (Etype (Index)));
- if Nkind (Drange) = N_Range
+ if Nkind (Drange) = N_Range then
+
+ -- Ensure that side effects in the bounds are properly handled
+
+ Remove_Side_Effects (Low_Bound (Drange), Variable_Ref => True);
+ Remove_Side_Effects (High_Bound (Drange), Variable_Ref => True);
-- Do not apply the range check to nodes associated with the
-- frontend expansion of the dispatch table. We first check
- -- if Ada.Tags is already loaded to void the addition of an
+ -- if Ada.Tags is already loaded to avoid the addition of an
-- undesired dependence on such run-time unit.
- and then
- (not Tagged_Type_Expansion
- or else not
- (RTU_Loaded (Ada_Tags)
- and then Nkind (Prefix (N)) = N_Selected_Component
- and then Present (Entity (Selector_Name (Prefix (N))))
- and then Entity (Selector_Name (Prefix (N))) =
- RTE_Record_Component (RE_Prims_Ptr)))
- then
- Apply_Range_Check (Drange, Etype (Index));
+ if not Tagged_Type_Expansion
+ or else not
+ (RTU_Loaded (Ada_Tags)
+ and then Nkind (Prefix (N)) = N_Selected_Component
+ and then Present (Entity (Selector_Name (Prefix (N))))
+ and then Entity (Selector_Name (Prefix (N))) =
+ RTE_Record_Component (RE_Prims_Ptr))
+ then
+ Apply_Range_Check (Drange, Etype (Index));
+ end if;
end if;
end if;
@@ -8898,7 +8916,7 @@ package body Sem_Res is
-- No need to perform any interface conversion if the type of the
-- expression coincides with the target type.
- if Ada_Version >= Ada_05
+ if Ada_Version >= Ada_2005
and then Expander_Active
and then Operand_Typ /= Target_Typ
then
--
cgit v1.2.1