-- 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
return;
end if;
- -- Ada 2012 AI04-0144-2 : dangerous order dependence. Actuals in nested
+ -- 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
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;
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
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)
-- We are interested only in components and discriminants
- if Ekind_In (Ent, E_Component, E_Discriminant) then
-
- -- 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.
+ Exp := Empty;
- 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 =>
+
+ -- 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.
- elsif not Is_Preelaborable_Expression (Exp) then
+ 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;
-----------------------------------
function Is_Partially_Initialized_Type
- (Typ : Entity_Id;
- Include_Null : Boolean := True) return Boolean
+ (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 Include_Null;
+ 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), Include_Null)
+ (Component_Type (Typ), Include_Implicit)
then
return True;
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
-- initialized, then the enclosing record type is also.
elsif Is_Partially_Initialized_Type
- (Etype (Ent), Include_Null)
+ (Etype (Ent), Include_Implicit)
then
return True;
end if;
if No (U) then
return True;
else
- return Is_Partially_Initialized_Type (U, Include_Null);
+ return Is_Partially_Initialized_Type (U, Include_Implicit);
end if;
end;
-- 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