Commit fd8b4053 by Hristian Kirtchev Committed by Arnaud Charlet

sem_ch13.adb (Analyze_Aspect_Specifications): Aspect Depends is now a delayed aspect.

2013-04-12  Hristian Kirtchev  <kirtchev@adacore.com>

	* sem_ch13.adb (Analyze_Aspect_Specifications): Aspect
	Depends is now a delayed aspect. The delay is required
	due to the interplay between aspects Depends and Global.
	(Check_Aspect_At_Freeze_Point): Add an entry for aspect Depends.
	* sem_prag.adb: Reformat various error messages.
	(Add_Item): New subsidiary routine.
	(Analyze_Pragma): Add new variables
	Global_Seen, Result_Seen, Subp_Inputs and Subp_Outputs. The
	analysis of pragma Depends now has the capability to check
	the proper mode and usage of subprogram inputs and outputs.
	(Appears_In): New routine.
	(Check_Function_Return): New routine.
	(Check_Mode): New routine.
	(Check_Usage): New routine.
	(Collect_Subprogram_Inputs_Outputs): New routine.

From-SVN: r197900
parent c2658843
2013-04-12 Hristian Kirtchev <kirtchev@adacore.com>
* sem_ch13.adb (Analyze_Aspect_Specifications): Aspect
Depends is now a delayed aspect. The delay is required
due to the interplay between aspects Depends and Global.
(Check_Aspect_At_Freeze_Point): Add an entry for aspect Depends.
* sem_prag.adb: Reformat various error messages.
(Add_Item): New subsidiary routine.
(Analyze_Pragma): Add new variables
Global_Seen, Result_Seen, Subp_Inputs and Subp_Outputs. The
analysis of pragma Depends now has the capability to check
the proper mode and usage of subprogram inputs and outputs.
(Appears_In): New routine.
(Check_Function_Return): New routine.
(Check_Mode): New routine.
(Check_Usage): New routine.
(Collect_Subprogram_Inputs_Outputs): New routine.
2013-04-12 Bob Duff <duff@adacore.com> 2013-04-12 Bob Duff <duff@adacore.com>
* par-ch7.adb (P_Package): Initialize Sloc in the newly-pushed scope * par-ch7.adb (P_Package): Initialize Sloc in the newly-pushed scope
......
...@@ -1475,6 +1475,9 @@ package body Sem_Ch13 is ...@@ -1475,6 +1475,9 @@ package body Sem_Ch13 is
Delay_Required := False; Delay_Required := False;
-- Aspect Depends must be delayed because it mentions names
-- of inputs and output that are classified by aspect Global.
when Aspect_Depends => when Aspect_Depends =>
Aitem := Aitem :=
Make_Pragma (Loc, Make_Pragma (Loc,
...@@ -1484,8 +1487,6 @@ package body Sem_Ch13 is ...@@ -1484,8 +1487,6 @@ package body Sem_Ch13 is
Make_Pragma_Argument_Association (Loc, Make_Pragma_Argument_Association (Loc,
Expression => Relocate_Node (Expr)))); Expression => Relocate_Node (Expr))));
Delay_Required := False;
-- Aspect Global must be delayed because it can mention names -- Aspect Global must be delayed because it can mention names
-- and benefit from the forward visibility rules applicable to -- and benefit from the forward visibility rules applicable to
-- aspects of subprograms. -- aspects of subprograms.
...@@ -7194,6 +7195,14 @@ package body Sem_Ch13 is ...@@ -7194,6 +7195,14 @@ package body Sem_Ch13 is
when Aspect_Default_Value => when Aspect_Default_Value =>
T := Entity (ASN); T := Entity (ASN);
-- Depends is a delayed aspect because it mentiones names first
-- introduced by aspect Global which is already delayed. There is
-- no action to be taken with respect to the aspect itself as the
-- analysis is done by the corresponding pragma.
when Aspect_Depends =>
return;
when Aspect_Dispatching_Domain => when Aspect_Dispatching_Domain =>
T := RTE (RE_Dispatching_Domain); T := RTE (RE_Dispatching_Domain);
...@@ -7205,8 +7214,8 @@ package body Sem_Ch13 is ...@@ -7205,8 +7214,8 @@ package body Sem_Ch13 is
-- Global is a delayed aspect because it may reference names that -- Global is a delayed aspect because it may reference names that
-- have not been declared yet. There is no action to be taken with -- have not been declared yet. There is no action to be taken with
-- respect to the aspect itself as the reference checking is done on -- respect to the aspect itself as the reference checking is done
-- the corresponding pragma. -- on the corresponding pragma.
when Aspect_Global => when Aspect_Global =>
return; return;
...@@ -7283,7 +7292,6 @@ package body Sem_Ch13 is ...@@ -7283,7 +7292,6 @@ package body Sem_Ch13 is
when Aspect_Abstract_State | when Aspect_Abstract_State |
Aspect_Contract_Case | Aspect_Contract_Case |
Aspect_Contract_Cases | Aspect_Contract_Cases |
Aspect_Depends |
Aspect_Dimension | Aspect_Dimension |
Aspect_Dimension_System | Aspect_Dimension_System |
Aspect_Implicit_Dereference | Aspect_Implicit_Dereference |
......
...@@ -458,6 +458,11 @@ package body Sem_Prag is ...@@ -458,6 +458,11 @@ package body Sem_Prag is
-- In Ada 95 or 05 mode, these are implementation defined pragmas, so -- In Ada 95 or 05 mode, these are implementation defined pragmas, so
-- should be caught by the No_Implementation_Pragmas restriction. -- should be caught by the No_Implementation_Pragmas restriction.
procedure Add_Item (Item : Entity_Id; To_List : in out Elist_Id);
-- Subsidiary routine to the analysis of pragmas Depends and Global.
-- Append an input or output item to a list. If the list is empty, a
-- new one is created.
procedure Check_Ada_83_Warning; procedure Check_Ada_83_Warning;
-- Issues a warning message for the current pragma if operating in Ada -- Issues a warning message for the current pragma if operating in Ada
-- 83 mode (used for language pragmas that are not a standard part of -- 83 mode (used for language pragmas that are not a standard part of
...@@ -983,6 +988,19 @@ package body Sem_Prag is ...@@ -983,6 +988,19 @@ package body Sem_Prag is
end if; end if;
end Ada_2012_Pragma; end Ada_2012_Pragma;
--------------
-- Add_Item --
--------------
procedure Add_Item (Item : Entity_Id; To_List : in out Elist_Id) is
begin
if No (To_List) then
To_List := New_Elmt_List;
end if;
Append_Unique_Elmt (Item, To_List);
end Add_Item;
-------------------------- --------------------------
-- Check_Ada_83_Warning -- -- Check_Ada_83_Warning --
-------------------------- --------------------------
...@@ -3485,8 +3503,8 @@ package body Sem_Prag is ...@@ -3485,8 +3503,8 @@ package body Sem_Prag is
and then C /= Convention (Overridden_Operation (E)) and then C /= Convention (Overridden_Operation (E))
then then
Error_Pragma_Arg Error_Pragma_Arg
("cannot change convention for overridden " ("cannot change convention for overridden dispatching "
& "dispatching operation", Arg1); & "operation", Arg1);
end if; end if;
-- Set the convention -- Set the convention
...@@ -8652,8 +8670,8 @@ package body Sem_Prag is ...@@ -8652,8 +8670,8 @@ package body Sem_Prag is
if Warn_On_Obsolescent_Feature then if Warn_On_Obsolescent_Feature then
Error_Msg_N Error_Msg_N
("'G'N'A'T pragma cpp'_virtual is now obsolete and has " ("'G'N'A'T pragma cpp'_virtual is now obsolete and has no "
& "no effect?j?", N); & "effect?j?", N);
end if; end if;
end CPP_Virtual; end CPP_Virtual;
...@@ -8667,8 +8685,8 @@ package body Sem_Prag is ...@@ -8667,8 +8685,8 @@ package body Sem_Prag is
if Warn_On_Obsolescent_Feature then if Warn_On_Obsolescent_Feature then
Error_Msg_N Error_Msg_N
("'G'N'A'T pragma cpp'_vtable is now obsolete and has " ("'G'N'A'T pragma cpp'_vtable is now obsolete and has no "
& "no effect?j?", N); & "effect?j?", N);
end if; end if;
end CPP_Vtable; end CPP_Vtable;
...@@ -8900,14 +8918,14 @@ package body Sem_Prag is ...@@ -8900,14 +8918,14 @@ package body Sem_Prag is
-- where FUNCTION_RESULT is a function Result attribute_reference -- where FUNCTION_RESULT is a function Result attribute_reference
when Pragma_Depends => Depends : declare when Pragma_Depends => Depends : declare
Subp_Decl : Node_Id;
Subp_Id : Entity_Id;
All_Inputs_Seen : Elist_Id := No_Elist; All_Inputs_Seen : Elist_Id := No_Elist;
-- A list containing the entities of all the inputs processed so -- A list containing the entities of all the inputs processed so
-- far. This Elist is populated with unique entities because the -- far. This Elist is populated with unique entities because the
-- same input may appear in multiple input lists. -- same input may appear in multiple input lists.
Global_Seen : Boolean := False;
-- A flag set when pragma Global has been processed
Outputs_Seen : Elist_Id := No_Elist; Outputs_Seen : Elist_Id := No_Elist;
-- A list containing the entities of all the outputs processed so -- A list containing the entities of all the outputs processed so
-- far. The elements of this list may come from different output -- far. The elements of this list may come from different output
...@@ -8916,12 +8934,52 @@ package body Sem_Prag is ...@@ -8916,12 +8934,52 @@ package body Sem_Prag is
Null_Output_Seen : Boolean := False; Null_Output_Seen : Boolean := False;
-- A flag used to track the legality of a null output -- A flag used to track the legality of a null output
Result_Seen : Boolean := False;
-- A flag set when Subp_Id'Result is processed
Subp_Id : Entity_Id;
-- The entity of the subprogram subject to pragma Depends
Subp_Inputs : Elist_Id := No_Elist;
Subp_Outputs : Elist_Id := No_Elist;
-- Two lists containing the full set of inputs and output of the
-- related subprograms. Note that these lists contain both nodes
-- and entities.
procedure Analyze_Dependency_Clause procedure Analyze_Dependency_Clause
(Clause : Node_Id; (Clause : Node_Id;
Is_Last : Boolean); Is_Last : Boolean);
-- Verify the legality of a single dependency clause. Flag Is_Last -- Verify the legality of a single dependency clause. Flag Is_Last
-- denotes whether Clause is the last clause in the relation. -- denotes whether Clause is the last clause in the relation.
function Appears_In
(List : Elist_Id;
Item_Id : Entity_Id) return Boolean;
-- Determine whether a particular item appears in a mixed list of
-- nodes and entities.
procedure Check_Function_Return;
-- Verify that Funtion'Result appears as one of the outputs
procedure Check_Mode
(Item : Node_Id;
Item_Id : Entity_Id;
Is_Input : Boolean);
-- Ensure that an item has a proper "in", "in out" or "out" mode
-- depending on its function. If this is not the case, emit an
-- error.
procedure Check_Usage
(Subp_List : Elist_Id;
Item_List : Elist_Id;
Is_Input : Boolean);
-- Verify that all items from list Subp_List appear in Item_List.
-- Emit an error if this is not the case.
procedure Collect_Subprogram_Inputs_Outputs;
-- Gather all inputs and outputs of the subprogram. These are the
-- formal parameters and entities classified in pragma Global.
procedure Normalize_Clause (Clause : Node_Id); procedure Normalize_Clause (Clause : Node_Id);
-- Remove a self-dependency "+" from the input list of a clause. -- Remove a self-dependency "+" from the input list of a clause.
-- Depending on the contents of the relation, either split the -- Depending on the contents of the relation, either split the
...@@ -9080,6 +9138,9 @@ package body Sem_Prag is ...@@ -9080,6 +9138,9 @@ package body Sem_Prag is
elsif Is_Input then elsif Is_Input then
Error_Msg_N Error_Msg_N
("function result cannot act as input", Item); ("function result cannot act as input", Item);
else
Result_Seen := True;
end if; end if;
-- Detect multiple uses of null in a single dependency list -- Detect multiple uses of null in a single dependency list
...@@ -9120,6 +9181,11 @@ package body Sem_Prag is ...@@ -9120,6 +9181,11 @@ package body Sem_Prag is
E_Out_Parameter, E_Out_Parameter,
E_Variable) E_Variable)
then then
-- Ensure that the item is of the correct mode
-- depending on its function.
Check_Mode (Item, Item_Id, Is_Input);
-- Detect multiple uses of the same state, variable -- Detect multiple uses of the same state, variable
-- or formal parameter. If this is not the case, -- or formal parameter. If this is not the case,
-- add the item to the list of processed relations. -- add the item to the list of processed relations.
...@@ -9127,11 +9193,7 @@ package body Sem_Prag is ...@@ -9127,11 +9193,7 @@ package body Sem_Prag is
if Contains (Seen, Item_Id) then if Contains (Seen, Item_Id) then
Error_Msg_N ("duplicate use of item", Item); Error_Msg_N ("duplicate use of item", Item);
else else
if No (Seen) then Add_Item (Item_Id, Seen);
Seen := New_Elmt_List;
end if;
Append_Elmt (Item_Id, Seen);
end if; end if;
-- Detect an illegal use of an input related to a -- Detect an illegal use of an input related to a
...@@ -9145,11 +9207,7 @@ package body Sem_Prag is ...@@ -9145,11 +9207,7 @@ package body Sem_Prag is
("input of a null output list appears in " ("input of a null output list appears in "
& "multiple input lists", Item); & "multiple input lists", Item);
else else
if No (All_Inputs_Seen) then Add_Item (Item_Id, All_Inputs_Seen);
All_Inputs_Seen := New_Elmt_List;
end if;
Append_Unique_Elmt (Item_Id, All_Inputs_Seen);
end if; end if;
-- When the item renames an entire object, replace -- When the item renames an entire object, replace
...@@ -9215,6 +9273,295 @@ package body Sem_Prag is ...@@ -9215,6 +9273,295 @@ package body Sem_Prag is
Analyze_Input_List (Inputs); Analyze_Input_List (Inputs);
end Analyze_Dependency_Clause; end Analyze_Dependency_Clause;
----------------
-- Appears_In --
----------------
function Appears_In
(List : Elist_Id;
Item_Id : Entity_Id) return Boolean
is
Elmt : Elmt_Id;
Id : Entity_Id;
begin
if Present (List) then
Elmt := First_Elmt (List);
while Present (Elmt) loop
if Nkind (Node (Elmt)) = N_Defining_Identifier then
Id := Node (Elmt);
else
Id := Entity (Node (Elmt));
end if;
if Id = Item_Id then
return True;
end if;
Next_Elmt (Elmt);
end loop;
end if;
return False;
end Appears_In;
----------------------------
-- Check_Function_Return --
----------------------------
procedure Check_Function_Return is
begin
if Ekind (Subp_Id) = E_Function and then not Result_Seen then
Error_Msg_NE
("result of & must appear in exactly one output list",
N, Subp_Id);
end if;
end Check_Function_Return;
----------------
-- Check_Mode --
----------------
procedure Check_Mode
(Item : Node_Id;
Item_Id : Entity_Id;
Is_Input : Boolean)
is
begin
if Is_Input then
if Ekind (Item_Id) = E_Out_Parameter
or else
(Global_Seen
and then not Appears_In (Subp_Inputs, Item_Id))
then
Error_Msg_NE
("item & must have mode in or in out", Item, Item_Id);
end if;
-- Output
else
if Ekind (Item_Id) = E_In_Parameter
or else
(Global_Seen
and then not Appears_In (Subp_Outputs, Item_Id))
then
Error_Msg_NE
("item & must have mode out or in out", Item, Item_Id);
end if;
end if;
end Check_Mode;
-----------------
-- Check_Usage --
-----------------
procedure Check_Usage
(Subp_List : Elist_Id;
Item_List : Elist_Id;
Is_Input : Boolean)
is
procedure Usage_Error (Item : Node_Id; Item_Id : Entity_Id);
-- Emit an error concerning the erroneous usage of an item
-----------------
-- Usage_Error --
-----------------
procedure Usage_Error (Item : Node_Id; Item_Id : Entity_Id) is
begin
if Is_Input then
Error_Msg_NE
("item & must appear in at least one input list of "
& "aspect Depends", Item, Item_Id);
else
Error_Msg_NE
("item & must appear in exactly one output list of "
& "aspect Depends", Item, Item_Id);
end if;
end Usage_Error;
-- Local variables
Elmt : Elmt_Id;
Item : Node_Id;
Item_Id : Entity_Id;
-- Start of processing for Check_Usage
begin
if No (Subp_List) then
return;
end if;
-- Each input or output of the subprogram must appear in a
-- dependency relation.
Elmt := First_Elmt (Subp_List);
while Present (Elmt) loop
Item := Node (Elmt);
if Nkind (Item) = N_Defining_Identifier then
Item_Id := Item;
else
Item_Id := Entity (Item);
end if;
-- The item does not appear in a dependency
if not Contains (Item_List, Item_Id) then
if Is_Formal (Item_Id) then
Usage_Error (Item, Item_Id);
-- States and global variables are not used properly only
-- when the subprogram is subject to pragma Global.
elsif Global_Seen then
Usage_Error (Item, Item_Id);
end if;
end if;
Next_Elmt (Elmt);
end loop;
end Check_Usage;
---------------------------------------
-- Collect_Subprogram_Inputs_Outputs --
---------------------------------------
procedure Collect_Subprogram_Inputs_Outputs is
procedure Collect_Global_List
(List : Node_Id;
Mode : Name_Id := Name_Input);
-- Collect all relevant items from a global list
-------------------------
-- Collect_Global_List --
-------------------------
procedure Collect_Global_List
(List : Node_Id;
Mode : Name_Id := Name_Input)
is
procedure Collect_Global_Item
(Item : Node_Id;
Mode : Name_Id);
-- Add an item to the proper subprogram input or output
-- collection.
-------------------------
-- Collect_Global_Item --
-------------------------
procedure Collect_Global_Item
(Item : Node_Id;
Mode : Name_Id)
is
begin
if Mode = Name_In_Out or else Mode = Name_Input then
Add_Item (Item, Subp_Inputs);
end if;
if Mode = Name_In_Out or else Mode = Name_Output then
Add_Item (Item, Subp_Outputs);
end if;
end Collect_Global_Item;
-- Local variables
Assoc : Node_Id;
Item : Node_Id;
-- Start of processing for Collect_Global_List
begin
-- Single global item declaration
if Nkind_In (List, N_Identifier, N_Selected_Component) then
Collect_Global_Item (List, Mode);
-- Simple global list or moded global list declaration
else
if Present (Expressions (List)) then
Item := First (Expressions (List));
while Present (Item) loop
Collect_Global_Item (Item, Mode);
Next (Item);
end loop;
else
Assoc := First (Component_Associations (List));
while Present (Assoc) loop
Collect_Global_List
(List => Expression (Assoc),
Mode => Chars (First (Choices (Assoc))));
Next (Assoc);
end loop;
end if;
end if;
end Collect_Global_List;
-- Local variables
Formal : Entity_Id;
Global : Node_Id;
List : Node_Id;
-- Start of processing for Collect_Subprogram_Inputs_Outputs
begin
-- Process all formal parameters
Formal := First_Formal (Subp_Id);
while Present (Formal) loop
if Ekind_In (Formal, E_In_Out_Parameter,
E_In_Parameter)
then
Add_Item (Formal, Subp_Inputs);
end if;
if Ekind_In (Formal, E_In_Out_Parameter,
E_Out_Parameter)
then
Add_Item (Formal, Subp_Outputs);
end if;
Next_Formal (Formal);
end loop;
-- If the subprogram is subject to pragma Global, traverse all
-- global lists and gather the relevant items.
Global := Find_Aspect (Subp_Id, Aspect_Global);
if Present (Global) then
Global_Seen := True;
-- Retrieve the pragma as it contains the analyzed lists
Global := Aspect_Rep_Item (Parent (Global));
-- The pragma may not have been analyzed because of the
-- arbitrary declaration order of aspects. Make sure that
-- it is analyzed for the purposes of item extraction.
if not Analyzed (Global) then
Analyze (Global);
end if;
List :=
Expression (First (Pragma_Argument_Associations (Global)));
-- Nothing to be done for a null global list
if Nkind (List) /= N_Null then
Collect_Global_List (List);
end if;
end if;
end Collect_Subprogram_Inputs_Outputs;
---------------------- ----------------------
-- Normalize_Clause -- -- Normalize_Clause --
---------------------- ----------------------
...@@ -9490,6 +9837,7 @@ package body Sem_Prag is ...@@ -9490,6 +9837,7 @@ package body Sem_Prag is
Clause : Node_Id; Clause : Node_Id;
Errors : Nat; Errors : Nat;
Last_Clause : Node_Id; Last_Clause : Node_Id;
Subp_Decl : Node_Id;
-- Start of processing for Depends -- Start of processing for Depends
...@@ -9511,10 +9859,22 @@ package body Sem_Prag is ...@@ -9511,10 +9859,22 @@ package body Sem_Prag is
Subp_Id := Defining_Unit_Name (Specification (Subp_Decl)); Subp_Id := Defining_Unit_Name (Specification (Subp_Decl));
Clause := Expression (Arg1); Clause := Expression (Arg1);
-- There is nothing to be done for a null dependency relation -- Empty dependency list
if Nkind (Clause) = N_Null then if Nkind (Clause) = N_Null then
null;
-- Gather all states, variables and formal parameters that the
-- subprogram may depend on. These items are obtained from the
-- parameter profile or pragma Global (if available).
Collect_Subprogram_Inputs_Outputs;
-- Verify that every input or output of the subprogram appear
-- in a dependency.
Check_Usage (Subp_Inputs, All_Inputs_Seen, True);
Check_Usage (Subp_Outputs, Outputs_Seen, False);
Check_Function_Return;
-- Dependency clauses appear as component associations of an -- Dependency clauses appear as component associations of an
-- aggregate. -- aggregate.
...@@ -9524,6 +9884,12 @@ package body Sem_Prag is ...@@ -9524,6 +9884,12 @@ package body Sem_Prag is
then then
Last_Clause := Last (Component_Associations (Clause)); Last_Clause := Last (Component_Associations (Clause));
-- Gather all states, variables and formal parameters that the
-- subprogram may depend on. These items are obtained from the
-- parameter profile or pragma Global (if available).
Collect_Subprogram_Inputs_Outputs;
-- Ensure that the formal parameters are visible when analyzing -- Ensure that the formal parameters are visible when analyzing
-- all clauses. This falls out of the general rule of aspects -- all clauses. This falls out of the general rule of aspects
-- pertaining to subprogram declarations. -- pertaining to subprogram declarations.
...@@ -9559,6 +9925,13 @@ package body Sem_Prag is ...@@ -9559,6 +9925,13 @@ package body Sem_Prag is
End_Scope; End_Scope;
-- Verify that every input or output of the subprogram appear
-- in a dependency.
Check_Usage (Subp_Inputs, All_Inputs_Seen, True);
Check_Usage (Subp_Outputs, Outputs_Seen, False);
Check_Function_Return;
-- The top level dependency relation is malformed -- The top level dependency relation is malformed
else else
...@@ -10047,8 +10420,8 @@ package body Sem_Prag is ...@@ -10047,8 +10420,8 @@ package body Sem_Prag is
Present (Source_Location) Present (Source_Location)
then then
Error_Pragma Error_Pragma
("parameter profile and source location cannot " ("parameter profile and source location cannot be used "
& "be used together in pragma%"); & "together in pragma%");
end if; end if;
Process_Eliminate_Pragma Process_Eliminate_Pragma
...@@ -10894,18 +11267,14 @@ package body Sem_Prag is ...@@ -10894,18 +11267,14 @@ package body Sem_Prag is
-- processed items. -- processed items.
else else
if No (Seen) then Add_Item (Item_Id, Seen);
Seen := New_Elmt_List;
end if;
Append_Elmt (Item_Id, Seen);
end if; end if;
if Ekind (Item_Id) = E_Abstract_State if Ekind (Item_Id) = E_Abstract_State
and then Is_Volatile_State (Item_Id) and then Is_Volatile_State (Item_Id)
then then
-- A global item of mode In_Out or Output cannot denote -- A global item of mode In_Out or Output cannot denote a
-- a volatile Input state. -- volatile Input state.
if Is_Input_State (Item_Id) if Is_Input_State (Item_Id)
and then (Global_Mode = Name_In_Out and then (Global_Mode = Name_In_Out
...@@ -10954,9 +11323,9 @@ package body Sem_Prag is ...@@ -10954,9 +11323,9 @@ package body Sem_Prag is
procedure Check_Mode_Restriction_In_Function (Mode : Node_Id) is procedure Check_Mode_Restriction_In_Function (Mode : Node_Id) is
begin begin
if Ekind (Subp_Id) = E_Function then if Ekind (Subp_Id) = E_Function then
Error_Msg_Name_1 := Chars (Mode); Error_Msg_NE
Error_Msg_N ("global mode & not applicable to functions",
("global mode % not applicable to functions", Mode); Mode, Mode);
end if; end if;
end Check_Mode_Restriction_In_Function; end Check_Mode_Restriction_In_Function;
...@@ -11008,22 +11377,22 @@ package body Sem_Prag is ...@@ -11008,22 +11377,22 @@ package body Sem_Prag is
Assoc := First (Component_Associations (List)); Assoc := First (Component_Associations (List));
while Present (Assoc) loop while Present (Assoc) loop
Mode := First (Choices (Assoc)); Mode := First (Choices (Assoc));
if Nkind (Mode) = N_Identifier then if Nkind (Mode) = N_Identifier then
if Chars (Mode) = Name_Contract_In then if Chars (Mode) = Name_Contract_In then
Check_Duplicate_Mode (Mode, Contract_Seen); Check_Duplicate_Mode (Mode, Contract_Seen);
elsif Chars (Mode) = Name_In_Out then elsif Chars (Mode) = Name_In_Out then
Check_Duplicate_Mode (Mode, In_Out_Seen); Check_Duplicate_Mode (Mode, In_Out_Seen);
Check_Mode_Restriction_In_Function (Mode); Check_Mode_Restriction_In_Function (Mode);
elsif Chars (Mode) = Name_Input then elsif Chars (Mode) = Name_Input then
Check_Duplicate_Mode (Mode, Input_Seen); Check_Duplicate_Mode (Mode, Input_Seen);
elsif Chars (Mode) = Name_Output then elsif Chars (Mode) = Name_Output then
Check_Duplicate_Mode (Mode, Output_Seen); Check_Duplicate_Mode (Mode, Output_Seen);
Check_Mode_Restriction_In_Function (Mode); Check_Mode_Restriction_In_Function (Mode);
else else
Error_Msg_N ("invalid mode selector", Mode); Error_Msg_N ("invalid mode selector", Mode);
...@@ -11316,8 +11685,8 @@ package body Sem_Prag is ...@@ -11316,8 +11685,8 @@ package body Sem_Prag is
null; null;
else else
Error_Pragma_Arg Error_Pragma_Arg
("controlling formal must be of synchronized " ("controlling formal must be of synchronized tagged type",
& "tagged type", Arg1); Arg1);
return; return;
end if; end if;
...@@ -12275,8 +12644,8 @@ package body Sem_Prag is ...@@ -12275,8 +12644,8 @@ package body Sem_Prag is
elsif In_Private_Part (Current_Scope) then elsif In_Private_Part (Current_Scope) then
Error_Pragma_Arg Error_Pragma_Arg
("pragma% only allowed for private type " ("pragma% only allowed for private type declared in "
& "declared in visible part", Arg1); & "visible part", Arg1);
else else
Error_Pragma_Arg Error_Pragma_Arg
...@@ -12369,12 +12738,12 @@ package body Sem_Prag is ...@@ -12369,12 +12738,12 @@ package body Sem_Prag is
if Ekind (Def_Id) /= E_Function then if Ekind (Def_Id) /= E_Function then
if VM_Target = JVM_Target then if VM_Target = JVM_Target then
Error_Pragma_Arg Error_Pragma_Arg
("pragma% requires function returning a " ("pragma% requires function returning a 'Java access "
& "'Java access type", Def_Id); & "type", Def_Id);
else else
Error_Pragma_Arg Error_Pragma_Arg
("pragma% requires function returning a " ("pragma% requires function returning a 'C'I'L access "
& "'C'I'L access type", Def_Id); & "type", Def_Id);
end if; end if;
end if; end if;
...@@ -12488,7 +12857,7 @@ package body Sem_Prag is ...@@ -12488,7 +12857,7 @@ package body Sem_Prag is
Error_Msg_Name_1 := Pname; Error_Msg_Name_1 := Pname;
Error_Msg_N Error_Msg_N
("first formal of % function must be a named access " ("first formal of % function must be a named access "
& " type", Parameter_Type (Parent (This_Formal))); & "type", Parameter_Type (Parent (This_Formal)));
elsif Atree.Convention elsif Atree.Convention
(Designated_Type (Etype (This_Formal))) /= Convention (Designated_Type (Etype (This_Formal))) /= Convention
...@@ -12531,13 +12900,13 @@ package body Sem_Prag is ...@@ -12531,13 +12900,13 @@ package body Sem_Prag is
if Atree.Convention (Etype (Def_Id)) /= Convention then if Atree.Convention (Etype (Def_Id)) /= Convention then
if Convention = Convention_Java then if Convention = Convention_Java then
Error_Pragma_Arg Error_Pragma_Arg
("pragma% requires function returning a " ("pragma% requires function returning a 'Java "
& "'Java access type", Arg1); & "access type", Arg1);
else else
pragma Assert (Convention = Convention_CIL); pragma Assert (Convention = Convention_CIL);
Error_Pragma_Arg Error_Pragma_Arg
("pragma% requires function returning a " ("pragma% requires function returning a 'C'I'L "
& "'C'I'L access type", Arg1); & "access type", Arg1);
end if; end if;
end if; end if;
...@@ -14611,8 +14980,8 @@ package body Sem_Prag is ...@@ -14611,8 +14980,8 @@ package body Sem_Prag is
elsif Lower_Val > Upper_Val then elsif Lower_Val > Upper_Val then
Error_Pragma Error_Pragma
("last_priority_expression must be greater than " ("last_priority_expression must be greater than or equal to "
& "or equal to first_priority_expression"); & "first_priority_expression");
-- Store the new policy, but always preserve System_Location since -- Store the new policy, but always preserve System_Location since
-- we like the error message with the run-time name. -- we like the error message with the run-time name.
...@@ -15454,8 +15823,8 @@ package body Sem_Prag is ...@@ -15454,8 +15823,8 @@ package body Sem_Prag is
or else In_Package_Body (Current_Scope) or else In_Package_Body (Current_Scope)
then then
Error_Pragma Error_Pragma
("pragma% can only apply to type declared immediately" ("pragma% can only apply to type declared immediately "
& " within a package declaration"); & "within a package declaration");
end if; end if;
-- A simple storage pool type must be an immutably limited record -- A simple storage pool type must be an immutably limited record
...@@ -15693,7 +16062,7 @@ package body Sem_Prag is ...@@ -15693,7 +16062,7 @@ package body Sem_Prag is
or else Present (Next_Formal (First_Formal (Ent))) or else Present (Next_Formal (First_Formal (Ent)))
then then
Error_Pragma_Arg Error_Pragma_Arg
("argument for pragma% must be function of one argument", ("argument for pragma% must be function of one argument",
Arg); Arg);
end if; end if;
end Check_OK_Stream_Convert_Function; end Check_OK_Stream_Convert_Function;
...@@ -16828,8 +17197,8 @@ package body Sem_Prag is ...@@ -16828,8 +17197,8 @@ package body Sem_Prag is
elsif not Is_Static_String_Expression (Arg1) then elsif not Is_Static_String_Expression (Arg1) then
Error_Pragma_Arg Error_Pragma_Arg
("argument of pragma% must be On/Off or " ("argument of pragma% must be On/Off or static string "
& "static string expression", Arg1); & "expression", Arg1);
-- One argument string expression case -- One argument string expression case
...@@ -16967,8 +17336,8 @@ package body Sem_Prag is ...@@ -16967,8 +17336,8 @@ package body Sem_Prag is
elsif not Is_Static_String_Expression (Arg2) then elsif not Is_Static_String_Expression (Arg2) then
Error_Pragma_Arg Error_Pragma_Arg
("second argument of pragma% must be entity " ("second argument of pragma% must be entity name "
& "name or static string expression", Arg2); & "or static string expression", Arg2);
-- String literal case -- String literal case
...@@ -17007,9 +17376,8 @@ package body Sem_Prag is ...@@ -17007,9 +17376,8 @@ package body Sem_Prag is
if Err then if Err then
Error_Msg Error_Msg
("??pragma Warnings On with no " ("??pragma Warnings On with no matching "
& "matching Warnings Off", & "Warnings Off", Loc);
Loc);
end if; end if;
end if; end if;
end if; end if;
......
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