[Ada] Spurious error with pragma Thread_Local_Storage

The following patch modifies the checks related to pragma
Thread_Local_Storage to correct a confusion in semantics which led to
spurious errors.

------------
-- Source --
------------

--  pack.ads

package Pack is
   type Arr is array (1 .. 5) of Boolean;

   type Arr_With_Default is array (1 .. 5) of Boolean
     with Default_Component_Value => False;

   type Int is new Integer range 1 .. 5;

   type Int_With_Default is new Integer range 1 .. 5
     with Default_Value => 1;

   protected type Prot_Typ is
      entry E;
   end Prot_Typ;

   type Rec_1 is record
      Comp : Integer;
   end record;

   type Rec_2 is record
      Comp : Int;
   end record;

   type Rec_3 is record
      Comp : Int_With_Default;
   end record;

   task type Task_Typ is
      entry E;
   end Task_Typ;
end Pack;

--  pack.adb

package body Pack is
   function F (Val : Int) return Int is
   begin
      if Val <= 1 then
         return 1;
      else
         return F (Val - 1) * Val;
      end if;
   end F;

   function F (Val : Int_With_Default) return Int_With_Default is
   begin
      if Val <= 1 then
         return 1;
      else
         return F (Val - 1) * Val;
      end if;
   end F;

   function F (Val : Integer) return Integer is
   begin
      if Val <= 1 then
         return 1;
      else
         return F (Val - 1) * Val;
      end if;
   end F;

   protected body Prot_Typ is
      entry E when True is begin null; end E;
   end Prot_Typ;

   task body Task_Typ is
   begin
      accept E;
   end Task_Typ;

   Obj_1 : Arr;                                                      --  OK
   pragma Thread_Local_Storage (Obj_1);

   Obj_2 : Arr := (others => True);                                  --  OK
   pragma Thread_Local_Storage (Obj_2);

   Obj_3 : Arr := (others => F (2) = Integer (3));                   --  ERROR
   pragma Thread_Local_Storage (Obj_3);

   Obj_4 : Arr_With_Default;                                         --  ERROR
   pragma Thread_Local_Storage (Obj_4);

   Obj_5 : Arr_With_Default := (others => True);                     --  OK
   pragma Thread_Local_Storage (Obj_5);

   Obj_6 : Arr_With_Default := (others => F (2) = Integer (3));      --  ERROR
   pragma Thread_Local_Storage (Obj_6);

   Obj_7 : Integer;                                                  --  OK
   pragma Thread_Local_Storage (Obj_7);

   Obj_8 : Integer := 1;                                             --  OK
   pragma Thread_Local_Storage (Obj_8);

   Obj_9 : Integer := F (2);                                         --  ERROR
   pragma Thread_Local_Storage (Obj_9);

   Obj_10 : Int;                                                     --  OK
   pragma Thread_Local_Storage (Obj_10);

   Obj_11 : Int := 1;                                                --  OK
   pragma Thread_Local_Storage (Obj_11);

   Obj_12 : Int := F (2);                                            --  ERROR
   pragma Thread_Local_Storage (Obj_12);

   Obj_13 : Int_With_Default;                                        --  ERROR
   pragma Thread_Local_Storage (Obj_13);

   Obj_14 : Int_With_Default := 1;                                   --  OK
   pragma Thread_Local_Storage (Obj_14);

   Obj_15 : Int_With_Default := F (2);                               --  ERROR
   pragma Thread_Local_Storage (Obj_15);

   Obj_16 : Prot_Typ;                                                --  ERROR
   pragma Thread_Local_Storage (Obj_16);

   Obj_17 : Rec_1;                                                   --  OK
   pragma Thread_Local_Storage (Obj_17);

   Obj_18 : Rec_1 := (others => 1);                                  --  OK
   pragma Thread_Local_Storage (Obj_18);

   Obj_19 : Rec_1 := (others => F (2));                              --  ERROR
   pragma Thread_Local_Storage (Obj_19);

   Obj_20 : Rec_2;                                                   --  OK
   pragma Thread_Local_Storage (Obj_20);

   Obj_21 : Rec_2 := (others => 1);                                  --  OK
   pragma Thread_Local_Storage (Obj_21);

   Obj_22 : Rec_2 := (others => F (2));                              --  ERROR
   pragma Thread_Local_Storage (Obj_22);

   Obj_23 : Rec_3;                                                   --  ERROR
   pragma Thread_Local_Storage (Obj_23);

   Obj_24 : Rec_3 := (others => 1);                                  --  OK
   pragma Thread_Local_Storage (Obj_24);

   Obj_25 : Rec_3 := (others => F (2));                              --  ERROR
   pragma Thread_Local_Storage (Obj_25);

   Obj_26 : Task_Typ;                                                --  ERROR
   pragma Thread_Local_Storage (Obj_26);
end Pack;

----------------------------
-- Compilation and output --
----------------------------

