Skip to content

R
riscv-gcc-1
Commit ac9e9918 by Robert Dewar Committed by Arnaud Charlet
Options

exp_prag.adb (Expand_Pragma_Common_Object): Use a single Machine_Attribute… 

exp_prag.adb (Expand_Pragma_Common_Object): Use a single Machine_Attribute pragma internally to implement the user pragma.

2006-10-31  Robert Dewar  <dewar@adacore.com>

	* exp_prag.adb (Expand_Pragma_Common_Object): Use a single
	Machine_Attribute pragma internally to implement the user pragma.
	Add processing for pragma Interface so that it is now completely
	equivalent to pragma Import.

	* sem_prag.adb (Analyze_Pragma, case Obsolescent): Extend this pragma
	so that it can be applied to all entities, including record components
	and enumeration literals.
	(Analyze_Pragma, case Priority_Specific_Dispatching): Check whether
	priority ranges are correct, verify compatibility against task
	dispatching and locking policies, and if everything is correct an entry
	is added to the table containing priority specific dispatching entries
	for this compilation unit.
	(Delay_Config_Pragma_Analyze): Delay processing
	Priority_Specific_Dispatching pragmas because when processing the
	pragma we need to access run-time data, such as the range of
	System.Any_Priority.
	(Sig_Flags): Add Pragma_Priority_Specific_Dispatching.
	Allow pragma Unreferenced as a context item
	Add pragma Preelaborable_Initialization
	(Analyze_Pragma, case Interface): Interface is extended so that it is
	now syntactically and semantically equivalent to Import.
	(Analyze_Pragma, case Compile_Time_Warning): Fix error of blowups on
	insertion characters.
	Add handling for Pragma_Wide_Character_Encoding
	(Process_Restrictions_Restriction_Warnings): Ensure that a warning
	never supercedes a real restriction, and that a real restriction
	always supercedes a warning.
	(Analyze_Pragma, case Assert): Set Low_Bound_Known if assert is of
	appropriate form.

