@@ -896,12 +896,19 @@ package body Errout is
-- Error_Msg_GNAT_Extension --
------------------------------
- procedure Error_Msg_GNAT_Extension (Extension : String) is
- Loc : constant Source_Ptr := Token_Ptr;
+ procedure Error_Msg_GNAT_Extension (Extension : String; Loc : Source_Ptr) is
begin
if not Extensions_Allowed then
- Error_Msg (Extension & " is a 'G'N'A'T specific extension", Loc);
- Error_Msg ("\unit must be compiled with -gnatX switch", Loc);
+ Error_Msg (Extension & " is a 'G'N'A'T-specific extension", Loc);
+
+ if No (Ada_Version_Pragma) then
+ Error_Msg ("\unit must be compiled with -gnatX "
+ & "or use pragma Extensions_Allowed (On)", Loc);
+ else
+ Error_Msg_Sloc := Sloc (Ada_Version_Pragma);
+ Error_Msg ("\incompatible with Ada version set#", Loc);
+ Error_Msg ("\must use pragma Extensions_Allowed (On)", Loc);
+ end if;
end if;
end Error_Msg_GNAT_Extension;
@@ -943,10 +943,11 @@ package Errout is
procedure Error_Msg_Ada_2022_Feature (Feature : String; Loc : Source_Ptr);
-- Analogous to Error_Msg_Ada_2012_Feature, for Ada 2022
- procedure Error_Msg_GNAT_Extension (Extension : String);
+ procedure Error_Msg_GNAT_Extension (Extension : String; Loc : Source_Ptr);
-- If not operating with extensions allowed, posts errors complaining
- -- that Extension is only supported when the -gnatX switch is enabled,
- -- with appropriate suggestions to fix it.
+ -- that Extension is only supported when the -gnatX switch is enabled
+ -- or pragma Extensions_Allowed (On) is used. Loc indicates the source
+ -- location of the extension construct.
procedure dmsg (Id : Error_Msg_Id) renames Erroutc.dmsg;
-- Debugging routine to dump an error message
@@ -234,7 +234,7 @@ package body Ch11 is
end if;
if Token = Tok_When then
- Error_Msg_GNAT_Extension ("raise when statement");
+ Error_Msg_GNAT_Extension ("raise when statement", Token_Ptr);
Mutate_Nkind (Raise_Node, N_Raise_When_Statement);
@@ -1225,7 +1225,7 @@ package body Ch12 is
elsif Token = Tok_Left_Paren then
Error_Msg_GNAT_Extension
- ("expression default for formal subprograms");
+ ("expression default for formal subprograms", Token_Ptr);
if Nkind (Spec_Node) = N_Function_Specification then
Scan; -- past "("
@@ -2788,7 +2788,7 @@ package body Ch3 is
else
P_Index_Subtype_Def_With_Fixed_Lower_Bound (Subtype_Mark_Node);
- Error_Msg_GNAT_Extension ("fixed-lower-bound array");
+ Error_Msg_GNAT_Extension ("fixed-lower-bound array", Token_Ptr);
end if;
exit when Token = Tok_Right_Paren or else Token = Tok_Of;
@@ -2857,7 +2857,8 @@ package body Ch3 is
P_Index_Subtype_Def_With_Fixed_Lower_Bound
(Subtype_Mark_Node);
- Error_Msg_GNAT_Extension ("fixed-lower-bound array");
+ Error_Msg_GNAT_Extension
+ ("fixed-lower-bound array", Token_Ptr);
end if;
exit when Token = Tok_Right_Paren or else Token = Tok_Of;
@@ -3359,7 +3360,7 @@ package body Ch3 is
-- later during analysis), and scan to the next token.
if Token = Tok_Box then
- Error_Msg_GNAT_Extension ("fixed-lower-bound array");
+ Error_Msg_GNAT_Extension ("fixed-lower-bound array", Token_Ptr);
Expr_Node := Empty;
Scan;
@@ -1783,9 +1783,8 @@ package body Ch4 is
Box_With_Identifier_Present := True;
Scan; -- past ">"
else
- Error_Msg
- ("Identifier within box only supported under -gnatX",
- Token_Ptr);
+ Error_Msg_GNAT_Extension
+ ("identifier within box", Token_Ptr);
Box_Present := True;
-- Avoid cascading errors by ignoring the identifier
end if;
@@ -1816,10 +1815,8 @@ package body Ch4 is
Id := P_Defining_Identifier;
if not Extensions_Allowed then
- Error_Msg
- ("IS following component association"
- & " only supported under -gnatX",
- Token_Ptr);
+ Error_Msg_GNAT_Extension
+ ("IS following component association", Token_Ptr);
elsif Box_With_Identifier_Present then
Error_Msg
("Both identifier-in-box and trailing identifier"
@@ -1975,7 +1975,7 @@ package body Ch5 is
Append_Elmt (Goto_Node, Goto_List);
if Token = Tok_When then
- Error_Msg_GNAT_Extension ("goto when statement");
+ Error_Msg_GNAT_Extension ("goto when statement", Token_Ptr);
Scan; -- past WHEN
Mutate_Nkind (Goto_Node, N_Goto_When_Statement);
@@ -1999,7 +1999,7 @@ package body Ch6 is
-- at a Return_when_statement
if Token = Tok_When and then not Missing_Semicolon_On_When then
- Error_Msg_GNAT_Extension ("return when statement");
+ Error_Msg_GNAT_Extension ("return when statement", Token_Ptr);
Mutate_Nkind (Ret_Node, N_Return_When_Statement);
Scan; -- past WHEN
@@ -2008,7 +2008,7 @@ package body Ch6 is
-- Allow IF instead of WHEN, giving error message
elsif Token = Tok_If then
- Error_Msg_GNAT_Extension ("return when statement");
+ Error_Msg_GNAT_Extension ("return when statement", Token_Ptr);
Mutate_Nkind (Ret_Node, N_Return_When_Statement);
T_When;
@@ -2601,10 +2601,8 @@ package body Sem_Ch13 is
Aspect);
elsif Is_Imported_Intrinsic then
- Error_Msg_N
- ("aspect % on intrinsic function is an extension: " &
- "use -gnatX",
- Aspect);
+ Error_Msg_GNAT_Extension
+ ("aspect % on intrinsic function", Sloc (Aspect));
else
Error_Msg_N
@@ -4411,11 +4409,7 @@ package body Sem_Ch13 is
when Aspect_Designated_Storage_Model =>
if not Extensions_Allowed then
- Error_Msg_N
- ("aspect only allowed if extensions enabled",
- Aspect);
- Error_Msg_N
- ("\unit must be compiled with -gnatX switch", Aspect);
+ Error_Msg_GNAT_Extension ("aspect %", Sloc (Aspect));
elsif not Is_Type (E)
or else Ekind (E) /= E_Access_Type
@@ -4430,11 +4424,7 @@ package body Sem_Ch13 is
when Aspect_Storage_Model_Type =>
if not Extensions_Allowed then
- Error_Msg_N
- ("aspect only allowed if extensions enabled",
- Aspect);
- Error_Msg_N
- ("\unit must be compiled with -gnatX switch", Aspect);
+ Error_Msg_GNAT_Extension ("aspect %", Sloc (Aspect));
elsif not Is_Type (E)
or else not Is_Immutably_Limited_Type (E)