FreeChainXenon/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

[Ada] Spurious error with pragma Thread_Local_Storage

Browse source 
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
This commit is contained in:
Hristian Kirtchev 2018-12-11 11:12:37 +00:00 • committed by Pierre-Marie de Rodat
parent 759f164802
commit 921186579c
2 changed files with 114 additions and 45 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

10
gcc/ada/ChangeLog
View file

@ -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

149
gcc/ada/freeze.adb
View file

@ -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.
-------------------------------------
-- Has_Incompatible_Initialization --
-------------------------------------
function Has_Incompatible_Initialization
(Var_Decl : Node_Id) return Boolean
is
Init_Expr : constant Node_Id := Expression (Var_Decl);
begin
-- The variable is default-initialized. This directly violates
-- the semantics of the pragma.
if Has_Default_Initialization (Var_Id) then
return True;
-- The variable has explicit initialization. In this case only
-- a handful of values satisfy the semantics of the pragma.
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;
-- A static expression is a legal form of initialization
elsif Is_Static_Expression (Init_Expr) then
return False;
-- A static aggregate is a legal form of initialization
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 default
-- A variable whose initialization is suppressed lacks any kind of
-- initialization.
if Suppress_Initialization (Var_Id) then
null;
-- The variable has some form of initialization. Check whether it
-- is compatible with the semantics of the pragma.
-- The variable has default initialization, or is explicitly
-- initialized to a value other than null, static expression,
-- or a static aggregate.
elsif Has_Init_Expression (Decl)
and then Present (Expr)
and then
-- The variable is initialized with "null"
(Nkind (Expr) = N_Null
or else
-- The variable is initialized with a static constant
Is_OK_Static_Expression (Expr)
or else
-- The variable is initialized with a static aggregate
(Nkind (Expr) = N_Aggregate
and then Compile_Time_Known_Aggregate (Expr)))
then
null;
-- Otherwise the initialization of the variable violates the
-- semantics of pragma Thread_Local_Storage.
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;