Commit 5067f3a0 by Pierre-Marie de Rodat

[multiple changes]

2017-09-13  Eric Botcazou  <ebotcazou@adacore.com>

	* sem_ch13.adb (Register_Address_Clause_Check): New procedure to save
	the suppression status of Alignment_Check on the current scope.
	(Alignment_Checks_Suppressed): New function to use the saved instead of
	the current suppression status of Alignment_Check.
	(Address_Clause_Check_Record): Add Alignment_Checks_Suppressed field.
	(Analyze_Attribute_Definition_Clause): Instead of manually appending to
	the table, call Register_Address_Clause_Check.
	(Validate_Address_Clauses): Call Alignment_Checks_Suppressed on the
	recorded address clause instead of its entity.

2017-09-13  Jerome Guitton  <guitton@adacore.com>

	* libgnarl/s-tpopsp__vxworks-tls.adb,
	libgnarl/s-tpopsp__vxworks-rtp.adb, libgnarl/s-tpopsp__vxworks.adb
	(Self): Register thread if task id is null.

2017-09-13  Arnaud Charlet  <charlet@adacore.com>

	* libgnat/s-htable.adb, libgnat/s-htable.ads: Minor style tuning.

2017-09-13  Arnaud Charlet  <charlet@adacore.com>

	* lib-xref-spark_specific.adb (Scopes): simplify hash map; now it maps
	from an entity to only scope index, as a mapping from an entity to the
	same entity was useless.
	(Get_Scope_Num): refactor as a simple renaming; rename parameter from N
	to E.
	(Set_Scope_Num): refactor as a simple renaming; rename parameter from N
	to E.
	(Is_Constant_Object_Without_Variable_Input): remove local "Result"
	variable, just use return statements.

