with Sem_Type; use Sem_Type;
with Sem_Util; use Sem_Util;
with Sem_VFpt; use Sem_VFpt;
+with Sem_Warn; use Sem_Warn;
with Stand; use Stand;
with Sinfo; use Sinfo;
with Sinfo.CN; use Sinfo.CN;
Pragma_Exit : exception;
-- This exception is used to exit pragma processing completely. It
- -- is used when an error is detected, and in other situations where
- -- it is known that no further processing is required.
+ -- is used when an error is detected, and no further processing is
+ -- required. It is also used if an earlier error has left the tree
+ -- in a state where the pragma should not be processed.
Arg_Count : Nat;
-- Number of pragma argument associations
Analyze (Expression (Arg1));
- if Unit_Kind = N_Generic_Subprogram_Declaration
+ if Unit_Kind = N_Generic_Subprogram_Declaration
or else Unit_Kind = N_Subprogram_Declaration
then
Unit_Name := Defining_Entity (Unit_Node);
- elsif Unit_Kind = N_Function_Instantiation
- or else Unit_Kind = N_Package_Instantiation
- or else Unit_Kind = N_Procedure_Instantiation
- then
+ elsif Unit_Kind in N_Generic_Instantiation then
Unit_Name := Defining_Entity (Unit_Node);
else
and then Ekind (E) /= E_Variable
and then not
(Is_Access_Type (E)
- and then Ekind (Designated_Type (E)) = E_Subprogram_Type)
+ and then Ekind (Designated_Type (E)) = E_Subprogram_Type)
then
Error_Pragma_Arg
("second argument of pragma% must be subprogram (type)",
-- suppress check for any check id value.
if C = All_Checks then
+
+ -- For All_Checks, we set all specific checks with the
+ -- exception of Elaboration_Check, which is handled specially
+ -- because of not wanting All_Checks to have the effect of
+ -- deactivating static elaboration order processing.
+
for J in Scope_Suppress'Range loop
- Scope_Suppress (J) := Suppress_Case;
+ if J /= Elaboration_Check then
+ Scope_Suppress (J) := Suppress_Case;
+ end if;
end loop;
+
+ -- If not All_Checks, just set appropriate entry. Note that we
+ -- will set Elaboration_Check if this is explicitly specified.
+
else
Scope_Suppress (C) := Suppress_Case;
end if;
if Warn_On_Unrecognized_Pragma then
Error_Pragma ("unrecognized pragma%!?");
else
- raise Pragma_Exit;
+ return;
end if;
else
Prag_Id := Get_Pragma_Id (Chars (N));
Error_Pragma ("pragma% must refer to a spec, not a body");
else
Set_Body_Required (Cunit_Node, True);
- Set_Has_Pragma_Elaborate_Body (Cunit_Ent);
+ Set_Has_Pragma_Elaborate_Body (Cunit_Ent);
-- If we are in dynamic elaboration mode, then we suppress
-- elaboration warnings for the unit, since it is definitely
Present (Source_Location)
then
Error_Pragma
- ("parameter profile and source location can not " &
+ ("parameter profile and source location cannot " &
"be used together in pragma%");
end if;
S : String_Id;
Active : Boolean := True;
+ 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
+
+ ------------------------------
+ -- Check_Obsolete_Subprogram--
+ ------------------------------
+
+ 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);
+ end if;
+ end Check_Obsolete_Subprogram;
+
+ -- Start of processing for pragma Obsolescent
+
begin
GNAT_Pragma;
Check_At_Most_N_Arguments (2);
if Present (Prev (N)) then
Subp := Prev (N);
+ Check_Obsolete_Subprogram;
-- Second possibility, stand alone subprogram declaration with the
-- pragma immediately following the declaration.
and then Nkind (Parent (N)) = N_Compilation_Unit_Aux
then
Subp := Unit (Parent (Parent (N)));
+ Check_Obsolete_Subprogram;
- -- Any other possibility is a misplacement
+ -- Only other possibility is library unit placement for package
else
- Subp := Empty;
- end if;
-
- -- Check correct placement
+ Subp := Find_Lib_Unit_Name;
- if Nkind (Subp) /= N_Subprogram_Declaration then
- Error_Pragma
- ("pragma% misplaced, must immediately " &
- "follow subprogram spec");
+ if Ekind (Subp) /= E_Package
+ and then Ekind (Subp) /= E_Generic_Package
+ then
+ Check_Obsolete_Subprogram;
+ end if;
end if;
-- If OK placement, acquire arguments
- Subp := Defining_Entity (Subp);
-
if Arg_Count >= 1 then
-- Deal with static string argument
("pragma% requires separate spec and must come before body");
elsif Rep_Item_Too_Early (E, N)
- or else
- Rep_Item_Too_Late (E, N)
+ or else Rep_Item_Too_Late (E, N)
then
raise Pragma_Exit;
--------------
-- pragma Warnings (On | Off, [LOCAL_NAME])
+ -- pragma Warnings (static_string_EXPRESSION);
when Pragma_Warnings => Warnings : begin
GNAT_Pragma;
Check_At_Least_N_Arguments (1);
- Check_At_Most_N_Arguments (2);
Check_No_Identifiers;
- -- One argument case was processed by parser in Par.Prag
+ -- One argument case
- if Arg_Count /= 1 then
+ if Arg_Count = 1 then
+ declare
+ Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
+
+ begin
+ -- On/Off one argument case was processed by parser
+
+ if Nkind (Argx) = N_Identifier
+ and then
+ (Chars (Argx) = Name_On
+ or else
+ Chars (Argx) = Name_Off)
+ then
+ null;
+
+ else
+ Check_Arg_Is_Static_Expression (Arg1, Standard_String);
+
+ declare
+ Lit : constant Node_Id := Expr_Value_S (Argx);
+ Str : constant String_Id := Strval (Lit);
+ C : Char_Code;
+
+ begin
+ for J in 1 .. String_Length (Str) loop
+ C := Get_String_Char (Str, J);
+
+ if In_Character_Range (C)
+ and then Set_Warning_Switch (Get_Character (C))
+ then
+ null;
+ else
+ Error_Pragma_Arg
+ ("invalid warning switch character", Arg1);
+ end if;
+ end loop;
+ end;
+ end if;
+ end;
+
+ -- Two argument case
+
+ elsif Arg_Count /= 1 then
Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
Check_Arg_Count (2);
-- is a conversion. Retrieve the real entity name.
if (In_Instance_Body
- or else In_Inlined_Body)
+ or else In_Inlined_Body)
and then Nkind (E_Id) = N_Unchecked_Type_Conversion
then
E_Id := Expression (E_Id);
return;
else
loop
- Set_Warnings_Off (E,
- (Chars (Expression (Arg1)) = Name_Off));
+ Set_Warnings_Off
+ (E, (Chars (Expression (Arg1)) = Name_Off));
if Is_Enumeration_Type (E) then
declare
end loop;
end if;
end;
+
+ -- More than two arguments
+ else
+ Check_At_Most_N_Arguments (2);
end if;
end Warnings;
OSDN Git Service
