-- --
-- 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- --
-- 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
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 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;
-
- Next_Component (Comp);
- end loop;
+ -- Here if type itself does not have a non-null Initialize operation:
+ -- check immediate ancestor.
- 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;
--------------------------------------
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;
----------------------------
-- 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 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);
then
return Original_Corresponding_Operation (Alias (S));
- -- If S overrides an inherted subprogram S2 the original corresponding
+ -- If S overrides an inherited subprogram S2 the original corresponding
-- operation of S is the original corresponding operation of S2
- elsif Is_Overriding_Operation (S)
- and then Present (Overridden_Operation (S))
- then
+ elsif Present (Overridden_Operation (S)) then
return Original_Corresponding_Operation (Overridden_Operation (S));
-- otherwise it is S itself
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
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 --
--------------------
OSDN Git Service