From-SVN: r252076
parent 231bba8d
2017-09-13 Eric Botcazou <ebotcazou@adacore.com>
* sem_ch13.adb (Register_Address_Clause_Check): New procedure to save
the suppression status of Alignment_Check on the current scope.
(Alignment_Checks_Suppressed): New function to use the saved instead of
the current suppression status of Alignment_Check.
(Address_Clause_Check_Record): Add Alignment_Checks_Suppressed field.
(Analyze_Attribute_Definition_Clause): Instead of manually appending to
the table, call Register_Address_Clause_Check.
(Validate_Address_Clauses): Call Alignment_Checks_Suppressed on the
recorded address clause instead of its entity.
2017-09-13 Jerome Guitton <guitton@adacore.com>
* libgnarl/s-tpopsp__vxworks-tls.adb,
libgnarl/s-tpopsp__vxworks-rtp.adb, libgnarl/s-tpopsp__vxworks.adb
(Self): Register thread if task id is null.
2017-09-13 Arnaud Charlet <charlet@adacore.com>
* libgnat/s-htable.adb, libgnat/s-htable.ads: Minor style tuning.
2017-09-13 Arnaud Charlet <charlet@adacore.com>
* lib-xref-spark_specific.adb (Scopes): simplify hash map; now it maps
from an entity to only scope index, as a mapping from an entity to the
same entity was useless.
(Get_Scope_Num): refactor as a simple renaming; rename parameter from N
to E.
(Set_Scope_Num): refactor as a simple renaming; rename parameter from N
to E.
(Is_Constant_Object_Without_Variable_Input): remove local "Result"
variable, just use return statements.
2017-09-13 Arnaud Charlet <charlet@adacore.com>
* libgnarl/s-vxwext__kernel-smp.adb,
......
......@@ -215,24 +215,20 @@ package body SPARK_Specific is
-- Packages
or else Nkind_In (N, N_Package_Body,
N_Package_Body_Stub,
N_Package_Declaration)
-- Protected units
or else Nkind_In (N, N_Protected_Body,
N_Protected_Body_Stub,
N_Protected_Type_Declaration)
-- Subprograms
or else Nkind_In (N, N_Subprogram_Body,
N_Subprogram_Body_Stub,
N_Subprogram_Declaration)
-- Task units
or else Nkind_In (N, N_Task_Body,
N_Task_Body_Stub,
N_Task_Type_Declaration)
then
Add_SPARK_Scope (N);
......@@ -310,8 +306,8 @@ package body SPARK_Specific is
function Get_Entity_Type (E : Entity_Id) return Character;
-- Return a character representing the type of entity
function Get_Scope_Num (N : Entity_Id) return Nat;
-- Return the scope number associated to entity N
function Get_Scope_Num (E : Entity_Id) return Nat;
-- Return the scope number associated with the entity E
function Is_Constant_Object_Without_Variable_Input
(E : Entity_Id) return Boolean;
......@@ -339,8 +335,8 @@ package body SPARK_Specific is
procedure Move (From : Natural; To : Natural);
-- Move procedure for Sort call
procedure Set_Scope_Num (N : Entity_Id; Num : Nat);
-- Associate entity N to scope number Num
procedure Set_Scope_Num (E : Entity_Id; Num : Nat);
-- Associate entity E with the scope number Num
procedure Update_Scope_Range
(S : Scope_Index;
......@@ -353,16 +349,10 @@ package body SPARK_Specific is
No_Scope : constant Nat := 0;
-- Initial scope counter
type Scope_Rec is record
Num : Nat;
Entity : Entity_Id;
end record;
-- Type used to relate an entity and a scope number
package Scopes is new GNAT.HTable.Simple_HTable
(Header_Num => Entity_Hashed_Range,
Element => Scope_Rec,
No_Element => (Num => No_Scope, Entity => Empty),
Element => Nat,
No_Element => No_Scope,
Key => Entity_Id,
Hash => Entity_Hash,
Equal => "=");
......@@ -411,10 +401,7 @@ package body SPARK_Specific is
-- Get_Scope_Num --
-------------------
function Get_Scope_Num (N : Entity_Id) return Nat is
begin
return Scopes.Get (N).Num;
end Get_Scope_Num;
function Get_Scope_Num (E : Entity_Id) return Nat renames Scopes.Get;
-----------------------------------------------
-- Is_Constant_Object_Without_Variable_Input --
......@@ -423,8 +410,6 @@ package body SPARK_Specific is
function Is_Constant_Object_Without_Variable_Input
(E : Entity_Id) return Boolean
is
Result : Boolean;
begin
case Ekind (E) is
......@@ -445,23 +430,21 @@ package body SPARK_Specific is
end if;
if Is_Imported (E) then
Result := False;
return False;
else
pragma Assert (Present (Expression (Decl)));
Result := Is_Static_Expression (Expression (Decl));
return Is_Static_Expression (Expression (Decl));
end if;
end;
when E_In_Parameter
| E_Loop_Parameter
=>
Result := True;
return True;
when others =>
Result := False;
return False;
end case;
return Result;
end Is_Constant_Object_Without_Variable_Input;
----------------------------
......@@ -663,10 +646,7 @@ package body SPARK_Specific is
-- Set_Scope_Num --
-------------------
procedure Set_Scope_Num (N : Entity_Id; Num : Nat) is
begin
Scopes.Set (K => N, E => Scope_Rec'(Num => Num, Entity => N));
end Set_Scope_Num;
procedure Set_Scope_Num (E : Entity_Id; Num : Nat) renames Scopes.Set;
------------------------
-- Update_Scope_Range --
......@@ -1430,7 +1410,11 @@ package body SPARK_Specific is
or else Nkind (N) in N_Later_Decl_Item
or else Nkind (N) = N_Entry_Body
then
Process (N);
if Nkind (N) in N_Body_Stub then
Process (Get_Body_From_Stub (N));
else
Process (N);
end if;
end if;
Traverse_Declaration_Or_Statement (N);
......
......@@ -72,9 +72,29 @@ package body Specific is
-- Self --
----------
-- To make Ada tasks and C threads interoperate better, we have added some
-- functionality to Self. Suppose a C main program (with threads) calls an
-- Ada procedure and the Ada procedure calls the tasking runtime system.
-- Eventually, a call will be made to self. Since the call is not coming
-- from an Ada task, there will be no corresponding ATCB.
-- What we do in Self is to catch references that do not come from
-- recognized Ada tasks, and create an ATCB for the calling thread.
-- The new ATCB will be "detached" from the normal Ada task master
-- hierarchy, much like the existing implicitly created signal-server
-- tasks.
function Self return Task_Id is
Result : constant Task_Id := To_Task_Id (tlsValueGet (ATCB_Key));
begin
return To_Task_Id (tlsValueGet (ATCB_Key));
if Result /= null then
return Result;
else
-- If the value is Null then it is a non-Ada task
return Register_Foreign_Thread;
end if;
end Self;
end Specific;
......@@ -71,9 +71,29 @@ package body Specific is
-- Self --
----------
-- To make Ada tasks and C threads interoperate better, we have added some
-- functionality to Self. Suppose a C main program (with threads) calls an
-- Ada procedure and the Ada procedure calls the tasking runtime system.
-- Eventually, a call will be made to self. Since the call is not coming
-- from an Ada task, there will be no corresponding ATCB.
-- What we do in Self is to catch references that do not come from
-- recognized Ada tasks, and create an ATCB for the calling thread.
-- The new ATCB will be "detached" from the normal Ada task master
-- hierarchy, much like the existing implicitly created signal-server
-- tasks.
function Self return Task_Id is
Result : constant Task_Id := ATCB;
begin
return ATCB;
if Result /= null then
return Result;
else
-- If the value is Null then it is a non-Ada task
return Register_Foreign_Thread;
end if;
end Self;
end Specific;
......@@ -121,9 +121,29 @@ package body Specific is
-- Self --
----------
-- To make Ada tasks and C threads interoperate better, we have added some
-- functionality to Self. Suppose a C main program (with threads) calls an
-- Ada procedure and the Ada procedure calls the tasking runtime system.
-- Eventually, a call will be made to self. Since the call is not coming
-- from an Ada task, there will be no corresponding ATCB.
-- What we do in Self is to catch references that do not come from
-- recognized Ada tasks, and create an ATCB for the calling thread.
-- The new ATCB will be "detached" from the normal Ada task master
-- hierarchy, much like the existing implicitly created signal-server
-- tasks.
function Self return Task_Id is
Result : constant Task_Id := To_Task_Id (ATCB_Key);
begin
return To_Task_Id (ATCB_Key);
if Result /= null then
return Result;
else
-- If the value is Null then it is a non-Ada task
return Register_Foreign_Thread;
end if;
end Self;
end Specific;
......@@ -82,8 +82,8 @@ package body System.HTable is
function Get_First return Elmt_Ptr is
begin
Iterator_Started := True;
Iterator_Index := Table'First;
Iterator_Ptr := Table (Iterator_Index);
Iterator_Index := Table'First;
Iterator_Ptr := Table (Iterator_Index);
return Get_Non_Null;
end Get_First;
......
......@@ -61,7 +61,7 @@ package System.HTable is
No_Element : Element;
-- The object that is returned by Get when no element has been set for
-- a given key
-- a given key.
type Key is private;
with function Hash (F : Key) return Header_Num;
......
......@@ -203,6 +203,15 @@ package body Sem_Ch13 is
-- renaming_as_body. For tagged types, the specification is one of the
-- primitive specs.
procedure Register_Address_Clause_Check
(N : Node_Id;
X : Entity_Id;
A : Uint;
Y : Entity_Id;
Off : Boolean);
-- Register a check for the address clause N. The rest of the parameters
-- are in keeping with the components of Address_Clause_Check_Record below.
procedure Resolve_Iterable_Operation
(N : Node_Id;
Cursor : Entity_Id;
......@@ -318,6 +327,11 @@ package body Sem_Ch13 is
Off : Boolean;
-- Whether the address is offset within Y in the second case
Alignment_Checks_Suppressed : Boolean;
-- Whether alignment checks are suppressed by an active scope suppress
-- setting. We need to save the value in order to be able to reuse it
-- after the back end has been run.
end record;
package Address_Clause_Checks is new Table.Table (
......@@ -328,6 +342,26 @@ package body Sem_Ch13 is
Table_Increment => 200,
Table_Name => "Address_Clause_Checks");
function Alignment_Checks_Suppressed
(ACCR : Address_Clause_Check_Record) return Boolean;
-- Return whether the alignment check generated for the address clause
-- is suppressed.
---------------------------------
-- Alignment_Checks_Suppressed --
---------------------------------
function Alignment_Checks_Suppressed
(ACCR : Address_Clause_Check_Record) return Boolean
is
begin
if Checks_May_Be_Suppressed (ACCR.X) then
return Is_Check_Suppressed (ACCR.X, Alignment_Check);
else
return ACCR.Alignment_Checks_Suppressed;
end if;
end Alignment_Checks_Suppressed;
-----------------------------------------
-- Adjust_Record_For_Reverse_Bit_Order --
-----------------------------------------
......@@ -5047,8 +5081,8 @@ package body Sem_Ch13 is
and then not Is_Generic_Type (Etype (U_Ent))
and then Address_Clause_Overlay_Warnings
then
Address_Clause_Checks.Append
((N, U_Ent, No_Uint, O_Ent, Off));
Register_Address_Clause_Check
(N, U_Ent, No_Uint, O_Ent, Off);
end if;
else
-- If this is not an overlay, mark a variable as being
......@@ -5073,8 +5107,8 @@ package body Sem_Ch13 is
if Compile_Time_Known_Value (Addr)
and then Address_Clause_Overlay_Warnings
then
Address_Clause_Checks.Append
((N, U_Ent, Expr_Value (Addr), Empty, False));
Register_Address_Clause_Check
(N, U_Ent, Expr_Value (Addr), Empty, False);
end if;
end;
end if;
......@@ -12254,6 +12288,22 @@ package body Sem_Ch13 is
end if;
end Push_Scope_And_Install_Discriminants;
-----------------------------------
-- Register_Address_Clause_Check --
-----------------------------------
procedure Register_Address_Clause_Check
(N : Node_Id;
X : Entity_Id;
A : Uint;
Y : Entity_Id;
Off : Boolean)
is
ACS : constant Boolean := Scope_Suppress.Suppress (Alignment_Check);
begin
Address_Clause_Checks.Append ((N, X, A, Y, Off, ACS));
end Register_Address_Clause_Check;
------------------------
-- Rep_Item_Too_Early --
------------------------
......@@ -13465,7 +13515,7 @@ package body Sem_Ch13 is
-- Check for known value not multiple of alignment
if No (ACCR.Y) then
if not Alignment_Checks_Suppressed (ACCR.X)
if not Alignment_Checks_Suppressed (ACCR)
and then X_Alignment /= 0
and then ACCR.A mod X_Alignment /= 0
then
......@@ -13510,7 +13560,7 @@ package body Sem_Ch13 is
-- Note: we do not check the alignment if we gave a size
-- warning, since it would likely be redundant.
elsif not Alignment_Checks_Suppressed (ACCR.X)
elsif not Alignment_Checks_Suppressed (ACCR)
and then Y_Alignment /= Uint_0
and then
(Y_Alignment < X_Alignment
......
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