-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2008, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
with Sem_Ch3; use Sem_Ch3;
with Sem_Ch6; use Sem_Ch6;
with Sem_Ch8; use Sem_Ch8;
+with Sem_Ch12; use Sem_Ch12;
with Sem_Ch13; use Sem_Ch13;
with Sem_Dist; use Sem_Dist;
with Sem_Elim; use Sem_Elim;
-- sequence, so the only way we get here is by being in the
-- declarative part of the body.
- elsif Nkind (P) = N_Subprogram_Body
- or else Nkind (P) = N_Package_Body
- or else Nkind (P) = N_Task_Body
- or else Nkind (P) = N_Entry_Body
+ elsif Nkind_In (P, N_Subprogram_Body,
+ N_Package_Body,
+ N_Task_Body,
+ N_Entry_Body)
then
return;
end if;
-- the end of the package declarations (for details, see
-- Analyze_Package_Specification.Analyze_PPCs).
- if Ekind (Scope (S)) /= E_Package
- and then
- Ekind (Scope (S)) /= E_Generic_Package
- then
+ if not Is_Package_Or_Generic_Package (Scope (S)) then
Analyze_PPC_In_Decl_Part (N, S);
end if;
P := N;
while Present (Prev (P)) loop
P := Prev (P);
- PO := Original_Node (P);
+
+ -- If the previous node is a generic subprogram, do not go to
+ -- to the original node, which is the unanalyzed tree: we need
+ -- to attach the pre/postconditions to the analyzed version
+ -- at this point. They get propagated to the original tree when
+ -- analyzing the corresponding body.
+
+ if Nkind (P) not in N_Generic_Declaration then
+ PO := Original_Node (P);
+ else
+ PO := P;
+ end if;
-- Skip past prior pragma
if Nkind (Parent (N)) = N_Subprogram_Body
and then List_Containing (N) = Declarations (Parent (N))
then
+ if Operating_Mode /= Generate_Code then
+
+ -- Analyze expression in pragma, for correctness
+ -- and for ASIS use.
+
+ Preanalyze_Spec_Expression
+ (Get_Pragma_Arg (Arg1), Standard_Boolean);
+ end if;
+
In_Body := True;
return;
Arg1x : constant Node_Id := Get_Pragma_Arg (Arg1);
begin
- GNAT_Pragma;
Check_Arg_Count (2);
Check_No_Identifiers;
Check_Arg_Is_Static_Expression (Arg2, Standard_String);
then
if Scope (E) /= Scope (Alias (E)) then
Error_Pragma_Ref
- ("cannot apply pragma% to non-local renaming&#", E);
+ ("cannot apply pragma% to non-local entity&#", E);
end if;
+
E := Alias (E);
- elsif Nkind (Parent (E)) = N_Full_Type_Declaration
+ elsif Nkind_In (Parent (E), N_Full_Type_Declaration,
+ N_Private_Extension_Declaration)
and then Scope (E) = Scope (Alias (E))
then
E := Alias (E);
and then Comp_Unit = Get_Source_Unit (E1)
and then not Is_Formal_Subprogram (E1)
and then Nkind (Original_Node (Parent (E1))) /=
- N_Full_Type_Declaration
+ N_Full_Type_Declaration
then
if Present (Alias (E1))
and then Scope (E1) /= Scope (Alias (E1))
then
Error_Pragma_Ref
- ("cannot apply pragma% to non-local renaming&#", E1);
+ ("cannot apply pragma% to non-local entity& declared#",
+ E1);
end if;
+
Set_Convention_From_Pragma (E1);
if Prag_Id = Pragma_Import then
Code_Val : Uint;
begin
- GNAT_Pragma;
-
if not OpenVMS_On_Target then
Error_Pragma
("?pragma% ignored (applies only to Open'V'M'S)");
(Arg_Internal : Node_Id := Empty)
is
begin
- GNAT_Pragma;
-
if No (Arg_Internal) then
Error_Pragma ("Internal parameter required for pragma%");
end if;
-- Pragma cannot apply to subprogram body
if Is_Subprogram (Def_Id)
- and then
- Nkind (Parent
- (Declaration_Node (Def_Id))) = N_Subprogram_Body
+ and then Nkind (Parent (Declaration_Node (Def_Id))) =
+ N_Subprogram_Body
then
Error_Pragma
("pragma% requires separate spec"
return;
end if;
- -- Import pragmas must be be for imported entities
+ -- Import pragmas must be for imported entities
if Prag_Id = Pragma_Import_Function
or else
Exp : Node_Id;
begin
- GNAT_Pragma;
Check_No_Identifiers;
Check_At_Least_N_Arguments (1);
Process_Interface_Name (Def_Id, Arg3, Arg4);
-- Note that we do not set Is_Public here. That's because we
- -- only want to set if if there is no address clause, and we
+ -- only want to set it if there is no address clause, and we
-- don't know that yet, so we delay that processing till
-- freeze time.
if Present (Decl)
and then Nkind (Decl) = N_Subprogram_Declaration
and then Present (Corresponding_Body (Decl))
- and then
- Nkind
- (Unit_Declaration_Node
- (Corresponding_Body (Decl))) =
+ and then Nkind (Unit_Declaration_Node
+ (Corresponding_Body (Decl))) =
N_Subprogram_Renaming_Declaration
then
Error_Msg_Sloc := Sloc (Def_Id);
elsif (C = Convention_Java or else C = Convention_CIL)
and then
- (Ekind (Def_Id) = E_Package
- or else Ekind (Def_Id) = E_Generic_Package
+ (Is_Package_Or_Generic_Package (Def_Id)
or else Ekind (Def_Id) = E_Exception
or else Nkind (Parent (Def_Id)) = N_Component_Declaration)
then
and then Present (Corresponding_Body (Decl))
then
Set_Inline_Flags (Corresponding_Body (Decl));
+
+ elsif Is_Generic_Instance (Subp) then
+
+ -- Indicate that the body needs to be created for
+ -- inlining subsequent calls. The instantiation
+ -- node follows the declaration of the wrapper
+ -- package created for it.
+
+ if Scope (Subp) /= Standard_Standard
+ and then
+ Need_Subprogram_Instance_Body
+ (Next (Unit_Declaration_Node (Scope (Alias (Subp)))),
+ Subp)
+ then
+ null;
+ end if;
end if;
end if;
Link_Nam : Node_Id;
String_Val : String_Id;
- procedure Check_Form_Of_Interface_Name (SN : Node_Id);
+ procedure Check_Form_Of_Interface_Name
+ (SN : Node_Id;
+ Ext_Name_Case : Boolean);
-- SN is a string literal node for an interface name. This routine
-- performs some minimal checks that the name is reasonable. In
-- particular that no spaces or other obviously incorrect characters
-- appear. This is only a warning, since any characters are allowed.
+ -- Ext_Name_Case is True for an External_Name, False for a Link_Name.
----------------------------------
-- Check_Form_Of_Interface_Name --
----------------------------------
- procedure Check_Form_Of_Interface_Name (SN : Node_Id) is
+ procedure Check_Form_Of_Interface_Name
+ (SN : Node_Id;
+ Ext_Name_Case : Boolean)
+ is
S : constant String_Id := Strval (Expr_Value_S (SN));
SL : constant Nat := String_Length (S);
C : Char_Code;
for J in 1 .. SL loop
C := Get_String_Char (S, J);
- if Warn_On_Export_Import
- and then
- (not In_Character_Range (C)
- or else (Get_Character (C) = ' '
- and then VM_Target /= CLI_Target)
- or else Get_Character (C) = ',')
+ -- Look for dubious character and issue unconditional warning.
+ -- Definitely dubious if not in character range.
+
+ if not In_Character_Range (C)
+
+ -- For all cases except external names on CLI target,
+ -- commas, spaces and slashes are dubious (in CLI, we use
+ -- spaces and commas in external names to specify assembly
+ -- version and public key).
+
+ or else ((not Ext_Name_Case or else VM_Target /= CLI_Target)
+ and then (Get_Character (C) = ' '
+ or else
+ Get_Character (C) = ','
+ or else
+ Get_Character (C) = '/'
+ or else
+ Get_Character (C) = '\'))
then
- Error_Msg_N
- ("?interface name contains illegal character", SN);
+ Error_Msg
+ ("?interface name contains illegal character",
+ Sloc (SN) + Source_Ptr (J));
end if;
end loop;
end Check_Form_Of_Interface_Name;
if Present (Ext_Nam) then
Check_Arg_Is_Static_Expression (Ext_Nam, Standard_String);
- Check_Form_Of_Interface_Name (Ext_Nam);
+ Check_Form_Of_Interface_Name (Ext_Nam, Ext_Name_Case => True);
- -- Verify that the external name is not the name of a local
- -- entity, which would hide the imported one and lead to
- -- run-time surprises. The problem can only arise for entities
- -- declared in a package body (otherwise the external name is
- -- fully qualified and won't conflict).
+ -- Verify that external name is not the name of a local entity,
+ -- which would hide the imported one and could lead to run-time
+ -- surprises. The problem can only arise for entities declared in
+ -- a package body (otherwise the external name is fully qualified
+ -- and will not conflict).
declare
Nam : Name_Id;
Par := Parent (E);
while Present (Par) loop
if Nkind (Par) = N_Package_Body then
- Error_Msg_Sloc := Sloc (E);
+ Error_Msg_Sloc := Sloc (E);
Error_Msg_NE
("imported entity is hidden by & declared#",
- Ext_Arg, E);
+ Ext_Arg, E);
exit;
end if;
if Present (Link_Nam) then
Check_Arg_Is_Static_Expression (Link_Nam, Standard_String);
- Check_Form_Of_Interface_Name (Link_Nam);
+ Check_Form_Of_Interface_Name (Link_Nam, Ext_Name_Case => False);
end if;
-- If there is no link name, just set the external name
E : Entity_Id;
In_Package_Spec : constant Boolean :=
- (Ekind (Current_Scope) = E_Package
- or else
- Ekind (Current_Scope) = E_Generic_Package)
+ Is_Package_Or_Generic_Package (Current_Scope)
and then not In_Package_Body (Current_Scope);
procedure Suppress_Unsuppress_Echeck (E : Entity_Id; C : Check_Id);
procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id) is
Class : Node_Id;
Param : Node_Id;
+ Mech_Name_Id : Name_Id;
procedure Bad_Class;
-- Signal bad descriptor class name
("mechanism for & has already been set", Mech_Name, Ent);
end if;
- -- MECHANISM_NAME ::= value | reference | descriptor
+ -- MECHANISM_NAME ::= value | reference | descriptor |
+ -- short_descriptor
if Nkind (Mech_Name) = N_Identifier then
if Chars (Mech_Name) = Name_Value then
Set_Mechanism (Ent, By_Descriptor);
return;
+ elsif Chars (Mech_Name) = Name_Short_Descriptor then
+ Check_VMS (Mech_Name);
+ Set_Mechanism (Ent, By_Short_Descriptor);
+ return;
+
elsif Chars (Mech_Name) = Name_Copy then
Error_Pragma_Arg
("bad mechanism name, Value assumed", Mech_Name);
Bad_Mechanism;
end if;
- -- MECHANISM_NAME ::= descriptor (CLASS_NAME)
+ -- MECHANISM_NAME ::= descriptor (CLASS_NAME) |
+ -- short_descriptor (CLASS_NAME)
-- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
-- Note: this form is parsed as an indexed component
elsif Nkind (Mech_Name) = N_Indexed_Component then
+
Class := First (Expressions (Mech_Name));
if Nkind (Prefix (Mech_Name)) /= N_Identifier
- or else Chars (Prefix (Mech_Name)) /= Name_Descriptor
- or else Present (Next (Class))
+ or else not (Chars (Prefix (Mech_Name)) = Name_Descriptor or else
+ Chars (Prefix (Mech_Name)) = Name_Short_Descriptor)
+ or else Present (Next (Class))
then
Bad_Mechanism;
+ else
+ Mech_Name_Id := Chars (Prefix (Mech_Name));
end if;
- -- MECHANISM_NAME ::= descriptor (Class => CLASS_NAME)
+ -- MECHANISM_NAME ::= descriptor (Class => CLASS_NAME) |
+ -- short_descriptor (Class => CLASS_NAME)
-- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
-- Note: this form is parsed as a function call
Param := First (Parameter_Associations (Mech_Name));
if Nkind (Name (Mech_Name)) /= N_Identifier
- or else Chars (Name (Mech_Name)) /= Name_Descriptor
+ or else not (Chars (Name (Mech_Name)) = Name_Descriptor or else
+ Chars (Name (Mech_Name)) = Name_Short_Descriptor)
or else Present (Next (Param))
or else No (Selector_Name (Param))
or else Chars (Selector_Name (Param)) /= Name_Class
Bad_Mechanism;
else
Class := Explicit_Actual_Parameter (Param);
+ Mech_Name_Id := Chars (Name (Mech_Name));
end if;
else
if Nkind (Class) /= N_Identifier then
Bad_Class;
- elsif Chars (Class) = Name_UBS then
+ elsif Mech_Name_Id = Name_Descriptor
+ and then Chars (Class) = Name_UBS
+ then
Set_Mechanism (Ent, By_Descriptor_UBS);
- elsif Chars (Class) = Name_UBSB then
+ elsif Mech_Name_Id = Name_Descriptor
+ and then Chars (Class) = Name_UBSB
+ then
Set_Mechanism (Ent, By_Descriptor_UBSB);
- elsif Chars (Class) = Name_UBA then
+ elsif Mech_Name_Id = Name_Descriptor
+ and then Chars (Class) = Name_UBA
+ then
Set_Mechanism (Ent, By_Descriptor_UBA);
- elsif Chars (Class) = Name_S then
+ elsif Mech_Name_Id = Name_Descriptor
+ and then Chars (Class) = Name_S
+ then
Set_Mechanism (Ent, By_Descriptor_S);
- elsif Chars (Class) = Name_SB then
+ elsif Mech_Name_Id = Name_Descriptor
+ and then Chars (Class) = Name_SB
+ then
Set_Mechanism (Ent, By_Descriptor_SB);
- elsif Chars (Class) = Name_A then
+ elsif Mech_Name_Id = Name_Descriptor
+ and then Chars (Class) = Name_A
+ then
Set_Mechanism (Ent, By_Descriptor_A);
- elsif Chars (Class) = Name_NCA then
+ elsif Mech_Name_Id = Name_Descriptor
+ and then Chars (Class) = Name_NCA
+ then
Set_Mechanism (Ent, By_Descriptor_NCA);
+ elsif Mech_Name_Id = Name_Short_Descriptor
+ and then Chars (Class) = Name_UBS
+ then
+ Set_Mechanism (Ent, By_Short_Descriptor_UBS);
+
+ elsif Mech_Name_Id = Name_Short_Descriptor
+ and then Chars (Class) = Name_UBSB
+ then
+ Set_Mechanism (Ent, By_Short_Descriptor_UBSB);
+
+ elsif Mech_Name_Id = Name_Short_Descriptor
+ and then Chars (Class) = Name_UBA
+ then
+ Set_Mechanism (Ent, By_Short_Descriptor_UBA);
+
+ elsif Mech_Name_Id = Name_Short_Descriptor
+ and then Chars (Class) = Name_S
+ then
+ Set_Mechanism (Ent, By_Short_Descriptor_S);
+
+ elsif Mech_Name_Id = Name_Short_Descriptor
+ and then Chars (Class) = Name_SB
+ then
+ Set_Mechanism (Ent, By_Short_Descriptor_SB);
+
+ elsif Mech_Name_Id = Name_Short_Descriptor
+ and then Chars (Class) = Name_A
+ then
+ Set_Mechanism (Ent, By_Short_Descriptor_A);
+
+ elsif Mech_Name_Id = Name_Short_Descriptor
+ and then Chars (Class) = Name_NCA
+ then
+ Set_Mechanism (Ent, By_Short_Descriptor_NCA);
+
else
Bad_Class;
end if;
Opt.Check_Policy_List := N;
end Assertion_Policy;
+ ------------------------------
+ -- Assume_No_Invalid_Values --
+ ------------------------------
+
+ -- pragma Assume_No_Invalid_Values (On | Off);
+
+ when Pragma_Assume_No_Invalid_Values =>
+ GNAT_Pragma;
+ Check_Valid_Configuration_Pragma;
+ Check_Arg_Count (1);
+ Check_No_Identifiers;
+ Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
+
+ if Chars (Expression (Arg1)) = Name_On then
+ Assume_No_Invalid_Values := True;
+ else
+ Assume_No_Invalid_Values := False;
+ end if;
+
---------------
-- AST_Entry --
---------------
-- pragma Comment (static_string_EXPRESSION)
- -- Processing for pragma Comment shares the circuitry for
- -- pragma Ident. The only differences are that Ident enforces
- -- a limit of 31 characters on its argument, and also enforces
- -- limitations on placement for DEC compatibility. Pragma
- -- Comment shares neither of these restrictions.
+ -- Processing for pragma Comment shares the circuitry for pragma
+ -- Ident. The only differences are that Ident enforces a limit of 31
+ -- characters on its argument, and also enforces limitations on
+ -- placement for DEC compatibility. Pragma Comment shares neither of
+ -- these restrictions.
-------------------
-- Common_Object --
-- (boolean_EXPRESSION, static_string_EXPRESSION);
when Pragma_Compile_Time_Error =>
+ GNAT_Pragma;
Process_Compile_Time_Warning_Or_Error;
--------------------------
-- (boolean_EXPRESSION, static_string_EXPRESSION);
when Pragma_Compile_Time_Warning =>
+ GNAT_Pragma;
Process_Compile_Time_Warning_Or_Error;
-------------------
when Pragma_CPP_Virtual => CPP_Virtual : declare
begin
+ GNAT_Pragma;
+
if Warn_On_Obsolescent_Feature then
Error_Msg_N
("'G'N'A'T pragma cpp'_virtual is now obsolete and has " &
when Pragma_CPP_Vtable => CPP_Vtable : declare
begin
+ GNAT_Pragma;
+
if Warn_On_Obsolescent_Feature then
Error_Msg_N
("'G'N'A'T pragma cpp'_vtable is now obsolete and has " &
-- pragma Discard_Names [([On =>] LOCAL_NAME)];
when Pragma_Discard_Names => Discard_Names : declare
- E_Id : Entity_Id;
E : Entity_Id;
+ E_Id : Entity_Id;
begin
Check_Ada_83_Warning;
Check_Arg_Count (1);
Check_Optional_Identifier (Arg1, Name_On);
Check_Arg_Is_Local_Name (Arg1);
+
E_Id := Expression (Arg1);
if Etype (E_Id) = Any_Type then
end if;
if (Is_First_Subtype (E)
- and then (Is_Enumeration_Type (E)
- or else Is_Tagged_Type (E)))
+ and then
+ (Is_Enumeration_Type (E) or else Is_Tagged_Type (E)))
or else Ekind (E) = E_Exception
then
Set_Discard_Names (E);
Error_Pragma_Arg
("inappropriate entity for pragma%", Arg1);
end if;
+
end if;
end if;
end Discard_Names;
Code : Node_Id renames Args (4);
begin
+ GNAT_Pragma;
+
if Inside_A_Generic then
Error_Pragma ("pragma% cannot be used for generic entities");
end if;
Typ : Entity_Id;
begin
+ GNAT_Pragma;
Check_No_Identifiers;
Check_Arg_Count (1);
Check_Arg_Is_Local_Name (Arg1);
Code : Node_Id renames Args (4);
begin
+ GNAT_Pragma;
Gather_Associations (Names, Args);
if Present (External) and then Present (Code) then
-- pragma Inline_Always ( NAME {, NAME} );
when Pragma_Inline_Always =>
+ GNAT_Pragma;
Process_Inline (True);
--------------------
-- pragma Inline_Generic (NAME {, NAME});
when Pragma_Inline_Generic =>
+ GNAT_Pragma;
Process_Generic_List;
----------------------
-- it was misplaced.
when Pragma_No_Body =>
+ GNAT_Pragma;
Pragma_Misplaced;
---------------
end loop;
end No_Return;
+ -----------------
+ -- No_Run_Time --
+ -----------------
+
+ -- pragma No_Run_Time;
+
+ -- Note: this pragma is retained for backwards compatibility.
+ -- See body of Rtsfind for full details on its handling.
+
+ when Pragma_No_Run_Time =>
+ GNAT_Pragma;
+ Check_Valid_Configuration_Pragma;
+ Check_Arg_Count (0);
+
+ No_Run_Time_Mode := True;
+ Configurable_Run_Time_Mode := True;
+
+ -- Set Duration to 32 bits if word size is 32
+
+ if Ttypes.System_Word_Size = 32 then
+ Duration_32_Bits_On_Target := True;
+ end if;
+
+ -- Set appropriate restrictions
+
+ Set_Restriction (No_Finalization, N);
+ Set_Restriction (No_Exception_Handlers, N);
+ Set_Restriction (Max_Tasks, N, 0);
+ Set_Restriction (No_Tasking, N);
+
------------------------
-- No_Strict_Aliasing --
------------------------
-- pragma No_Strict_Aliasing [([Entity =>] type_LOCAL_NAME)];
- when Pragma_No_Strict_Aliasing => No_Strict_Alias : declare
+ when Pragma_No_Strict_Aliasing => No_Strict_Aliasing : declare
E_Id : Entity_Id;
begin
Set_No_Strict_Aliasing (Implementation_Base_Type (E_Id));
end if;
- end No_Strict_Alias;
+ end No_Strict_Aliasing;
+
+ -----------------------
+ -- Normalize_Scalars --
+ -----------------------
+
+ -- pragma Normalize_Scalars;
+
+ when Pragma_Normalize_Scalars =>
+ Check_Ada_83_Warning;
+ Check_Arg_Count (0);
+ Check_Valid_Configuration_Pragma;
+ Normalize_Scalars := True;
+ Init_Or_Norm_Scalars := True;
-----------------
-- Obsolescent --
if Present (Ename) then
-- If entity name matches, we are fine
+ -- Save entity in pragma argument, for ASIS use.
if Chars (Ename) = Chars (Ent) then
- null;
+ Set_Entity (Ename, Ent);
+ Generate_Reference (Ent, Ename);
-- If entity name does not match, only possibility is an
-- enumeration literal from an enumeration type declaration.
"enumeration literal");
elsif Chars (Ent) = Chars (Ename) then
+ Set_Entity (Ename, Ent);
+ Generate_Reference (Ent, Ename);
exit;
else
declare
Ent : constant Entity_Id := Find_Lib_Unit_Name;
begin
- if Ekind (Ent) = E_Package
- or else Ekind (Ent) = E_Generic_Package
- then
+ if Is_Package_Or_Generic_Package (Ent) then
Set_Obsolescent (Ent);
return;
end if;
end if;
end Obsolescent;
- -----------------
- -- No_Run_Time --
- -----------------
-
- -- pragma No_Run_Time
-
- -- Note: this pragma is retained for backwards compatibility.
- -- See body of Rtsfind for full details on its handling.
-
- when Pragma_No_Run_Time =>
- GNAT_Pragma;
- Check_Valid_Configuration_Pragma;
- Check_Arg_Count (0);
-
- No_Run_Time_Mode := True;
- Configurable_Run_Time_Mode := True;
-
- -- Set Duration to 32 bits if word size is 32
-
- if Ttypes.System_Word_Size = 32 then
- Duration_32_Bits_On_Target := True;
- end if;
-
- -- Set appropriate restrictions
-
- Set_Restriction (No_Finalization, N);
- Set_Restriction (No_Exception_Handlers, N);
- Set_Restriction (Max_Tasks, N, 0);
- Set_Restriction (No_Tasking, N);
-
- -----------------------
- -- Normalize_Scalars --
- -----------------------
-
- -- pragma Normalize_Scalars;
-
- when Pragma_Normalize_Scalars =>
- Check_Ada_83_Warning;
- Check_Arg_Count (0);
- Check_Valid_Configuration_Pragma;
- Normalize_Scalars := True;
- Init_Or_Norm_Scalars := True;
-
--------------
-- Optimize --
--------------
end if;
end Preelab_Init;
- -------------
- -- Polling --
- -------------
-
- -- pragma Polling (ON | OFF);
-
- when Pragma_Polling =>
- GNAT_Pragma;
- Check_Arg_Count (1);
- Check_No_Identifiers;
- Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
- Polling_Required := (Chars (Expression (Arg1)) = Name_On);
-
--------------------
-- Persistent_BSS --
--------------------
end if;
end Persistent_BSS;
+ -------------
+ -- Polling --
+ -------------
+
+ -- pragma Polling (ON | OFF);
+
+ when Pragma_Polling =>
+ GNAT_Pragma;
+ Check_Arg_Count (1);
+ Check_No_Identifiers;
+ Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
+ Polling_Required := (Chars (Expression (Arg1)) = Name_On);
+
-------------------
-- Postcondition --
-------------------
-- or the identifier GCC, no other identifiers are acceptable.
when Pragma_System_Name =>
+ GNAT_Pragma;
Check_No_Identifiers;
Check_Arg_Count (1);
Check_Arg_Is_One_Of (Arg1, Name_Gcc, Name_Gnat);
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 --
----------------
Variant : Node_Id;
begin
- GNAT_Pragma;
+ Ada_2005_Pragma;
Check_No_Identifiers;
Check_Arg_Count (1);
Check_Arg_Is_Local_Name (Arg1);
-- pragma Unsuppress (IDENTIFIER [, [On =>] NAME]);
when Pragma_Unsuppress =>
- GNAT_Pragma;
+ Ada_2005_Pragma;
Process_Suppress_Unsuppress (False);
-------------------
-- pragma Wide_Character_Encoding (IDENTIFIER);
when Pragma_Wide_Character_Encoding =>
+ GNAT_Pragma;
-- Nothing to do, handled in parser. Note that we do not enforce
-- configuration pragma placement, this pragma can appear at any
Pragma_Annotate => -1,
Pragma_Assert => -1,
Pragma_Assertion_Policy => 0,
+ Pragma_Assume_No_Invalid_Values => 0,
Pragma_Asynchronous => -1,
Pragma_Atomic => 0,
Pragma_Atomic_Components => 0,
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,
OSDN Git Service