$ gcc -c pack.adb
pack.adb:47:04: Thread_Local_Storage variable "Obj_4" is improperly
  initialized
pack.adb:47:04: only allowed initialization is explicit "null", static
  expression or static aggregate
pack.adb:62:04: Thread_Local_Storage variable "Obj_9" is improperly
  initialized
pack.adb:62:04: only allowed initialization is explicit "null", static
  expression or static aggregate
pack.adb:71:04: Thread_Local_Storage variable "Obj_12" is improperly
  initialized
pack.adb:71:04: only allowed initialization is explicit "null", static
  expression or static aggregate
pack.adb:74:04: Thread_Local_Storage variable "Obj_13" is improperly
  initialized
pack.adb:74:04: only allowed initialization is explicit "null", static
  expression or static aggregate
pack.adb:80:04: Thread_Local_Storage variable "Obj_15" is improperly
  initialized
pack.adb:80:04: only allowed initialization is explicit "null", static
  expression or static aggregate
pack.adb:83:04: Thread_Local_Storage variable "Obj_16" is improperly
  initialized
pack.adb:83:04: only allowed initialization is explicit "null", static
  expression or static aggregate
pack.adb:92:04: Thread_Local_Storage variable "Obj_19" is improperly
  initialized
pack.adb:92:04: only allowed initialization is explicit "null", static
  expression or static aggregate
pack.adb:101:04: Thread_Local_Storage variable "Obj_22" is improperly
  initialized
pack.adb:101:04: only allowed initialization is explicit "null", static
  expression or static aggregate
pack.adb:104:04: Thread_Local_Storage variable "Obj_23" is improperly
  initialized
pack.adb:104:04: only allowed initialization is explicit "null", static
  expression or static aggregate
pack.adb:110:04: Thread_Local_Storage variable "Obj_25" is improperly
  initialized
pack.adb:110:04: only allowed initialization is explicit "null", static
  expression or static aggregate
pack.adb:113:04: Thread_Local_Storage variable "Obj_26" is improperly
  initialized
pack.adb:113:04: only allowed initialization is explicit "null", static
  expression or static aggregate

2018-12-11  Hristian Kirtchev  <kirtchev@adacore.com>

gcc/ada/

	* freeze.adb (Check_Pragma_Thread_Local_Storage): Use the
	violating set to diagnose detect an illegal initialization,
	rather than the complement of the OK set.
	(Freeze_Object_Declaration): Factorize code in
	Has_Default_Initialization.
	(Has_Default_Initialization, Has_Incompatible_Initialization):
	New routines.

From-SVN: r267017

2 files changed, 109 insertions, 40 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index aab6ceb..c08199b 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,13 @@
+2018-12-11  Hristian Kirtchev  <kirtchev@adacore.com>
+
+	* freeze.adb (Check_Pragma_Thread_Local_Storage): Use the
+	violating set to diagnose detect an illegal initialization,
+	rather than the complement of the OK set.
+	(Freeze_Object_Declaration): Factorize code in
+	Has_Default_Initialization.
+	(Has_Default_Initialization, Has_Incompatible_Initialization):
+	New routines.
+
 2018-12-11  Dmitriy Anisimkov  <anisimko@adacore.com>
 
 	* libgnat/g-socket.ads (Family_Type): Add new enumerated value
diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb
index dc3e54c..0573949 100644
--- a/gcc/ada/freeze.adb
+++ b/gcc/ada/freeze.adb
@@ -3187,8 +3187,13 @@ package body Freeze is
          --  length of the array, or its corresponding attribute.
 
          procedure Check_Pragma_Thread_Local_Storage (Var_Id : Entity_Id);
-         --  Ensure that the initialization state of variable Var_Id subject to
-         --  pragma Thread_Local_Storage satisfies the semantics of the pragma.
+         --  Ensure that the initialization state of variable Var_Id subject
+         --  to pragma Thread_Local_Storage agrees with the semantics of the
+         --  pragma.
+
+         function Has_Default_Initialization
+           (Obj_Id : Entity_Id) return Boolean;
+         --  Determine whether object Obj_Id default initialized
 
          -------------------------------
          -- Check_Large_Modular_Array --
@@ -3274,53 +3279,117 @@ package body Freeze is
          ---------------------------------------
 
          procedure Check_Pragma_Thread_Local_Storage (Var_Id : Entity_Id) is
-            Decl : constant Node_Id := Declaration_Node (Var_Id);
-            Expr : constant Node_Id := Expression (Decl);
+            function Has_Incompatible_Initialization
+              (Var_Decl : Node_Id) return Boolean;
+            --  Determine whether variable Var_Id with declaration Var_Decl is
+            --  initialized with a value that violates the semantics of pragma
+            --  Thread_Local_Storage.
 
-         begin
-            --  A variable whose initialization is suppressed lacks default
-            --  initialization.
+            -------------------------------------
+            -- Has_Incompatible_Initialization --
+            -------------------------------------
 
-            if Suppress_Initialization (Var_Id) then
-               null;
+            function Has_Incompatible_Initialization
+              (Var_Decl : Node_Id) return Boolean
+            is
+               Init_Expr : constant Node_Id := Expression (Var_Decl);
 
-            --  The variable has some form of initialization. Check whether it
-            --  is compatible with the semantics of the pragma.
+            begin
+               --  The variable is default-initialized. This directly violates
+               --  the semantics of the pragma.
 
-            elsif Has_Init_Expression (Decl)
-              and then Present (Expr)
-              and then
+               if Has_Default_Initialization (Var_Id) then
+                  return True;
 
-               --  The variable is initialized with "null"
+               --  The variable has explicit initialization. In this case only
+               --  a handful of values satisfy the semantics of the pragma.
 
-                (Nkind (Expr) = N_Null
-                   or else
+               elsif Has_Init_Expression (Var_Decl)
+                 and then Present (Init_Expr)
+               then
+                  --  "null" is a legal form of initialization
+
+                  if Nkind (Init_Expr) = N_Null then
+                     return False;
 
-               --  The variable is initialized with a static constant
+                  --  A static expression is a legal form of initialization
 
-                 Is_OK_Static_Expression (Expr)
-                   or else
+                  elsif Is_Static_Expression (Init_Expr) then
+                     return False;
 
-               --  The variable is initialized with a static aggregate
+                  --  A static aggregate is a legal form of initialization
 
-                (Nkind (Expr) = N_Aggregate
-                   and then Compile_Time_Known_Aggregate (Expr)))
-            then
+                  elsif Nkind (Init_Expr) = N_Aggregate
+                    and then Compile_Time_Known_Aggregate (Init_Expr)
+                  then
+                     return False;
+
+                  --  All other initialization expressions violate the semantic
+                  --  of the pragma.
+
+                  else
+                     return True;
+                  end if;
+
+               --  The variable lacks any kind of initialization, which agrees
+               --  with the semantics of the pragma.
+
+               else
+                  return False;
+               end if;
+            end Has_Incompatible_Initialization;
+
+            --  Local declarations
+
+            Var_Decl : constant Node_Id := Declaration_Node (Var_Id);
+
+         --  Start of processing for Check_Pragma_Thread_Local_Storage
+
+         begin
+            --  A variable whose initialization is suppressed lacks any kind of
+            --  initialization.
+
+            if Suppress_Initialization (Var_Id) then
                null;
 
-            --  Otherwise the initialization of the variable violates the
-            --  semantics of pragma Thread_Local_Storage.
+            --  The variable has default initialization, or is explicitly
+            --  initialized to a value other than null, static expression,
+            --  or a static aggregate.
 
-            else
+            elsif Has_Incompatible_Initialization (Var_Decl) then
                Error_Msg_NE
                  ("Thread_Local_Storage variable& is improperly initialized",
-                  Decl, Var_Id);
+                  Var_Decl, Var_Id);
                Error_Msg_NE
                  ("\only allowed initialization is explicit NULL, static "
-                  & "expression or static aggregate", Decl, Var_Id);
+                  & "expression or static aggregate", Var_Decl, Var_Id);
             end if;
          end Check_Pragma_Thread_Local_Storage;
 
+         --------------------------------
+         -- Has_Default_Initialization --
+         --------------------------------
+
+         function Has_Default_Initialization
+           (Obj_Id : Entity_Id) return Boolean
+         is
+            Obj_Decl : constant Node_Id   := Declaration_Node (Obj_Id);
+            Obj_Typ  : constant Entity_Id := Etype (Obj_Id);
+
+         begin
+            return
+              Comes_From_Source (Obj_Id)
+                and then not Is_Imported (Obj_Id)
+                and then not Has_Init_Expression (Obj_Decl)
+                and then
+                  ((Has_Non_Null_Base_Init_Proc (Obj_Typ)
+                     and then not No_Initialization (Obj_Decl)
+                     and then not Initialization_Suppressed (Obj_Typ))
+                   or else
+                     (Needs_Simple_Initialization (Obj_Typ)
+                       and then not Is_Internal (Obj_Id)));
+         end Has_Default_Initialization;
+
          --  Local variables
 
          Typ : constant Entity_Id := Etype (E);
@@ -3438,17 +3507,7 @@ package body Freeze is
          if Ekind (E) = E_Constant and then Present (Full_View (E)) then
             null;
 
-         elsif Comes_From_Source (E)
-           and then not Is_Imported (E)
-           and then not Has_Init_Expression (Declaration_Node (E))
-           and then
-             ((Has_Non_Null_Base_Init_Proc (Typ)
-                and then not No_Initialization (Declaration_Node (E))
-                and then not Initialization_Suppressed (Typ))
-              or else
-                (Needs_Simple_Initialization (Typ)
-                  and then not Is_Internal (E)))
-         then
+         elsif Has_Default_Initialization (E) then
             Check_Restriction
               (No_Default_Initialization, Declaration_Node (E));
          end if;