From-SVN: r118268
parent 53cc4a7a
Showing with 890 additions and 482 deletions
gcc/ada/exp_prag.adb
...@@ -63,7 +63,7 @@ package body Exp_Prag is ...@@ -63,7 +63,7 @@ package body Exp_Prag is
procedure Expand_Pragma_Abort_Defer (N : Node_Id); procedure Expand_Pragma_Abort_Defer (N : Node_Id);
procedure Expand_Pragma_Assert (N : Node_Id); procedure Expand_Pragma_Assert (N : Node_Id);
procedure Expand_Pragma_Common_Object (N : Node_Id); procedure Expand_Pragma_Common_Object (N : Node_Id);
procedure Expand_Pragma_Import (N : Node_Id); procedure Expand_Pragma_Import_Or_Interface (N : Node_Id);
procedure Expand_Pragma_Import_Export_Exception (N : Node_Id); procedure Expand_Pragma_Import_Export_Exception (N : Node_Id);
procedure Expand_Pragma_Inspection_Point (N : Node_Id); procedure Expand_Pragma_Inspection_Point (N : Node_Id);
procedure Expand_Pragma_Interrupt_Priority (N : Node_Id); procedure Expand_Pragma_Interrupt_Priority (N : Node_Id);
...@@ -136,7 +136,7 @@ package body Exp_Prag is ...@@ -136,7 +136,7 @@ package body Exp_Prag is
Expand_Pragma_Import_Export_Exception (N); Expand_Pragma_Import_Export_Exception (N);
when Pragma_Import => when Pragma_Import =>
Expand_Pragma_Import (N); Expand_Pragma_Import_Or_Interface (N);
when Pragma_Import_Exception => when Pragma_Import_Exception =>
Expand_Pragma_Import_Export_Exception (N); Expand_Pragma_Import_Export_Exception (N);
...@@ -144,6 +144,9 @@ package body Exp_Prag is ...@@ -144,6 +144,9 @@ package body Exp_Prag is
when Pragma_Inspection_Point => when Pragma_Inspection_Point =>
Expand_Pragma_Inspection_Point (N); Expand_Pragma_Inspection_Point (N);
when Pragma_Interface =>
Expand_Pragma_Import_Or_Interface (N);
when Pragma_Interrupt_Priority => when Pragma_Interrupt_Priority =>
Expand_Pragma_Interrupt_Priority (N); Expand_Pragma_Interrupt_Priority (N);
...@@ -299,19 +302,12 @@ package body Exp_Prag is ...@@ -299,19 +302,12 @@ package body Exp_Prag is
-- Expand_Pragma_Common_Object -- -- Expand_Pragma_Common_Object --
--------------------------------- ---------------------------------
-- Add series of pragmas to replicate semantic effect in DEC Ada -- Use a machine attribute to replicate semantic effect in DEC Ada
-- pragma Linker_Section (internal_name, external_name); -- pragma Machine_Attribute (intern_name, "common_object", extern_name);
-- pragma Machine_Attribute (internal_name, "overlaid");
-- pragma Machine_Attribute (internal_name, "global");
-- pragma Machine_Attribute (internal_name, "initialize");
-- For now we do nothing with the size attribute ??? -- For now we do nothing with the size attribute ???
-- Really this expansion would be much better in the back end. The
-- front end should not need to know about target dependent, back end
-- dependent semantics ???
procedure Expand_Pragma_Common_Object (N : Node_Id) is procedure Expand_Pragma_Common_Object (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N); Loc : constant Source_Ptr := Sloc (N);
...@@ -351,34 +347,9 @@ package body Exp_Prag is ...@@ -351,34 +347,9 @@ package body Exp_Prag is
Ploc := Sloc (Psect); Ploc := Sloc (Psect);
-- Insert pragmas -- Insert the pragma
Insert_List_After_And_Analyze (N, New_List (
-- The Linker_Section pragma ensures the correct section
Make_Pragma (Loc,
Chars => Name_Linker_Section,
Pragma_Argument_Associations => New_List (
Make_Pragma_Argument_Association (Iloc,
Expression => New_Copy_Tree (Internal)),
Make_Pragma_Argument_Association (Ploc,
Expression => New_Copy_Tree (Psect)))),
-- Machine_Attribute "overlaid" ensures that this section
-- overlays any other sections of the same name.
Make_Pragma (Loc,
Chars => Name_Machine_Attribute,
Pragma_Argument_Associations => New_List (
Make_Pragma_Argument_Association (Iloc,
Expression => New_Copy_Tree (Internal)),
Make_Pragma_Argument_Association (Eloc,
Expression =>
Make_String_Literal (Sloc => Ploc,
Strval => "overlaid")))),
-- Machine_Attribute "global" ensures that section is visible Insert_After_And_Analyze (N,
Make_Pragma (Loc, Make_Pragma (Loc,
Chars => Name_Machine_Attribute, Chars => Name_Machine_Attribute,
...@@ -388,24 +359,15 @@ package body Exp_Prag is ...@@ -388,24 +359,15 @@ package body Exp_Prag is
Make_Pragma_Argument_Association (Eloc, Make_Pragma_Argument_Association (Eloc,
Expression => Expression =>
Make_String_Literal (Sloc => Ploc, Make_String_Literal (Sloc => Ploc,
Strval => "global")))), Strval => "common_object")),
Make_Pragma_Argument_Association (Ploc,
-- Machine_Attribute "initialize" ensures section is demand zeroed Expression => New_Copy_Tree (Psect)))));
Make_Pragma (Loc,
Chars => Name_Machine_Attribute,
Pragma_Argument_Associations => New_List (
Make_Pragma_Argument_Association (Iloc,
Expression => New_Copy_Tree (Internal)),
Make_Pragma_Argument_Association (Eloc,
Expression =>
Make_String_Literal (Sloc => Ploc,
Strval => "initialize"))))));
end Expand_Pragma_Common_Object; end Expand_Pragma_Common_Object;
-------------------------- ---------------------------------------
-- Expand_Pragma_Import -- -- Expand_Pragma_Import_Or_Interface --
-------------------------- ---------------------------------------
-- When applied to a variable, the default initialization must not be -- When applied to a variable, the default initialization must not be
-- done. As it is already done when the pragma is found, we just get rid -- done. As it is already done when the pragma is found, we just get rid
...@@ -418,7 +380,7 @@ package body Exp_Prag is ...@@ -418,7 +380,7 @@ package body Exp_Prag is
-- have to elaborate the initialization expression when it is first -- have to elaborate the initialization expression when it is first
-- seen (i.e. this elaboration cannot be deferred to the freeze point). -- seen (i.e. this elaboration cannot be deferred to the freeze point).
procedure Expand_Pragma_Import (N : Node_Id) is procedure Expand_Pragma_Import_Or_Interface (N : Node_Id) is
Def_Id : constant Entity_Id := Entity (Arg2 (N)); Def_Id : constant Entity_Id := Entity (Arg2 (N));
Typ : Entity_Id; Typ : Entity_Id;
Init_Call : Node_Id; Init_Call : Node_Id;
...@@ -455,7 +417,7 @@ package body Exp_Prag is ...@@ -455,7 +417,7 @@ package body Exp_Prag is
Set_Expression (Parent (Def_Id), Empty); Set_Expression (Parent (Def_Id), Empty);
end if; end if;
end if; end if;
end Expand_Pragma_Import; end Expand_Pragma_Import_Or_Interface;
------------------------------------------- -------------------------------------------
-- Expand_Pragma_Import_Export_Exception -- -- Expand_Pragma_Import_Export_Exception --
......
gcc/ada/sem_prag.adb
...@@ -495,7 +495,15 @@ package body Sem_Prag is ...@@ -495,7 +495,15 @@ package body Sem_Prag is
function Is_Configuration_Pragma return Boolean; function Is_Configuration_Pragma return Boolean;
-- Deterermines if the placement of the current pragma is appropriate -- Deterermines if the placement of the current pragma is appropriate
-- for a configuration pragma (precedes the current compilation unit) -- for a configuration pragma (precedes the current compilation unit).
function Is_In_Context_Clause return Boolean;
-- Returns True if pragma appears within the context clause of a unit,
-- and False for any other placement (does not generate any messages).
function Is_Static_String_Expression (Arg : Node_Id) return Boolean;
-- Analyzes the argument, and determines if it is a static string
-- expression, returns True if so, False if non-static or not String.
procedure Pragma_Misplaced; procedure Pragma_Misplaced;
-- Issue fatal error message for misplaced pragma -- Issue fatal error message for misplaced pragma
...@@ -581,8 +589,9 @@ package body Sem_Prag is ...@@ -581,8 +589,9 @@ package body Sem_Prag is
procedure Process_Interrupt_Or_Attach_Handler; procedure Process_Interrupt_Or_Attach_Handler;
-- Common processing for Interrupt and Attach_Handler pragmas -- Common processing for Interrupt and Attach_Handler pragmas
procedure Process_Restrictions_Or_Restriction_Warnings; procedure Process_Restrictions_Or_Restriction_Warnings (Warn : Boolean);
-- Common processing for Restrictions and Restriction_Warnings pragmas -- Common processing for Restrictions and Restriction_Warnings pragmas.
-- Warn is False for Restrictions, True for Restriction_Warnings.
procedure Process_Suppress_Unsuppress (Suppress_Case : Boolean); procedure Process_Suppress_Unsuppress (Suppress_Case : Boolean);
-- Common processing for Suppress and Unsuppress. The boolean parameter -- Common processing for Suppress and Unsuppress. The boolean parameter
...@@ -1803,6 +1812,46 @@ package body Sem_Prag is ...@@ -1803,6 +1812,46 @@ package body Sem_Prag is
end if; end if;
end Is_Configuration_Pragma; end Is_Configuration_Pragma;
--------------------------
-- Is_In_Context_Clause --
--------------------------
function Is_In_Context_Clause return Boolean is
Plist : List_Id;
Parent_Node : Node_Id;
begin
if not Is_List_Member (N) then
return False;
else
Plist := List_Containing (N);
Parent_Node := Parent (Plist);
if Parent_Node = Empty
or else Nkind (Parent_Node) /= N_Compilation_Unit
or else Context_Items (Parent_Node) /= Plist
then
return False;
end if;
end if;
return True;
end Is_In_Context_Clause;
---------------------------------
-- Is_Static_String_Expression --
---------------------------------
function Is_Static_String_Expression (Arg : Node_Id) return Boolean is
Argx : constant Node_Id := Get_Pragma_Arg (Arg);
begin
Analyze_And_Resolve (Argx);
return Is_OK_Static_Expression (Argx)
and then Nkind (Argx) = N_String_Literal;
end Is_Static_String_Expression;
---------------------- ----------------------
-- Pragma_Misplaced -- -- Pragma_Misplaced --
---------------------- ----------------------
...@@ -1961,9 +2010,9 @@ package body Sem_Prag is ...@@ -1961,9 +2010,9 @@ package body Sem_Prag is
procedure Set_Convention_From_Pragma (E : Entity_Id) is procedure Set_Convention_From_Pragma (E : Entity_Id) is
begin begin
-- Check invalid attempt to change convention for an overridden -- Ada 2005 (AI-430): Check invalid attempt to change convention
-- dispatching operation. This is Ada 2005 AI 430. Technically -- for an overridden dispatching operation. Technically this is
-- this is an amendment and should only be done in Ada 2005 mode. -- an amendment and should only be done in Ada 2005 mode.
-- However, this is clearly a mistake, since the problem that is -- However, this is clearly a mistake, since the problem that is
-- addressed by this AI is that there is a clear gap in the RM! -- addressed by this AI is that there is a clear gap in the RM!
...@@ -3585,7 +3634,9 @@ package body Sem_Prag is ...@@ -3585,7 +3634,9 @@ package body Sem_Prag is
-- but it is harmless (and more straightforward) to simply handle all -- but it is harmless (and more straightforward) to simply handle all
-- cases here, even if it means we repeat a bit of work in some cases. -- cases here, even if it means we repeat a bit of work in some cases.
procedure Process_Restrictions_Or_Restriction_Warnings is procedure Process_Restrictions_Or_Restriction_Warnings
(Warn : Boolean)
is
Arg : Node_Id; Arg : Node_Id;
R_Id : Restriction_Id; R_Id : Restriction_Id;
Id : Name_Id; Id : Name_Id;
...@@ -3596,10 +3647,6 @@ package body Sem_Prag is ...@@ -3596,10 +3647,6 @@ package body Sem_Prag is
-- Checks unit name parameter for No_Dependence. Returns if it has -- Checks unit name parameter for No_Dependence. Returns if it has
-- an appropriate form, otherwise raises pragma argument error. -- an appropriate form, otherwise raises pragma argument error.
procedure Set_Warning (R : All_Restrictions);
-- If this is a Restriction_Warnings pragma, set warning flag,
-- otherwise reset the flag.
--------------------- ---------------------
-- Check_Unit_Name -- -- Check_Unit_Name --
--------------------- ---------------------
...@@ -3619,19 +3666,6 @@ package body Sem_Prag is ...@@ -3619,19 +3666,6 @@ package body Sem_Prag is
end if; end if;
end Check_Unit_Name; end Check_Unit_Name;
-----------------
-- Set_Warning --
-----------------
procedure Set_Warning (R : All_Restrictions) is
begin
if Prag_Id = Pragma_Restriction_Warnings then
Restriction_Warnings (R) := True;
else
Restriction_Warnings (R) := False;
end if;
end Set_Warning;
-- Start of processing for Process_Restrictions_Or_Restriction_Warnings -- Start of processing for Process_Restrictions_Or_Restriction_Warnings
begin begin
...@@ -3666,16 +3700,33 @@ package body Sem_Prag is ...@@ -3666,16 +3700,33 @@ package body Sem_Prag is
(No_Implementation_Restrictions, Arg); (No_Implementation_Restrictions, Arg);
end if; end if;
Set_Restriction (R_Id, N); -- If this is a warning, then set the warning unless we already
Set_Warning (R_Id); -- have a real restriction active (we never want a warning to
-- override a real restriction).
-- A very special case that must be processed here: if Warn then
-- pragma Restrictions (No_Exceptions) turns off if not Restriction_Active (R_Id) then
-- all run-time checking. This is a bit dubious in Set_Restriction (R_Id, N);
-- terms of the formal language definition, but it Restriction_Warnings (R_Id) := True;
-- is what is intended by RM H.4(12). end if;
-- If real restriction case, then set it and make sure that the
-- restriction warning flag is off, since a real restriction
-- always overrides a warning.
if R_Id = No_Exceptions then else
Set_Restriction (R_Id, N);
Restriction_Warnings (R_Id) := False;
end if;
-- A very special case that must be processed here: pragma
-- Restrictions (No_Exceptions) turns off all run-time
-- checking. This is a bit dubious in terms of the formal
-- language definition, but it is what is intended by RM
-- H.4(12). Restriction_Warnings never affects generated code
-- so this is done only in the real restriction case.
if R_Id = No_Exceptions and then not Warn then
Scope_Suppress := (others => True); Scope_Suppress := (others => True);
end if; end if;
...@@ -3705,19 +3756,36 @@ package body Sem_Prag is ...@@ -3705,19 +3756,36 @@ package body Sem_Prag is
then then
Error_Pragma_Arg Error_Pragma_Arg
("value must be non-negative integer", Arg); ("value must be non-negative integer", Arg);
end if;
-- Restriction pragma is active -- Restriction pragma is active
else Val := Expr_Value (Expr);
Val := Expr_Value (Expr);
if not UI_Is_In_Int_Range (Val) then if not UI_Is_In_Int_Range (Val) then
Error_Pragma_Arg Error_Pragma_Arg
("pragma ignored, value too large?", Arg); ("pragma ignored, value too large?", Arg);
else end if;
Set_Restriction (R_Id, N, Integer (UI_To_Int (Val)));
Set_Warning (R_Id); -- Warning case. If the real restriction is active, then we
-- ignore the request, since warning never overrides a real
-- restriction. Otherwise we set the proper warning. Note that
-- this circuit sets the warning again if it is already set,
-- which is what we want, since the constant may have changed.
if Warn then
if not Restriction_Active (R_Id) then
Set_Restriction
(R_Id, N, Integer (UI_To_Int (Val)));
Restriction_Warnings (R_Id) := True;
end if; end if;
-- Real restriction case, set restriction and make sure warning
-- flag is off since real restriction always overrides warning.
else
Set_Restriction (R_Id, N, Integer (UI_To_Int (Val)));
Restriction_Warnings (R_Id) := False;
end if; end if;
end if; end if;
...@@ -4416,7 +4484,7 @@ package body Sem_Prag is ...@@ -4416,7 +4484,7 @@ package body Sem_Prag is
return; return;
end if; end if;
Set_Is_Ada_2005 (Entity (E_Id)); Set_Is_Ada_2005_Only (Entity (E_Id));
else else
Check_Arg_Count (0); Check_Arg_Count (0);
...@@ -4507,7 +4575,10 @@ package body Sem_Prag is ...@@ -4507,7 +4575,10 @@ package body Sem_Prag is
-- pragma Assert ([Check =>] Boolean_EXPRESSION -- pragma Assert ([Check =>] Boolean_EXPRESSION
-- [, [Message =>] Static_String_EXPRESSION]); -- [, [Message =>] Static_String_EXPRESSION]);
when Pragma_Assert => when Pragma_Assert => Assert : declare
Expr : Node_Id;
begin
Check_At_Least_N_Arguments (1); Check_At_Least_N_Arguments (1);
Check_At_Most_N_Arguments (2); Check_At_Most_N_Arguments (2);
Check_Arg_Order ((Name_Check, Name_Message)); Check_Arg_Order ((Name_Check, Name_Message));
...@@ -4531,13 +4602,15 @@ package body Sem_Prag is ...@@ -4531,13 +4602,15 @@ package body Sem_Prag is
-- directly, or it may cause insertion of actions that would -- directly, or it may cause insertion of actions that would
-- escape the attempt to suppress the assertion code. -- escape the attempt to suppress the assertion code.
Expr := Expression (Arg1);
if Expander_Active and not Assertions_Enabled then if Expander_Active and not Assertions_Enabled then
Rewrite (N, Rewrite (N,
Make_If_Statement (Loc, Make_If_Statement (Loc,
Condition => Condition =>
Make_And_Then (Loc, Make_And_Then (Loc,
Left_Opnd => New_Occurrence_Of (Standard_False, Loc), Left_Opnd => New_Occurrence_Of (Standard_False, Loc),
Right_Opnd => Get_Pragma_Arg (Arg1)), Right_Opnd => Expr),
Then_Statements => New_List ( Then_Statements => New_List (
Make_Null_Statement (Loc)))); Make_Null_Statement (Loc))));
...@@ -4548,9 +4621,29 @@ package body Sem_Prag is ...@@ -4548,9 +4621,29 @@ package body Sem_Prag is
-- and resolve the expression. -- and resolve the expression.
else else
Analyze_And_Resolve (Expression (Arg1), Any_Boolean); Analyze_And_Resolve (Expr, Any_Boolean);
end if; end if;
-- If assertion is of the form (X'First = literal), where X is
-- formal parameter, then set Low_Bound_Known flag on this formal.
if Nkind (Expr) = N_Op_Eq then
declare
Right : constant Node_Id := Right_Opnd (Expr);
Left : constant Node_Id := Left_Opnd (Expr);
begin
if Nkind (Left) = N_Attribute_Reference
and then Attribute_Name (Left) = Name_First
and then Is_Entity_Name (Prefix (Left))
and then Is_Formal (Entity (Prefix (Left)))
and then Nkind (Right) = N_Integer_Literal
then
Set_Low_Bound_Known (Entity (Prefix (Left)));
end if;
end;
end if;
end Assert;
---------------------- ----------------------
-- Assertion_Policy -- -- Assertion_Policy --
---------------------- ----------------------
...@@ -4961,31 +5054,55 @@ package body Sem_Prag is ...@@ -4961,31 +5054,55 @@ package body Sem_Prag is
if Compile_Time_Known_Value (Arg1x) then if Compile_Time_Known_Value (Arg1x) then
if Is_True (Expr_Value (Get_Pragma_Arg (Arg1))) then if Is_True (Expr_Value (Get_Pragma_Arg (Arg1))) then
String_To_Name_Buffer (Strval (Get_Pragma_Arg (Arg2)));
Add_Char_To_Name_Buffer ('?');
declare declare
Msg : String (1 .. Name_Len) := Str : constant String_Id :=
Name_Buffer (1 .. Name_Len); Strval (Get_Pragma_Arg (Arg2));
Len : constant Int := String_Length (Str);
B : Natural; Cont : Boolean;
Ptr : Nat;
CC : Char_Code;
C : Character;
begin begin
-- This loop looks for multiple lines separated by Cont := False;
-- ASCII.LF and breaks them into continuation error Ptr := 1;
-- messages marked with the usual back slash.
-- Loop through segments of message separated by line
B := 1; -- feeds. We output these segments as separate messages
for S in 2 .. Msg'Length - 1 loop -- with continuation marks for all but the first.
if Msg (S) = ASCII.LF then
Msg (S) := '?'; loop
Error_Msg_N (Msg (B .. S), Arg1); Error_Msg_Strlen := 0;
B := S;
Msg (B) := '\'; -- Loop to copy characters from argument to error
-- message string buffer.
loop
exit when Ptr > Len;
CC := Get_String_Char (Str, Ptr);
Ptr := Ptr + 1;
-- Ignore wide chars ??? else store character
if In_Character_Range (CC) then
C := Get_Character (CC);
exit when C = ASCII.LF;
Error_Msg_Strlen := Error_Msg_Strlen + 1;
Error_Msg_String (Error_Msg_Strlen) := C;
end if;
end loop;
-- Here with one line ready to go
if Cont = False then
Error_Msg_N ("?~", Arg1);
Cont := True;
else
Error_Msg_N ("\?~", Arg1);
end if; end if;
end loop;
Error_Msg_N (Msg (B .. Msg'Length), Arg1); exit when Ptr > Len;
end loop;
end; end;
end if; end if;
end if; end if;
...@@ -5739,29 +5856,14 @@ package body Sem_Prag is ...@@ -5739,29 +5856,14 @@ package body Sem_Prag is
-- pragma Elaborate (library_unit_NAME {, library_unit_NAME}); -- pragma Elaborate (library_unit_NAME {, library_unit_NAME});
when Pragma_Elaborate => Elaborate : declare when Pragma_Elaborate => Elaborate : declare
Plist : List_Id; Arg : Node_Id;
Parent_Node : Node_Id; Citem : Node_Id;
Arg : Node_Id;
Citem : Node_Id;
begin begin
-- Pragma must be in context items list of a compilation unit -- Pragma must be in context items list of a compilation unit
if not Is_List_Member (N) then if not Is_In_Context_Clause then
Pragma_Misplaced; Pragma_Misplaced;
return;
else
Plist := List_Containing (N);
Parent_Node := Parent (Plist);
if Parent_Node = Empty
or else Nkind (Parent_Node) /= N_Compilation_Unit
or else Context_Items (Parent_Node) /= Plist
then
Pragma_Misplaced;
return;
end if;
end if; end if;
-- Must be at least one argument -- Must be at least one argument
...@@ -5777,7 +5879,6 @@ package body Sem_Prag is ...@@ -5777,7 +5879,6 @@ package body Sem_Prag is
if Ada_Version = Ada_83 and then Comes_From_Source (N) then if Ada_Version = Ada_83 and then Comes_From_Source (N) then
Citem := Next (N); Citem := Next (N);
while Present (Citem) loop while Present (Citem) loop
if Nkind (Citem) = N_Pragma if Nkind (Citem) = N_Pragma
or else (Nkind (Citem) = N_With_Clause or else (Nkind (Citem) = N_With_Clause
...@@ -5794,13 +5895,13 @@ package body Sem_Prag is ...@@ -5794,13 +5895,13 @@ package body Sem_Prag is
end if; end if;
-- Finally, the arguments must all be units mentioned in a with -- Finally, the arguments must all be units mentioned in a with
-- clause in the same context clause. Note we already checked -- clause in the same context clause. Note we already checked (in
-- (in Par.Prag) that the arguments are either identifiers or -- Par.Prag) that the arguments are all identifiers or selected
-- components.
Arg := Arg1; Arg := Arg1;
Outer : while Present (Arg) loop Outer : while Present (Arg) loop
Citem := First (Plist); Citem := First (List_Containing (N));
Inner : while Citem /= N loop Inner : while Citem /= N loop
if Nkind (Citem) = N_With_Clause if Nkind (Citem) = N_With_Clause
and then Same_Name (Name (Citem), Expression (Arg)) and then Same_Name (Name (Citem), Expression (Arg))
...@@ -5820,6 +5921,7 @@ package body Sem_Prag is ...@@ -5820,6 +5921,7 @@ package body Sem_Prag is
Set_Suppress_Elaboration_Warnings Set_Suppress_Elaboration_Warnings
(Entity (Name (Citem))); (Entity (Name (Citem)));
end if; end if;
exit Inner; exit Inner;
end if; end if;
...@@ -5852,31 +5954,16 @@ package body Sem_Prag is ...@@ -5852,31 +5954,16 @@ package body Sem_Prag is
-- pragma Elaborate_All (library_unit_NAME {, library_unit_NAME}); -- pragma Elaborate_All (library_unit_NAME {, library_unit_NAME});
when Pragma_Elaborate_All => Elaborate_All : declare when Pragma_Elaborate_All => Elaborate_All : declare
Plist : List_Id; Arg : Node_Id;
Parent_Node : Node_Id; Citem : Node_Id;
Arg : Node_Id;
Citem : Node_Id;
begin begin
Check_Ada_83_Warning; Check_Ada_83_Warning;
-- Pragma must be in context items list of a compilation unit -- Pragma must be in context items list of a compilation unit
if not Is_List_Member (N) then if not Is_In_Context_Clause then
Pragma_Misplaced; Pragma_Misplaced;
return;
else
Plist := List_Containing (N);
Parent_Node := Parent (Plist);
if Parent_Node = Empty
or else Nkind (Parent_Node) /= N_Compilation_Unit
or else Context_Items (Parent_Node) /= Plist
then
Pragma_Misplaced;
return;
end if;
end if; end if;
-- Must be at least one argument -- Must be at least one argument
...@@ -5896,7 +5983,7 @@ package body Sem_Prag is ...@@ -5896,7 +5983,7 @@ package body Sem_Prag is
Arg := Arg1; Arg := Arg1;
Outr : while Present (Arg) loop Outr : while Present (Arg) loop
Citem := First (Plist); Citem := First (List_Containing (N));
Innr : while Citem /= N loop Innr : while Citem /= N loop
if Nkind (Citem) = N_With_Clause if Nkind (Citem) = N_With_Clause
...@@ -7182,13 +7269,20 @@ package body Sem_Prag is ...@@ -7182,13 +7269,20 @@ package body Sem_Prag is
--------------- ---------------
-- pragma Interface ( -- pragma Interface (
-- convention_IDENTIFIER, -- [ Convention =>] convention_IDENTIFIER,
-- local_NAME ); -- [ Entity =>] local_NAME
-- [, [External_Name =>] static_string_EXPRESSION ]
-- [, [Link_Name =>] static_string_EXPRESSION ]);
when Pragma_Interface => when Pragma_Interface =>
GNAT_Pragma; GNAT_Pragma;
Check_Arg_Count (2); Check_Arg_Order
Check_No_Identifiers; ((Name_Convention,
Name_Entity,
Name_External_Name,
Name_Link_Name));
Check_At_Least_N_Arguments (2);
Check_At_Most_N_Arguments (4);
Process_Import_Or_Interface; Process_Import_Or_Interface;
-------------------- --------------------
...@@ -8215,119 +8309,204 @@ package body Sem_Prag is ...@@ -8215,119 +8309,204 @@ package body Sem_Prag is
-- Obsolescent -- -- Obsolescent --
----------------- -----------------
-- pragma Obsolescent [(static_string_EXPRESSION [, Ada_05])]; -- pragma Obsolescent [(
-- [Entity => NAME,]
-- [(static_string_EXPRESSION [, Ada_05])];
when Pragma_Obsolescent => Obsolescent : declare when Pragma_Obsolescent => Obsolescent : declare
Subp : Node_Or_Entity_Id; Ename : Node_Id;
S : String_Id; Decl : Node_Id;
Active : Boolean := True;
procedure Set_Obsolescent (E : Entity_Id);
-- Given an entity Ent, mark it as obsolescent if appropriate
procedure Check_Obsolete_Subprogram; ---------------------
-- Checks if Subp is a subprogram declaration node, and if so -- Set_Obsolescent --
-- replaces Subp by the defining entity of the subprogram. If not, ---------------------
-- issues an error message
------------------------------ procedure Set_Obsolescent (E : Entity_Id) is
-- Check_Obsolete_Subprogram-- Active : Boolean;
------------------------------ Ent : Entity_Id;
S : String_Id;
procedure Check_Obsolete_Subprogram is
begin begin
if Nkind (Subp) /= N_Subprogram_Declaration then Active := True;
Error_Pragma Ent := E;
("pragma% misplaced, must immediately " &
"follow subprogram/package declaration"); -- Entity name was given
else
Subp := Defining_Entity (Subp); if Present (Ename) then
-- If entity name matches, we are fine
if Chars (Ename) = Chars (Ent) then
null;
-- If entity name does not match, only possibility is an
-- enumeration literal from an enumeration type declaration.
elsif Ekind (Ent) /= E_Enumeration_Type then
Error_Pragma
("pragma % entity name does not match declaration");
else
Ent := First_Literal (E);
loop
if No (Ent) then
Error_Pragma
("pragma % entity name does not match any " &
"enumeration literal");
elsif Chars (Ent) = Chars (Ename) then
exit;
else
Ent := Next_Literal (Ent);
end if;
end loop;
end if;
end if; end if;
end Check_Obsolete_Subprogram;
-- Ent points to entity to be marked
if Arg_Count >= 1 then
-- Deal with static string argument
Check_Arg_Is_Static_Expression (Arg1, Standard_String);
S := Strval (Expression (Arg1));
for J in 1 .. String_Length (S) loop
if not In_Character_Range (Get_String_Char (S, J)) then
Error_Pragma_Arg
("pragma% argument does not allow wide characters",
Arg1);
end if;
end loop;
Set_Obsolescent_Warning (Ent, Expression (Arg1));
-- Check for Ada_05 parameter
if Arg_Count /= 1 then
Check_Arg_Count (2);
declare
Argx : constant Node_Id := Get_Pragma_Arg (Arg2);
begin
Check_Arg_Is_Identifier (Argx);
if Chars (Argx) /= Name_Ada_05 then
Error_Msg_Name_2 := Name_Ada_05;
Error_Pragma_Arg
("only allowed argument for pragma% is %", Argx);
end if;
if Ada_Version_Explicit < Ada_05
or else not Warn_On_Ada_2005_Compatibility
then
Active := False;
end if;
end;
end if;
end if;
-- Set flag if pragma active
if Active then
Set_Is_Obsolescent (Ent);
end if;
return;
end Set_Obsolescent;
-- Start of processing for pragma Obsolescent -- Start of processing for pragma Obsolescent
begin begin
GNAT_Pragma; GNAT_Pragma;
Check_At_Most_N_Arguments (2);
Check_No_Identifiers;
-- Check OK placement Check_At_Most_N_Arguments (3);
-- First possibility is within a declarative region, where the -- See if first argument specifies an entity name
-- pragma immediately follows a subprogram declaration.
if Present (Prev (N)) then if Arg_Count >= 1
Subp := Prev (N); and then Chars (Arg1) = Name_Entity
Check_Obsolete_Subprogram; then
Ename := Get_Pragma_Arg (Arg1);
-- Second possibility, stand alone subprogram declaration with the if Nkind (Ename) /= N_Character_Literal
-- pragma immediately following the declaration. and then
Nkind (Ename) /= N_Identifier
and then
Nkind (Ename) /= N_Operator_Symbol
then
Error_Pragma_Arg ("entity name expected for pragma%", Arg1);
end if;
elsif No (Prev (N)) -- Eliminate first argument, so we can share processing
and then Nkind (Parent (N)) = N_Compilation_Unit_Aux
then
Subp := Unit (Parent (Parent (N)));
Check_Obsolete_Subprogram;
-- Only other possibility is library unit placement for package Arg1 := Arg2;
Arg2 := Arg3;
Arg_Count := Arg_Count - 1;
else -- No Entity name argument given
Subp := Find_Lib_Unit_Name;
if Ekind (Subp) /= E_Package else
and then Ekind (Subp) /= E_Generic_Package Ename := Empty;
then
Check_Obsolete_Subprogram;
end if;
end if; end if;
-- If OK placement, acquire arguments Check_No_Identifiers;
if Arg_Count >= 1 then -- Get immediately preceding declaration
-- Deal with static string argument Decl := Prev (N);
while Present (Decl) and then Nkind (Decl) = N_Pragma loop
Prev (Decl);
end loop;
Check_Arg_Is_Static_Expression (Arg1, Standard_String); -- Cases where we do not follow anything other than another pragma
S := Strval (Expression (Arg1));
for J in 1 .. String_Length (S) loop if No (Decl) then
if not In_Character_Range (Get_String_Char (S, J)) then
Error_Pragma_Arg
("pragma% argument does not allow wide characters",
Arg1);
end if;
end loop;
Set_Obsolescent_Warning (Subp, Expression (Arg1)); -- First case: library level compilation unit declaration with
-- the pragma immediately following the declaration.
-- Check for Ada_05 parameter if Nkind (Parent (N)) = N_Compilation_Unit_Aux then
Set_Obsolescent
(Defining_Entity (Unit (Parent (Parent (N)))));
return;
if Arg_Count /= 1 then -- Case 2: library unit placement for package
Check_Arg_Count (2);
else
declare declare
Argx : constant Node_Id := Get_Pragma_Arg (Arg2); Ent : constant Entity_Id := Find_Lib_Unit_Name;
begin begin
Check_Arg_Is_Identifier (Argx); if Ekind (Ent) = E_Package
or else Ekind (Ent) = E_Generic_Package
if Chars (Argx) /= Name_Ada_05 then
Error_Msg_Name_2 := Name_Ada_05;
Error_Pragma_Arg
("only allowed argument for pragma% is %", Argx);
end if;
if Ada_Version_Explicit < Ada_05
or else not Warn_On_Ada_2005_Compatibility
then then
Active := False; Set_Obsolescent (Ent);
return;
end if; end if;
end; end;
end if; end if;
end if;
-- Set flag if pragma active -- Cases where we must follow a declaration
if Active then else
Set_Is_Obsolescent (Subp); if Nkind (Decl) not in N_Declaration
and then Nkind (Decl) not in N_Later_Decl_Item
and then Nkind (Decl) not in N_Generic_Declaration
then
Error_Pragma
("pragma% misplaced, " &
"must immediately follow a declaration");
else
Set_Obsolescent (Defining_Entity (Decl));
return;
end if;
end if; end if;
end Obsolescent; end Obsolescent;
...@@ -8525,6 +8704,31 @@ package body Sem_Prag is ...@@ -8525,6 +8704,31 @@ package body Sem_Prag is
Check_Arg_Is_One_Of (Arg1, Name_Semaphore, Name_No); Check_Arg_Is_One_Of (Arg1, Name_Semaphore, Name_No);
end if; end if;
----------------------------------
-- Preelaborable_Initialization --
----------------------------------
-- pragma Preelaborable_Initialization (DIRECT_NAME);
when Pragma_Preelaborable_Initialization => Preelab_Init : declare
Ent : Entity_Id;
begin
Check_Arg_Count (1);
Check_No_Identifiers;
Check_Arg_Is_Identifier (Arg1);
Check_Arg_Is_Local_Name (Arg1);
Check_First_Subtype (Arg1);
Ent := Entity (Expression (Arg1));
if not Is_Private_Type (Ent) then
Error_Pragma_Arg
("pragma % can only be applied to private type", Arg1);
end if;
Set_Known_To_Have_Preelab_Init (Ent);
end Preelab_Init;
------------- -------------
-- Polling -- -- Polling --
------------- -------------
...@@ -8764,6 +8968,136 @@ package body Sem_Prag is ...@@ -8764,6 +8968,136 @@ package body Sem_Prag is
end if; end if;
end Priority; end Priority;
-----------------------------------
-- Priority_Specific_Dispatching --
-----------------------------------
-- pragma Priority_Specific_Dispatching (
-- policy_IDENTIFIER,
-- first_priority_EXPRESSION,
-- last_priority_EXPRESSION);
when Pragma_Priority_Specific_Dispatching =>
Priority_Specific_Dispatching : declare
Prio_Id : constant Entity_Id := RTE (RE_Any_Priority);
-- This is the entity System.Any_Priority;
DP : Character;
Lower_Bound : Node_Id;
Upper_Bound : Node_Id;
Lower_Val : Uint;
Upper_Val : Uint;
begin
Check_Arg_Count (3);
Check_No_Identifiers;
Check_Arg_Is_Task_Dispatching_Policy (Arg1);
Check_Valid_Configuration_Pragma;
Get_Name_String (Chars (Expression (Arg1)));
DP := Fold_Upper (Name_Buffer (1));
Lower_Bound := Expression (Arg2);
Check_Arg_Is_Static_Expression (Lower_Bound, Standard_Integer);
Lower_Val := Expr_Value (Lower_Bound);
Upper_Bound := Expression (Arg3);
Check_Arg_Is_Static_Expression (Upper_Bound, Standard_Integer);
Upper_Val := Expr_Value (Upper_Bound);
-- It is not allowed to use Task_Dispatching_Policy and
-- Priority_Specific_Dispatching in the same partition.
if Task_Dispatching_Policy /= ' ' then
Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
Error_Pragma
("pragma% incompatible with Task_Dispatching_Policy#");
-- Check lower bound in range
elsif Lower_Val < Expr_Value (Type_Low_Bound (Prio_Id))
or else
Lower_Val > Expr_Value (Type_High_Bound (Prio_Id))
then
Error_Pragma_Arg
("first_priority is out of range", Arg2);
-- Check upper bound in range
elsif Upper_Val < Expr_Value (Type_Low_Bound (Prio_Id))
or else
Upper_Val > Expr_Value (Type_High_Bound (Prio_Id))
then
Error_Pragma_Arg
("last_priority is out of range", Arg3);
-- Check that the priority range is valid
elsif Lower_Val > Upper_Val then
Error_Pragma
("last_priority_expression must be greater than" &
" or equal to first_priority_expression");
-- Store the new policy, but always preserve System_Location since
-- we like the error message with the run-time name.
else
-- Check overlapping in the priority ranges specified in other
-- Priority_Specific_Dispatching pragmas within the same
-- partition. We can only check those we know about!
for J in
Specific_Dispatching.First .. Specific_Dispatching.Last
loop
if Specific_Dispatching.Table (J).First_Priority in
UI_To_Int (Lower_Val) .. UI_To_Int (Upper_Val)
or else Specific_Dispatching.Table (J).Last_Priority in
UI_To_Int (Lower_Val) .. UI_To_Int (Upper_Val)
then
Error_Msg_Sloc :=
Specific_Dispatching.Table (J).Pragma_Loc;
Error_Pragma ("priority range overlaps with" &
" Priority_Specific_Dispatching#");
end if;
end loop;
-- The use of Priority_Specific_Dispatching is incompatible
-- with Task_Dispatching_Policy.
if Task_Dispatching_Policy /= ' ' then
Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
Error_Pragma ("Priority_Specific_Dispatching incompatible" &
" with Task_Dispatching_Policy#");
end if;
-- The use of Priority_Specific_Dispatching forces ceiling
-- locking policy.
if Locking_Policy /= ' ' and then Locking_Policy /= 'C' then
Error_Msg_Sloc := Locking_Policy_Sloc;
Error_Pragma ("Priority_Specific_Dispatching incompatible" &
" with Locking_Policy#");
-- Set the Ceiling_Locking policy, but preserve System_Location
-- since we like the error message with the run time name.
else
Locking_Policy := 'C';
if Locking_Policy_Sloc /= System_Location then
Locking_Policy_Sloc := Loc;
end if;
end if;
-- Add entry in the table
Specific_Dispatching.Append
((Dispatching_Policy => DP,
First_Priority => UI_To_Int (Lower_Val),
Last_Priority => UI_To_Int (Upper_Val),
Pragma_Loc => Loc));
end if;
end Priority_Specific_Dispatching;
------------- -------------
-- Profile -- -- Profile --
------------- -------------
...@@ -8782,7 +9116,6 @@ package body Sem_Prag is ...@@ -8782,7 +9116,6 @@ package body Sem_Prag is
begin begin
if Chars (Argx) = Name_Ravenscar then if Chars (Argx) = Name_Ravenscar then
Set_Ravenscar_Profile (N); Set_Ravenscar_Profile (N);
elsif Chars (Argx) = Name_Restricted then elsif Chars (Argx) = Name_Restricted then
Set_Profile_Restrictions (Restricted, N, Warn => False); Set_Profile_Restrictions (Restricted, N, Warn => False);
else else
...@@ -8809,7 +9142,6 @@ package body Sem_Prag is ...@@ -8809,7 +9142,6 @@ package body Sem_Prag is
begin begin
if Chars (Argx) = Name_Ravenscar then if Chars (Argx) = Name_Ravenscar then
Set_Profile_Restrictions (Ravenscar, N, Warn => True); Set_Profile_Restrictions (Ravenscar, N, Warn => True);
elsif Chars (Argx) = Name_Restricted then elsif Chars (Argx) = Name_Restricted then
Set_Profile_Restrictions (Restricted, N, Warn => True); Set_Profile_Restrictions (Restricted, N, Warn => True);
else else
...@@ -9251,7 +9583,7 @@ package body Sem_Prag is ...@@ -9251,7 +9583,7 @@ package body Sem_Prag is
-- | restriction_parameter_IDENTIFIER => EXPRESSION -- | restriction_parameter_IDENTIFIER => EXPRESSION
when Pragma_Restrictions => when Pragma_Restrictions =>
Process_Restrictions_Or_Restriction_Warnings; Process_Restrictions_Or_Restriction_Warnings (Warn => False);
-------------------------- --------------------------
-- Restriction_Warnings -- -- Restriction_Warnings --
...@@ -9264,7 +9596,7 @@ package body Sem_Prag is ...@@ -9264,7 +9596,7 @@ package body Sem_Prag is
-- | restriction_parameter_IDENTIFIER => EXPRESSION -- | restriction_parameter_IDENTIFIER => EXPRESSION
when Pragma_Restriction_Warnings => when Pragma_Restriction_Warnings =>
Process_Restrictions_Or_Restriction_Warnings; Process_Restrictions_Or_Restriction_Warnings (Warn => True);
---------------- ----------------
-- Reviewable -- -- Reviewable --
...@@ -10291,47 +10623,90 @@ package body Sem_Prag is ...@@ -10291,47 +10623,90 @@ package body Sem_Prag is
-- pragma Unreferenced (local_Name {, local_Name}); -- pragma Unreferenced (local_Name {, local_Name});
-- or when used in a context clause:
-- pragma Unreferenced (library_unit_NAME {, library_unit_NAME}
when Pragma_Unreferenced => Unreferenced : declare when Pragma_Unreferenced => Unreferenced : declare
Arg_Node : Node_Id; Arg_Node : Node_Id;
Arg_Expr : Node_Id; Arg_Expr : Node_Id;
Arg_Ent : Entity_Id; Arg_Ent : Entity_Id;
Citem : Node_Id;
begin begin
GNAT_Pragma; GNAT_Pragma;
Check_At_Least_N_Arguments (1); Check_At_Least_N_Arguments (1);
Arg_Node := Arg1; -- Check case of appearing within context clause
while Present (Arg_Node) loop
Check_No_Identifier (Arg_Node);
-- Note that the analyze call done by Check_Arg_Is_Local_Name if Is_In_Context_Clause then
-- will in fact generate a reference, so that the entity will
-- have a reference, which will inhibit any warnings about it
-- not being referenced, and also properly show up in the ali
-- file as a reference. But this reference is recorded before
-- the Has_Pragma_Unreferenced flag is set, so that no warning
-- is generated for this reference.
Check_Arg_Is_Local_Name (Arg_Node); -- The arguments must all be units mentioned in a with
Arg_Expr := Get_Pragma_Arg (Arg_Node); -- clause in the same context clause. Note we already checked
-- (in Par.Prag) that the arguments are either identifiers or
if Is_Entity_Name (Arg_Expr) then Arg_Node := Arg1;
Arg_Ent := Entity (Arg_Expr); while Present (Arg_Node) loop
Citem := First (List_Containing (N));
while Citem /= N loop
if Nkind (Citem) = N_With_Clause
and then Same_Name (Name (Citem), Expression (Arg_Node))
then
Set_Has_Pragma_Unreferenced
(Cunit_Entity
(Get_Source_Unit
(Library_Unit (Citem))));
Set_Unit_Name (Expression (Arg_Node), Name (Citem));
exit;
end if;
-- If the entity is overloaded, the pragma applies to the Next (Citem);
-- most recent overloading, as documented. In this case, end loop;
-- name resolution does not generate a reference, so it
-- must be done here explicitly.
if Is_Overloaded (Arg_Expr) then if Citem = N then
Generate_Reference (Arg_Ent, N); Error_Pragma_Arg
("argument of pragma% is not with'ed unit", Arg_Node);
end if; end if;
Set_Has_Pragma_Unreferenced (Arg_Ent); Next (Arg_Node);
end if; end loop;
Next (Arg_Node); -- Case of not in list of context items
end loop;
else
Arg_Node := Arg1;
while Present (Arg_Node) loop
Check_No_Identifier (Arg_Node);
-- Note: the analyze call done by Check_Arg_Is_Local_Name
-- will in fact generate reference, so that the entity will
-- have a reference, which will inhibit any warnings about
-- it not being referenced, and also properly show up in the
-- ali file as a reference. But this reference is recorded
-- before the Has_Pragma_Unreferenced flag is set, so that
-- no warning is generated for this reference.
Check_Arg_Is_Local_Name (Arg_Node);
Arg_Expr := Get_Pragma_Arg (Arg_Node);
if Is_Entity_Name (Arg_Expr) then
Arg_Ent := Entity (Arg_Expr);
-- If the entity is overloaded, the pragma applies to the
-- most recent overloading, as documented. In this case,
-- name resolution does not generate a reference, so it
-- must be done here explicitly.
if Is_Overloaded (Arg_Expr) then
Generate_Reference (Arg_Ent, N);
end if;
Set_Has_Pragma_Unreferenced (Arg_Ent);
end if;
Next (Arg_Node);
end loop;
end if;
end Unreferenced; end Unreferenced;
------------------------------ ------------------------------
...@@ -10446,21 +10821,24 @@ package body Sem_Prag is ...@@ -10446,21 +10821,24 @@ package body Sem_Prag is
-- Warnings -- -- Warnings --
-------------- --------------
-- pragma Warnings (On | Off, [LOCAL_NAME]) -- pragma Warnings (On | Off);
-- pragma Warnings (On | Off, LOCAL_NAME);
-- pragma Warnings (static_string_EXPRESSION); -- pragma Warnings (static_string_EXPRESSION);
-- pragma Warnings (On | Off, STRING_LITERAL);
when Pragma_Warnings => Warnings : begin when Pragma_Warnings => Warnings : begin
GNAT_Pragma; GNAT_Pragma;
Check_At_Least_N_Arguments (1); Check_At_Least_N_Arguments (1);
Check_No_Identifiers; Check_No_Identifiers;
-- One argument case declare
Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
if Arg_Count = 1 then begin
declare -- One argument case
Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
if Arg_Count = 1 then
begin
-- On/Off one argument case was processed by parser -- On/Off one argument case was processed by parser
if Nkind (Argx) = N_Identifier if Nkind (Argx) = N_Identifier
...@@ -10471,9 +10849,16 @@ package body Sem_Prag is ...@@ -10471,9 +10849,16 @@ package body Sem_Prag is
then then
null; null;
else -- One argument case must be ON/OFF or static string expr
Check_Arg_Is_Static_Expression (Arg1, Standard_String);
elsif not Is_Static_String_Expression (Arg1) then
Error_Pragma_Arg
("argument of pragma% must be On/Off or " &
"static string expression", Arg2);
-- One argument string expression case
else
declare declare
Lit : constant Node_Id := Expr_Value_S (Argx); Lit : constant Node_Id := Expr_Value_S (Argx);
Str : constant String_Id := Strval (Lit); Str : constant String_Id := Strval (Lit);
...@@ -10494,70 +10879,111 @@ package body Sem_Prag is ...@@ -10494,70 +10879,111 @@ package body Sem_Prag is
end loop; end loop;
end; end;
end if; end if;
end;
-- Two argument case -- Two or more arguments (must be two)
elsif Arg_Count /= 1 then else
Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off); Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
Check_Arg_Count (2); Check_At_Most_N_Arguments (2);
declare declare
E_Id : Node_Id; E_Id : Node_Id;
E : Entity_Id; E : Entity_Id;
Err : Boolean;
begin begin
E_Id := Expression (Arg2); E_Id := Expression (Arg2);
Analyze (E_Id); Analyze (E_Id);
-- In the expansion of an inlined body, a reference to -- In the expansion of an inlined body, a reference to
-- the formal may be wrapped in a conversion if the actual -- the formal may be wrapped in a conversion if the
-- is a conversion. Retrieve the real entity name. -- actual is a conversion. Retrieve the real entity name.
if (In_Instance_Body if (In_Instance_Body
or else In_Inlined_Body) or else In_Inlined_Body)
and then Nkind (E_Id) = N_Unchecked_Type_Conversion and then Nkind (E_Id) = N_Unchecked_Type_Conversion
then then
E_Id := Expression (E_Id); E_Id := Expression (E_Id);
end if; end if;
if not Is_Entity_Name (E_Id) then -- Entity name case
Error_Pragma_Arg
("second argument of pragma% must be entity name",
Arg2);
end if;
E := Entity (E_Id); if Is_Entity_Name (E_Id) then
E := Entity (E_Id);
if E = Any_Id then if E = Any_Id then
return; return;
else else
loop loop
Set_Warnings_Off Set_Warnings_Off
(E, (Chars (Expression (Arg1)) = Name_Off)); (E, (Chars (Expression (Arg1)) = Name_Off));
if Is_Enumeration_Type (E) then if Is_Enumeration_Type (E) then
declare declare
Lit : Entity_Id; Lit : Entity_Id;
begin begin
Lit := First_Literal (E); Lit := First_Literal (E);
while Present (Lit) loop while Present (Lit) loop
Set_Warnings_Off (Lit); Set_Warnings_Off (Lit);
Next_Literal (Lit); Next_Literal (Lit);
end loop; end loop;
end; end;
end if;
exit when No (Homonym (E));
E := Homonym (E);
end loop;
end if; end if;
exit when No (Homonym (E)); -- Error if not entity or static string literal case
E := Homonym (E);
end loop;
end if;
end;
-- More than two arguments elsif not Is_Static_String_Expression (Arg2) then
else Error_Pragma_Arg
Check_At_Most_N_Arguments (2); ("second argument of pragma% must be entity " &
end if; "name or static string expression", Arg2);
-- String literal case
else
String_To_Name_Buffer
(Strval (Expr_Value_S (Expression (Arg2))));
-- Configuration pragma case
if Is_Configuration_Pragma then
if Chars (Argx) = Name_On then
Error_Pragma
("pragma Warnings (Off, string) cannot be " &
"used as configuration pragma");
else
Set_Specific_Warning_Off
(No_Location, Name_Buffer (1 .. Name_Len));
end if;
-- Normal (non-configuration pragma) case
else
if Chars (Argx) = Name_Off then
Set_Specific_Warning_Off
(Loc, Name_Buffer (1 .. Name_Len));
elsif Chars (Argx) = Name_On then
Set_Specific_Warning_On
(Loc, Name_Buffer (1 .. Name_Len), Err);
if Err then
Error_Msg
("?pragma Warnings On with no " &
"matching Warnings Off",
Loc);
end if;
end if;
end if;
end if;
end;
end if;
end;
end Warnings; end Warnings;
------------------- -------------------
...@@ -10594,6 +11020,21 @@ package body Sem_Prag is ...@@ -10594,6 +11020,21 @@ package body Sem_Prag is
end if; end if;
end Weak_External; end Weak_External;
-----------------------------
-- Wide_Character_Encoding --
-----------------------------
-- pragma Wide_Character_Encoding (IDENTIFIER);
when Pragma_Wide_Character_Encoding =>
-- Nothing to do, handled in parser. Note that we do not enforce
-- configuration pragma placement, this pragma can appear at any
-- place in the source, allowing mixed encodings within a single
-- source program.
null;
-------------------- --------------------
-- Unknown_Pragma -- -- Unknown_Pragma --
-------------------- --------------------
...@@ -10615,7 +11056,9 @@ package body Sem_Prag is ...@@ -10615,7 +11056,9 @@ package body Sem_Prag is
function Delay_Config_Pragma_Analyze (N : Node_Id) return Boolean is function Delay_Config_Pragma_Analyze (N : Node_Id) return Boolean is
begin begin
return Chars (N) = Name_Interrupt_State; return Chars (N) = Name_Interrupt_State
or else
Chars (N) = Name_Priority_Specific_Dispatching;
end Delay_Config_Pragma_Analyze; end Delay_Config_Pragma_Analyze;
------------------------- -------------------------
...@@ -10714,158 +11157,161 @@ package body Sem_Prag is ...@@ -10714,158 +11157,161 @@ package body Sem_Prag is
Sig_Flags : constant array (Pragma_Id) of Int := Sig_Flags : constant array (Pragma_Id) of Int :=
(Pragma_AST_Entry => -1, (Pragma_AST_Entry => -1,
Pragma_Abort_Defer => -1, Pragma_Abort_Defer => -1,
Pragma_Ada_83 => -1, Pragma_Ada_83 => -1,
Pragma_Ada_95 => -1, Pragma_Ada_95 => -1,
Pragma_Ada_05 => -1, Pragma_Ada_05 => -1,
Pragma_Ada_2005 => -1, Pragma_Ada_2005 => -1,
Pragma_All_Calls_Remote => -1, Pragma_All_Calls_Remote => -1,
Pragma_Annotate => -1, Pragma_Annotate => -1,
Pragma_Assert => -1, Pragma_Assert => -1,
Pragma_Assertion_Policy => 0, Pragma_Assertion_Policy => 0,
Pragma_Asynchronous => -1, Pragma_Asynchronous => -1,
Pragma_Atomic => 0, Pragma_Atomic => 0,
Pragma_Atomic_Components => 0, Pragma_Atomic_Components => 0,
Pragma_Attach_Handler => -1, Pragma_Attach_Handler => -1,
Pragma_CPP_Class => 0, Pragma_CPP_Class => 0,
Pragma_CPP_Constructor => 0, Pragma_CPP_Constructor => 0,
Pragma_CPP_Virtual => 0, Pragma_CPP_Virtual => 0,
Pragma_CPP_Vtable => 0, Pragma_CPP_Vtable => 0,
Pragma_C_Pass_By_Copy => 0, Pragma_C_Pass_By_Copy => 0,
Pragma_Comment => 0, Pragma_Comment => 0,
Pragma_Common_Object => -1, Pragma_Common_Object => -1,
Pragma_Compile_Time_Warning => -1, Pragma_Compile_Time_Warning => -1,
Pragma_Complete_Representation => 0, Pragma_Complete_Representation => 0,
Pragma_Complex_Representation => 0, Pragma_Complex_Representation => 0,
Pragma_Component_Alignment => -1, Pragma_Component_Alignment => -1,
Pragma_Controlled => 0, Pragma_Controlled => 0,
Pragma_Convention => 0, Pragma_Convention => 0,
Pragma_Convention_Identifier => 0, Pragma_Convention_Identifier => 0,
Pragma_Debug => -1, Pragma_Debug => -1,
Pragma_Debug_Policy => 0, Pragma_Debug_Policy => 0,
Pragma_Detect_Blocking => -1, Pragma_Detect_Blocking => -1,
Pragma_Discard_Names => 0, Pragma_Discard_Names => 0,
Pragma_Elaborate => -1, Pragma_Elaborate => -1,
Pragma_Elaborate_All => -1, Pragma_Elaborate_All => -1,
Pragma_Elaborate_Body => -1, Pragma_Elaborate_Body => -1,
Pragma_Elaboration_Checks => -1, Pragma_Elaboration_Checks => -1,
Pragma_Eliminate => -1, Pragma_Eliminate => -1,
Pragma_Explicit_Overriding => -1, Pragma_Explicit_Overriding => -1,
Pragma_Export => -1, Pragma_Export => -1,
Pragma_Export_Exception => -1, Pragma_Export_Exception => -1,
Pragma_Export_Function => -1, Pragma_Export_Function => -1,
Pragma_Export_Object => -1, Pragma_Export_Object => -1,
Pragma_Export_Procedure => -1, Pragma_Export_Procedure => -1,
Pragma_Export_Value => -1, Pragma_Export_Value => -1,
Pragma_Export_Valued_Procedure => -1, Pragma_Export_Valued_Procedure => -1,
Pragma_Extend_System => -1, Pragma_Extend_System => -1,
Pragma_Extensions_Allowed => -1, Pragma_Extensions_Allowed => -1,
Pragma_External => -1, Pragma_External => -1,
Pragma_External_Name_Casing => -1, Pragma_External_Name_Casing => -1,
Pragma_Finalize_Storage_Only => 0, Pragma_Finalize_Storage_Only => 0,
Pragma_Float_Representation => 0, Pragma_Float_Representation => 0,
Pragma_Ident => -1, Pragma_Ident => -1,
Pragma_Import => +2, Pragma_Import => +2,
Pragma_Import_Exception => 0, Pragma_Import_Exception => 0,
Pragma_Import_Function => 0, Pragma_Import_Function => 0,
Pragma_Import_Object => 0, Pragma_Import_Object => 0,
Pragma_Import_Procedure => 0, Pragma_Import_Procedure => 0,
Pragma_Import_Valued_Procedure => 0, Pragma_Import_Valued_Procedure => 0,
Pragma_Initialize_Scalars => -1, Pragma_Initialize_Scalars => -1,
Pragma_Inline => 0, Pragma_Inline => 0,
Pragma_Inline_Always => 0, Pragma_Inline_Always => 0,
Pragma_Inline_Generic => 0, Pragma_Inline_Generic => 0,
Pragma_Inspection_Point => -1, Pragma_Inspection_Point => -1,
Pragma_Interface => +2, Pragma_Interface => +2,
Pragma_Interface_Name => +2, Pragma_Interface_Name => +2,
Pragma_Interrupt_Handler => -1, Pragma_Interrupt_Handler => -1,
Pragma_Interrupt_Priority => -1, Pragma_Interrupt_Priority => -1,
Pragma_Interrupt_State => -1, Pragma_Interrupt_State => -1,
Pragma_Java_Constructor => -1, Pragma_Java_Constructor => -1,
Pragma_Java_Interface => -1, Pragma_Java_Interface => -1,
Pragma_Keep_Names => 0, Pragma_Keep_Names => 0,
Pragma_License => -1, Pragma_License => -1,
Pragma_Link_With => -1, Pragma_Link_With => -1,
Pragma_Linker_Alias => -1, Pragma_Linker_Alias => -1,
Pragma_Linker_Constructor => -1, Pragma_Linker_Constructor => -1,
Pragma_Linker_Destructor => -1, Pragma_Linker_Destructor => -1,
Pragma_Linker_Options => -1, Pragma_Linker_Options => -1,
Pragma_Linker_Section => -1, Pragma_Linker_Section => -1,
Pragma_List => -1, Pragma_List => -1,
Pragma_Locking_Policy => -1, Pragma_Locking_Policy => -1,
Pragma_Long_Float => -1, Pragma_Long_Float => -1,
Pragma_Machine_Attribute => -1, Pragma_Machine_Attribute => -1,
Pragma_Main => -1, Pragma_Main => -1,
Pragma_Main_Storage => -1, Pragma_Main_Storage => -1,
Pragma_Memory_Size => -1, Pragma_Memory_Size => -1,
Pragma_No_Return => 0, Pragma_No_Return => 0,
Pragma_No_Run_Time => -1, Pragma_No_Run_Time => -1,
Pragma_No_Strict_Aliasing => -1, Pragma_No_Strict_Aliasing => -1,
Pragma_Normalize_Scalars => -1, Pragma_Normalize_Scalars => -1,
Pragma_Obsolescent => 0, Pragma_Obsolescent => 0,
Pragma_Optimize => -1, Pragma_Optimize => -1,
Pragma_Optional_Overriding => -1, Pragma_Optional_Overriding => -1,
Pragma_Pack => 0, Pragma_Pack => 0,
Pragma_Page => -1, Pragma_Page => -1,
Pragma_Passive => -1, Pragma_Passive => -1,
Pragma_Polling => -1, Pragma_Preelaborable_Initialization => -1,
Pragma_Persistent_BSS => 0, Pragma_Polling => -1,
Pragma_Preelaborate => -1, Pragma_Persistent_BSS => 0,
Pragma_Preelaborate_05 => -1, Pragma_Preelaborate => -1,
Pragma_Priority => -1, Pragma_Preelaborate_05 => -1,
Pragma_Profile => 0, Pragma_Priority => -1,
Pragma_Profile_Warnings => 0, Pragma_Priority_Specific_Dispatching => -1,
Pragma_Propagate_Exceptions => -1, Pragma_Profile => 0,
Pragma_Psect_Object => -1, Pragma_Profile_Warnings => 0,
Pragma_Pure => -1, Pragma_Propagate_Exceptions => -1,
Pragma_Pure_05 => -1, Pragma_Psect_Object => -1,
Pragma_Pure_Function => -1, Pragma_Pure => -1,
Pragma_Queuing_Policy => -1, Pragma_Pure_05 => -1,
Pragma_Ravenscar => -1, Pragma_Pure_Function => -1,
Pragma_Remote_Call_Interface => -1, Pragma_Queuing_Policy => -1,
Pragma_Remote_Types => -1, Pragma_Ravenscar => -1,
Pragma_Restricted_Run_Time => -1, Pragma_Remote_Call_Interface => -1,
Pragma_Restriction_Warnings => -1, Pragma_Remote_Types => -1,
Pragma_Restrictions => -1, Pragma_Restricted_Run_Time => -1,
Pragma_Reviewable => -1, Pragma_Restriction_Warnings => -1,
Pragma_Share_Generic => -1, Pragma_Restrictions => -1,
Pragma_Shared => -1, Pragma_Reviewable => -1,
Pragma_Shared_Passive => -1, Pragma_Share_Generic => -1,
Pragma_Source_File_Name => -1, Pragma_Shared => -1,
Pragma_Source_File_Name_Project => -1, Pragma_Shared_Passive => -1,
Pragma_Source_Reference => -1, Pragma_Source_File_Name => -1,
Pragma_Storage_Size => -1, Pragma_Source_File_Name_Project => -1,
Pragma_Storage_Unit => -1, Pragma_Source_Reference => -1,
Pragma_Stream_Convert => -1, Pragma_Storage_Size => -1,
Pragma_Style_Checks => -1, Pragma_Storage_Unit => -1,
Pragma_Subtitle => -1, Pragma_Stream_Convert => -1,
Pragma_Suppress => 0, Pragma_Style_Checks => -1,
Pragma_Suppress_Exception_Locations => 0, Pragma_Subtitle => -1,
Pragma_Suppress_All => -1, Pragma_Suppress => 0,
Pragma_Suppress_Debug_Info => 0, Pragma_Suppress_Exception_Locations => 0,
Pragma_Suppress_Initialization => 0, Pragma_Suppress_All => -1,
Pragma_System_Name => -1, Pragma_Suppress_Debug_Info => 0,
Pragma_Task_Dispatching_Policy => -1, Pragma_Suppress_Initialization => 0,
Pragma_Task_Info => -1, Pragma_System_Name => -1,
Pragma_Task_Name => -1, Pragma_Task_Dispatching_Policy => -1,
Pragma_Task_Storage => 0, Pragma_Task_Info => -1,
Pragma_Thread_Body => +2, Pragma_Task_Name => -1,
Pragma_Time_Slice => -1, Pragma_Task_Storage => 0,
Pragma_Title => -1, Pragma_Thread_Body => +2,
Pragma_Unchecked_Union => 0, Pragma_Time_Slice => -1,
Pragma_Unimplemented_Unit => -1, Pragma_Title => -1,
Pragma_Universal_Data => -1, Pragma_Unchecked_Union => 0,
Pragma_Unreferenced => -1, Pragma_Unimplemented_Unit => -1,
Pragma_Unreserve_All_Interrupts => -1, Pragma_Universal_Data => -1,
Pragma_Unsuppress => 0, Pragma_Unreferenced => -1,
Pragma_Use_VADS_Size => -1, Pragma_Unreserve_All_Interrupts => -1,
Pragma_Validity_Checks => -1, Pragma_Unsuppress => 0,
Pragma_Volatile => 0, Pragma_Use_VADS_Size => -1,
Pragma_Volatile_Components => 0, Pragma_Validity_Checks => -1,
Pragma_Warnings => -1, Pragma_Volatile => 0,
Pragma_Weak_External => 0, Pragma_Volatile_Components => 0,
Unknown_Pragma => 0); Pragma_Warnings => -1,
Pragma_Weak_External => -1,
Pragma_Wide_Character_Encoding => 0,
Unknown_Pragma => 0);
function Is_Non_Significant_Pragma_Reference (N : Node_Id) return Boolean is function Is_Non_Significant_Pragma_Reference (N : Node_Id) return Boolean is
P : Node_Id; P : Node_Id;
......
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