+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,
-- 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);
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;
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;
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 => "=");
-- 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 --
function Is_Constant_Object_Without_Variable_Input
(E : Entity_Id) return Boolean
is
- Result : Boolean;
-
begin
case Ekind (E) 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;
----------------------------
-- 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 --
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);
-- 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;
-- 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;
-- 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;
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;
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;
-- 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;
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 (
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 --
-----------------------------------------
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
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;
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 --
------------------------
-- 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
-- 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
projects / gcc.git / commitdiff