-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2011, 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 Output; use Output;
with Opt; use Opt;
with Rtsfind; use Rtsfind;
-with Scans; use Scans;
-with Scn; use Scn;
with Sem; use Sem;
with Sem_Aux; use Sem_Aux;
with Sem_Attr; use Sem_Attr;
-- safely used by New_Copy_Tree, since there is no case of a recursive
-- call from the processing inside New_Copy_Tree.
- NCT_Hash_Threshhold : constant := 20;
+ NCT_Hash_Threshold : constant := 20;
-- If there are more than this number of pairs of entries in the
-- map, then Hash_Tables_Used will be set, and the hash tables will
-- be initialized and used for the searches.
-- Set to True if hash tables are in use
NCT_Table_Entries : Nat;
- -- Count entries in table to see if threshhold is reached
+ -- Count entries in table to see if threshold is reached
NCT_Hash_Table_Setup : Boolean := False;
-- Set to True if hash table contains data. We set this True if we
-- 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;
- -- Comments needed???
-
end record;
package Actuals_In_Call is new Table.Table (
end if;
end Apply_Compile_Time_Constraint_Error;
+ --------------------------------
+ -- Bad_Predicated_Subtype_Use --
+ --------------------------------
+
+ procedure Bad_Predicated_Subtype_Use
+ (Msg : String;
+ N : Node_Id;
+ Typ : Entity_Id)
+ is
+ begin
+ if Has_Predicates (Typ) then
+ if Is_Generic_Actual_Type (Typ) then
+ Error_Msg_FE (Msg & '?', N, Typ);
+ Error_Msg_F ("\Program_Error will be raised at run time?", N);
+ Insert_Action (N,
+ Make_Raise_Program_Error (Sloc (N),
+ Reason => PE_Bad_Predicated_Generic_Type));
+
+ else
+ Error_Msg_FE (Msg, N, Typ);
+ end if;
+ end if;
+ end Bad_Predicated_Subtype_Use;
+
--------------------------
-- Build_Actual_Subtype --
--------------------------
Act2 : Node_Id;
begin
- -- This could use comments ???
+ if Ada_Version < Ada_2012 then
+ return;
+ end if;
+
+ -- Ada 2012 AI04-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 0 .. Actuals_In_Call.Last loop
+ 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;
Act1 := Prefix (Act1);
end if;
- for K in 0 .. Actuals_In_Call.Last loop
+ for K in 1 .. Actuals_In_Call.Last loop
if K /= J then
Act2 := Actuals_In_Call.Table (K).Act;
null;
elsif Denotes_Same_Object (Act1, Act2)
- and then False
+ and then Parent (Act1) /= Parent (Act2)
then
- Error_Msg_N ("?,mighty suspicious!!!", Act1);
+ 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;
procedure Check_Potentially_Blocking_Operation (N : Node_Id) is
S : Entity_Id;
+
begin
-- N is one of the potentially blocking operations listed in 9.5.1(8).
-- When pragma Detect_Blocking is active, the run time will raise
if Is_Protected_Type (S) then
Error_Msg_N
("potentially blocking operation in protected operation?", N);
-
return;
end if;
end loop;
end Collect_Interfaces_Info;
+ ---------------------
+ -- Collect_Parents --
+ ---------------------
+
+ procedure Collect_Parents
+ (T : Entity_Id;
+ List : out Elist_Id;
+ Use_Full_View : Boolean := True)
+ is
+ Current_Typ : Entity_Id := T;
+ Parent_Typ : Entity_Id;
+
+ begin
+ List := New_Elmt_List;
+
+ -- No action if the if the type has no parents
+
+ if T = Etype (T) then
+ return;
+ end if;
+
+ loop
+ Parent_Typ := Etype (Current_Typ);
+
+ if Is_Private_Type (Parent_Typ)
+ and then Present (Full_View (Parent_Typ))
+ and then Use_Full_View
+ then
+ Parent_Typ := Full_View (Base_Type (Parent_Typ));
+ end if;
+
+ Append_Elmt (Parent_Typ, List);
+
+ exit when Parent_Typ = Current_Typ;
+ Current_Typ := Parent_Typ;
+ end loop;
+ end Collect_Parents;
+
----------------------------------
-- Collect_Primitive_Operations --
----------------------------------
Formal_Derived : Boolean := False;
Id : Entity_Id;
+ function Match (E : Entity_Id) return Boolean;
+ -- True if E's base type is B_Type, or E is of an anonymous access type
+ -- and the base type of its designated type is B_Type.
+
+ -----------
+ -- Match --
+ -----------
+
+ function Match (E : Entity_Id) return Boolean is
+ Etyp : Entity_Id := Etype (E);
+
+ begin
+ if Ekind (Etyp) = E_Anonymous_Access_Type then
+ Etyp := Designated_Type (Etyp);
+ end if;
+
+ return Base_Type (Etyp) = B_Type;
+ end Match;
+
+ -- Start of processing for Collect_Primitive_Operations
+
begin
-- For tagged types, the primitive operations are collected as they
-- are declared, and held in an explicit list which is simply returned.
then
Is_Prim := False;
- if Base_Type (Etype (Id)) = B_Type then
+ if Match (Id) then
Is_Prim := True;
+
else
Formal := First_Formal (Id);
while Present (Formal) loop
- if Base_Type (Etype (Formal)) = B_Type then
- Is_Prim := True;
- exit;
-
- elsif Ekind (Etype (Formal)) = E_Anonymous_Access_Type
- and then Base_Type
- (Designated_Type (Etype (Formal))) = B_Type
- then
+ if Match (Formal) then
Is_Prim := True;
exit;
end if;
if Chars (Id) = Name_Op_Eq
and then Is_Dispatching_Operation (Id)
and then Present (Alias (Id))
- and then Is_Overriding_Operation (Alias (Id))
+ and then Present (Overridden_Operation (Alias (Id)))
and then Base_Type (Etype (First_Entity (Id))) =
Base_Type (Etype (First_Entity (Alias (Id))))
then
-------------------------
function Denotes_Same_Object (A1, A2 : Node_Id) return Boolean is
+ Obj1 : Node_Id := A1;
+ Obj2 : Node_Id := A2;
+
+ procedure Check_Renaming (Obj : in out Node_Id);
+ -- If an object is a renaming, examine renamed object. If it is a
+ -- dereference of a variable, or an indexed expression with non-constant
+ -- indexes, no overlap check can be reported.
+
+ --------------------
+ -- Check_Renaming --
+ --------------------
+
+ procedure Check_Renaming (Obj : in out Node_Id) is
+ begin
+ if Is_Entity_Name (Obj)
+ and then Present (Renamed_Entity (Entity (Obj)))
+ then
+ Obj := Renamed_Entity (Entity (Obj));
+ if Nkind (Obj) = N_Explicit_Dereference
+ and then Is_Variable (Prefix (Obj))
+ then
+ Obj := Empty;
+
+ elsif Nkind (Obj) = N_Indexed_Component then
+ declare
+ Indx : Node_Id;
+
+ begin
+ Indx := First (Expressions (Obj));
+ while Present (Indx) loop
+ if not Is_OK_Static_Expression (Indx) then
+ Obj := Empty;
+ exit;
+ end if;
+
+ Next_Index (Indx);
+ end loop;
+ end;
+ end if;
+ end if;
+ end Check_Renaming;
+
+ -- Start of processing for Denotes_Same_Object
+
begin
+ Check_Renaming (Obj1);
+ Check_Renaming (Obj2);
+
+ if No (Obj1)
+ or else No (Obj2)
+ then
+ return False;
+ end if;
+
-- If we have entity names, then must be same entity
- if Is_Entity_Name (A1) then
- if Is_Entity_Name (A2) then
- return Entity (A1) = Entity (A2);
+ if Is_Entity_Name (Obj1) then
+ if Is_Entity_Name (Obj2) then
+ return Entity (Obj1) = Entity (Obj2);
else
return False;
end if;
-- No match if not same node kind
- elsif Nkind (A1) /= Nkind (A2) then
+ elsif Nkind (Obj1) /= Nkind (Obj2) then
return False;
-- For selected components, must have same prefix and selector
- elsif Nkind (A1) = N_Selected_Component then
- return Denotes_Same_Object (Prefix (A1), Prefix (A2))
+ elsif Nkind (Obj1) = N_Selected_Component then
+ return Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2))
and then
- Entity (Selector_Name (A1)) = Entity (Selector_Name (A2));
+ Entity (Selector_Name (Obj1)) = Entity (Selector_Name (Obj2));
-- For explicit dereferences, prefixes must be same
- elsif Nkind (A1) = N_Explicit_Dereference then
- return Denotes_Same_Object (Prefix (A1), Prefix (A2));
+ elsif Nkind (Obj1) = N_Explicit_Dereference then
+ return Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2));
-- For indexed components, prefixes and all subscripts must be the same
- elsif Nkind (A1) = N_Indexed_Component then
- if Denotes_Same_Object (Prefix (A1), Prefix (A2)) then
+ elsif Nkind (Obj1) = N_Indexed_Component then
+ if Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2)) then
declare
Indx1 : Node_Id;
Indx2 : Node_Id;
begin
- Indx1 := First (Expressions (A1));
- Indx2 := First (Expressions (A2));
+ Indx1 := First (Expressions (Obj1));
+ Indx2 := First (Expressions (Obj2));
while Present (Indx1) loop
- -- Shouldn't we be checking that values are the same???
+ -- Indexes must denote the same static value or same object
+
+ if Is_OK_Static_Expression (Indx1) then
+ if not Is_OK_Static_Expression (Indx2) then
+ return False;
+
+ elsif Expr_Value (Indx1) /= Expr_Value (Indx2) then
+ return False;
+ end if;
- if not Denotes_Same_Object (Indx1, Indx2) then
+ elsif not Denotes_Same_Object (Indx1, Indx2) then
return False;
end if;
-- For slices, prefixes must match and bounds must match
- elsif Nkind (A1) = N_Slice
- and then Denotes_Same_Object (Prefix (A1), Prefix (A2))
+ elsif Nkind (Obj1) = N_Slice
+ and then Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2))
then
declare
Lo1, Lo2, Hi1, Hi2 : Node_Id;
begin
- Get_Index_Bounds (Etype (A1), Lo1, Hi1);
- Get_Index_Bounds (Etype (A2), Lo2, Hi2);
+ Get_Index_Bounds (Etype (Obj1), Lo1, Hi1);
+ Get_Index_Bounds (Etype (Obj2), Lo2, Hi2);
-- Check whether bounds are statically identical. There is no
-- attempt to detect partial overlap of slices.
- -- What about an array and a slice of an array???
-
return Denotes_Same_Object (Lo1, Lo2)
and then Denotes_Same_Object (Hi1, Hi2);
end;
- -- Literals will appear as indices. Isn't this where we should check
+ -- Literals will appear as indexes. Isn't this where we should check
-- Known_At_Compile_Time at least if we are generating warnings ???
- elsif Nkind (A1) = N_Integer_Literal then
- return Intval (A1) = Intval (A2);
+ elsif Nkind (Obj1) = N_Integer_Literal then
+ return Intval (Obj1) = Intval (Obj2);
else
return False;
Set_Scope (Def_Id, Current_Scope);
return;
- -- Analogous to privals, the discriminal generated for an entry
- -- index parameter acts as a weak declaration. Perform minimal
- -- decoration to avoid bogus errors.
+ -- Analogous to privals, the discriminal generated for an entry index
+ -- parameter acts as a weak declaration. Perform minimal decoration
+ -- to avoid bogus errors.
elsif Is_Discriminal (Def_Id)
and then Ekind (Discriminal_Link (Def_Id)) = E_Entry_Index_Parameter
Set_Scope (Def_Id, Current_Scope);
return;
- -- In the body or private part of an instance, a type extension
- -- may introduce a component with the same name as that of an
- -- actual. The legality rule is not enforced, but the semantics
- -- of the full type with two components of the same name are not
- -- clear at this point ???
+ -- In the body or private part of an instance, a type extension may
+ -- introduce a component with the same name as that of an actual. The
+ -- legality rule is not enforced, but the semantics of the full type
+ -- with two components of same name are not clear at this point???
elsif In_Instance_Not_Visible then
null;
then
null;
- -- Conversely, with front-end inlining we may compile the parent
- -- body first, and a child unit subsequently. The context is now
- -- the parent spec, and body entities are not visible.
+ -- Conversely, with front-end inlining we may compile the parent body
+ -- first, and a child unit subsequently. The context is now the
+ -- parent spec, and body entities are not visible.
elsif Is_Child_Unit (Def_Id)
and then Is_Package_Body_Entity (E)
Error_Msg_Sloc := Sloc (E);
-- If the previous declaration is an incomplete type declaration
- -- this may be an attempt to complete it with a private type.
- -- The following avoids confusing cascaded errors.
+ -- this may be an attempt to complete it with a private type. The
+ -- following avoids confusing cascaded errors.
if Nkind (Parent (E)) = N_Incomplete_Type_Declaration
and then Nkind (Parent (Def_Id)) = N_Private_Type_Declaration
Error_Msg_N ("& conflicts with declaration#", E);
return;
- -- If the name of the unit appears in its own context clause,
- -- a dummy package with the name has already been created, and
- -- the error emitted. Try to continue quietly.
+ -- If the name of the unit appears in its own context clause, a
+ -- dummy package with the name has already been created, and the
+ -- error emitted. Try to continue quietly.
elsif Error_Posted (E)
and then Sloc (E) = No_Location
Error_Msg_N ("\generic units cannot be overloaded", Def_Id);
end if;
- -- If entity is in standard, then we are in trouble, because
- -- it means that we have a library package with a duplicated
- -- name. That's hard to recover from, so abort!
+ -- If entity is in standard, then we are in trouble, because it
+ -- means that we have a library package with a duplicated name.
+ -- That's hard to recover from, so abort!
if S = Standard_Standard then
raise Unrecoverable_Error;
end if;
end if;
- -- If we fall through, declaration is OK , or OK enough to continue
+ -- If we fall through, declaration is OK, at least OK enough to continue
- -- If Def_Id is a discriminant or a record component we are in the
- -- midst of inheriting components in a derived record definition.
- -- Preserve their Ekind and Etype.
+ -- If Def_Id is a discriminant or a record component we are in the midst
+ -- of inheriting components in a derived record definition. Preserve
+ -- their Ekind and Etype.
if Ekind_In (Def_Id, E_Discriminant, E_Component) then
null;
- -- If a type is already set, leave it alone (happens whey a type
- -- declaration is reanalyzed following a call to the optimizer)
+ -- If a type is already set, leave it alone (happens when a type
+ -- declaration is reanalyzed following a call to the optimizer).
elsif Present (Etype (Def_Id)) then
null;
and then In_Extended_Main_Source_Unit (Def_Id)
- -- Finally, the hidden entity must be either immediately visible
- -- or use visible (from a used package)
+ -- Finally, the hidden entity must be either immediately visible or
+ -- use visible (i.e. from a used package).
and then
(Is_Immediately_Visible (C)
function Has_Overriding_Initialize (T : Entity_Id) return Boolean is
BT : constant Entity_Id := Base_Type (T);
- Comp : Entity_Id;
P : Elmt_Id;
begin
if Is_Controlled (BT) then
-
- -- For derived types, check immediate ancestor, excluding
- -- Controlled itself.
-
- if Is_Derived_Type (BT)
- and then not In_Predefined_Unit (Etype (BT))
- and then Has_Overriding_Initialize (Etype (BT))
- then
- return True;
+ if Is_RTU (Scope (BT), Ada_Finalization) then
+ return False;
elsif Present (Primitive_Operations (BT)) then
P := First_Elmt (Primitive_Operations (BT));
while Present (P) loop
- if Chars (Node (P)) = Name_Initialize
- and then Comes_From_Source (Node (P))
- then
- return True;
- end if;
+ declare
+ Init : constant Entity_Id := Node (P);
+ Formal : constant Entity_Id := First_Formal (Init);
+ begin
+ if Ekind (Init) = E_Procedure
+ and then Chars (Init) = Name_Initialize
+ and then Comes_From_Source (Init)
+ and then Present (Formal)
+ and then Etype (Formal) = BT
+ and then No (Next_Formal (Formal))
+ and then (Ada_Version < Ada_2012
+ or else not Null_Present (Parent (Init)))
+ then
+ return True;
+ end if;
+ end;
Next_Elmt (P);
end loop;
end if;
- return False;
-
- elsif Has_Controlled_Component (BT) then
- Comp := First_Component (BT);
- while Present (Comp) loop
- if Has_Overriding_Initialize (Etype (Comp)) then
- return True;
- end if;
+ -- Here if type itself does not have a non-null Initialize operation:
+ -- check immediate ancestor.
- Next_Component (Comp);
- end loop;
-
- return False;
-
- else
- return False;
+ if Is_Derived_Type (BT)
+ and then Has_Overriding_Initialize (Etype (BT))
+ then
+ return True;
+ end if;
end if;
+
+ return False;
end Has_Overriding_Initialize;
--------------------------------------
-- We are interested only in components and discriminants
- if Ekind_In (Ent, E_Component, E_Discriminant) then
+ Exp := Empty;
- -- Get default expression if any. If there is no declaration
- -- node, it means we have an internal entity. The parent and
- -- tag fields are examples of such entities. For these cases,
- -- we just test the type of the entity.
-
- if Present (Declaration_Node (Ent)) then
- Exp := Expression (Declaration_Node (Ent));
- else
- Exp := Empty;
- end if;
+ case Ekind (Ent) is
+ when E_Component =>
- -- A component has PI if it has no default expression and the
- -- component type has PI.
+ -- Get default expression if any. If there is no declaration
+ -- node, it means we have an internal entity. The parent and
+ -- tag fields are examples of such entities. For such cases,
+ -- we just test the type of the entity.
- if No (Exp) then
- if not Has_Preelaborable_Initialization (Etype (Ent)) then
- Has_PE := False;
- exit;
+ if Present (Declaration_Node (Ent)) then
+ Exp := Expression (Declaration_Node (Ent));
end if;
- -- Require the default expression to be preelaborable
+ when E_Discriminant =>
- elsif not Is_Preelaborable_Expression (Exp) then
+ -- Note: for a renamed discriminant, the Declaration_Node
+ -- may point to the one from the ancestor, and have a
+ -- different expression, so use the proper attribute to
+ -- retrieve the expression from the derived constraint.
+
+ Exp := Discriminant_Default_Value (Ent);
+
+ when others =>
+ goto Check_Next_Entity;
+ end case;
+
+ -- A component has PI if it has no default expression and the
+ -- component type has PI.
+
+ if No (Exp) then
+ if not Has_Preelaborable_Initialization (Etype (Ent)) then
Has_PE := False;
exit;
end if;
+
+ -- Require the default expression to be preelaborable
+
+ elsif not Is_Preelaborable_Expression (Exp) then
+ Has_PE := False;
+ exit;
end if;
+ <<Check_Next_Entity>>
Next_Entity (Ent);
end loop;
end Check_Components;
begin
Save_Interps (N, New_Prefix);
- Rewrite (N, Make_Explicit_Dereference (Sloc (N), Prefix => New_Prefix));
+ Rewrite (N,
+ Make_Explicit_Dereference (Sloc (Parent (N)),
+ Prefix => New_Prefix));
Set_Etype (N, Designated_Type (Etype (New_Prefix)));
if Is_Entity_Name (New_Prefix) then
Ent := Entity (New_Prefix);
+ Pref := New_Prefix;
-- For a retrieval of a subcomponent of some composite object,
-- retrieve the ultimate entity if there is one.
end if;
end if;
+ -- Place the reference on the entity node
+
if Present (Ent) then
- Generate_Reference (Ent, New_Prefix);
+ Generate_Reference (Ent, Pref);
end if;
end if;
end Insert_Explicit_Dereference;
and then Comes_From_Source (Decl)
- -- The constant is not completed. A full object declaration
- -- or a pragma Import complete a deferred constant.
+ -- The constant is not completed. A full object declaration or a
+ -- pragma Import complete a deferred constant.
and then not Has_Completion (Defining_Identifier (Decl))
then
end loop;
end Inspect_Deferred_Constant_Completion;
- -------------------
- -- Is_AAMP_Float --
- -------------------
-
- function Is_AAMP_Float (E : Entity_Id) return Boolean is
- pragma Assert (Is_Type (E));
- begin
- return AAMP_On_Target
- and then Is_Floating_Point_Type (E)
- and then E = Base_Type (E);
- end Is_AAMP_Float;
-
-----------------------------
-- Is_Actual_Out_Parameter --
-----------------------------
Call : Node_Id;
begin
Find_Actual (N, Formal, Call);
- return Present (Formal)
- and then Ekind (Formal) = E_Out_Parameter;
+ return Present (Formal) and then Ekind (Formal) = E_Out_Parameter;
end Is_Actual_Out_Parameter;
-------------------------
begin
-- Predicate is not relevant to subprograms
- if Is_Entity_Name (N)
- and then Is_Overloadable (Entity (N))
- then
+ if Is_Entity_Name (N) and then Is_Overloadable (Entity (N)) then
return False;
elsif Is_Atomic (Etype (N))
----------------------------------------------
function Is_Dependent_Component_Of_Mutable_Object
- (Object : Node_Id) return Boolean
+ (Object : Node_Id) return Boolean
is
P : Node_Id;
Prefix_Type : Entity_Id;
P_Aliased := True;
end if;
- -- A discriminant check on a selected component may be
- -- expanded into a dereference when removing side-effects.
- -- Recover the original node and its type, which may be
- -- unconstrained.
+ -- A discriminant check on a selected component may be expanded
+ -- into a dereference when removing side-effects. Recover the
+ -- original node and its type, which may be unconstrained.
elsif Nkind (P) = N_Explicit_Dereference
and then not (Comes_From_Source (P))
Prefix_Type := Etype (P);
else
- -- Check for prefix being an aliased component ???
+ -- Check for prefix being an aliased component???
+
null;
end if;
Comp :=
Original_Record_Component (Entity (Selector_Name (Object)));
- -- As per AI-0017, the renaming is illegal in a generic body,
- -- even if the subtype is indefinite.
+ -- As per AI-0017, the renaming is illegal in a generic body, even
+ -- if the subtype is indefinite.
-- Ada 2005 (AI-363): In Ada 2005 an aliased object can be mutable
function Is_LHS (N : Node_Id) return Boolean is
P : constant Node_Id := Parent (N);
+
begin
- return Nkind (P) = N_Assignment_Statement
- and then Name (P) = N;
+ if Nkind (P) = N_Assignment_Statement then
+ return Name (P) = N;
+
+ elsif
+ Nkind_In (P, N_Indexed_Component, N_Selected_Component, N_Slice)
+ then
+ return N = Prefix (P) and then Is_LHS (P);
+
+ else
+ return False;
+ end if;
end Is_LHS;
----------------------------
-- Is_Partially_Initialized_Type --
-----------------------------------
- function Is_Partially_Initialized_Type (Typ : Entity_Id) return Boolean is
+ function Is_Partially_Initialized_Type
+ (Typ : Entity_Id;
+ Include_Implicit : Boolean := True) return Boolean
+ is
begin
if Is_Scalar_Type (Typ) then
return False;
elsif Is_Access_Type (Typ) then
- return True;
+ return Include_Implicit;
elsif Is_Array_Type (Typ) then
-- If component type is partially initialized, so is array type
- if Is_Partially_Initialized_Type (Component_Type (Typ)) then
+ if Is_Partially_Initialized_Type
+ (Component_Type (Typ), Include_Implicit)
+ then
return True;
-- Otherwise we are only partially initialized if we are fully
elsif Is_Record_Type (Typ) then
- -- A discriminated type is always partially initialized
+ -- A discriminated type is always partially initialized if in
+ -- all mode
- if Has_Discriminants (Typ) then
+ if Has_Discriminants (Typ) and then Include_Implicit then
return True;
-- A tagged type is always partially initialized
-- If a component is of a type which is itself partially
-- initialized, then the enclosing record type is also.
- elsif Is_Partially_Initialized_Type (Etype (Ent)) then
+ elsif Is_Partially_Initialized_Type
+ (Etype (Ent), Include_Implicit)
+ then
return True;
end if;
end if;
if No (U) then
return True;
else
- return Is_Partially_Initialized_Type (U);
+ return Is_Partially_Initialized_Type (U, Include_Implicit);
end if;
end;
when N_Explicit_Dereference =>
return False;
- -- Function call arguments are never lvalues
-
- when N_Function_Call =>
- return False;
-
- -- Positional parameter for procedure, entry, or accept call
+ -- Positional parameter for subprogram, entry, or accept call.
+ -- In older versions of Ada function call arguments are never
+ -- lvalues. In Ada 2012 functions can have in-out parameters.
- when N_Procedure_Call_Statement |
+ when N_Function_Call |
+ N_Procedure_Call_Statement |
N_Entry_Call_Statement |
N_Accept_Statement
=>
+ if Nkind (P) = N_Function_Call
+ and then Ada_Version < Ada_2012
+ then
+ return False;
+ end if;
+
+ -- The following mechanism is clumsy and fragile. A single
+ -- flag set in Resolve_Actuals would be preferable ???
+
declare
Proc : Entity_Id;
Form : Entity_Id;
-- Itype references within the copied tree.
-- The following hash tables are used if the Map supplied has more
- -- than hash threshhold entries to speed up access to the map. If
+ -- than hash threshold entries to speed up access to the map. If
-- there are fewer entries, then the map is searched sequentially
-- (because setting up a hash table for only a few entries takes
-- more time than it saves.
else
NCT_Table_Entries := NCT_Table_Entries + 1;
- if NCT_Table_Entries > NCT_Hash_Threshhold then
+ if NCT_Table_Entries > NCT_Hash_Threshold then
Build_NCT_Hash_Tables;
end if;
end if;
Next_Elmt (Elmt);
end loop;
- if NCT_Table_Entries > NCT_Hash_Threshhold then
+ if NCT_Table_Entries > NCT_Hash_Threshold then
Build_NCT_Hash_Tables;
else
NCT_Hash_Tables_Used := False;
if Comes_From_Source (Exp)
or else Modification_Comes_From_Source
then
- if Has_Pragma_Unmodified (Ent) then
+ -- Give warning if pragma unmodified given and we are
+ -- sure this is a modification.
+
+ if Has_Pragma_Unmodified (Ent) and then Sure then
Error_Msg_NE ("?pragma Unmodified given for &!", N, Ent);
end if;
if Modification_Comes_From_Source then
Generate_Reference (Ent, Exp, 'm');
+
+ -- If the target of the assignment is the bound variable
+ -- in an iterator, indicate that the corresponding array
+ -- or container is also modified.
+
+ if Ada_Version >= Ada_2012
+ and then
+ Nkind (Parent (Ent)) = N_Iterator_Specification
+ then
+ declare
+ Domain : constant Node_Id := Name (Parent (Ent));
+
+ begin
+ -- TBD : in the full version of the construct, the
+ -- domain of iteration can be given by an expression.
+
+ if Is_Entity_Name (Domain) then
+ Generate_Reference (Entity (Domain), Exp, 'm');
+ Set_Is_True_Constant (Entity (Domain), False);
+ Set_Never_Set_In_Source (Entity (Domain), False);
+ end if;
+ end;
+ end if;
end if;
Check_Nested_Access (Ent);
end if;
end Object_Access_Level;
+ --------------------------------------
+ -- Original_Corresponding_Operation --
+ --------------------------------------
+
+ function Original_Corresponding_Operation (S : Entity_Id) return Entity_Id
+ is
+ Typ : constant Entity_Id := Find_Dispatching_Type (S);
+
+ begin
+ -- If S is an inherited primitive S2 the original corresponding
+ -- operation of S is the original corresponding operation of S2
+
+ if Present (Alias (S))
+ and then Find_Dispatching_Type (Alias (S)) /= Typ
+ then
+ return Original_Corresponding_Operation (Alias (S));
+
+ -- If S overrides an inherited subprogram S2 the original corresponding
+ -- operation of S is the original corresponding operation of S2
+
+ elsif Present (Overridden_Operation (S)) then
+ return Original_Corresponding_Operation (Overridden_Operation (S));
+
+ -- otherwise it is S itself
+
+ else
+ return S;
+ end if;
+ end Original_Corresponding_Operation;
+
-----------------------
-- Private_Component --
-----------------------
Set_Sloc (Endl, Loc);
end Process_End_Label;
- ------------------
- -- Real_Convert --
- ------------------
-
- -- We do the conversion to get the value of the real string by using
- -- the scanner, see Sinput for details on use of the internal source
- -- buffer for scanning internal strings.
-
- function Real_Convert (S : String) return Node_Id is
- Save_Src : constant Source_Buffer_Ptr := Source;
- Negative : Boolean;
-
- begin
- Source := Internal_Source_Ptr;
- Scan_Ptr := 1;
-
- for J in S'Range loop
- Source (Source_Ptr (J)) := S (J);
- end loop;
-
- Source (S'Length + 1) := EOF;
-
- if Source (Scan_Ptr) = '-' then
- Negative := True;
- Scan_Ptr := Scan_Ptr + 1;
- else
- Negative := False;
- end if;
-
- Scan;
-
- if Negative then
- Set_Realval (Token_Node, UR_Negate (Realval (Token_Node)));
- end if;
-
- Source := Save_Src;
- return Token_Node;
- end Real_Convert;
-
------------------------------------
-- References_Generic_Formal_Type --
------------------------------------
if Requires_Transient_Scope (Component_Type (Typ)) then
return True;
- -- Otherwise, we only need a transient scope if the size is not
- -- known at compile time.
+ -- Otherwise, we only need a transient scope if the size depends on
+ -- the value of one or more discriminants.
else
- return not Size_Known_At_Compile_Time (Typ);
+ return Size_Depends_On_Discriminant (Typ);
end if;
-- All other cases do not require a transient scope
procedure Save_Actual (N : Node_Id; Writable : Boolean := False) is
begin
- if Is_Entity_Name (N)
+ 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
end Set_Size_Info;
--------------------
+ -- Static_Boolean --
+ --------------------
+
+ function Static_Boolean (N : Node_Id) return Uint is
+ begin
+ Analyze_And_Resolve (N, Standard_Boolean);
+
+ if N = Error
+ or else Error_Posted (N)
+ or else Etype (N) = Any_Type
+ then
+ return No_Uint;
+ end if;
+
+ if Is_Static_Expression (N) then
+ if not Raises_Constraint_Error (N) then
+ return Expr_Value (N);
+ else
+ return No_Uint;
+ end if;
+
+ elsif Etype (N) = Any_Type then
+ return No_Uint;
+
+ else
+ Flag_Non_Static_Expr
+ ("static boolean expression required here", N);
+ return No_Uint;
+ end if;
+ end Static_Boolean;
+
+ --------------------
-- Static_Integer --
--------------------
end if;
end Unqualify;
+ -----------------------
+ -- Visible_Ancestors --
+ -----------------------
+
+ function Visible_Ancestors (Typ : Entity_Id) return Elist_Id is
+ List_1 : Elist_Id;
+ List_2 : Elist_Id;
+ Elmt : Elmt_Id;
+
+ begin
+ pragma Assert (Is_Record_Type (Typ)
+ and then Is_Tagged_Type (Typ));
+
+ -- Collect all the parents and progenitors of Typ. If the full-view of
+ -- private parents and progenitors is available then it is used to
+ -- generate the list of visible ancestors; otherwise their partial
+ -- view is added to the resulting list.
+
+ Collect_Parents
+ (T => Typ,
+ List => List_1,
+ Use_Full_View => True);
+
+ Collect_Interfaces
+ (T => Typ,
+ Ifaces_List => List_2,
+ Exclude_Parents => True,
+ Use_Full_View => True);
+
+ -- Join the two lists. Avoid duplications because an interface may
+ -- simultaneously be parent and progenitor of a type.
+
+ Elmt := First_Elmt (List_2);
+ while Present (Elmt) loop
+ Append_Unique_Elmt (Node (Elmt), List_1);
+ Next_Elmt (Elmt);
+ end loop;
+
+ return List_1;
+ end Visible_Ancestors;
+
----------------------
-- Within_Init_Proc --
----------------------
OSDN Git Service
