Skip to content

R
riscv-gcc-1
Commit a51368fa by Arnaud Charlet
Options

[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
parent c7775327
Showing with 149 additions and 75 deletions
gcc/ada/ChangeLog
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,
......
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);
......
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);
......
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
......
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),
......
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);
......
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 --
---------------------------------
......
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,
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment