===================================================================
@@ -410,8 +410,8 @@ package body Sem_Prag is
-- case, and if found, issues an appropriate error message.
procedure Check_First_Subtype (Arg : Node_Id);
- -- Checks that Arg, whose expression is an entity name referencing a
- -- subtype, does not reference a type that is not a first subtype.
+ -- Checks that Arg, whose expression is an entity name, references a
+ -- first subtype.
procedure Check_In_Main_Program;
-- Common checks for pragmas that appear within a main program
@@ -976,8 +976,7 @@ package body Sem_Prag is
Check_Arg_Is_Identifier (Argx);
if not Is_Locking_Policy_Name (Chars (Argx)) then
- Error_Pragma_Arg
- ("& is not a valid locking policy name", Argx);
+ Error_Pragma_Arg ("& is not a valid locking policy name", Argx);
end if;
end Check_Arg_Is_Locking_Policy;
@@ -1032,7 +1031,6 @@ package body Sem_Prag is
Error_Pragma_Arg ("invalid argument for pragma%", Argx);
end if;
end Check_Arg_Is_One_Of;
-
---------------------------------
-- Check_Arg_Is_Queuing_Policy --
---------------------------------
@@ -1044,8 +1042,7 @@ package body Sem_Prag is
Check_Arg_Is_Identifier (Argx);
if not Is_Queuing_Policy_Name (Chars (Argx)) then
- Error_Pragma_Arg
- ("& is not a valid queuing policy name", Argx);
+ Error_Pragma_Arg ("& is not a valid queuing policy name", Argx);
end if;
end Check_Arg_Is_Queuing_Policy;
@@ -1210,9 +1207,7 @@ package body Sem_Prag is
S : Entity_Id := Id;
begin
- while Present (S)
- and then S /= Standard_Standard
- loop
+ while Present (S) and then S /= Standard_Standard loop
if Ekind (S) = E_Generic_Package
and then In_Package_Body (S)
then
@@ -1342,10 +1337,22 @@ package body Sem_Prag is
procedure Check_First_Subtype (Arg : Node_Id) is
Argx : constant Node_Id := Get_Pragma_Arg (Arg);
+ Ent : constant Entity_Id := Entity (Argx);
begin
- if not Is_First_Subtype (Entity (Argx)) then
+ if Is_First_Subtype (Ent) then
+ null;
+
+ elsif Is_Type (Ent) then
Error_Pragma_Arg
("pragma% cannot apply to subtype", Argx);
+
+ elsif Is_Object (Ent) then
+ Error_Pragma_Arg
+ ("pragma% cannot apply to object, requires a type", Argx);
+
+ else
+ Error_Pragma_Arg
+ ("pragma% cannot apply to&, requires a type", Argx);
end if;
end Check_First_Subtype;
@@ -2188,6 +2195,7 @@ package body Sem_Prag is
if Error_Msg_Name_1 = Name_Precondition then
Error_Msg_Name_1 := Name_Pre;
+
elsif Error_Msg_Name_1 = Name_Postcondition then
Error_Msg_Name_1 := Name_Post;
end if;
Some pragmas (e.g. Pack, Preelaborable_Initialization) can be applied only to a first subtype. Previously the circuitry reporting errors for illegal attempts to apply them to anything else always assumed that the (illegal) argument was a subtype. The error message is now correctly specialized for the case of entities that are not types or subtypes. $ gcc -c preelab_on_var.ads preelab_on_var.ads:9:41: pragma "Preelaborable_Initialization" cannot apply to subtype preelab_on_var.ads:13:41: pragma "Preelaborable_Initialization" cannot apply to object, requires a type preelab_on_var.ads:16:41: pragma "Preelaborable_Initialization" cannot apply to "P", requires a type package Preelab_On_Var is package P is type T is private; private type T is null record; end P; subtype S is P.T; pragma Preelaborable_Initialization (S); -- ERROR: pragma applies to base type only X : P.T; pragma Preelaborable_Initialization (X); -- ERROR: pragma never applies to object pragma Preelaborable_Initialization (P); -- ERROR: pragma never applies to package end Preelab_On_Var; Tested on x86_64-pc-linux-gnu, committed on trunk 2010-10-22 Thomas Quinot <quinot@adacore.com> * sem_prag.adb (Check_First_Subtype): Specialize error messages for case where argument is not a type.