===================================================================
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
+-- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -1252,6 +1252,8 @@
Set_Etype (N, Aggr_Subtyp);
Set_Analyzed (N);
end if;
+
+ Check_Function_Writable_Actuals (N);
end Resolve_Aggregate;
-----------------------------
@@ -2816,6 +2818,8 @@
else
Error_Msg_N ("no unique type for this aggregate", A);
end if;
+
+ Check_Function_Writable_Actuals (N);
end Resolve_Extension_Aggregate;
------------------------------
===================================================================
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
+-- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -8061,6 +8061,8 @@
Set_Last_Entity
(Class_Wide_Type (Derived_Type), Last_Entity (Derived_Type));
end if;
+
+ Check_Function_Writable_Actuals (N);
end Build_Derived_Record_Type;
------------------------
@@ -19678,6 +19680,8 @@
then
Derive_Progenitor_Subprograms (T, T);
end if;
+
+ Check_Function_Writable_Actuals (N);
end Record_Type_Declaration;
----------------------------
===================================================================
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
+-- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -692,7 +692,6 @@
-- checks have been applied.
Note_Possible_Modification (Lhs, Sure => True);
- Check_Order_Dependence;
-- ??? a real accessibility check is needed when ???
===================================================================
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
+-- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -502,8 +502,8 @@
Write_Line (" .H* turn off warnings for holes in records");
Write_Line (" i*+ turn on warnings for implementation unit");
Write_Line (" I turn off warnings for implementation unit");
- Write_Line (" .i turn on warnings for overlapping actuals");
- Write_Line (" .I* turn off warnings for overlapping actuals");
+ Write_Line (" .i*+ turn on warnings for overlapping actuals");
+ Write_Line (" .I turn off warnings for overlapping actuals");
Write_Line (" j+ turn on warnings for obsolescent " &
"(annex J) feature");
Write_Line (" J* turn off warnings for obsolescent " &
===================================================================
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
+-- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -57,7 +57,6 @@
with Stand; use Stand;
with Style;
with Stringt; use Stringt;
-with Table;
with Targparm; use Targparm;
with Tbuild; use Tbuild;
with Ttypes; use Ttypes;
@@ -96,30 +95,6 @@
subtype NCT_Header_Num is Int range 0 .. 511;
-- Defines range of headers in hash tables (512 headers)
- ----------------------------------
- -- Order Dependence (AI05-0144) --
- ----------------------------------
-
- -- Each actual in a call is entered into the table below. A flag indicates
- -- whether the corresponding formal is OUT or IN OUT. Each top-level call
- -- (procedure call, condition, assignment) examines all the actuals for a
- -- possible order dependence. The table is reset after each such check.
- -- The actuals to be checked in a call to Check_Order_Dependence are at
- -- positions 1 .. Last.
-
- type Actual_Name is record
- Act : Node_Id;
- Is_Writable : Boolean;
- end record;
-
- package Actuals_In_Call is new Table.Table (
- Table_Component_Type => Actual_Name,
- Table_Index_Type => Int,
- Table_Low_Bound => 0,
- Table_Initial => 10,
- Table_Increment => 100,
- Table_Name => "Actuals");
-
-----------------------
-- Local Subprograms --
-----------------------
@@ -1245,6 +1220,590 @@
end if;
end Cannot_Raise_Constraint_Error;
+ -------------------------------------
+ -- Check_Function_Writable_Actuals --
+ -------------------------------------
+
+ procedure Check_Function_Writable_Actuals (N : Node_Id) is
+ Writable_Actuals_List : Elist_Id := No_Elist;
+ Identifiers_List : Elist_Id := No_Elist;
+ Error_Node : Node_Id := Empty;
+
+ procedure Collect_Identifiers (N : Node_Id);
+ -- In a single traversal of subtree N collect in Writable_Actuals_List
+ -- all the actuals of functions with writable actuals, and in the list
+ -- Identifiers_List collect all the identifiers that are not actuals of
+ -- functions with writable actuals. If a writable actual is referenced
+ -- twice as writable actual then Error_Node is set to reference its
+ -- second occurrence, the error is reported, and the tree traversal
+ -- is abandoned.
+
+ function Get_Function_Id (Call : Node_Id) return Entity_Id;
+ -- Return the entity associated with the function call
+
+ procedure Preanalyze_Without_Errors (N : Node_Id);
+ -- Preanalyze N without reporting errors
+
+ -------------------------
+ -- Collect_Identifiers --
+ -------------------------
+
+ procedure Collect_Identifiers (N : Node_Id) is
+
+ function Check_Node (N : Node_Id) return Traverse_Result;
+ -- Process a single node during the tree traversal to collect the
+ -- writable actuals of functions and all the identifiers which are
+ -- not writable actuals of functions.
+
+ function Contains (List : Elist_Id; N : Node_Id) return Boolean;
+ -- Returns True if List has a node whose Entity is Entity (N)
+
+ -------------------------
+ -- Check_Function_Call --
+ -------------------------
+
+ function Check_Node (N : Node_Id) return Traverse_Result is
+ Is_Writable_Actual : Boolean := False;
+
+ begin
+ if Nkind (N) = N_Identifier then
+
+ -- No analysis possible if the entity is not decorated
+
+ if No (Entity (N)) then
+ return Skip;
+
+ -- We don't collect identifiers of packages, called functions,
+ -- etc.
+
+ elsif Ekind_In (Entity (N),
+ E_Package,
+ E_Function,
+ E_Procedure,
+ E_Entry)
+ then
+ return Skip;
+
+ -- Analyze if N is a writable actual of a function
+
+ elsif Nkind (Parent (N)) = N_Function_Call then
+ declare
+ Call : constant Node_Id := Parent (N);
+ Id : constant Entity_Id := Get_Function_Id (Call);
+ Actual : Node_Id;
+ Formal : Node_Id;
+
+ begin
+ Formal := First_Formal (Id);
+ Actual := First_Actual (Call);
+ while Present (Actual) and then Present (Formal) loop
+ if Actual = N then
+ if Ekind_In (Formal, E_Out_Parameter,
+ E_In_Out_Parameter)
+ then
+ Is_Writable_Actual := True;
+ end if;
+
+ exit;
+ end if;
+
+ Next_Formal (Formal);
+ Next_Actual (Actual);
+ end loop;
+ end;
+ end if;
+
+ if Is_Writable_Actual then
+ if Contains (Writable_Actuals_List, N) then
+ Error_Msg_N
+ ("conflict of writable function parameter in "
+ & "construct with arbitrary order of evaluation", N);
+ Error_Node := N;
+ return Abandon;
+ end if;
+
+ if Writable_Actuals_List = No_Elist then
+ Writable_Actuals_List := New_Elmt_List;
+ end if;
+
+ Append_Elmt (N, Writable_Actuals_List);
+ else
+ if Identifiers_List = No_Elist then
+ Identifiers_List := New_Elmt_List;
+ end if;
+
+ Append_Unique_Elmt (N, Identifiers_List);
+ end if;
+ end if;
+
+ return OK;
+ end Check_Node;
+
+ --------------
+ -- Contains --
+ --------------
+
+ function Contains
+ (List : Elist_Id;
+ N : Node_Id) return Boolean
+ is
+ pragma Assert (Nkind (N) in N_Has_Entity);
+
+ Elmt : Elmt_Id;
+ begin
+ if List = No_Elist then
+ return False;
+ end if;
+
+ Elmt := First_Elmt (List);
+ loop
+ if No (Elmt) then
+ return False;
+ elsif Entity (Node (Elmt)) = Entity (N) then
+ return True;
+ else
+ Next_Elmt (Elmt);
+ end if;
+ end loop;
+ end Contains;
+
+ ------------------
+ -- Do_Traversal --
+ ------------------
+
+ procedure Do_Traversal is new Traverse_Proc (Check_Node);
+ -- The traversal procedure
+
+ -- Start of processing for Collect_Identifiers
+
+ begin
+ if Present (Error_Node) then
+ return;
+ end if;
+
+ if Nkind (N) in N_Subexpr
+ and then Is_Static_Expression (N)
+ then
+ return;
+ end if;
+
+ Do_Traversal (N);
+ end Collect_Identifiers;
+
+ ---------------------
+ -- Get_Function_Id --
+ ---------------------
+
+ function Get_Function_Id (Call : Node_Id) return Entity_Id is
+ Nam : constant Node_Id := Name (Call);
+ Id : Entity_Id;
+ begin
+ if Nkind (Nam) = N_Explicit_Dereference then
+ Id := Etype (Nam);
+ pragma Assert (Ekind (Id) = E_Subprogram_Type);
+
+ elsif Nkind (Nam) = N_Selected_Component then
+ Id := Entity (Selector_Name (Nam));
+
+ elsif Nkind (Nam) = N_Indexed_Component then
+ Id := Entity (Selector_Name (Prefix (Nam)));
+
+ else
+ Id := Entity (Nam);
+ end if;
+
+ return Id;
+ end Get_Function_Id;
+
+ ---------------------------
+ -- Preanalyze_Expression --
+ ---------------------------
+
+ procedure Preanalyze_Without_Errors (N : Node_Id) is
+ Status : constant Boolean := Get_Ignore_Errors;
+ begin
+ Set_Ignore_Errors (True);
+ Preanalyze (N);
+ Set_Ignore_Errors (Status);
+ end Preanalyze_Without_Errors;
+
+ -- Start of processing for Check_Function_Writable_Actuals
+
+ begin
+ if Ada_Version < Ada_2012
+ or else (not (Nkind (N) in N_Op)
+ and then not (Nkind (N) in N_Membership_Test)
+ and then not Nkind_In (N,
+ N_Range,
+ N_Aggregate,
+ N_Extension_Aggregate,
+ N_Full_Type_Declaration,
+ N_Function_Call,
+ N_Procedure_Call_Statement,
+ N_Entry_Call_Statement))
+ or else (Nkind (N) = N_Full_Type_Declaration
+ and then not Is_Record_Type (Defining_Identifier (N)))
+ then
+ return;
+ end if;
+
+ -- If a construct C has two or more direct constituents that are names
+ -- or expressions whose evaluation may occur in an arbitrary order, at
+ -- least one of which contains a function call with an in out or out
+ -- parameter, then the construct is legal only if: for each name N that
+ -- is passed as a parameter of mode in out or out to some inner function
+ -- call C2 (not including the construct C itself), there is no other
+ -- name anywhere within a direct constituent of the construct C other
+ -- than the one containing C2, that is known to refer to the same
+ -- object (RM 6.4.1(6.17/3)).
+
+ case Nkind (N) is
+ when N_Range =>
+ Collect_Identifiers (Low_Bound (N));
+ Collect_Identifiers (High_Bound (N));
+
+ when N_Op | N_Membership_Test =>
+ declare
+ Expr : Node_Id;
+ begin
+ Collect_Identifiers (Left_Opnd (N));
+
+ if Present (Right_Opnd (N)) then
+ Collect_Identifiers (Right_Opnd (N));
+ end if;
+
+ if Nkind_In (N, N_In, N_Not_In)
+ and then Present (Alternatives (N))
+ then
+ Expr := First (Alternatives (N));
+ while Present (Expr) loop
+ Collect_Identifiers (Expr);
+
+ Next (Expr);
+ end loop;
+ end if;
+ end;
+
+ when N_Full_Type_Declaration =>
+ declare
+ function Get_Record_Part (N : Node_Id) return Node_Id;
+ -- Return the record part of this record type definition
+
+ function Get_Record_Part (N : Node_Id) return Node_Id is
+ Type_Def : constant Node_Id := Type_Definition (N);
+ begin
+ if Nkind (Type_Def) = N_Derived_Type_Definition then
+ return Record_Extension_Part (Type_Def);
+ else
+ return Type_Def;
+ end if;
+ end Get_Record_Part;
+
+ Comp : Node_Id;
+ Def_Id : Entity_Id := Defining_Identifier (N);
+ Rec : Node_Id := Get_Record_Part (N);
+ begin
+ -- No need to perform any analysis if the record has no
+ -- components
+
+ if No (Rec) or else No (Component_List (Rec)) then
+ return;
+ end if;
+
+ -- Collect the identifiers starting from the deepest
+ -- derivation. Done to report the error in the deepest
+ -- derivation.
+
+ loop
+ if Present (Component_List (Rec)) then
+ Comp := First (Component_Items (Component_List (Rec)));
+ while Present (Comp) loop
+ if Nkind (Comp) = N_Component_Declaration
+ and then Present (Expression (Comp))
+ then
+ Collect_Identifiers (Expression (Comp));
+ end if;
+
+ Next (Comp);
+ end loop;
+ end if;
+
+ exit when No (Underlying_Type (Etype (Def_Id)))
+ or else Base_Type (Underlying_Type (Etype (Def_Id)))
+ = Def_Id;
+
+ Def_Id := Base_Type (Underlying_Type (Etype (Def_Id)));
+ Rec := Get_Record_Part (Parent (Def_Id));
+ end loop;
+ end;
+
+ when N_Subprogram_Call |
+ N_Entry_Call_Statement =>
+ declare
+ Id : constant Entity_Id := Get_Function_Id (N);
+ Formal : Node_Id;
+ Actual : Node_Id;
+
+ begin
+ Formal := First_Formal (Id);
+ Actual := First_Actual (N);
+ while Present (Actual) and then Present (Formal) loop
+ if Ekind_In (Formal, E_Out_Parameter,
+ E_In_Out_Parameter)
+ then
+ Collect_Identifiers (Actual);
+ end if;
+
+ Next_Formal (Formal);
+ Next_Actual (Actual);
+ end loop;
+ end;
+
+ when N_Aggregate |
+ N_Extension_Aggregate =>
+ declare
+ Assoc : Node_Id;
+ Choice : Node_Id;
+ Comp_Expr : Node_Id;
+
+ begin
+ -- Handle the N_Others_Choice of array aggregates with static
+ -- bounds. There is no need to perform this analysis in
+ -- aggregates without static bounds since we cannot evaluate
+ -- if the N_Others_Choice covers several elements. There is
+ -- no need to handle the N_Others choice of record aggregates
+ -- since at this stage it has been already expanded by
+ -- Resolve_Record_Aggregate.
+
+ if Is_Array_Type (Etype (N))
+ and then Nkind (N) = N_Aggregate
+ and then Present (Aggregate_Bounds (N))
+ and then Compile_Time_Known_Bounds (Etype (N))
+ and then Expr_Value (High_Bound (Aggregate_Bounds (N)))
+ > Expr_Value (Low_Bound (Aggregate_Bounds (N)))
+ then
+ declare
+ Count_Components : Uint := Uint_0;
+ Num_Components : Uint;
+ Others_Assoc : Node_Id;
+ Others_Choice : Node_Id := Empty;
+ Others_Box_Present : Boolean := False;
+
+ begin
+ -- Count positional associations
+
+ if Present (Expressions (N)) then
+ Comp_Expr := First (Expressions (N));
+ while Present (Comp_Expr) loop
+ Count_Components := Count_Components + 1;
+ Next (Comp_Expr);
+ end loop;
+ end if;
+
+ -- Count the rest of elements and locate the N_Others
+ -- choice (if any)
+
+ Assoc := First (Component_Associations (N));
+ while Present (Assoc) loop
+ Choice := First (Choices (Assoc));
+ while Present (Choice) loop
+ if Nkind (Choice) = N_Others_Choice then
+ Others_Assoc := Assoc;
+ Others_Choice := Choice;
+ Others_Box_Present := Box_Present (Assoc);
+
+ -- Count several components
+
+ elsif Nkind_In (Choice, N_Range,
+ N_Subtype_Indication)
+ or else (Is_Entity_Name (Choice)
+ and then Is_Type (Entity (Choice)))
+ then
+ declare
+ L, H : Node_Id;
+ begin
+ Get_Index_Bounds (Choice, L, H);
+ pragma Assert
+ (Compile_Time_Known_Value (L)
+ and then Compile_Time_Known_Value (H));
+ Count_Components :=
+ Count_Components
+ + Expr_Value (H) - Expr_Value (L) + 1;
+ end;
+
+ -- Count single component. No other case available
+ -- since we are handling an aggregate with static
+ -- bounds.
+
+ else
+ pragma Assert (Is_Static_Expression (Choice)
+ or else Nkind (Choice) = N_Identifier
+ or else Nkind (Choice) = N_Integer_Literal);
+
+ Count_Components := Count_Components + 1;
+ end if;
+
+ Next (Choice);
+ end loop;
+
+ Next (Assoc);
+ end loop;
+
+ Num_Components :=
+ Expr_Value (High_Bound (Aggregate_Bounds (N)))
+ - Expr_Value (Low_Bound (Aggregate_Bounds (N)))
+ + 1;
+
+ pragma Assert (Count_Components <= Num_Components);
+
+ -- Handle the N_Others choice if it covers several
+ -- components
+
+ if Present (Others_Choice)
+ and then (Num_Components - Count_Components) > 1
+ then
+ if not Others_Box_Present then
+
+ -- At this stage, if expansion is active, the
+ -- expression of the others choice has not been
+ -- analyzed. Hence we generate a duplicate and
+ -- we analyze it silently to have available the
+ -- minimum decoration required to collect the
+ -- identifiers.
+
+ if not Expander_Active then
+ Comp_Expr := Expression (Others_Assoc);
+ else
+ Comp_Expr :=
+ New_Copy_Tree (Expression (Others_Assoc));
+ Preanalyze_Without_Errors (Comp_Expr);
+ end if;
+
+ Collect_Identifiers (Comp_Expr);
+
+ if Writable_Actuals_List /= No_Elist then
+
+ -- As suggested by Robert, at current stage we
+ -- report occurrences of this case as warnings.
+
+ Error_Msg_N
+ ("conflict of writable function parameter in "
+ & "construct with arbitrary order of "
+ & "evaluation?",
+ Node (First_Elmt (Writable_Actuals_List)));
+ end if;
+ end if;
+ end if;
+ end;
+ end if;
+
+ -- Handle ancestor part of extension aggregates
+
+ if Nkind (N) = N_Extension_Aggregate then
+ Collect_Identifiers (Ancestor_Part (N));
+ end if;
+
+ -- Handle positional associations
+
+ if Present (Expressions (N)) then
+ Comp_Expr := First (Expressions (N));
+ while Present (Comp_Expr) loop
+ if not Is_Static_Expression (Comp_Expr) then
+ Collect_Identifiers (Comp_Expr);
+ end if;
+
+ Next (Comp_Expr);
+ end loop;
+ end if;
+
+ -- Handle discrete associations
+
+ if Present (Component_Associations (N)) then
+ Assoc := First (Component_Associations (N));
+ while Present (Assoc) loop
+
+ if not Box_Present (Assoc) then
+ Choice := First (Choices (Assoc));
+ while Present (Choice) loop
+
+ -- For now we skip discriminants since it requires
+ -- performing the analysis in two phases: first one
+ -- analyzing discriminants and second one analyzing
+ -- the rest of components since discriminants are
+ -- evaluated prior to components: too much extra
+ -- work to detect a corner case???
+
+ if Nkind (Choice) in N_Has_Entity
+ and then Present (Entity (Choice))
+ and then Ekind (Entity (Choice))
+ = E_Discriminant
+ then
+ null;
+
+ elsif Box_Present (Assoc) then
+ null;
+
+ else
+ if not Analyzed (Expression (Assoc)) then
+ Comp_Expr :=
+ New_Copy_Tree (Expression (Assoc));
+ Preanalyze_Without_Errors (Comp_Expr);
+ else
+ Comp_Expr := Expression (Assoc);
+ end if;
+
+ Collect_Identifiers (Comp_Expr);
+ end if;
+
+ Next (Choice);
+ end loop;
+ end if;
+
+ Next (Assoc);
+ end loop;
+ end if;
+ end;
+
+ when others =>
+ return;
+ end case;
+
+ -- No further action needed if we already reported an error
+
+ if Present (Error_Node) then
+ return;
+ end if;
+
+ -- Check if some writable argument of a function is referenced
+
+ if Writable_Actuals_List /= No_Elist
+ and then Identifiers_List /= No_Elist
+ then
+ declare
+ Elmt_1 : Elmt_Id;
+ Elmt_2 : Elmt_Id;
+
+ begin
+ Elmt_1 := First_Elmt (Writable_Actuals_List);
+ while Present (Elmt_1) loop
+ Elmt_2 := First_Elmt (Identifiers_List);
+ while Present (Elmt_2) loop
+ if Entity (Node (Elmt_1)) = Entity (Node (Elmt_2)) then
+ Error_Msg_N
+ ("conflict of writable function parameter in construct "
+ & "with arbitrary order of evaluation",
+ Node (Elmt_1));
+ end if;
+
+ Next_Elmt (Elmt_2);
+ end loop;
+
+ Next_Elmt (Elmt_1);
+ end loop;
+ end;
+ end if;
+ end Check_Function_Writable_Actuals;
+
--------------------------------
-- Check_Implicit_Dereference --
--------------------------------
@@ -1529,65 +2088,6 @@
end if;
end Check_Nested_Access;
- ----------------------------
- -- Check_Order_Dependence --
- ----------------------------
-
- procedure Check_Order_Dependence is
- Act1 : Node_Id;
- Act2 : Node_Id;
-
- begin
- if Ada_Version < Ada_2012 then
- return;
- end if;
-
- -- Ada 2012 AI05-0144-2: Dangerous order dependence. Actuals in nested
- -- calls within a construct have been collected. If one of them is
- -- writable and overlaps with another one, evaluation of the enclosing
- -- construct is nondeterministic. This is illegal in Ada 2012, but is
- -- treated as a warning for now.
-
- for J in 1 .. Actuals_In_Call.Last loop
- if Actuals_In_Call.Table (J).Is_Writable then
- Act1 := Actuals_In_Call.Table (J).Act;
-
- if Nkind (Act1) = N_Attribute_Reference then
- Act1 := Prefix (Act1);
- end if;
-
- for K in 1 .. Actuals_In_Call.Last loop
- if K /= J then
- Act2 := Actuals_In_Call.Table (K).Act;
-
- if Nkind (Act2) = N_Attribute_Reference then
- Act2 := Prefix (Act2);
- end if;
-
- if Actuals_In_Call.Table (K).Is_Writable
- and then K < J
- then
- -- Already checked
-
- null;
-
- elsif Denotes_Same_Object (Act1, Act2)
- and then Parent (Act1) /= Parent (Act2)
- then
- Error_Msg_N
- ("result may differ if evaluated "
- & "after other actual in expression??", Act1);
- end if;
- end if;
- end loop;
- end if;
- end loop;
-
- -- Remove checked actuals from table
-
- Actuals_In_Call.Set_Last (0);
- end Check_Order_Dependence;
-
------------------------------------------
-- Check_Potentially_Blocking_Operation --
------------------------------------------
@@ -12595,35 +13095,6 @@
end if;
end Same_Value;
- -----------------
- -- Save_Actual --
- -----------------
-
- procedure Save_Actual (N : Node_Id; Writable : Boolean := False) is
- begin
- if Ada_Version < Ada_2012 then
- return;
-
- elsif Is_Entity_Name (N)
- or else
- Nkind_In (N, N_Indexed_Component, N_Selected_Component, N_Slice)
- or else
- (Nkind (N) = N_Attribute_Reference
- and then Attribute_Name (N) = Name_Access)
-
- then
- -- We are only interested in IN OUT parameters of inner calls
-
- if not Writable
- or else Nkind (Parent (N)) = N_Function_Call
- or else Nkind (Parent (N)) in N_Op
- then
- Actuals_In_Call.Increment_Last;
- Actuals_In_Call.Table (Actuals_In_Call.Last) := (N, Writable);
- end if;
- end if;
- end Save_Actual;
-
------------------------
-- Scope_Is_Transient --
------------------------
===================================================================
@@ -178,6 +178,17 @@
-- not necessarily mean that CE could be raised, but a response of True
-- means that for sure CE cannot be raised.
+ procedure Check_Function_Writable_Actuals (N : Node_Id);
+ -- (Ada 2012): If the construct N has two or more direct constituents that
+ -- are names or expressions whose evaluation may occur in an arbitrary
+ -- order, at least one of which contains a function call with an in out or
+ -- out parameter, then the construct is legal only if: for each name that
+ -- is passed as a parameter of mode in out or out to some inner function
+ -- call C2 (not including the construct N itself), there is no other name
+ -- anywhere within a direct constituent of the construct C other than
+ -- the one containing C2, that is known to refer to the same object (RM
+ -- 6.4.1(6.17/3)).
+
procedure Check_Implicit_Dereference (Nam : Node_Id; Typ : Entity_Id);
-- AI05-139-2: Accessors and iterators for containers. This procedure
-- checks whether T is a reference type, and if so it adds an interprettion
@@ -215,11 +226,6 @@
-- is accessed inside a nested procedure, and set Has_Up_Level_Access flag
-- accordingly. This is currently only enabled for VM_Target /= No_VM.
- procedure Check_Order_Dependence;
- -- Examine the actuals in a top-level call to determine whether aliasing
- -- between two actuals, one of which is writable, can make the call
- -- order-dependent.
-
procedure Check_Potentially_Blocking_Operation (N : Node_Id);
-- N is one of the statement forms that is a potentially blocking
-- operation. If it appears within a protected action, emit warning.
@@ -1404,11 +1410,6 @@
-- are only partially ordered, so Scope_Within_Or_Same (A,B) and
-- Scope_Within_Or_Same (B,A) can both be False for a given pair A,B.
- procedure Save_Actual (N : Node_Id; Writable : Boolean := False);
- -- Enter an actual in a call in a table global, for subsequent check of
- -- possible order dependence in the presence of IN OUT parameters for
- -- functions in Ada 2012 (or access parameters in older language versions).
-
function Scope_Within (Scope1, Scope2 : Entity_Id) return Boolean;
-- Like Scope_Within_Or_Same, except that this function returns
-- False in the case where Scope1 and Scope2 are the same scope.
===================================================================
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
+-- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -2864,18 +2864,6 @@
return;
end if;
- -- AI05-144-2: Check dangerous order dependence within an expression
- -- that is not a subexpression. Exclude RHS of an assignment, because
- -- both sides may have side-effects and the check must be performed
- -- over the statement.
-
- if Nkind (Parent (N)) not in N_Subexpr
- and then Nkind (Parent (N)) /= N_Assignment_Statement
- and then Nkind (Parent (N)) /= N_Procedure_Call_Statement
- then
- Check_Order_Dependence;
- end if;
-
-- The expression is definitely NOT overloaded at this point, so
-- we reset the Is_Overloaded flag to avoid any confusion when
-- reanalyzing the node.
@@ -3378,6 +3366,7 @@
begin
Check_Argument_Order;
+ Check_Function_Writable_Actuals (N);
if Present (First_Actual (N)) then
Check_Prefixed_Call;
@@ -3776,21 +3765,6 @@
end if;
end if;
- -- Save actual for subsequent check on order dependence, and
- -- indicate whether actual is modifiable. For AI05-0144-2.
-
- -- If this is a call to a reference function that is the result
- -- of expansion, as in element iterator loops, this does not lead
- -- to a dangerous order dependence: only subsequent use of the
- -- denoted element might, in some enclosing call.
-
- if not Has_Implicit_Dereference (Etype (Nam))
- or else Comes_From_Source (N)
- then
- Save_Actual (A, Ekind (F) /= E_In_Parameter);
- end if;
-
- -- For mode IN, if actual is an entity, and the type of the formal
-- has warnings suppressed, then we reset Never_Set_In_Source for
-- the calling entity. The reason for this is to catch cases like
-- GNAT.Spitbol.Patterns.Vstring_Var where the called subprogram
@@ -5108,6 +5082,7 @@
Check_Unset_Reference (L);
Check_Unset_Reference (R);
+ Check_Function_Writable_Actuals (N);
end Resolve_Arithmetic_Op;
------------------
@@ -7632,6 +7607,8 @@
end if;
end;
end if;
+
+ Check_Function_Writable_Actuals (N);
end Resolve_Logical_Op;
---------------------------
@@ -7729,6 +7706,7 @@
if Present (Alternatives (N)) then
Resolve_Set_Membership;
+ Check_Function_Writable_Actuals (N);
return;
elsif not Is_Overloaded (R)
@@ -7793,6 +7771,7 @@
end if;
Eval_Membership_Op (N);
+ Check_Function_Writable_Actuals (N);
end Resolve_Membership_Op;
------------------
===================================================================
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
+-- Copyright (C) 1999-2013, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -292,6 +292,7 @@
Warn_On_Non_Local_Exception := True;
Warn_On_Object_Renames_Function := True;
Warn_On_Obsolescent_Feature := True;
+ Warn_On_Overlap := True;
Warn_On_Parameter_Order := True;
Warn_On_Questionable_Missing_Parens := True;
Warn_On_Redundant_Constructs := True;
===================================================================
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
+-- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -1458,6 +1458,15 @@
return S;
end First_Sloc;
+ -----------------------
+ -- Get_Ignore_Errors --
+ -----------------------
+
+ function Get_Ignore_Errors return Boolean is
+ begin
+ return Errors_Must_Be_Ignored;
+ end Get_Ignore_Errors;
+
----------------
-- Initialize --
----------------
===================================================================
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
+-- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -746,6 +746,9 @@
-- where the expression is parenthesized, an attempt is made to include
-- the parentheses (i.e. to return the location of the initial paren).
+ function Get_Ignore_Errors return Boolean;
+ -- Return True if all error calls are ignored.
+
procedure Purge_Messages (From : Source_Ptr; To : Source_Ptr)
renames Erroutc.Purge_Messages;
-- All error messages whose location is in the range From .. To (not
===================================================================
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
+-- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -3611,6 +3611,8 @@
Check_Universal_Expression (L);
Check_Universal_Expression (H);
end if;
+
+ Check_Function_Writable_Actuals (N);
end Analyze_Range;
-----------------------
===================================================================
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
+-- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -978,10 +978,6 @@
& "null-excluding return??",
Reason => CE_Null_Not_Allowed);
end if;
-
- -- Apply checks suggested by AI05-0144 (dangerous order dependence)
-
- Check_Order_Dependence;
end if;
end Analyze_Function_Return;
@@ -1266,11 +1262,6 @@
if Nkind (N) = N_Procedure_Call_Statement then
Analyze_Call (N);
Resolve (N, Standard_Void_Type);
-
- -- Apply checks suggested by AI05-0144
-
- Check_Order_Dependence;
-
else
Analyze (N);
end if;
===================================================================
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
+-- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -1595,8 +1595,9 @@
Warn_On_Overlap : Boolean := False;
-- GNAT
- -- Set to True to generate warnings when a writable actual which is not
- -- a by-copy type overlaps with another actual in a subprogram call.
+ -- Set to True to generate warnings when a writable actual overlaps with
+ -- another actual in a subprogram call. This applies only in modes before
+ -- Ada 2012. Starting with Ada 2012, such overlaps are illegal.
-- Modified by use of -gnatw.i/.I.
Warn_On_Questionable_Missing_Parens : Boolean := True;
If the construct N has two or more direct constituents that are names or expressions whose evaluation may occur in an arbitrary order, at least one of which contains a function call with an in out or out parameter, then the construct is legal only if: for each name that is passed as a parameter of mode in out or out to some inner function call C2 (not including the construct N itself), there is no other name anywhere within a direct constituent of the construct C other than the one containing C2, that is known to refer to the same object (RM 6.4.1(6.17/3)). The following test now compiles with errors: pragma Ada_2012; procedure aliasfunc is function Init_Value return Integer is begin return 0; end; function f (a : in out integer) return integer is begin a := a + 1; return 3; end; procedure p (a : in out Integer; b : in out Integer) is begin a := b; end; table : array (1 .. 3) of Integer := (others => 0); x : integer := Init_Value; begin p (a => x, b => table (f (x))); end; Command: gcc -c aliasfunc.adb Output: aliasfunc.adb:24:30: conflict of writable function parameter in construct with arbitrary order of evaluation Tested on x86_64-pc-linux-gnu, committed on trunk 2013-01-29 Javier Miranda <miranda@adacore.com> * errout.ads, errout.adb (Get_Ignore_Errors): New subprogram. * opt.ads (Warn_On_Overlap): Update documentation. * sem_aggr.adb (Resolve_Aggregate, Resolve_Extension_Aggregate): Check function writable actuals. * sem_ch3.adb (Build_Derived_Record_Type, Record_Type_Declaration): Check function writable actuals. * sem_ch4.adb (Analyze_Range): Check function writable actuals. * sem_ch5.adb (Analyze_Assignment): Remove code of the initial implementation of AI05-0144. * sem_ch6.adb (Analyze_Function_Return, (Analyze_Procedure_Call.Analyze_Call_And_Resolve): Remove code of the initial implementation of AI05-0144. * sem_res.adb (Resolve): Remove code of the initial implementation. (Resolve_Actuals): Call Check_Function_Writable_Actuals and remove call of the initial implementation. (Resolve_Arithmetic_Op, Resolve_Logical_Op, Resolve_Membership_Op): Check function writable actuals. * sem_util.ad[sb] (Actuals_In_Call): Removed (Check_Order_Dependence): Removed (Save_Actual): Removed (Check_Function_Writable_Actuals): New subprogram. * usage.adb (Usage): Update documentation. * warnsw.adb (Set_Warning_Switch): Enable warn_on_overlap when setting all warnings.