-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
+-- 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- --
with Stand; use Stand;
with Style;
with Stringt; use Stringt;
-with Table;
with Targparm; use Targparm;
with Tbuild; use Tbuild;
with Ttypes; use Ttypes;
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 --
-----------------------
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 --
--------------------------------
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 --
------------------------------------------
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 --
------------------------
projects / gcc.git / commitdiff