+2016-06-14 Tristan Gingold <gingold@adacore.com>
+
+ * einfo.adb, einfo.ads (Has_Timing_Event,
+ Set_Has_Timing_Event): Add Has_Timing_Event flag.
+ (Write_Entity_Flags): Display * sem_util.ads, sem_util.adb:
+ (Propagate_Type_Has_Flags): New procedure to factorize code.
+ * exp_ch3.adb (Expand_Freeze_Array_Type,
+ Expand_Freeze_Record_Type): Call Propagate_Type_Has_Flags.
+ * sem_ch3.adb (Access_Type_Decalaration): Initialize
+ Has_Timing_Event flag. (Analyze_Object_Declaration):
+ Move code that check No_Local_Timing_Events near
+ the code that check No_Local_Protected_Objects.
+ (Analyze_Private_Extension_Declaration, Array_Type_Declaration)
+ (Build_Derived_Type, Copy_Array_Base_Type_Attributes,
+ Process_Full_View) (Record_Type_Definition): Call
+ Propagate_Type_Has_Flags.
+ * sem_ch4.adb (Analyze_Allocator): Check No_Local_Timing_Events.
+ * sem_ch7.adb (New_Private_Type): Set Has_Timing_Event on the
+ Timing_Event type.
+ (Uninstall_Declaration): Call Propagate_Type_Has_Flags.
+ * sem_ch9.adb (Analyze_Protected_Definition): Call
+ Propagate_Type_Has_Flags.
+
+2016-06-14 Arnaud Charlet <charlet@adacore.com>
+
+ * sem.ads: Minor style fix.
+
2016-06-14 Ed Schonberg <schonberg@adacore.com>
* sem_ch12.adb (Analyze_Associations): An actual parameter
-- Is_Exception_Handler Flag286
-- Rewritten_For_C Flag287
-- Predicates_Ignored Flag288
+ -- Has_Timing_Event Flag289
- -- (unused) Flag289
- -- (unused) Flag300
+ -- (unused) Flag290
+
+ -- (unused) Flag291
+ -- (unused) Flag292
+ -- (unused) Flag293
+ -- (unused) Flag294
+ -- (unused) Flag295
+ -- (unused) Flag296
+ -- (unused) Flag297
+ -- (unused) Flag298
+ -- (unused) Flag299
+ -- (unused) Flag300
-- (unused) Flag301
-- (unused) Flag302
-- (unused) Flag303
return Flag228 (Id);
end Has_Thunks;
+ function Has_Timing_Event (Id : E) return B is
+ begin
+ return Flag289 (Base_Type (Id));
+ end Has_Timing_Event;
+
function Has_Unchecked_Union (Id : E) return B is
begin
return Flag123 (Base_Type (Id));
Set_Flag228 (Id, V);
end Set_Has_Thunks;
+ procedure Set_Has_Timing_Event (Id : E; V : B := True) is
+ begin
+ Set_Flag289 (Id, V);
+ end Set_Has_Timing_Event;
+
procedure Set_Has_Unchecked_Union (Id : E; V : B := True) is
begin
pragma Assert (Id = Base_Type (Id));
W ("Has_Storage_Size_Clause", Flag23 (Id));
W ("Has_Stream_Size_Clause", Flag184 (Id));
W ("Has_Task", Flag30 (Id));
+ W ("Has_Timing_Event", Flag289 (Id));
W ("Has_Thunks", Flag228 (Id));
W ("Has_Unchecked_Union", Flag123 (Id));
W ("Has_Unknown_Discriminants", Flag72 (Id));
-- such an object must create the required tasks. Note: the flag is not
-- set on access types, even if they designate an object that Has_Task.
+-- Has_Timing_Event (Flag289) [base type only]
+-- Defined in all type entities. Set on language defined type
+-- Ada.Real_Time.Timing_Events.Timing_Event, and also (recursively) on
+-- any composite type which has a component for which Has_Timing_Event
+-- is set. Used for the No_Local_Timing_Event restriction.
+
-- Has_Thunks (Flag228)
-- Applies to E_Constant entities marked Is_Tag. True for secondary tag
-- referencing a dispatch table whose contents are pointers to thunks.
-- Has_Static_Predicate (Flag269)
-- Has_Static_Predicate_Aspect (Flag259)
-- Has_Task (Flag30) (base type only)
+ -- Has_Timing_Event (Flag289) (base type only)
-- Has_Unchecked_Union (Flag123) (base type only)
-- Has_Volatile_Components (Flag87) (base type only)
-- In_Use (Flag8)
function Has_Storage_Size_Clause (Id : E) return B;
function Has_Stream_Size_Clause (Id : E) return B;
function Has_Task (Id : E) return B;
+ function Has_Timing_Event (Id : E) return B;
function Has_Thunks (Id : E) return B;
function Has_Unchecked_Union (Id : E) return B;
function Has_Unknown_Discriminants (Id : E) return B;
procedure Set_Has_Storage_Size_Clause (Id : E; V : B := True);
procedure Set_Has_Stream_Size_Clause (Id : E; V : B := True);
procedure Set_Has_Task (Id : E; V : B := True);
+ procedure Set_Has_Timing_Event (Id : E; V : B := True);
procedure Set_Has_Thunks (Id : E; V : B := True);
procedure Set_Has_Unchecked_Union (Id : E; V : B := True);
procedure Set_Has_Unknown_Discriminants (Id : E; V : B := True);
pragma Inline (Has_Storage_Size_Clause);
pragma Inline (Has_Stream_Size_Clause);
pragma Inline (Has_Task);
+ pragma Inline (Has_Timing_Event);
pragma Inline (Has_Thunks);
pragma Inline (Has_Unchecked_Union);
pragma Inline (Has_Unknown_Discriminants);
pragma Inline (Set_Has_Storage_Size_Clause);
pragma Inline (Set_Has_Stream_Size_Clause);
pragma Inline (Set_Has_Task);
+ pragma Inline (Set_Has_Timing_Event);
pragma Inline (Set_Has_Thunks);
pragma Inline (Set_Has_Unchecked_Union);
pragma Inline (Set_Has_Unknown_Discriminants);
-- been a private type at the point of definition. Same if component
-- type is controlled or contains protected objects.
- Set_Has_Task (Base, Has_Task (Comp_Typ));
- Set_Has_Protected (Base, Has_Protected (Comp_Typ));
+ Propagate_Type_Has_Flags (Base, Comp_Typ);
Set_Has_Controlled_Component
- (Base, Has_Controlled_Component
+ (Base, Has_Controlled_Component
(Comp_Typ)
- or else
- Is_Controlled (Comp_Typ));
+ or else
+ Is_Controlled (Comp_Typ));
if No (Init_Proc (Base)) then
while Present (Comp) loop
Comp_Typ := Etype (Comp);
- if Has_Task (Comp_Typ) then
- Set_Has_Task (Typ);
- end if;
-
- if Has_Protected (Comp_Typ) then
- Set_Has_Protected (Typ);
- end if;
+ Propagate_Type_Has_Flags (Typ, Comp_Typ);
-- Do not set Has_Controlled_Component on a class-wide equivalent
-- type. See Make_CW_Equivalent_Type.
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, 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- --
-- xx : x := y * z;
-- end record;
--- for x'small use 0.25
+-- for x'small use 0.25;
-- The expander is in charge of dealing with fixed-point, and of course the
-- small declaration, which is not too late, since the declaration of type q
-- and to Has_Protected.
Set_Has_Task (T, False);
- Set_Has_Controlled_Component (T, False);
Set_Has_Protected (T, False);
+ Set_Has_Timing_Event (T, False);
+ Set_Has_Controlled_Component (T, False);
-- Initialize field Finalization_Master explicitly to Empty, to avoid
-- problems where an incomplete view of this entity has been previously
end if;
end if;
+ -- Check for violation of No_Local_Timing_Events
+
+ if Has_Timing_Event (T) and then not Is_Library_Level_Entity (Id) then
+ Check_Restriction (No_Local_Timing_Events, Id);
+ end if;
+
-- The actual subtype of the object is the nominal subtype, unless
-- the nominal one is unconstrained and obtained from the expression.
Set_In_Private_Part (Id);
end if;
- -- Check for violation of No_Local_Timing_Events
-
- if Restriction_Check_Required (No_Local_Timing_Events)
- and then not Is_Library_Level_Entity (Id)
- and then Is_RTE (Etype (Id), RE_Timing_Event)
- then
- Check_Restriction (No_Local_Timing_Events, N);
- end if;
-
<<Leave>>
-- Initialize the refined state of a variable here because this is a
-- common destination for legal and illegal object declarations.
Init_Size_Align (T);
Set_Default_SSO (T);
- Set_Etype (T, Parent_Base);
- Set_Has_Task (T, Has_Task (Parent_Base));
- Set_Has_Protected (T, Has_Task (Parent_Base));
+ Set_Etype (T, Parent_Base);
+ Propagate_Type_Has_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);
- Set_Has_Task (Implicit_Base, Has_Task (Element_Type));
- Set_Has_Protected (Implicit_Base, Has_Protected (Element_Type));
+ Propagate_Type_Has_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);
- Set_Has_Task (T, Has_Task (Element_Type));
- Set_Has_Protected (T, Has_Protected (Element_Type));
+ Propagate_Type_Has_Flags (T, Element_Type);
Set_Has_Controlled_Component (T, Has_Controlled_Component
(Element_Type)
or else
begin
-- Set common attributes
- Set_Scope (Derived_Type, Current_Scope);
+ Set_Scope (Derived_Type, Current_Scope);
- Set_Etype (Derived_Type, Parent_Base);
- Set_Ekind (Derived_Type, Ekind (Parent_Base));
- Set_Has_Task (Derived_Type, Has_Task (Parent_Base));
- Set_Has_Protected (Derived_Type, Has_Protected (Parent_Base));
+ Set_Etype (Derived_Type, Parent_Base);
+ Set_Ekind (Derived_Type, Ekind (Parent_Base));
+ Propagate_Type_Has_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));
- Set_Has_Protected (T1, Has_Protected (T2));
- Set_Has_Task (T1, Has_Task (T2));
+ Propagate_Type_Has_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));
- Set_Has_Task (Class_Wide_Type (Priv_T), Has_Task (Full_T));
- Set_Has_Protected
- (Class_Wide_Type (Priv_T), Has_Protected (Full_T));
+ Propagate_Type_Has_Flags (Class_Wide_Type (Priv_T), Full_T);
end if;
end;
end if;
Init_Component_Location (Component);
end if;
- if Has_Task (Etype (Component)) then
- Set_Has_Task (T);
- end if;
-
- if Has_Protected (Etype (Component)) then
- Set_Has_Protected (T);
- end if;
+ Propagate_Type_Has_Flags (T, Etype (Component));
if Ekind (Component) /= E_Component then
null;
Check_Restriction (No_Local_Protected_Objects, N);
end if;
+ -- Likewise for No_Local_Timing_Events
+
+ if Has_Timing_Event (Designated_Type (Acc_Type))
+ and then not Is_Library_Level_Entity (Acc_Type)
+ then
+ Check_Restriction (No_Local_Timing_Events, N);
+ end if;
+
-- If the No_Streams restriction is set, check that the type of the
-- object is not, and does not contain, any subtype derived from
-- Ada.Streams.Root_Stream_Type. Note that we guard the call to
with Opt; use Opt;
with Output; use Output;
with Restrict; use Restrict;
+with Rtsfind; use Rtsfind;
with Sem; use Sem;
with Sem_Aux; use Sem_Aux;
with Sem_Cat; use Sem_Cat;
Set_Is_Limited_Record (Id, Limited_Present (Def));
Set_Has_Delayed_Freeze (Id, True);
+ -- Recognize Ada.Real_Time.Timing_Events.Timing_Events here
+
+ if Is_RTE (Id, RE_Timing_Event) then
+ Set_Has_Timing_Event (Id);
+ end if;
+
-- Create a class-wide type with the same attributes
Make_Class_Wide_Type (Id);
Set_Finalize_Storage_Only
(Priv, Finalize_Storage_Only
(Base_Type (Full)));
- Set_Has_Task (Priv, Has_Task (Base_Type (Full)));
- Set_Has_Protected (Priv, Has_Protected (Base_Type (Full)));
+ Propagate_Type_Has_Flags
+ (Priv, Base_Type (Full));
Set_Has_Controlled_Component
(Priv, Has_Controlled_Component
(Base_Type (Full)));
while Present (E) loop
if Ekind_In (E, E_Function, E_Procedure) then
Set_Convention (E, Convention_Protected);
-
- elsif Is_Task_Type (Etype (E))
- or else Has_Task (Etype (E))
- then
- Set_Has_Task (Current_Scope);
-
- elsif Is_Protected_Type (Etype (E))
- or else Has_Protected (Etype (E))
- then
- Set_Has_Protected (Current_Scope);
+ else
+ Propagate_Type_Has_Flags (Current_Scope, Etype (E));
end if;
Next_Entity (E);
Set_Sloc (Endl, Loc);
end Process_End_Label;
+ ------------------------------
+ -- Propagate_Type_Has_Flags --
+ ------------------------------
+
+ procedure Propagate_Type_Has_Flags
+ (Typ : Entity_Id;
+ Comp_Typ : Entity_Id) is
+ begin
+ if Has_Task (Comp_Typ) then
+ Set_Has_Task (Typ);
+ end if;
+
+ if Has_Protected (Comp_Typ) then
+ Set_Has_Protected (Typ);
+ end if;
+
+ if Has_Timing_Event (Comp_Typ) then
+ Set_Has_Timing_Event (Typ);
+ end if;
+ end Propagate_Type_Has_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
+ (Typ : Entity_Id;
+ Comp_Typ : Entity_Id);
+ -- Set Has_Task, Has_Protected and Has_Timing_Event on Typ when the flags
+ -- are set on Comp_Typ. This follows the definition of these flags which
+ -- are set (recursively) on any composite type which has a component marked
+ -- by one of these flags. This procedure can only set flags for Typ, and
+ -- never clear them. Comp_Typ is the type of a component or a parent.
+
procedure Record_Possible_Part_Of_Reference
(Var_Id : Entity_Id;
Ref : Node_Id);
projects / gcc.git / commitdiff