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
Tested on x86_64-pc-linux-gnu, committed on trunk
2018-12-11 Hristian Kirtchev <kirtc...@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.--- gcc/ada/freeze.adb
+++ 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;
