+2016-06-14 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch6.adb (Set_Actual_Subtypes): Do not generate actual
+ subtypes for unconstrained formals when analyzing the generated
+ body of an expression function, because it may lead to premature
+ and misplaced freezing of the types of formals.
+
+2016-06-14 Gary Dismukes <dismukes@adacore.com>
+
+ * sem_elab.adb, sem_ch4.adb: Minor reformatting and typo fix.
+
+2016-06-14 Tristan Gingold <gingold@adacore.com>
+
+ * einfo.adb (Set_Has_Timing_Event): Add assertion.
+ * sem_util.ads, sem_util.adb (Propagate_Concurrent_Flags): New
+ name for Propagate_Type_Has_Flags.
+ * exp_ch3.adb, sem_ch3.adb, sem_ch7.adb, sem_ch9.adb: Adjust after
+ renaming.
+
2016-06-14 Bob Duff <duff@adacore.com>
* sem_elab.adb (Check_A_Call): Do nothing if the callee is
procedure Set_Has_Timing_Event (Id : E; V : B := True) is
begin
+ pragma Assert (Id = Base_Type (Id));
Set_Flag289 (Id, V);
end Set_Has_Timing_Event;
-- been a private type at the point of definition. Same if component
-- type is controlled or contains protected objects.
- Propagate_Type_Has_Flags (Base, Comp_Typ);
+ Propagate_Concurrent_Flags (Base, Comp_Typ);
Set_Has_Controlled_Component
(Base, Has_Controlled_Component (Comp_Typ)
or else Is_Controlled (Comp_Typ));
while Present (Comp) loop
Comp_Typ := Etype (Comp);
- Propagate_Type_Has_Flags (Typ, Comp_Typ);
+ Propagate_Concurrent_Flags (Typ, Comp_Typ);
-- Do not set Has_Controlled_Component on a class-wide equivalent
-- type. See Make_CW_Equivalent_Type.
Set_Default_SSO (T);
Set_Etype (T, Parent_Base);
- Propagate_Type_Has_Flags (T, Parent_Base);
+ Propagate_Concurrent_Flags (T, Parent_Base);
Set_Convention (T, Convention (Parent_Type));
Set_First_Rep_Item (T, First_Rep_Item (Parent_Type));
Set_First_Index (Implicit_Base, First_Index (T));
Set_Component_Type (Implicit_Base, Element_Type);
- Propagate_Type_Has_Flags (Implicit_Base, Element_Type);
+ Propagate_Concurrent_Flags (Implicit_Base, Element_Type);
Set_Component_Size (Implicit_Base, Uint_0);
Set_Packed_Array_Impl_Type (Implicit_Base, Empty);
Set_Has_Controlled_Component (Implicit_Base,
Set_Is_Constrained (T, False);
Set_First_Index (T, First (Subtype_Marks (Def)));
Set_Has_Delayed_Freeze (T, True);
- Propagate_Type_Has_Flags (T, Element_Type);
+ Propagate_Concurrent_Flags (T, Element_Type);
Set_Has_Controlled_Component (T, Has_Controlled_Component
(Element_Type)
or else
Set_Scope (Derived_Type, Current_Scope);
- Set_Etype (Derived_Type, Parent_Base);
- Set_Ekind (Derived_Type, Ekind (Parent_Base));
- Propagate_Type_Has_Flags (Derived_Type, Parent_Base);
+ Set_Etype (Derived_Type, Parent_Base);
+ Set_Ekind (Derived_Type, Ekind (Parent_Base));
+ Propagate_Concurrent_Flags (Derived_Type, Parent_Base);
Set_Size_Info (Derived_Type, Parent_Type);
Set_RM_Size (Derived_Type, RM_Size (Parent_Type));
Set_Component_Size (T1, Component_Size (T2));
Set_Has_Controlled_Component (T1, Has_Controlled_Component (T2));
Set_Has_Non_Standard_Rep (T1, Has_Non_Standard_Rep (T2));
- Propagate_Type_Has_Flags (T1, T2);
+ Propagate_Concurrent_Flags (T1, T2);
Set_Is_Packed (T1, Is_Packed (T2));
Set_Has_Aliased_Components (T1, Has_Aliased_Components (T2));
Set_Has_Atomic_Components (T1, Has_Atomic_Components (T2));
Set_Class_Wide_Type
(Base_Type (Full_T), Class_Wide_Type (Priv_T));
- Propagate_Type_Has_Flags (Class_Wide_Type (Priv_T), Full_T);
+ Propagate_Concurrent_Flags (Class_Wide_Type (Priv_T), Full_T);
end if;
end;
end if;
Init_Component_Location (Component);
end if;
- Propagate_Type_Has_Flags (T, Etype (Component));
+ Propagate_Concurrent_Flags (T, Etype (Component));
if Ekind (Component) /= E_Component then
null;
if Warn_On_Suspicious_Contract
and then not Referenced (Loop_Id, Cond)
then
- -- Generating C this check causes spurious warnings on inlined
+ -- Generating C, this check causes spurious warnings on inlined
-- postconditions; we can safely disable it because this check
- -- was previously performed when analying the internally built
+ -- was previously performed when analyzing the internally built
-- postconditions procedure.
if Modify_Tree_For_C and then In_Inlined_Body then
return;
end if;
+ -- The subtype declarations may freeze the formals. The body generated
+ -- for an expression function is not a freeze point, so do not emit
+ -- these declarations (small loss of efficiency in rare cases).
+
+ if Nkind (N) = N_Subprogram_Body
+ and then Was_Expression_Function (N)
+ then
+ return;
+ end if;
+
Formal := First_Formal (Subp);
while Present (Formal) loop
T := Etype (Formal);
Set_Finalize_Storage_Only
(Priv, Finalize_Storage_Only
(Base_Type (Full)));
- Propagate_Type_Has_Flags
+ Propagate_Concurrent_Flags
(Priv, Base_Type (Full));
Set_Has_Controlled_Component
(Priv, Has_Controlled_Component
if Ekind_In (E, E_Function, E_Procedure) then
Set_Convention (E, Convention_Protected);
else
- Propagate_Type_Has_Flags (Current_Scope, Etype (E));
+ Propagate_Concurrent_Flags (Current_Scope, Etype (E));
end if;
Next_Entity (E);
Table_Name => "Delay_Check");
C_Scope : Entity_Id;
- -- Top level scope of current scope. Compute this only once at the outer
+ -- Top-level scope of current scope. Compute this only once at the outer
-- level, i.e. for a call to Check_Elab_Call from outside this unit.
Outer_Level_Sloc : Source_Ptr;
-- Msg_S is an info message (output if Elab_Info_Messages is set.
function Find_W_Scope return Entity_Id;
- -- Find top level scope for called entity (not following renamings
+ -- Find top-level scope for called entity (not following renamings
-- or derivations). This is where the Elaborate_All will go if it is
-- needed. We start with the called entity, except in the case of an
-- initialization procedure outside the current package, where the init
-- we ignore this flag.
E_Scope : Entity_Id;
- -- Top level scope of entity for called subprogram. This value includes
+ -- Top-level scope of entity for called subprogram. This value includes
-- following renamings and derivations, so this scope can be in a
-- non-visible unit. This is the scope that is to be investigated to
-- see whether an elaboration check is required.
-- Flag set when a source entity is called during elaboration in SPARK
W_Scope : constant Entity_Id := Find_W_Scope;
- -- Top level scope of directly called entity for subprogram. This
+ -- Top-level scope of directly called entity for subprogram. This
-- differs from E_Scope in the case where renamings or derivations
-- are involved, since it does not follow these links. W_Scope is
-- generally in a visible unit, and it is this scope that may require
-- Static model, call is not in elaboration code, we
-- never need to worry, because in the static model the
- -- top level caller always takes care of things.
+ -- top-level caller always takes care of things.
else
return;
Set_Sloc (Endl, Loc);
end Process_End_Label;
- ------------------------------
- -- Propagate_Type_Has_Flags --
- ------------------------------
+ --------------------------------
+ -- Propagate_Concurrent_Flags --
+ --------------------------------
- procedure Propagate_Type_Has_Flags
+ procedure Propagate_Concurrent_Flags
(Typ : Entity_Id;
Comp_Typ : Entity_Id) is
begin
if Has_Timing_Event (Comp_Typ) then
Set_Has_Timing_Event (Typ);
end if;
- end Propagate_Type_Has_Flags;
+ end Propagate_Concurrent_Flags;
---------------------------------------
-- Record_Possible_Part_Of_Reference --
-- parameter Ent gives the entity to which the End_Label refers,
-- and to which cross-references are to be generated.
- procedure Propagate_Type_Has_Flags
+ procedure Propagate_Concurrent_Flags
(Typ : Entity_Id;
Comp_Typ : Entity_Id);
-- Set Has_Task, Has_Protected and Has_Timing_Event on Typ when the flags