From a51368fad9985f84e3215cf9897f389698fbbba5 Mon Sep 17 00:00:00 2001
From: Arnaud Charlet <charlet@gcc.gnu.org>
Date: Mon, 23 Jan 2017 13:04:16 +0100
Subject: [PATCH] [multiple changes]
2017-01-23 Pascal Obry <obry@adacore.com>
* s-taprop-mingw.adb (Enter_Task): Initialize the Thread handle which
is needed when a foreign thread call a Win32 API using a thread handle
like GetThreadTimes() for example.
2017-01-23 Hristian Kirtchev <kirtchev@adacore.com>
* sem_ch13.adb (Analyze_Attribute_Definition_Clause): Do not
allow an 'Address clause to be specified on a prefix of a
class-wide type.
2017-01-23 Hristian Kirtchev <kirtchev@adacore.com>
* checks.adb (Insert_Valid_Check): Ensure that the prefix of
attribute 'Valid is a renaming of the original expression when
the expression denotes a name. For all other kinds of expression,
use a constant to capture the value.
* exp_util.adb (Is_Name_Reference): Moved to Sem_Util.
* sem_util.ads, sem_util.adb (Is_Name_Reference): Moved from Exp_Util.
2017-01-23 Justin Squirek <squirek@adacore.com>
* sem_eval.adb (Eval_Integer_Literal): Add special
case to avoid optimizing out check if the literal appears in
an if-expression.
From-SVN: r244792
---
gcc/ada/ChangeLog | 48 ++++++++++++++++++++++++++++++
gcc/ada/checks.adb | 8 ++++-
gcc/ada/exp_util.adb | 61 --------------------------------------
gcc/ada/s-taprop-mingw.adb | 25 +++++++++-------
gcc/ada/sem_ch13.adb | 15 +++++++++-
gcc/ada/sem_eval.adb | 7 +++--
gcc/ada/sem_util.adb | 54 +++++++++++++++++++++++++++++++++
gcc/ada/sem_util.ads | 6 ++++
8 files changed, 149 insertions(+), 75 deletions(-)
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index e05fcaa9c358..10a61b88759a 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,51 @@
+2017-01-23 Pascal Obry <obry@adacore.com>
+
+ * s-taprop-mingw.adb (Enter_Task): Initialize the Thread handle which
+ is needed when a foreign thread call a Win32 API using a thread handle
+ like GetThreadTimes() for example.
+
+2017-01-23 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * sem_ch13.adb (Analyze_Attribute_Definition_Clause): Do not
+ allow an 'Address clause to be specified on a prefix of a
+ class-wide type.
+
+2017-01-23 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * checks.adb (Insert_Valid_Check): Ensure that the prefix of
+ attribute 'Valid is a renaming of the original expression when
+ the expression denotes a name. For all other kinds of expression,
+ use a constant to capture the value.
+ * exp_util.adb (Is_Name_Reference): Moved to Sem_Util.
+ * sem_util.ads, sem_util.adb (Is_Name_Reference): Moved from Exp_Util.
+
+2017-01-23 Justin Squirek <squirek@adacore.com>
+
+ * sem_eval.adb (Eval_Integer_Literal): Add special
+ case to avoid optimizing out check if the literal appears in
+ an if-expression.
+
+2017-01-23 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * sem_ch13.adb (Analyze_Attribute_Definition_Clause): Do not
+ allow an 'Address clause to be specified on a prefix of a
+ class-wide type.
+
+2017-01-23 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * checks.adb (Insert_Valid_Check): Ensure that the prefix of
+ attribute 'Valid is a renaming of the original expression when
+ the expression denotes a name. For all other kinds of expression,
+ use a constant to capture the value.
+ * exp_util.adb (Is_Name_Reference): Moved to Sem_Util.
+ * sem_util.ads, sem_util.adb (Is_Name_Reference): Moved from Exp_Util.
+
+2017-01-23 Justin Squirek <squirek@adacore.com>
+
+ * sem_eval.adb (Eval_Integer_Literal): Add special
+ case to avoid optimizing out check if the literal appears in
+ an if-expression.
+
2017-01-23 Ed Schonberg <schonberg@adacore.com>
* sem_ch4.adb (Try_Primitive_Operations,
diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb
index 7f4a5894696b..011878eb046d 100644
--- a/gcc/ada/checks.adb
+++ b/gcc/ada/checks.adb
@@ -7206,12 +7206,18 @@ package body Checks is
Force_Evaluation (Exp, Name_Req => False);
end if;
- -- Build the prefix for the 'Valid call
+ -- Build the prefix for the 'Valid call. If the expression denotes
+ -- a name, use a renaming to alias it, otherwise use a constant to
+ -- capture the value of the expression.
+
+ -- Temp : ... renames Expr; -- reference to a name
+ -- Temp : constant ... := Expr; -- all other cases
PV :=
Duplicate_Subexpr_No_Checks
(Exp => Exp,
Name_Req => False,
+ Renaming_Req => Is_Name_Reference (Exp),
Related_Id => Related_Id,
Is_Low_Bound => Is_Low_Bound,
Is_High_Bound => Is_High_Bound);
diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb
index e828a1e0978d..a0b0edad1914 100644
--- a/gcc/ada/exp_util.adb
+++ b/gcc/ada/exp_util.adb
@@ -9014,12 +9014,6 @@ package body Exp_Util is
-- is present (xxx is taken from the Chars field of Related_Nod),
-- otherwise it generates an internal temporary.
- function Is_Name_Reference (N : Node_Id) return Boolean;
- -- Determine if the tree referenced by N represents a name. This is
- -- similar to Is_Object_Reference but returns true only if N can be
- -- renamed without the need for a temporary, the typical example of
- -- an object not in this category being a function call.
-
---------------------
-- Build_Temporary --
---------------------
@@ -9050,61 +9044,6 @@ package body Exp_Util is
end if;
end Build_Temporary;
- -----------------------
- -- Is_Name_Reference --
- -----------------------
-
- function Is_Name_Reference (N : Node_Id) return Boolean is
- begin
- if Is_Entity_Name (N) then
- return Present (Entity (N)) and then Is_Object (Entity (N));
- end if;
-
- case Nkind (N) is
- when N_Indexed_Component
- | N_Slice
- =>
- return
- Is_Name_Reference (Prefix (N))
- or else Is_Access_Type (Etype (Prefix (N)));
-
- -- Attributes 'Input, 'Old and 'Result produce objects
-
- when N_Attribute_Reference =>
- return
- Nam_In
- (Attribute_Name (N), Name_Input, Name_Old, Name_Result);
-
- when N_Selected_Component =>
- return
- Is_Name_Reference (Selector_Name (N))
- and then
- (Is_Name_Reference (Prefix (N))
- or else Is_Access_Type (Etype (Prefix (N))));
-
- when N_Explicit_Dereference =>
- return True;
-
- -- A view conversion of a tagged name is a name reference
-
- when N_Type_Conversion =>
- return
- Is_Tagged_Type (Etype (Subtype_Mark (N)))
- and then Is_Tagged_Type (Etype (Expression (N)))
- and then Is_Name_Reference (Expression (N));
-
- -- An unchecked type conversion is considered to be a name if
- -- the operand is a name (this construction arises only as a
- -- result of expansion activities).
-
- when N_Unchecked_Type_Conversion =>
- return Is_Name_Reference (Expression (N));
-
- when others =>
- return False;
- end case;
- end Is_Name_Reference;
-
-- Local variables
Loc : constant Source_Ptr := Sloc (Exp);
diff --git a/gcc/ada/s-taprop-mingw.adb b/gcc/ada/s-taprop-mingw.adb
index c945e1dfcc7a..aba2367310d0 100644
--- a/gcc/ada/s-taprop-mingw.adb
+++ b/gcc/ada/s-taprop-mingw.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNARL 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- --
@@ -157,11 +157,19 @@ package body System.Task_Primitives.Operations is
package body Specific is
+ -------------------
+ -- Is_Valid_Task --
+ -------------------
+
function Is_Valid_Task return Boolean is
begin
return TlsGetValue (TlsIndex) /= System.Null_Address;
end Is_Valid_Task;
+ ---------
+ -- Set --
+ ---------
+
procedure Set (Self_Id : Task_Id) is
Succeeded : BOOL;
begin
@@ -761,13 +769,9 @@ package body System.Task_Primitives.Operations is
-- 1) from System.Task_Primitives.Operations.Initialize
-- 2) from System.Tasking.Stages.Task_Wrapper
- -- The thread initialisation has to be done only for the first case
-
- -- This is because the GetCurrentThread NT call does not return the real
- -- thread handler but only a "pseudo" one. It is not possible to release
- -- the thread handle and free the system resources from this "pseudo"
- -- handle. So we really want to keep the real thread handle set in
- -- System.Task_Primitives.Operations.Create_Task during thread creation.
+ -- The pseudo handle (LL.Thread) need not be closed when it is no
+ -- longer needed. Calling the CloseHandle function with this handle
+ -- has no effect.
procedure Enter_Task (Self_ID : Task_Id) is
procedure Get_Stack_Bounds (Base : Address; Limit : Address);
@@ -787,6 +791,7 @@ package body System.Task_Primitives.Operations is
raise Invalid_CPU_Number;
end if;
+ Self_ID.Common.LL.Thread := GetCurrentThread;
Self_ID.Common.LL.Thread_Id := GetCurrentThreadId;
Get_Stack_Bounds
@@ -887,8 +892,8 @@ package body System.Task_Primitives.Operations is
DWORD (Stack_Size),
Entry_Point,
pTaskParameter,
- DWORD (Create_Suspended) or
- DWORD (Stack_Size_Param_Is_A_Reservation),
+ DWORD (Create_Suspended)
+ or DWORD (Stack_Size_Param_Is_A_Reservation),
TaskId'Unchecked_Access);
else
hTask := CreateThread
diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb
index db0b1d8c364a..f8078ff62f38 100644
--- a/gcc/ada/sem_ch13.adb
+++ b/gcc/ada/sem_ch13.adb
@@ -4915,7 +4915,20 @@ package body Sem_Ch13 is
or else Has_Controlled_Component (Etype (U_Ent))
then
Error_Msg_NE
- ("??controlled object& must not be overlaid", Nam, U_Ent);
+ ("??controlled object & must not be overlaid", Nam, U_Ent);
+ Error_Msg_N
+ ("\??Program_Error will be raised at run time", Nam);
+ Insert_Action (Declaration_Node (U_Ent),
+ Make_Raise_Program_Error (Loc,
+ Reason => PE_Overlaid_Controlled_Object));
+ return;
+
+ -- Case of an address clause for a class-wide object which is
+ -- considered erroneous.
+
+ elsif Is_Class_Wide_Type (Etype (U_Ent)) then
+ Error_Msg_NE
+ ("??class-wide object & must not be overlaid", Nam, U_Ent);
Error_Msg_N
("\??Program_Error will be raised at run time", Nam);
Insert_Action (Declaration_Node (U_Ent),
diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb
index 0d135cf3d60a..6e56e1d10bfd 100644
--- a/gcc/ada/sem_eval.adb
+++ b/gcc/ada/sem_eval.adb
@@ -2682,9 +2682,12 @@ package body Sem_Eval is
-- If the literal appears in a non-expression context, then it is
-- certainly appearing in a non-static context, so check it. This is
-- actually a redundant check, since Check_Non_Static_Context would
- -- check it, but it seems worth while avoiding the call.
+ -- check it, but it seems worth while to optimize out the call.
- if Nkind (Parent (N)) not in N_Subexpr
+ -- An exception is made for a literal in an if or case expression
+
+ if (Nkind_In (Parent (N), N_If_Expression, N_Case_Expression_Alternative)
+ or else Nkind (Parent (N)) not in N_Subexpr)
and then not In_Any_Integer_Context
then
Check_Non_Static_Context (N);
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index 752a69b16e48..fd45a3866783 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -13405,6 +13405,60 @@ package body Sem_Util is
end if;
end Is_Local_Variable_Reference;
+ -----------------------
+ -- Is_Name_Reference --
+ -----------------------
+
+ function Is_Name_Reference (N : Node_Id) return Boolean is
+ begin
+ if Is_Entity_Name (N) then
+ return Present (Entity (N)) and then Is_Object (Entity (N));
+ end if;
+
+ case Nkind (N) is
+ when N_Indexed_Component
+ | N_Slice
+ =>
+ return
+ Is_Name_Reference (Prefix (N))
+ or else Is_Access_Type (Etype (Prefix (N)));
+
+ -- Attributes 'Input, 'Old and 'Result produce objects
+
+ when N_Attribute_Reference =>
+ return
+ Nam_In (Attribute_Name (N), Name_Input, Name_Old, Name_Result);
+
+ when N_Selected_Component =>
+ return
+ Is_Name_Reference (Selector_Name (N))
+ and then
+ (Is_Name_Reference (Prefix (N))
+ or else Is_Access_Type (Etype (Prefix (N))));
+
+ when N_Explicit_Dereference =>
+ return True;
+
+ -- A view conversion of a tagged name is a name reference
+
+ when N_Type_Conversion =>
+ return
+ Is_Tagged_Type (Etype (Subtype_Mark (N)))
+ and then Is_Tagged_Type (Etype (Expression (N)))
+ and then Is_Name_Reference (Expression (N));
+
+ -- An unchecked type conversion is considered to be a name if the
+ -- operand is a name (this construction arises only as a result of
+ -- expansion activities).
+
+ when N_Unchecked_Type_Conversion =>
+ return Is_Name_Reference (Expression (N));
+
+ when others =>
+ return False;
+ end case;
+ end Is_Name_Reference;
+
---------------------------------
-- Is_Nontrivial_DIC_Procedure --
---------------------------------
diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads
index d08480087534..42d51a5f848b 100644
--- a/gcc/ada/sem_util.ads
+++ b/gcc/ada/sem_util.ads
@@ -1548,6 +1548,12 @@ package Sem_Util is
-- parameter of the current enclosing subprogram.
-- Why are OUT parameters not considered here ???
+ function Is_Name_Reference (N : Node_Id) return Boolean;
+ -- Determine whether arbitrary node N is a reference to a name. This is
+ -- similar to Is_Object_Reference but returns True only if N can be renamed
+ -- without the need for a temporary, the typical example of an object not
+ -- in this category being a function call.
+
function Is_Nontrivial_DIC_Procedure (Id : Entity_Id) return Boolean;
-- Determine whether entity Id denotes the procedure that verifies the
-- assertion expression of pragma Default_Initial_Condition and if it does,
--
GitLab