Skip to content

R
riscv-gcc-1
Commit 4c8a5bb8 by Arnaud Charlet
Options

[multiple changes] 

2009-04-08  Thomas Quinot  <quinot@adacore.com>

	* sem_ch8.adb: Minor reformatting.
	Minor code reorganization.

2009-04-08  Robert Dewar  <dewar@adacore.com>

	* snames.h, einfo.adb, einfo.ads, sem_prag.adb, snames.adb,
	snames.ads, freeze.adb, par-prag.adb: Add implementation of
	pragma Thread_Local_Storage, setting new flag
	Has_Pragma_Thread_Local_Storage in corresponding entities.

From-SVN: r145725
parent ecc4ddde
Showing with 155 additions and 51 deletions
gcc/ada/ChangeLog
2009-04-08 Thomas Quinot <quinot@adacore.com>
* sem_ch8.adb: Minor reformatting.
Minor code reorganization.
2009-04-08 Robert Dewar <dewar@adacore.com>
* snames.h, einfo.adb, einfo.ads, sem_prag.adb, snames.adb,
snames.ads, freeze.adb, par-prag.adb: Add implementation of
pragma Thread_Local_Storage, setting new flag
Has_Pragma_Thread_Local_Storage in corresponding entities.
2009-04-08 Emmanuel Briot <briot@adacore.com>
* prj.ads: Update comment on switches file
gcc/ada/einfo.adb
......@@ -421,6 +421,7 @@ package body Einfo is
-- Debug_Info_Off Flag166
-- Sec_Stack_Needed_For_Return Flag167
-- Materialize_Entity Flag168
-- Has_Pragma_Thread_Local_Storage Flag169
-- Is_Known_Valid Flag170
-- Is_Hidden_Open_Scope Flag171
......@@ -1346,6 +1347,11 @@ package body Einfo is
return Flag179 (Id);
end Has_Pragma_Pure_Function;
function Has_Pragma_Thread_Local_Storage (Id : E) return B is
begin
return Flag169 (Id);
end Has_Pragma_Thread_Local_Storage;
function Has_Pragma_Unmodified (Id : E) return B is
begin
return Flag233 (Id);
......@@ -3771,6 +3777,11 @@ package body Einfo is
Set_Flag179 (Id, V);
end Set_Has_Pragma_Pure_Function;
procedure Set_Has_Pragma_Thread_Local_Storage (Id : E; V : B := True) is
begin
Set_Flag169 (Id, V);
end Set_Has_Pragma_Thread_Local_Storage;
procedure Set_Has_Pragma_Unmodified (Id : E; V : B := True) is
begin
Set_Flag233 (Id, V);
......@@ -7516,6 +7527,7 @@ package body Einfo is
W ("Has_Pragma_Preelab_Init", Flag221 (Id));
W ("Has_Pragma_Pure", Flag203 (Id));
W ("Has_Pragma_Pure_Function", Flag179 (Id));
W ("Has_Pragma_Thread_Local_Storage", Flag169 (Id));
W ("Has_Pragma_Unmodified", Flag233 (Id));
W ("Has_Pragma_Unreferenced", Flag180 (Id));
W ("Has_Pragma_Unreferenced_Objects", Flag212 (Id));
......
gcc/ada/einfo.ads
......@@ -1611,6 +1611,10 @@ package Einfo is
-- Pure_Function was given for the entity. In some cases, we need to
-- know that Is_Pure was explicitly set using this pragma.
-- Has_Pragma_Thread_Local_Storage (Flag169)
-- Present in all entities. If set, indicates that a valid pragma
-- Thread_Local_Storage was given for the entity.
-- Has_Pragma_Unmodified (Flag233)
-- Present in all entities. Can only be set for variables (E_Variable,
-- E_Out_Parameter, E_In_Out_Parameter). Set if a valid pragma Unmodified
......@@ -4562,6 +4566,7 @@ package Einfo is
-- Has_Pragma_Pack (Flag121) (base type only)
-- Has_Pragma_Pure (Flag203)
-- Has_Pragma_Pure_Function (Flag179)
-- Has_Pragma_Thread_Local_Storage (Flag169)
-- Has_Pragma_Unmodified (Flag233)
-- Has_Pragma_Unreferenced (Flag180)
-- Has_Private_Declaration (Flag155)
......@@ -5885,6 +5890,7 @@ package Einfo is
function Has_Pragma_Preelab_Init (Id : E) return B;
function Has_Pragma_Pure (Id : E) return B;
function Has_Pragma_Pure_Function (Id : E) return B;
function Has_Pragma_Thread_Local_Storage (Id : E) return B;
function Has_Pragma_Unmodified (Id : E) return B;
function Has_Pragma_Unreferenced (Id : E) return B;
function Has_Pragma_Unreferenced_Objects (Id : E) return B;
......@@ -6442,6 +6448,7 @@ package Einfo is
procedure Set_Has_Pragma_Preelab_Init (Id : E; V : B := True);
procedure Set_Has_Pragma_Pure (Id : E; V : B := True);
procedure Set_Has_Pragma_Pure_Function (Id : E; V : B := True);
procedure Set_Has_Pragma_Thread_Local_Storage (Id : E; V : B := True);
procedure Set_Has_Pragma_Unmodified (Id : E; V : B := True);
procedure Set_Has_Pragma_Unreferenced (Id : E; V : B := True);
procedure Set_Has_Pragma_Unreferenced_Objects (Id : E; V : B := True);
......@@ -7089,6 +7096,7 @@ package Einfo is
pragma Inline (Has_Pragma_Preelab_Init);
pragma Inline (Has_Pragma_Pure);
pragma Inline (Has_Pragma_Pure_Function);
pragma Inline (Has_Pragma_Thread_Local_Storage);
pragma Inline (Has_Pragma_Unmodified);
pragma Inline (Has_Pragma_Unreferenced);
pragma Inline (Has_Pragma_Unreferenced_Objects);
......@@ -7514,6 +7522,7 @@ package Einfo is
pragma Inline (Set_Has_Pragma_Preelab_Init);
pragma Inline (Set_Has_Pragma_Pure);
pragma Inline (Set_Has_Pragma_Pure_Function);
pragma Inline (Set_Has_Pragma_Thread_Local_Storage);
pragma Inline (Set_Has_Pragma_Unmodified);
pragma Inline (Set_Has_Pragma_Unreferenced);
pragma Inline (Set_Has_Pragma_Unreferenced_Objects);
......
gcc/ada/freeze.adb
......@@ -1436,6 +1436,9 @@ package body Freeze is
Formal : Entity_Id;
Atype : Entity_Id;
Has_Default_Initialization : Boolean := False;
-- This flag gets set to true for a variable with default initialization
procedure Check_Current_Instance (Comp_Decl : Node_Id);
-- Check that an Access or Unchecked_Access attribute with a prefix
-- which is the current instance type can only be applied when the type
......@@ -2714,10 +2717,39 @@ package body Freeze is
(Needs_Simple_Initialization (Etype (E))
and then not Is_Internal (E)))
then
Has_Default_Initialization := True;
Check_Restriction
(No_Default_Initialization, Declaration_Node (E));
end if;
-- Check that a Thread_Local_Storage variable does not have
-- default initialization, and any explicit initialization must
-- either be the null constant or a static constant.
if Has_Pragma_Thread_Local_Storage (E) then
declare
Decl : constant Node_Id := Declaration_Node (E);
begin
if Has_Default_Initialization
or else
(Has_Init_Expression (Decl)
and then
(No (Expression (Decl))
or else not
(Is_Static_Expression (Expression (Decl))
or else
Nkind (Expression (Decl)) = N_Null)))
then
Error_Msg_NE
("Thread_Local_Storage variable& is "
& "improperly initialized", Decl, E);
Error_Msg_NE
("\only allowed initialization is explicit "
& "NULL or static expression", Decl, E);
end if;
end;
end if;
-- For imported objects, set Is_Public unless there is also an
-- address clause, which means that there is no external symbol
-- needed for the Import (Is_Public may still be set for other
......
gcc/ada/par-prag.adb
......@@ -1187,6 +1187,7 @@ begin
Pragma_Task_Info |
Pragma_Task_Name |
Pragma_Task_Storage |
Pragma_Thread_Local_Storage |
Pragma_Time_Slice |
Pragma_Title |
Pragma_Unchecked_Union |
......
gcc/ada/sem_ch8.adb
......@@ -402,8 +402,8 @@ package body Sem_Ch8 is
-- references the package in question.
procedure Attribute_Renaming (N : Node_Id);
-- Analyze renaming of attribute as function. The renaming declaration N
-- is rewritten as a function body that returns the attribute reference
-- Analyze renaming of attribute as subprogram. The renaming declaration N
-- is rewritten as a subprogram body that returns the attribute reference
-- applied to the formals of the function.
procedure Check_Frozen_Renaming (N : Node_Id; Subp : Entity_Id);
......@@ -2546,9 +2546,9 @@ package body Sem_Ch8 is
end if;
else
-- If the use_type_clause appears in a compilation context,
-- If the use_type_clause appears in a compilation unit context,
-- check whether it comes from a unit that may appear in a
-- limited with_clause, for a better error message.
-- limited_with_clause, for a better error message.
if Nkind (Parent (N)) = N_Compilation_Unit
and then Nkind (Id) /= N_Identifier
......@@ -2558,32 +2558,31 @@ package body Sem_Ch8 is
Pref : Node_Id;
function Mentioned (Nam : Node_Id) return Boolean;
-- check whether the prefix of expanded name for the
-- type appears in the prefix of some limited_with_clause.
-- Check whether the prefix of expanded name for the type
-- appears in the prefix of some limited_with_clause.
---------------
-- Mentioned --
---------------
function Mentioned (Nam : Node_Id) return Boolean is
begin
if Nkind (Name (Item)) = N_Selected_Component
and then Chars (Prefix (Name (Item))) = Chars (Nam)
then
return True;
else
return False;
end if;
return Nkind (Name (Item)) = N_Selected_Component
and then
Chars (Prefix (Name (Item))) = Chars (Nam);
end Mentioned;
begin
Pref := Prefix (Id);
Item := First (Context_Items (Parent (N)));
while Present (Item)
and then Item /= N
loop
while Present (Item) and then Item /= N loop
if Nkind (Item) = N_With_Clause
and then Limited_Present (Item)
and then Mentioned (Pref)
then
Change_Error_Text (Get_Msg_Id,
"premature usage of incomplete type");
Change_Error_Text
(Get_Msg_Id, "premature usage of incomplete type");
end if;
Next (Item);
......@@ -2650,11 +2649,11 @@ package body Sem_Ch8 is
begin
Generate_Definition (New_S);
-- This procedure is called in the context of subprogram renaming,
-- and thus the attribute must be one that is a subprogram. All of
-- those have at least one formal parameter, with the singular
-- exception of AST_Entry (which is a real oddity, it is odd that
-- this can be renamed at all!)
-- This procedure is called in the context of subprogram renaming, and
-- thus the attribute must be one that is a subprogram. All of those
-- have at least one formal parameter, with the singular exception of
-- AST_Entry (which is a real oddity, it is odd that this can be renamed
-- at all!)
if not Is_Non_Empty_List (Parameter_Specifications (Spec)) then
if Aname /= Name_AST_Entry then
......@@ -2689,22 +2688,22 @@ package body Sem_Ch8 is
Chars => Chars (Defining_Identifier (Param_Spec))));
-- The expressions in the attribute reference are not freeze
-- points. Neither is the attribute as a whole, see below.
-- points. Neither is the attribute as a whole, see below.
Set_Must_Not_Freeze (Last (Expr_List));
Next (Param_Spec);
end loop;
end if;
-- Immediate error if too many formals. Other mismatches in numbers
-- of number of types of parameters are detected when we analyze the
-- body of the subprogram that we construct.
-- Immediate error if too many formals. Other mismatches in number or
-- types of parameters are detected when we analyze the body of the
-- subprogram that we construct.
if Form_Num > 2 then
Error_Msg_N ("too many formals for attribute", N);
-- Error if the attribute reference has expressions that look
-- like formal parameters.
-- Error if the attribute reference has expressions that look like
-- formal parameters.
elsif Present (Expressions (Nam)) then
Error_Msg_N ("illegal expressions in attribute reference", Nam);
......@@ -2731,10 +2730,10 @@ package body Sem_Ch8 is
end if;
end if;
-- AST_Entry is an odd case. It doesn't really make much sense to
-- allow it to be renamed, but that's the DEC rule, so we have to
-- do it right. The point is that the AST_Entry call should be made
-- now, and what the function will return is the returned value.
-- AST_Entry is an odd case. It doesn't really make much sense to allow
-- it to be renamed, but that's the DEC rule, so we have to do it right.
-- The point is that the AST_Entry call should be made now, and what the
-- function will return is the returned value.
-- Note that there is no Expr_List in this case anyway
......
gcc/ada/sem_prag.adb
......@@ -11239,6 +11239,42 @@ package body Sem_Prag is
end if;
end Task_Storage;
--------------------------
-- Thread_Local_Storage --
--------------------------
-- pragma Thread_Local_Storage ([Entity =>] LOCAL_NAME);
when Pragma_Thread_Local_Storage => Thread_Local_Storage : declare
Id : Node_Id;
E : Entity_Id;
begin
GNAT_Pragma;
Check_Arg_Count (1);
Check_Optional_Identifier (Arg1, Name_Entity);
Check_Arg_Is_Local_Name (Arg1);
Id := Expression (Arg1);
Analyze (Id);
if not Is_Entity_Name (Id)
or else Ekind (Entity (Id)) /= E_Variable
then
Error_Pragma_Arg ("local variable name required", Arg1);
end if;
E := Entity (Id);
if Rep_Item_Too_Early (E, N)
or else Rep_Item_Too_Late (E, N)
then
raise Pragma_Exit;
end if;
Set_Has_Pragma_Thread_Local_Storage (E);
end Thread_Local_Storage;
----------------
-- Time_Slice --
----------------
......@@ -12367,6 +12403,7 @@ package body Sem_Prag is
Pragma_Task_Info => -1,
Pragma_Task_Name => -1,
Pragma_Task_Storage => 0,
Pragma_Thread_Local_Storage => 0,
Pragma_Time_Slice => -1,
Pragma_Title => -1,
Pragma_Unchecked_Union => 0,
......
gcc/ada/snames.adb
......@@ -327,6 +327,7 @@ package body Snames is
"task_info#" &
"task_name#" &
"task_storage#" &
"thread_local_storage#" &
"time_slice#" &
"title#" &
"unchecked_union#" &
......
gcc/ada/snames.h
......@@ -377,23 +377,24 @@ extern unsigned char Get_Pragma_Id (int);
#define Pragma_Task_Info 150
#define Pragma_Task_Name 151
#define Pragma_Task_Storage 152
#define Pragma_Time_Slice 153
#define Pragma_Title 154
#define Pragma_Unchecked_Union 155
#define Pragma_Unimplemented_Unit 156
#define Pragma_Universal_Aliasing 157
#define Pragma_Unmodified 158
#define Pragma_Unreferenced 159
#define Pragma_Unreferenced_Objects 160
#define Pragma_Unreserve_All_Interrupts 161
#define Pragma_Volatile 162
#define Pragma_Volatile_Components 163
#define Pragma_Weak_External 164
#define Pragma_AST_Entry 165
#define Pragma_Fast_Math 166
#define Pragma_Interface 167
#define Pragma_Priority 168
#define Pragma_Storage_Size 169
#define Pragma_Storage_Unit 170
#define Pragma_Thread_Local_Storage 153
#define Pragma_Time_Slice 154
#define Pragma_Title 155
#define Pragma_Unchecked_Union 156
#define Pragma_Unimplemented_Unit 157
#define Pragma_Universal_Aliasing 158
#define Pragma_Unmodified 159
#define Pragma_Unreferenced 160
#define Pragma_Unreferenced_Objects 161
#define Pragma_Unreserve_All_Interrupts 162
#define Pragma_Volatile 163
#define Pragma_Volatile_Components 164
#define Pragma_Weak_External 165
#define Pragma_AST_Entry 166
#define Pragma_Fast_Math 167
#define Pragma_Interface 168
#define Pragma_Priority 169
#define Pragma_Storage_Size 170
#define Pragma_Storage_Unit 171
/* End of snames.h (C version of Snames package spec) */
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment