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
procedure Expand_Pragma_Abort_Defer (N : Node_Id);
procedure Expand_Pragma_Assert (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_Inspection_Point (N : Node_Id);
procedure Expand_Pragma_Interrupt_Priority (N : Node_Id);
......@@ -136,7 +136,7 @@ package body Exp_Prag is
Expand_Pragma_Import_Export_Exception (N);
when Pragma_Import =>
Expand_Pragma_Import (N);
Expand_Pragma_Import_Or_Interface (N);
when Pragma_Import_Exception =>
Expand_Pragma_Import_Export_Exception (N);
......@@ -144,6 +144,9 @@ package body Exp_Prag is
when Pragma_Inspection_Point =>
Expand_Pragma_Inspection_Point (N);
when Pragma_Interface =>
Expand_Pragma_Import_Or_Interface (N);
when Pragma_Interrupt_Priority =>
Expand_Pragma_Interrupt_Priority (N);
......@@ -299,19 +302,12 @@ package body Exp_Prag is
-- 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 (internal_name, "overlaid");
-- pragma Machine_Attribute (internal_name, "global");
-- pragma Machine_Attribute (internal_name, "initialize");
-- pragma Machine_Attribute (intern_name, "common_object", extern_name);
-- 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
Loc : constant Source_Ptr := Sloc (N);
......@@ -351,34 +347,9 @@ package body Exp_Prag is
Ploc := Sloc (Psect);
-- Insert pragmas
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")))),
-- Insert the pragma
-- Machine_Attribute "global" ensures that section is visible
Insert_After_And_Analyze (N,
Make_Pragma (Loc,
Chars => Name_Machine_Attribute,
......@@ -388,24 +359,15 @@ package body Exp_Prag is
Make_Pragma_Argument_Association (Eloc,
Expression =>
Make_String_Literal (Sloc => Ploc,
Strval => "global")))),
-- Machine_Attribute "initialize" ensures section is demand zeroed
Strval => "common_object")),
Make_Pragma_Argument_Association (Ploc,
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;
--------------------------
-- Expand_Pragma_Import --
--------------------------
---------------------------------------
-- Expand_Pragma_Import_Or_Interface --
---------------------------------------
-- 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
......@@ -418,7 +380,7 @@ package body Exp_Prag is
-- have to elaborate the initialization expression when it is first
-- 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));
Typ : Entity_Id;
Init_Call : Node_Id;
......@@ -455,7 +417,7 @@ package body Exp_Prag is
Set_Expression (Parent (Def_Id), Empty);
end if;
end if;
end Expand_Pragma_Import;
end Expand_Pragma_Import_Or_Interface;
-------------------------------------------
-- Expand_Pragma_Import_Export_Exception --
......
gcc/ada/sem_prag.adb
......@@ -495,7 +495,15 @@ package body Sem_Prag is
function Is_Configuration_Pragma return Boolean;
-- 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;
-- Issue fatal error message for misplaced pragma
......@@ -581,8 +589,9 @@ package body Sem_Prag is
procedure Process_Interrupt_Or_Attach_Handler;
-- Common processing for Interrupt and Attach_Handler pragmas
procedure Process_Restrictions_Or_Restriction_Warnings;
-- Common processing for Restrictions and Restriction_Warnings pragmas
procedure Process_Restrictions_Or_Restriction_Warnings (Warn : Boolean);
-- Common processing for Restrictions and Restriction_Warnings pragmas.
-- Warn is False for Restrictions, True for Restriction_Warnings.
procedure Process_Suppress_Unsuppress (Suppress_Case : Boolean);
-- Common processing for Suppress and Unsuppress. The boolean parameter
......@@ -1803,6 +1812,46 @@ package body Sem_Prag is
end if;
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 --
----------------------
......@@ -1961,9 +2010,9 @@ package body Sem_Prag is
procedure Set_Convention_From_Pragma (E : Entity_Id) is
begin
-- Check invalid attempt to change convention for an overridden
-- dispatching operation. This is Ada 2005 AI 430. Technically
-- this is an amendment and should only be done in Ada 2005 mode.
-- Ada 2005 (AI-430): Check invalid attempt to change convention
-- for an overridden dispatching operation. Technically this is
-- an amendment and should only be done in Ada 2005 mode.
-- 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!
......@@ -3585,7 +3634,9 @@ package body Sem_Prag is
-- 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.
procedure Process_Restrictions_Or_Restriction_Warnings is
procedure Process_Restrictions_Or_Restriction_Warnings
(Warn : Boolean)
is
Arg : Node_Id;
R_Id : Restriction_Id;
Id : Name_Id;
......@@ -3596,10 +3647,6 @@ package body Sem_Prag is
-- Checks unit name parameter for No_Dependence. Returns if it has
-- 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 --
---------------------
......@@ -3619,19 +3666,6 @@ package body Sem_Prag is
end if;
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
begin
......@@ -3666,16 +3700,33 @@ package body Sem_Prag is
(No_Implementation_Restrictions, Arg);
end if;
Set_Restriction (R_Id, N);
Set_Warning (R_Id);
-- If this is a warning, then set the warning unless we already
-- have a real restriction active (we never want a warning to
-- override a real restriction).
-- 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).
if Warn then
if not Restriction_Active (R_Id) then
Set_Restriction (R_Id, N);
Restriction_Warnings (R_Id) := True;
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);
end if;
......@@ -3705,19 +3756,36 @@ package body Sem_Prag is
then
Error_Pragma_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
Error_Pragma_Arg
("pragma ignored, value too large?", Arg);
else
Set_Restriction (R_Id, N, Integer (UI_To_Int (Val)));
Set_Warning (R_Id);
if not UI_Is_In_Int_Range (Val) then
Error_Pragma_Arg
("pragma ignored, value too large?", Arg);
end if;
-- 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;
-- 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;
......@@ -4416,7 +4484,7 @@ package body Sem_Prag is
return;
end if;
Set_Is_Ada_2005 (Entity (E_Id));
Set_Is_Ada_2005_Only (Entity (E_Id));
else
Check_Arg_Count (0);
......@@ -4507,7 +4575,10 @@ package body Sem_Prag is
-- pragma Assert ([Check =>] Boolean_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_Most_N_Arguments (2);
Check_Arg_Order ((Name_Check, Name_Message));
......@@ -4531,13 +4602,15 @@ package body Sem_Prag is
-- directly, or it may cause insertion of actions that would
-- escape the attempt to suppress the assertion code.
Expr := Expression (Arg1);
if Expander_Active and not Assertions_Enabled then
Rewrite (N,
Make_If_Statement (Loc,
Condition =>
Make_And_Then (Loc,
Left_Opnd => New_Occurrence_Of (Standard_False, Loc),
Right_Opnd => Get_Pragma_Arg (Arg1)),
Right_Opnd => Expr),
Then_Statements => New_List (
Make_Null_Statement (Loc))));
......@@ -4548,9 +4621,29 @@ package body Sem_Prag is
-- and resolve the expression.
else
Analyze_And_Resolve (Expression (Arg1), Any_Boolean);
Analyze_And_Resolve (Expr, Any_Boolean);
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 --
----------------------
......@@ -4961,31 +5054,55 @@ package body Sem_Prag is
if Compile_Time_Known_Value (Arg1x) 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
Msg : String (1 .. Name_Len) :=
Name_Buffer (1 .. Name_Len);
B : Natural;
Str : constant String_Id :=
Strval (Get_Pragma_Arg (Arg2));
Len : constant Int := String_Length (Str);
Cont : Boolean;
Ptr : Nat;
CC : Char_Code;
C : Character;
begin
-- This loop looks for multiple lines separated by
-- ASCII.LF and breaks them into continuation error
-- messages marked with the usual back slash.
B := 1;
for S in 2 .. Msg'Length - 1 loop
if Msg (S) = ASCII.LF then
Msg (S) := '?';
Error_Msg_N (Msg (B .. S), Arg1);
B := S;
Msg (B) := '\';
Cont := False;
Ptr := 1;
-- Loop through segments of message separated by line
-- feeds. We output these segments as separate messages
-- with continuation marks for all but the first.
loop
Error_Msg_Strlen := 0;
-- 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 loop;
Error_Msg_N (Msg (B .. Msg'Length), Arg1);
exit when Ptr > Len;
end loop;
end;
end if;
end if;
......@@ -5739,29 +5856,14 @@ package body Sem_Prag is
-- pragma Elaborate (library_unit_NAME {, library_unit_NAME});
when Pragma_Elaborate => Elaborate : declare
Plist : List_Id;
Parent_Node : Node_Id;
Arg : Node_Id;
Citem : Node_Id;
Arg : Node_Id;
Citem : Node_Id;
begin
-- 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;
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;
-- Must be at least one argument
......@@ -5777,7 +5879,6 @@ package body Sem_Prag is
if Ada_Version = Ada_83 and then Comes_From_Source (N) then
Citem := Next (N);
while Present (Citem) loop
if Nkind (Citem) = N_Pragma
or else (Nkind (Citem) = N_With_Clause
......@@ -5794,13 +5895,13 @@ package body Sem_Prag is
end if;
-- Finally, the arguments must all be units mentioned in a with
-- clause in the same context clause. Note we already checked
-- (in Par.Prag) that the arguments are either identifiers or
-- clause in the same context clause. Note we already checked (in
-- Par.Prag) that the arguments are all identifiers or selected
-- components.
Arg := Arg1;
Outer : while Present (Arg) loop
Citem := First (Plist);
Citem := First (List_Containing (N));
Inner : while Citem /= N loop
if Nkind (Citem) = N_With_Clause
and then Same_Name (Name (Citem), Expression (Arg))
......@@ -5820,6 +5921,7 @@ package body Sem_Prag is
Set_Suppress_Elaboration_Warnings
(Entity (Name (Citem)));
end if;
exit Inner;
end if;
......@@ -5852,31 +5954,16 @@ package body Sem_Prag is
-- pragma Elaborate_All (library_unit_NAME {, library_unit_NAME});
when Pragma_Elaborate_All => Elaborate_All : declare
Plist : List_Id;
Parent_Node : Node_Id;
Arg : Node_Id;
Citem : Node_Id;
Arg : Node_Id;
Citem : Node_Id;
begin
Check_Ada_83_Warning;
-- 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;
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;
-- Must be at least one argument
......@@ -5896,7 +5983,7 @@ package body Sem_Prag is
Arg := Arg1;
Outr : while Present (Arg) loop
Citem := First (Plist);
Citem := First (List_Containing (N));
Innr : while Citem /= N loop
if Nkind (Citem) = N_With_Clause
......@@ -7182,13 +7269,20 @@ package body Sem_Prag is
---------------
-- pragma Interface (
-- convention_IDENTIFIER,
-- local_NAME );
-- [ Convention =>] convention_IDENTIFIER,
-- [ Entity =>] local_NAME
-- [, [External_Name =>] static_string_EXPRESSION ]
-- [, [Link_Name =>] static_string_EXPRESSION ]);
when Pragma_Interface =>
GNAT_Pragma;
Check_Arg_Count (2);
Check_No_Identifiers;
Check_Arg_Order
((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;
--------------------
......@@ -8215,119 +8309,204 @@ package body Sem_Prag is
-- Obsolescent --
-----------------
-- pragma Obsolescent [(static_string_EXPRESSION [, Ada_05])];
-- pragma Obsolescent [(
-- [Entity => NAME,]
-- [(static_string_EXPRESSION [, Ada_05])];
when Pragma_Obsolescent => Obsolescent : declare
Subp : Node_Or_Entity_Id;
S : String_Id;
Active : Boolean := True;
Ename : Node_Id;
Decl : Node_Id;
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
-- replaces Subp by the defining entity of the subprogram. If not,
-- issues an error message
---------------------
-- Set_Obsolescent --
---------------------
------------------------------
-- Check_Obsolete_Subprogram--
------------------------------
procedure Set_Obsolescent (E : Entity_Id) is
Active : Boolean;
Ent : Entity_Id;
S : String_Id;
procedure Check_Obsolete_Subprogram is
begin
if Nkind (Subp) /= N_Subprogram_Declaration then
Error_Pragma
("pragma% misplaced, must immediately " &
"follow subprogram/package declaration");
else
Subp := Defining_Entity (Subp);
Active := True;
Ent := E;
-- Entity name was given
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 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
begin
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
-- pragma immediately follows a subprogram declaration.
-- See if first argument specifies an entity name
if Present (Prev (N)) then
Subp := Prev (N);
Check_Obsolete_Subprogram;
if Arg_Count >= 1
and then Chars (Arg1) = Name_Entity
then
Ename := Get_Pragma_Arg (Arg1);
-- Second possibility, stand alone subprogram declaration with the
-- pragma immediately following the declaration.
if Nkind (Ename) /= N_Character_Literal
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))
and then Nkind (Parent (N)) = N_Compilation_Unit_Aux
then
Subp := Unit (Parent (Parent (N)));
Check_Obsolete_Subprogram;
-- Eliminate first argument, so we can share processing
-- Only other possibility is library unit placement for package
Arg1 := Arg2;
Arg2 := Arg3;
Arg_Count := Arg_Count - 1;
else
Subp := Find_Lib_Unit_Name;
-- No Entity name argument given
if Ekind (Subp) /= E_Package
and then Ekind (Subp) /= E_Generic_Package
then
Check_Obsolete_Subprogram;
end if;
else
Ename := Empty;
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);
S := Strval (Expression (Arg1));
-- Cases where we do not follow anything other than another pragma
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;
if No (Decl) then
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
Check_Arg_Count (2);
-- Case 2: library unit placement for package
else
declare
Argx : constant Node_Id := Get_Pragma_Arg (Arg2);
Ent : constant Entity_Id := Find_Lib_Unit_Name;
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
if Ekind (Ent) = E_Package
or else Ekind (Ent) = E_Generic_Package
then
Active := False;
Set_Obsolescent (Ent);
return;
end if;
end;
end if;
end if;
-- Set flag if pragma active
-- Cases where we must follow a declaration
if Active then
Set_Is_Obsolescent (Subp);
else
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 Obsolescent;
......@@ -8525,6 +8704,31 @@ package body Sem_Prag is
Check_Arg_Is_One_Of (Arg1, Name_Semaphore, Name_No);
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 --
-------------
......@@ -8764,6 +8968,136 @@ package body Sem_Prag is
end if;
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 --
-------------
......@@ -8782,7 +9116,6 @@ package body Sem_Prag is
begin
if Chars (Argx) = Name_Ravenscar then
Set_Ravenscar_Profile (N);
elsif Chars (Argx) = Name_Restricted then
Set_Profile_Restrictions (Restricted, N, Warn => False);
else
......@@ -8809,7 +9142,6 @@ package body Sem_Prag is
begin
if Chars (Argx) = Name_Ravenscar then
Set_Profile_Restrictions (Ravenscar, N, Warn => True);
elsif Chars (Argx) = Name_Restricted then
Set_Profile_Restrictions (Restricted, N, Warn => True);
else
......@@ -9251,7 +9583,7 @@ package body Sem_Prag is
-- | restriction_parameter_IDENTIFIER => EXPRESSION
when Pragma_Restrictions =>
Process_Restrictions_Or_Restriction_Warnings;
Process_Restrictions_Or_Restriction_Warnings (Warn => False);
--------------------------
-- Restriction_Warnings --
......@@ -9264,7 +9596,7 @@ package body Sem_Prag is
-- | restriction_parameter_IDENTIFIER => EXPRESSION
when Pragma_Restriction_Warnings =>
Process_Restrictions_Or_Restriction_Warnings;
Process_Restrictions_Or_Restriction_Warnings (Warn => True);
----------------
-- Reviewable --
......@@ -10291,47 +10623,90 @@ package body Sem_Prag is
-- 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
Arg_Node : Node_Id;
Arg_Expr : Node_Id;
Arg_Ent : Entity_Id;
Citem : Node_Id;
begin
GNAT_Pragma;
Check_At_Least_N_Arguments (1);
Arg_Node := Arg1;
while Present (Arg_Node) loop
Check_No_Identifier (Arg_Node);
-- Check case of appearing within context clause
-- Note that the analyze call done by Check_Arg_Is_Local_Name
-- 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.
if Is_In_Context_Clause then
Check_Arg_Is_Local_Name (Arg_Node);
Arg_Expr := Get_Pragma_Arg (Arg_Node);
-- The arguments must all be units mentioned in a with
-- 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_Ent := Entity (Arg_Expr);
Arg_Node := Arg1;
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
-- most recent overloading, as documented. In this case,
-- name resolution does not generate a reference, so it
-- must be done here explicitly.
Next (Citem);
end loop;
if Is_Overloaded (Arg_Expr) then
Generate_Reference (Arg_Ent, N);
if Citem = N then
Error_Pragma_Arg
("argument of pragma% is not with'ed unit", Arg_Node);
end if;
Set_Has_Pragma_Unreferenced (Arg_Ent);
end if;
Next (Arg_Node);
end loop;
Next (Arg_Node);
end loop;
-- Case of not in list of context items
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;
------------------------------
......@@ -10446,21 +10821,24 @@ package body Sem_Prag is
-- Warnings --
--------------
-- pragma Warnings (On | Off, [LOCAL_NAME])
-- pragma Warnings (On | Off);
-- pragma Warnings (On | Off, LOCAL_NAME);
-- pragma Warnings (static_string_EXPRESSION);
-- pragma Warnings (On | Off, STRING_LITERAL);
when Pragma_Warnings => Warnings : begin
GNAT_Pragma;
Check_At_Least_N_Arguments (1);
Check_No_Identifiers;
-- One argument case
declare
Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
if Arg_Count = 1 then
declare
Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
begin
-- One argument case
if Arg_Count = 1 then
begin
-- On/Off one argument case was processed by parser
if Nkind (Argx) = N_Identifier
......@@ -10471,9 +10849,16 @@ package body Sem_Prag is
then
null;
else
Check_Arg_Is_Static_Expression (Arg1, Standard_String);
-- One argument case must be ON/OFF or static string expr
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
Lit : constant Node_Id := Expr_Value_S (Argx);
Str : constant String_Id := Strval (Lit);
......@@ -10494,70 +10879,111 @@ package body Sem_Prag is
end loop;
end;
end if;
end;
-- Two argument case
-- Two or more arguments (must be two)
elsif Arg_Count /= 1 then
Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
Check_Arg_Count (2);
else
Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
Check_At_Most_N_Arguments (2);
declare
E_Id : Node_Id;
E : Entity_Id;
declare
E_Id : Node_Id;
E : Entity_Id;
Err : Boolean;
begin
E_Id := Expression (Arg2);
Analyze (E_Id);
begin
E_Id := Expression (Arg2);
Analyze (E_Id);
-- In the expansion of an inlined body, a reference to
-- the formal may be wrapped in a conversion if the actual
-- is a conversion. Retrieve the real entity name.
-- In the expansion of an inlined body, a reference to
-- the formal may be wrapped in a conversion if the
-- actual is a conversion. Retrieve the real entity name.
if (In_Instance_Body
or else In_Inlined_Body)
and then Nkind (E_Id) = N_Unchecked_Type_Conversion
then
E_Id := Expression (E_Id);
end if;
if (In_Instance_Body
or else In_Inlined_Body)
and then Nkind (E_Id) = N_Unchecked_Type_Conversion
then
E_Id := Expression (E_Id);
end if;
if not Is_Entity_Name (E_Id) then
Error_Pragma_Arg
("second argument of pragma% must be entity name",
Arg2);
end if;
-- Entity name case
E := Entity (E_Id);
if Is_Entity_Name (E_Id) then
E := Entity (E_Id);
if E = Any_Id then
return;
else
loop
Set_Warnings_Off
(E, (Chars (Expression (Arg1)) = Name_Off));
if Is_Enumeration_Type (E) then
declare
Lit : Entity_Id;
begin
Lit := First_Literal (E);
while Present (Lit) loop
Set_Warnings_Off (Lit);
Next_Literal (Lit);
end loop;
end;
if E = Any_Id then
return;
else
loop
Set_Warnings_Off
(E, (Chars (Expression (Arg1)) = Name_Off));
if Is_Enumeration_Type (E) then
declare
Lit : Entity_Id;
begin
Lit := First_Literal (E);
while Present (Lit) loop
Set_Warnings_Off (Lit);
Next_Literal (Lit);
end loop;
end;
end if;
exit when No (Homonym (E));
E := Homonym (E);
end loop;
end if;
exit when No (Homonym (E));
E := Homonym (E);
end loop;
end if;
end;
-- Error if not entity or static string literal case
-- More than two arguments
else
Check_At_Most_N_Arguments (2);
end if;
elsif not Is_Static_String_Expression (Arg2) then
Error_Pragma_Arg
("second argument of pragma% must be entity " &
"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;
-------------------
......@@ -10594,6 +11020,21 @@ package body Sem_Prag is
end if;
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 --
--------------------
......@@ -10615,7 +11056,9 @@ package body Sem_Prag is
function Delay_Config_Pragma_Analyze (N : Node_Id) return Boolean is
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;
-------------------------
......@@ -10714,158 +11157,161 @@ package body Sem_Prag is
Sig_Flags : constant array (Pragma_Id) of Int :=
(Pragma_AST_Entry => -1,
Pragma_Abort_Defer => -1,
Pragma_Ada_83 => -1,
Pragma_Ada_95 => -1,
Pragma_Ada_05 => -1,
Pragma_Ada_2005 => -1,
Pragma_All_Calls_Remote => -1,
Pragma_Annotate => -1,
Pragma_Assert => -1,
Pragma_Assertion_Policy => 0,
Pragma_Asynchronous => -1,
Pragma_Atomic => 0,
Pragma_Atomic_Components => 0,
Pragma_Attach_Handler => -1,
Pragma_CPP_Class => 0,
Pragma_CPP_Constructor => 0,
Pragma_CPP_Virtual => 0,
Pragma_CPP_Vtable => 0,
Pragma_C_Pass_By_Copy => 0,
Pragma_Comment => 0,
Pragma_Common_Object => -1,
Pragma_Compile_Time_Warning => -1,
Pragma_Complete_Representation => 0,
Pragma_Complex_Representation => 0,
Pragma_Component_Alignment => -1,
Pragma_Controlled => 0,
Pragma_Convention => 0,
Pragma_Convention_Identifier => 0,
Pragma_Debug => -1,
Pragma_Debug_Policy => 0,
Pragma_Detect_Blocking => -1,
Pragma_Discard_Names => 0,
Pragma_Elaborate => -1,
Pragma_Elaborate_All => -1,
Pragma_Elaborate_Body => -1,
Pragma_Elaboration_Checks => -1,
Pragma_Eliminate => -1,
Pragma_Explicit_Overriding => -1,
Pragma_Export => -1,
Pragma_Export_Exception => -1,
Pragma_Export_Function => -1,
Pragma_Export_Object => -1,
Pragma_Export_Procedure => -1,
Pragma_Export_Value => -1,
Pragma_Export_Valued_Procedure => -1,
Pragma_Extend_System => -1,
Pragma_Extensions_Allowed => -1,
Pragma_External => -1,
Pragma_External_Name_Casing => -1,
Pragma_Finalize_Storage_Only => 0,
Pragma_Float_Representation => 0,
Pragma_Ident => -1,
Pragma_Import => +2,
Pragma_Import_Exception => 0,
Pragma_Import_Function => 0,
Pragma_Import_Object => 0,
Pragma_Import_Procedure => 0,
Pragma_Import_Valued_Procedure => 0,
Pragma_Initialize_Scalars => -1,
Pragma_Inline => 0,
Pragma_Inline_Always => 0,
Pragma_Inline_Generic => 0,
Pragma_Inspection_Point => -1,
Pragma_Interface => +2,
Pragma_Interface_Name => +2,
Pragma_Interrupt_Handler => -1,
Pragma_Interrupt_Priority => -1,
Pragma_Interrupt_State => -1,
Pragma_Java_Constructor => -1,
Pragma_Java_Interface => -1,
Pragma_Keep_Names => 0,
Pragma_License => -1,
Pragma_Link_With => -1,
Pragma_Linker_Alias => -1,
Pragma_Linker_Constructor => -1,
Pragma_Linker_Destructor => -1,
Pragma_Linker_Options => -1,
Pragma_Linker_Section => -1,
Pragma_List => -1,
Pragma_Locking_Policy => -1,
Pragma_Long_Float => -1,
Pragma_Machine_Attribute => -1,
Pragma_Main => -1,
Pragma_Main_Storage => -1,
Pragma_Memory_Size => -1,
Pragma_No_Return => 0,
Pragma_No_Run_Time => -1,
Pragma_No_Strict_Aliasing => -1,
Pragma_Normalize_Scalars => -1,
Pragma_Obsolescent => 0,
Pragma_Optimize => -1,
Pragma_Optional_Overriding => -1,
Pragma_Pack => 0,
Pragma_Page => -1,
Pragma_Passive => -1,
Pragma_Polling => -1,
Pragma_Persistent_BSS => 0,
Pragma_Preelaborate => -1,
Pragma_Preelaborate_05 => -1,
Pragma_Priority => -1,
Pragma_Profile => 0,
Pragma_Profile_Warnings => 0,
Pragma_Propagate_Exceptions => -1,
Pragma_Psect_Object => -1,
Pragma_Pure => -1,
Pragma_Pure_05 => -1,
Pragma_Pure_Function => -1,
Pragma_Queuing_Policy => -1,
Pragma_Ravenscar => -1,
Pragma_Remote_Call_Interface => -1,
Pragma_Remote_Types => -1,
Pragma_Restricted_Run_Time => -1,
Pragma_Restriction_Warnings => -1,
Pragma_Restrictions => -1,
Pragma_Reviewable => -1,
Pragma_Share_Generic => -1,
Pragma_Shared => -1,
Pragma_Shared_Passive => -1,
Pragma_Source_File_Name => -1,
Pragma_Source_File_Name_Project => -1,
Pragma_Source_Reference => -1,
Pragma_Storage_Size => -1,
Pragma_Storage_Unit => -1,
Pragma_Stream_Convert => -1,
Pragma_Style_Checks => -1,
Pragma_Subtitle => -1,
Pragma_Suppress => 0,
Pragma_Suppress_Exception_Locations => 0,
Pragma_Suppress_All => -1,
Pragma_Suppress_Debug_Info => 0,
Pragma_Suppress_Initialization => 0,
Pragma_System_Name => -1,
Pragma_Task_Dispatching_Policy => -1,
Pragma_Task_Info => -1,
Pragma_Task_Name => -1,
Pragma_Task_Storage => 0,
Pragma_Thread_Body => +2,
Pragma_Time_Slice => -1,
Pragma_Title => -1,
Pragma_Unchecked_Union => 0,
Pragma_Unimplemented_Unit => -1,
Pragma_Universal_Data => -1,
Pragma_Unreferenced => -1,
Pragma_Unreserve_All_Interrupts => -1,
Pragma_Unsuppress => 0,
Pragma_Use_VADS_Size => -1,
Pragma_Validity_Checks => -1,
Pragma_Volatile => 0,
Pragma_Volatile_Components => 0,
Pragma_Warnings => -1,
Pragma_Weak_External => 0,
Unknown_Pragma => 0);
(Pragma_AST_Entry => -1,
Pragma_Abort_Defer => -1,
Pragma_Ada_83 => -1,
Pragma_Ada_95 => -1,
Pragma_Ada_05 => -1,
Pragma_Ada_2005 => -1,
Pragma_All_Calls_Remote => -1,
Pragma_Annotate => -1,
Pragma_Assert => -1,
Pragma_Assertion_Policy => 0,
Pragma_Asynchronous => -1,
Pragma_Atomic => 0,
Pragma_Atomic_Components => 0,
Pragma_Attach_Handler => -1,
Pragma_CPP_Class => 0,
Pragma_CPP_Constructor => 0,
Pragma_CPP_Virtual => 0,
Pragma_CPP_Vtable => 0,
Pragma_C_Pass_By_Copy => 0,
Pragma_Comment => 0,
Pragma_Common_Object => -1,
Pragma_Compile_Time_Warning => -1,
Pragma_Complete_Representation => 0,
Pragma_Complex_Representation => 0,
Pragma_Component_Alignment => -1,
Pragma_Controlled => 0,
Pragma_Convention => 0,
Pragma_Convention_Identifier => 0,
Pragma_Debug => -1,
Pragma_Debug_Policy => 0,
Pragma_Detect_Blocking => -1,
Pragma_Discard_Names => 0,
Pragma_Elaborate => -1,
Pragma_Elaborate_All => -1,
Pragma_Elaborate_Body => -1,
Pragma_Elaboration_Checks => -1,
Pragma_Eliminate => -1,
Pragma_Explicit_Overriding => -1,
Pragma_Export => -1,
Pragma_Export_Exception => -1,
Pragma_Export_Function => -1,
Pragma_Export_Object => -1,
Pragma_Export_Procedure => -1,
Pragma_Export_Value => -1,
Pragma_Export_Valued_Procedure => -1,
Pragma_Extend_System => -1,
Pragma_Extensions_Allowed => -1,
Pragma_External => -1,
Pragma_External_Name_Casing => -1,
Pragma_Finalize_Storage_Only => 0,
Pragma_Float_Representation => 0,
Pragma_Ident => -1,
Pragma_Import => +2,
Pragma_Import_Exception => 0,
Pragma_Import_Function => 0,
Pragma_Import_Object => 0,
Pragma_Import_Procedure => 0,
Pragma_Import_Valued_Procedure => 0,
Pragma_Initialize_Scalars => -1,
Pragma_Inline => 0,
Pragma_Inline_Always => 0,
Pragma_Inline_Generic => 0,
Pragma_Inspection_Point => -1,
Pragma_Interface => +2,
Pragma_Interface_Name => +2,
Pragma_Interrupt_Handler => -1,
Pragma_Interrupt_Priority => -1,
Pragma_Interrupt_State => -1,
Pragma_Java_Constructor => -1,
Pragma_Java_Interface => -1,
Pragma_Keep_Names => 0,
Pragma_License => -1,
Pragma_Link_With => -1,
Pragma_Linker_Alias => -1,
Pragma_Linker_Constructor => -1,
Pragma_Linker_Destructor => -1,
Pragma_Linker_Options => -1,
Pragma_Linker_Section => -1,
Pragma_List => -1,
Pragma_Locking_Policy => -1,
Pragma_Long_Float => -1,
Pragma_Machine_Attribute => -1,
Pragma_Main => -1,
Pragma_Main_Storage => -1,
Pragma_Memory_Size => -1,
Pragma_No_Return => 0,
Pragma_No_Run_Time => -1,
Pragma_No_Strict_Aliasing => -1,
Pragma_Normalize_Scalars => -1,
Pragma_Obsolescent => 0,
Pragma_Optimize => -1,
Pragma_Optional_Overriding => -1,
Pragma_Pack => 0,
Pragma_Page => -1,
Pragma_Passive => -1,
Pragma_Preelaborable_Initialization => -1,
Pragma_Polling => -1,
Pragma_Persistent_BSS => 0,
Pragma_Preelaborate => -1,
Pragma_Preelaborate_05 => -1,
Pragma_Priority => -1,
Pragma_Priority_Specific_Dispatching => -1,
Pragma_Profile => 0,
Pragma_Profile_Warnings => 0,
Pragma_Propagate_Exceptions => -1,
Pragma_Psect_Object => -1,
Pragma_Pure => -1,
Pragma_Pure_05 => -1,
Pragma_Pure_Function => -1,
Pragma_Queuing_Policy => -1,
Pragma_Ravenscar => -1,
Pragma_Remote_Call_Interface => -1,
Pragma_Remote_Types => -1,
Pragma_Restricted_Run_Time => -1,
Pragma_Restriction_Warnings => -1,
Pragma_Restrictions => -1,
Pragma_Reviewable => -1,
Pragma_Share_Generic => -1,
Pragma_Shared => -1,
Pragma_Shared_Passive => -1,
Pragma_Source_File_Name => -1,
Pragma_Source_File_Name_Project => -1,
Pragma_Source_Reference => -1,
Pragma_Storage_Size => -1,
Pragma_Storage_Unit => -1,
Pragma_Stream_Convert => -1,
Pragma_Style_Checks => -1,
Pragma_Subtitle => -1,
Pragma_Suppress => 0,
Pragma_Suppress_Exception_Locations => 0,
Pragma_Suppress_All => -1,
Pragma_Suppress_Debug_Info => 0,
Pragma_Suppress_Initialization => 0,
Pragma_System_Name => -1,
Pragma_Task_Dispatching_Policy => -1,
Pragma_Task_Info => -1,
Pragma_Task_Name => -1,
Pragma_Task_Storage => 0,
Pragma_Thread_Body => +2,
Pragma_Time_Slice => -1,
Pragma_Title => -1,
Pragma_Unchecked_Union => 0,
Pragma_Unimplemented_Unit => -1,
Pragma_Universal_Data => -1,
Pragma_Unreferenced => -1,
Pragma_Unreserve_All_Interrupts => -1,
Pragma_Unsuppress => 0,
Pragma_Use_VADS_Size => -1,
Pragma_Validity_Checks => -1,
Pragma_Volatile => 0,
Pragma_Volatile_Components => 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
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