[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

8 files changed, 173 insertions, 45 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index d16939f..35ebd0c 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,37 @@
+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,
diff --git a/gcc/ada/lib-xref-spark_specific.adb b/gcc/ada/lib-xref-spark_specific.adb
index 5f2cdef..b6ddd93 100644
--- a/gcc/ada/lib-xref-spark_specific.adb
+++ b/gcc/ada/lib-xref-spark_specific.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);
diff --git a/gcc/ada/libgnarl/s-tpopsp__vxworks-rtp.adb b/gcc/ada/libgnarl/s-tpopsp__vxworks-rtp.adb
index b49c0cf..c7e2f66 100644
--- a/gcc/ada/libgnarl/s-tpopsp__vxworks-rtp.adb
+++ b/gcc/ada/libgnarl/s-tpopsp__vxworks-rtp.adb
@@ -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;
diff --git a/gcc/ada/libgnarl/s-tpopsp__vxworks-tls.adb b/gcc/ada/libgnarl/s-tpopsp__vxworks-tls.adb
index 744ec48..7cdad5a 100644
--- a/gcc/ada/libgnarl/s-tpopsp__vxworks-tls.adb
+++ b/gcc/ada/libgnarl/s-tpopsp__vxworks-tls.adb
@@ -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;
diff --git a/gcc/ada/libgnarl/s-tpopsp__vxworks.adb b/gcc/ada/libgnarl/s-tpopsp__vxworks.adb
index bc343b1..bd8f92d 100644
--- a/gcc/ada/libgnarl/s-tpopsp__vxworks.adb
+++ b/gcc/ada/libgnarl/s-tpopsp__vxworks.adb
@@ -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;
diff --git a/gcc/ada/libgnat/s-htable.adb b/gcc/ada/libgnat/s-htable.adb
index f72b6492..b640a34 100644
--- a/gcc/ada/libgnat/s-htable.adb
+++ b/gcc/ada/libgnat/s-htable.adb
@@ -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;
 
diff --git a/gcc/ada/libgnat/s-htable.ads b/gcc/ada/libgnat/s-htable.ads
index b6d9960..810343a 100644
--- a/gcc/ada/libgnat/s-htable.ads
+++ b/gcc/ada/libgnat/s-htable.ads
@@ -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;
diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb
index 3ab8b35..1fc5c15 100644
--- a/gcc/ada/sem_ch13.adb
+++ b/gcc/ada/sem_ch13.adb
@@ -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