[multiple changes]
2017-09-13 Hristian Kirtchev <kirtchev@adacore.com> * einfo.adb: Flag42 is now Is_Controlled_Active. (Is_Controlled): This attribute is now synthesized. (Is_Controlled_Active): This attribute is now an explicit flag rather than a synthesized attribute. (Set_Is_Controlled): Removed. (Set_Is_Controlled_Active): New routine. (Write_Entity_Flags): Update the output for Flag42. * einfo.ads: Update the documentation of the following attributes: Disable_Controlled, Is_Controlled, Is_Controlled_Active, Is_Controlled and Is_Controlled_Active have swapped their functionality. (Is_Controlled): Renamed to Is_Controlled_Active. (Is_Controlled_Active): Renamed to Is_Controlled. (Set_Is_Controlled): Renamed to Set_Is_Controlled_Active. * exp_ch3.adb (Expand_Freeze_Record_Type): Restore the original use of Is_Controlled. * exp_util.adb (Has_Some_Controlled_Component): Code clean up. (Needs_Finalization): Code clean up. Remove the tests for Disable_Controlled because a) they were incorrect as they would reject a type which is sublect to the aspect, but may contain controlled components, and b) they are no longer necessary. * exp_util.ads (Needs_Finalization): Update comment on documentation. * freeze.adb (Freeze_Array_Type): Restore the original use of Is_Controlled. (Freeze_Record_Type): Restore the original use of Is_Controlled. * sem_ch3.adb (Analyze_Object_Declaration): Restore the original use of Is_Controlled. (Array_Type_Declaration): Restore the original use of Is_Controlled. (Build_Derived_Private_Type): Restore the original use of Is_Controlled. (Build_Derived_Record_Type): Set the Is_Controlled_Active flag of a type derived from Ada.Finalization.[Limited_]Controlled. (Build_Derived_Type): Restore the original use of Is_Controlled. (Record_Type_Definition): Restore the original use of Is_Controlled. * sem_ch7.adb (Preserve_Full_Attributes): Restore the original use of Is_Controlled. * sem_ch13.adb (Analyze_Aspect_Disable_Controlled): New routine. (Analyze_Aspect_Specifications): Use routine Analyze_Aspect_Disable_Controlled to process aspect Disable_Controlled. 2017-09-13 Vincent Celier <celier@adacore.com> * clean.adb (Gnatclean): Fix error when looking for target of <target>-gnatclean 2017-09-13 Javier Miranda <miranda@adacore.com> Ed Schonberg <schonberg@adacore.com> * sem_ch8.adb (Find_Expanded_Name): Complete code that identifies an expanded name that designates the current instance of a child unit in its own body and appears as the prefix of a reference to an entity local to the child unit. From-SVN: r252065
This commit is contained in:
parent
caf3dcdf25
commit
0cb81445f4
|
@ -1,3 +1,56 @@
|
|||
2017-09-13 Hristian Kirtchev <kirtchev@adacore.com>
|
||||
|
||||
* einfo.adb: Flag42 is now Is_Controlled_Active.
|
||||
(Is_Controlled): This attribute is now synthesized.
|
||||
(Is_Controlled_Active): This attribute is now an explicit flag rather
|
||||
than a synthesized attribute. (Set_Is_Controlled): Removed.
|
||||
(Set_Is_Controlled_Active): New routine.
|
||||
(Write_Entity_Flags): Update the output for Flag42.
|
||||
* einfo.ads: Update the documentation of the following attributes:
|
||||
Disable_Controlled, Is_Controlled, Is_Controlled_Active, Is_Controlled
|
||||
and Is_Controlled_Active have swapped their functionality.
|
||||
(Is_Controlled): Renamed to Is_Controlled_Active.
|
||||
(Is_Controlled_Active): Renamed to Is_Controlled.
|
||||
(Set_Is_Controlled): Renamed to Set_Is_Controlled_Active.
|
||||
* exp_ch3.adb (Expand_Freeze_Record_Type): Restore the original use of
|
||||
Is_Controlled.
|
||||
* exp_util.adb (Has_Some_Controlled_Component): Code clean up.
|
||||
(Needs_Finalization): Code clean up. Remove the tests for
|
||||
Disable_Controlled because a) they were incorrect as they would reject
|
||||
a type which is sublect to the aspect, but may contain controlled
|
||||
components, and b) they are no longer necessary.
|
||||
* exp_util.ads (Needs_Finalization): Update comment on documentation.
|
||||
* freeze.adb (Freeze_Array_Type): Restore the original use of
|
||||
Is_Controlled.
|
||||
(Freeze_Record_Type): Restore the original use of Is_Controlled.
|
||||
* sem_ch3.adb (Analyze_Object_Declaration): Restore the original use of
|
||||
Is_Controlled.
|
||||
(Array_Type_Declaration): Restore the original use of Is_Controlled.
|
||||
(Build_Derived_Private_Type): Restore the original use of
|
||||
Is_Controlled.
|
||||
(Build_Derived_Record_Type): Set the Is_Controlled_Active flag of a
|
||||
type derived from Ada.Finalization.[Limited_]Controlled.
|
||||
(Build_Derived_Type): Restore the original use of Is_Controlled.
|
||||
(Record_Type_Definition): Restore the original use of Is_Controlled.
|
||||
* sem_ch7.adb (Preserve_Full_Attributes): Restore the original use of
|
||||
Is_Controlled.
|
||||
* sem_ch13.adb (Analyze_Aspect_Disable_Controlled): New routine.
|
||||
(Analyze_Aspect_Specifications): Use routine
|
||||
Analyze_Aspect_Disable_Controlled to process aspect Disable_Controlled.
|
||||
|
||||
2017-09-13 Vincent Celier <celier@adacore.com>
|
||||
|
||||
* clean.adb (Gnatclean): Fix error when looking for target
|
||||
of <target>-gnatclean
|
||||
|
||||
2017-09-13 Javier Miranda <miranda@adacore.com>
|
||||
Ed Schonberg <schonberg@adacore.com>
|
||||
|
||||
* sem_ch8.adb (Find_Expanded_Name): Complete code that identifies an
|
||||
expanded name that designates the current instance of a child unit in
|
||||
its own body and appears as the prefix of a reference to an entity
|
||||
local to the child unit.
|
||||
|
||||
2017-09-12 Bob Duff <duff@adacore.com>
|
||||
|
||||
* sem_warn.adb: Minor comment.
|
||||
|
|
|
@ -519,7 +519,7 @@ package body Clean is
|
|||
Find_Program_Name;
|
||||
|
||||
if Name_Len > 10
|
||||
and then Name_Buffer (Name_Len - 7 .. Name_Len) = "gnatclean"
|
||||
and then Name_Buffer (Name_Len - 8 .. Name_Len) = "gnatclean"
|
||||
then
|
||||
Target := new String'(Name_Buffer (1 .. Name_Len - 9));
|
||||
Arg_Len := Arg_Len + 1;
|
||||
|
|
|
@ -334,7 +334,7 @@ package body Einfo is
|
|||
-- Body_Needed_For_SAL Flag40
|
||||
|
||||
-- Treat_As_Volatile Flag41
|
||||
-- Is_Controlled Flag42
|
||||
-- Is_Controlled_Active Flag42
|
||||
-- Has_Controlled_Component Flag43
|
||||
-- Is_Pure Flag44
|
||||
-- In_Private_Part Flag45
|
||||
|
@ -2189,10 +2189,10 @@ package body Einfo is
|
|||
return Flag76 (Id);
|
||||
end Is_Constructor;
|
||||
|
||||
function Is_Controlled (Id : E) return B is
|
||||
function Is_Controlled_Active (Id : E) return B is
|
||||
begin
|
||||
return Flag42 (Base_Type (Id));
|
||||
end Is_Controlled;
|
||||
end Is_Controlled_Active;
|
||||
|
||||
function Is_Controlling_Formal (Id : E) return B is
|
||||
begin
|
||||
|
@ -5341,11 +5341,11 @@ package body Einfo is
|
|||
Set_Flag76 (Id, V);
|
||||
end Set_Is_Constructor;
|
||||
|
||||
procedure Set_Is_Controlled (Id : E; V : B := True) is
|
||||
procedure Set_Is_Controlled_Active (Id : E; V : B := True) is
|
||||
begin
|
||||
pragma Assert (Id = Base_Type (Id));
|
||||
Set_Flag42 (Id, V);
|
||||
end Set_Is_Controlled;
|
||||
end Set_Is_Controlled_Active;
|
||||
|
||||
procedure Set_Is_Controlling_Formal (Id : E; V : B := True) is
|
||||
begin
|
||||
|
@ -7902,14 +7902,14 @@ package body Einfo is
|
|||
K = E_Constant or else K = E_In_Parameter or else K = E_Loop_Parameter;
|
||||
end Is_Constant_Object;
|
||||
|
||||
--------------------------
|
||||
-- Is_Controlled_Active --
|
||||
--------------------------
|
||||
-------------------
|
||||
-- Is_Controlled --
|
||||
-------------------
|
||||
|
||||
function Is_Controlled_Active (Id : E) return B is
|
||||
function Is_Controlled (Id : E) return B is
|
||||
begin
|
||||
return Is_Controlled (Id) and then not Disable_Controlled (Id);
|
||||
end Is_Controlled_Active;
|
||||
return Is_Controlled_Active (Id) and then not Disable_Controlled (Id);
|
||||
end Is_Controlled;
|
||||
|
||||
--------------------
|
||||
-- Is_Discriminal --
|
||||
|
@ -9549,7 +9549,7 @@ package body Einfo is
|
|||
W ("Is_Constr_Subt_For_U_Nominal", Flag80 (Id));
|
||||
W ("Is_Constrained", Flag12 (Id));
|
||||
W ("Is_Constructor", Flag76 (Id));
|
||||
W ("Is_Controlled", Flag42 (Id));
|
||||
W ("Is_Controlled_Active", Flag42 (Id));
|
||||
W ("Is_Controlling_Formal", Flag97 (Id));
|
||||
W ("Is_Descendant_Of_Address", Flag223 (Id));
|
||||
W ("Is_DIC_Procedure", Flag132 (Id));
|
||||
|
|
|
@ -980,8 +980,9 @@ package Einfo is
|
|||
-- incomplete type.
|
||||
|
||||
-- Disable_Controlled (Flag253)
|
||||
-- Present in all entities. Set for a controlled type (Is_Controlled flag
|
||||
-- set) if the aspect Disable_Controlled is active for the type.
|
||||
-- Present in all entities. Set for a controlled type subject to aspect
|
||||
-- Disable_Controlled which evaluates to True. This flag is taken into
|
||||
-- account in synthesized attribute Is_Controlled.
|
||||
|
||||
-- Discard_Names (Flag88)
|
||||
-- Defined in types and exception entities. Set if pragma Discard_Names
|
||||
|
@ -2443,14 +2444,14 @@ package Einfo is
|
|||
-- Defined in function and procedure entities. Set if a pragma
|
||||
-- CPP_Constructor applies to the subprogram.
|
||||
|
||||
-- Is_Controlled (Flag42) [base type only]
|
||||
-- Is_Controlled_Active (Flag42) [base type only]
|
||||
-- Defined in all type entities. Indicates that the type is controlled,
|
||||
-- i.e. is either a descendant of Ada.Finalization.Controlled or of
|
||||
-- Ada.Finalization.Limited_Controlled.
|
||||
|
||||
-- Is_Controlled_Active (synth) [base type only]
|
||||
-- Defined in all type entities. Set if Is_Controlled is set for the
|
||||
-- type, and Disable_Controlled is not set.
|
||||
-- Is_Controlled (synth) [base type only]
|
||||
-- Defined in all type entities. Set if Is_Controlled_Active is set for
|
||||
-- the type, and Disable_Controlled is not set.
|
||||
|
||||
-- Is_Controlling_Formal (Flag97)
|
||||
-- Defined in all Formal_Kind entities. Marks the controlling parameters
|
||||
|
@ -5648,7 +5649,7 @@ package Einfo is
|
|||
-- Is_Atomic (Flag85)
|
||||
-- Is_Constr_Subt_For_U_Nominal (Flag80)
|
||||
-- Is_Constr_Subt_For_UN_Aliased (Flag141)
|
||||
-- Is_Controlled (Flag42) (base type only)
|
||||
-- Is_Controlled_Active (Flag42) (base type only)
|
||||
-- Is_Eliminated (Flag124)
|
||||
-- Is_Frozen (Flag4)
|
||||
-- Is_Generic_Actual_Type (Flag94)
|
||||
|
@ -5684,7 +5685,7 @@ package Einfo is
|
|||
-- Invariant_Procedure (synth)
|
||||
-- Is_Access_Protected_Subprogram_Type (synth)
|
||||
-- Is_Atomic_Or_VFA (synth)
|
||||
-- Is_Controlled_Active (synth)
|
||||
-- Is_Controlled (synth)
|
||||
-- Partial_Invariant_Procedure (synth)
|
||||
-- Predicate_Function (synth)
|
||||
-- Predicate_Function_M (synth)
|
||||
|
@ -6344,7 +6345,7 @@ package Einfo is
|
|||
-- Private_View (Node22)
|
||||
-- Stored_Constraint (Elist23)
|
||||
-- Has_Completion (Flag26)
|
||||
-- Is_Controlled (Flag42) (base type only)
|
||||
-- Is_Controlled_Active (Flag42) (base type only)
|
||||
-- Is_For_Access_Subtype (Flag118) (subtype only)
|
||||
-- (plus type attributes)
|
||||
|
||||
|
@ -6497,7 +6498,7 @@ package Einfo is
|
|||
-- Is_Class_Wide_Equivalent_Type (Flag35)
|
||||
-- Is_Concurrent_Record_Type (Flag20)
|
||||
-- Is_Constrained (Flag12)
|
||||
-- Is_Controlled (Flag42) (base type only)
|
||||
-- Is_Controlled_Active (Flag42) (base type only)
|
||||
-- Is_Interface (Flag186)
|
||||
-- Is_Limited_Interface (Flag197)
|
||||
-- No_Reordering (Flag239) (base type only)
|
||||
|
@ -6526,7 +6527,7 @@ package Einfo is
|
|||
-- Has_Record_Rep_Clause (Flag65) (base type only)
|
||||
-- Is_Concurrent_Record_Type (Flag20)
|
||||
-- Is_Constrained (Flag12)
|
||||
-- Is_Controlled (Flag42) (base type only)
|
||||
-- Is_Controlled_Active (Flag42) (base type only)
|
||||
-- Is_Interface (Flag186)
|
||||
-- Is_Limited_Interface (Flag197)
|
||||
-- No_Reordering (Flag239) (base type only)
|
||||
|
@ -7169,7 +7170,7 @@ package Einfo is
|
|||
function Is_Constr_Subt_For_UN_Aliased (Id : E) return B;
|
||||
function Is_Constrained (Id : E) return B;
|
||||
function Is_Constructor (Id : E) return B;
|
||||
function Is_Controlled (Id : E) return B;
|
||||
function Is_Controlled_Active (Id : E) return B;
|
||||
function Is_Controlling_Formal (Id : E) return B;
|
||||
function Is_CPP_Class (Id : E) return B;
|
||||
function Is_Descendant_Of_Address (Id : E) return B;
|
||||
|
@ -7489,7 +7490,7 @@ package Einfo is
|
|||
function Is_Base_Type (Id : E) return B;
|
||||
function Is_Boolean_Type (Id : E) return B;
|
||||
function Is_Constant_Object (Id : E) return B;
|
||||
function Is_Controlled_Active (Id : E) return B;
|
||||
function Is_Controlled (Id : E) return B;
|
||||
function Is_Discriminal (Id : E) return B;
|
||||
function Is_Dynamic_Scope (Id : E) return B;
|
||||
function Is_External_State (Id : E) return B;
|
||||
|
@ -7858,7 +7859,7 @@ package Einfo is
|
|||
procedure Set_Is_Constr_Subt_For_UN_Aliased (Id : E; V : B := True);
|
||||
procedure Set_Is_Constrained (Id : E; V : B := True);
|
||||
procedure Set_Is_Constructor (Id : E; V : B := True);
|
||||
procedure Set_Is_Controlled (Id : E; V : B := True);
|
||||
procedure Set_Is_Controlled_Active (Id : E; V : B := True);
|
||||
procedure Set_Is_Controlling_Formal (Id : E; V : B := True);
|
||||
procedure Set_Is_CPP_Class (Id : E; V : B := True);
|
||||
procedure Set_Is_Descendant_Of_Address (Id : E; V : B := True);
|
||||
|
@ -8676,7 +8677,7 @@ package Einfo is
|
|||
pragma Inline (Is_Constr_Subt_For_UN_Aliased);
|
||||
pragma Inline (Is_Constrained);
|
||||
pragma Inline (Is_Constructor);
|
||||
pragma Inline (Is_Controlled);
|
||||
pragma Inline (Is_Controlled_Active);
|
||||
pragma Inline (Is_Controlling_Formal);
|
||||
pragma Inline (Is_CPP_Class);
|
||||
pragma Inline (Is_Decimal_Fixed_Point_Type);
|
||||
|
@ -9190,7 +9191,7 @@ package Einfo is
|
|||
pragma Inline (Set_Is_Constr_Subt_For_UN_Aliased);
|
||||
pragma Inline (Set_Is_Constrained);
|
||||
pragma Inline (Set_Is_Constructor);
|
||||
pragma Inline (Set_Is_Controlled);
|
||||
pragma Inline (Set_Is_Controlled_Active);
|
||||
pragma Inline (Set_Is_Controlling_Formal);
|
||||
pragma Inline (Set_Is_CPP_Class);
|
||||
pragma Inline (Set_Is_Descendant_Of_Address);
|
||||
|
@ -9434,7 +9435,7 @@ package Einfo is
|
|||
|
||||
pragma Inline (Base_Type);
|
||||
pragma Inline (Is_Base_Type);
|
||||
pragma Inline (Is_Controlled_Active);
|
||||
pragma Inline (Is_Controlled);
|
||||
pragma Inline (Is_Package_Or_Generic_Package);
|
||||
pragma Inline (Is_Packed_Array);
|
||||
pragma Inline (Is_Subprogram_Or_Generic_Subprogram);
|
||||
|
|
|
@ -4951,7 +4951,7 @@ package body Exp_Ch3 is
|
|||
and then
|
||||
(Has_Controlled_Component (Comp_Typ)
|
||||
or else (Chars (Comp) /= Name_uParent
|
||||
and then (Is_Controlled_Active (Comp_Typ))))
|
||||
and then Is_Controlled (Comp_Typ)))
|
||||
then
|
||||
Set_Has_Controlled_Component (Typ);
|
||||
end if;
|
||||
|
|
|
@ -10296,48 +10296,48 @@ package body Exp_Util is
|
|||
-- Needs_Finalization --
|
||||
------------------------
|
||||
|
||||
function Needs_Finalization (T : Entity_Id) return Boolean is
|
||||
function Has_Some_Controlled_Component (Rec : Entity_Id) return Boolean;
|
||||
-- If type is not frozen yet, check explicitly among its components,
|
||||
-- because the Has_Controlled_Component flag is not necessarily set.
|
||||
function Needs_Finalization (Typ : Entity_Id) return Boolean is
|
||||
function Has_Some_Controlled_Component
|
||||
(Input_Typ : Entity_Id) return Boolean;
|
||||
-- Determine whether type Input_Typ has at least one controlled
|
||||
-- component.
|
||||
|
||||
-----------------------------------
|
||||
-- Has_Some_Controlled_Component --
|
||||
-----------------------------------
|
||||
|
||||
function Has_Some_Controlled_Component
|
||||
(Rec : Entity_Id) return Boolean
|
||||
(Input_Typ : Entity_Id) return Boolean
|
||||
is
|
||||
Comp : Entity_Id;
|
||||
|
||||
begin
|
||||
if Has_Controlled_Component (Rec) then
|
||||
-- When a type is already frozen and has at least one controlled
|
||||
-- component, or is manually decorated, it is sufficient to inspect
|
||||
-- flag Has_Controlled_Component.
|
||||
|
||||
if Has_Controlled_Component (Input_Typ) then
|
||||
return True;
|
||||
|
||||
elsif not Is_Frozen (Rec) then
|
||||
if Is_Record_Type (Rec) then
|
||||
Comp := First_Entity (Rec);
|
||||
-- Otherwise inspect the internals of the type
|
||||
|
||||
elsif not Is_Frozen (Input_Typ) then
|
||||
if Is_Array_Type (Input_Typ) then
|
||||
return Needs_Finalization (Component_Type (Input_Typ));
|
||||
|
||||
elsif Is_Record_Type (Input_Typ) then
|
||||
Comp := First_Component (Input_Typ);
|
||||
while Present (Comp) loop
|
||||
if not Is_Type (Comp)
|
||||
and then Needs_Finalization (Etype (Comp))
|
||||
then
|
||||
if Needs_Finalization (Etype (Comp)) then
|
||||
return True;
|
||||
end if;
|
||||
|
||||
Next_Entity (Comp);
|
||||
Next_Component (Comp);
|
||||
end loop;
|
||||
|
||||
return False;
|
||||
|
||||
else
|
||||
return
|
||||
Is_Array_Type (Rec)
|
||||
and then Needs_Finalization (Component_Type (Rec));
|
||||
end if;
|
||||
else
|
||||
return False;
|
||||
end if;
|
||||
|
||||
return False;
|
||||
end Has_Some_Controlled_Component;
|
||||
|
||||
-- Start of processing for Needs_Finalization
|
||||
|
@ -10349,32 +10349,34 @@ package body Exp_Util is
|
|||
if Restriction_Active (No_Finalization) then
|
||||
return False;
|
||||
|
||||
-- C++ types are not considered controlled. It is assumed that the
|
||||
-- non-Ada side will handle their clean up.
|
||||
-- C++ types are not considered controlled. It is assumed that the non-
|
||||
-- Ada side will handle their clean up.
|
||||
|
||||
elsif Convention (T) = Convention_CPP then
|
||||
elsif Convention (Typ) = Convention_CPP then
|
||||
return False;
|
||||
|
||||
-- Never needs finalization if Disable_Controlled set
|
||||
-- Class-wide types are treated as controlled because derivations from
|
||||
-- the root type may introduce controlled components.
|
||||
|
||||
elsif Disable_Controlled (T) then
|
||||
return False;
|
||||
elsif Is_Class_Wide_Type (Typ) then
|
||||
return True;
|
||||
|
||||
elsif Is_Class_Wide_Type (T) and then Disable_Controlled (Etype (T)) then
|
||||
return False;
|
||||
-- Concurrent types are controlled as long as their corresponding record
|
||||
-- is controlled.
|
||||
|
||||
elsif Is_Concurrent_Type (Typ)
|
||||
and then Present (Corresponding_Record_Type (Typ))
|
||||
and then Needs_Finalization (Corresponding_Record_Type (Typ))
|
||||
then
|
||||
return True;
|
||||
|
||||
-- Otherwise the type is controlled when it is either derived from type
|
||||
-- [Limited_]Controlled and not subject to aspect Disable_Controlled, or
|
||||
-- contains at least one controlled component.
|
||||
|
||||
else
|
||||
-- Class-wide types are treated as controlled because derivations
|
||||
-- from the root type can introduce controlled components.
|
||||
|
||||
return
|
||||
Is_Class_Wide_Type (T)
|
||||
or else Is_Controlled (T)
|
||||
or else Has_Some_Controlled_Component (T)
|
||||
or else
|
||||
(Is_Concurrent_Type (T)
|
||||
and then Present (Corresponding_Record_Type (T))
|
||||
and then Needs_Finalization (Corresponding_Record_Type (T)));
|
||||
Is_Controlled (Typ) or else Has_Some_Controlled_Component (Typ);
|
||||
end if;
|
||||
end Needs_Finalization;
|
||||
|
||||
|
@ -10387,7 +10389,6 @@ package body Exp_Util is
|
|||
Typ : Entity_Id) return Boolean
|
||||
is
|
||||
begin
|
||||
|
||||
-- If we have no initialization of any kind, then we don't need to place
|
||||
-- any restrictions on the address clause, because the object will be
|
||||
-- elaborated after the address clause is evaluated. This happens if the
|
||||
|
|
|
@ -924,11 +924,9 @@ package Exp_Util is
|
|||
-- consist of constants, when the object has a nontrivial initialization
|
||||
-- or is controlled.
|
||||
|
||||
function Needs_Finalization (T : Entity_Id) return Boolean;
|
||||
-- True if type T is controlled, or has controlled subcomponents. Also
|
||||
-- True if T is a class-wide type, because some type extension might add
|
||||
-- controlled subcomponents, except that if pragma Restrictions
|
||||
-- (No_Finalization) applies, this is False for class-wide types.
|
||||
function Needs_Finalization (Typ : Entity_Id) return Boolean;
|
||||
-- Determine whether type Typ is controlled and this requires finalization
|
||||
-- actions.
|
||||
|
||||
function Non_Limited_Designated_Type (T : Entity_Id) return Entity_Id;
|
||||
-- An anonymous access type may designate a limited view. Check whether
|
||||
|
|
|
@ -2574,7 +2574,7 @@ package body Freeze is
|
|||
|
||||
-- Propagate flags for component type
|
||||
|
||||
if Is_Controlled_Active (Component_Type (Arr))
|
||||
if Is_Controlled (Component_Type (Arr))
|
||||
or else Has_Controlled_Component (Ctyp)
|
||||
then
|
||||
Set_Has_Controlled_Component (Arr);
|
||||
|
@ -4508,7 +4508,7 @@ package body Freeze is
|
|||
(Has_Controlled_Component (Etype (Comp))
|
||||
or else
|
||||
(Chars (Comp) /= Name_uParent
|
||||
and then Is_Controlled_Active (Etype (Comp)))
|
||||
and then Is_Controlled (Etype (Comp)))
|
||||
or else
|
||||
(Is_Protected_Type (Etype (Comp))
|
||||
and then
|
||||
|
|
|
@ -1595,6 +1595,9 @@ package body Sem_Ch13 is
|
|||
procedure Analyze_Aspect_Convention;
|
||||
-- Perform analysis of aspect Convention
|
||||
|
||||
procedure Analyze_Aspect_Disable_Controlled;
|
||||
-- Perform analysis of aspect Disable_Controlled
|
||||
|
||||
procedure Analyze_Aspect_Export_Import;
|
||||
-- Perform analysis of aspects Export or Import
|
||||
|
||||
|
@ -1678,6 +1681,60 @@ package body Sem_Ch13 is
|
|||
end if;
|
||||
end Analyze_Aspect_Convention;
|
||||
|
||||
---------------------------------------
|
||||
-- Analyze_Aspect_Disable_Controlled --
|
||||
---------------------------------------
|
||||
|
||||
procedure Analyze_Aspect_Disable_Controlled is
|
||||
begin
|
||||
-- The aspect applies only to controlled records
|
||||
|
||||
if not (Ekind (E) = E_Record_Type
|
||||
and then Is_Controlled_Active (E))
|
||||
then
|
||||
Error_Msg_N
|
||||
("aspect % requires controlled record type", Aspect);
|
||||
return;
|
||||
end if;
|
||||
|
||||
-- Preanalyze the expression (if any) when the aspect resides
|
||||
-- in a generic unit.
|
||||
|
||||
if Inside_A_Generic then
|
||||
if Present (Expr) then
|
||||
Preanalyze_And_Resolve (Expr, Any_Boolean);
|
||||
end if;
|
||||
|
||||
-- Otherwise the aspect resides in a nongeneric context
|
||||
|
||||
else
|
||||
-- A controlled record type loses its controlled semantics
|
||||
-- when the expression statically evaluates to True.
|
||||
|
||||
if Present (Expr) then
|
||||
Analyze_And_Resolve (Expr, Any_Boolean);
|
||||
|
||||
if Is_OK_Static_Expression (Expr) then
|
||||
if Is_True (Static_Boolean (Expr)) then
|
||||
Set_Disable_Controlled (E);
|
||||
end if;
|
||||
|
||||
-- Otherwise the expression is not static
|
||||
|
||||
else
|
||||
Error_Msg_N
|
||||
("expression of aspect % must be static", Aspect);
|
||||
end if;
|
||||
|
||||
-- Otherwise the aspect appears without an expression and
|
||||
-- defaults to True.
|
||||
|
||||
else
|
||||
Set_Disable_Controlled (E);
|
||||
end if;
|
||||
end if;
|
||||
end Analyze_Aspect_Disable_Controlled;
|
||||
|
||||
----------------------------------
|
||||
-- Analyze_Aspect_Export_Import --
|
||||
----------------------------------
|
||||
|
@ -3468,34 +3525,7 @@ package body Sem_Ch13 is
|
|||
-- Disable_Controlled
|
||||
|
||||
elsif A_Id = Aspect_Disable_Controlled then
|
||||
if Ekind (E) /= E_Record_Type
|
||||
or else not Is_Controlled (E)
|
||||
then
|
||||
Error_Msg_N
|
||||
("aspect % requires controlled record type", Aspect);
|
||||
goto Continue;
|
||||
end if;
|
||||
|
||||
-- If we're in a generic template, we don't want to try
|
||||
-- to disable controlled types, because typical usage is
|
||||
-- "Disable_Controlled => not <some_check>'Enabled", and
|
||||
-- the value of Enabled is not known until we see a
|
||||
-- particular instance. In such a context, we just need
|
||||
-- to preanalyze the expression for legality.
|
||||
|
||||
if Expander_Active then
|
||||
Analyze_And_Resolve (Expr, Standard_Boolean);
|
||||
|
||||
if not Present (Expr)
|
||||
or else Is_True (Static_Boolean (Expr))
|
||||
then
|
||||
Set_Disable_Controlled (E);
|
||||
end if;
|
||||
|
||||
elsif Serious_Errors_Detected = 0 then
|
||||
Preanalyze_And_Resolve (Expr, Standard_Boolean);
|
||||
end if;
|
||||
|
||||
Analyze_Aspect_Disable_Controlled;
|
||||
goto Continue;
|
||||
end if;
|
||||
|
||||
|
@ -10839,8 +10869,8 @@ package body Sem_Ch13 is
|
|||
|
||||
E : constant Entity_Id := Entity (N);
|
||||
|
||||
Non_Generic_Case : constant Boolean := Nkind (N) = N_Freeze_Entity;
|
||||
-- True in non-generic case. Some of the processing here is skipped
|
||||
Nongeneric_Case : constant Boolean := Nkind (N) = N_Freeze_Entity;
|
||||
-- True in nongeneric case. Some of the processing here is skipped
|
||||
-- for the generic case since it is not needed. Basically in the
|
||||
-- generic case, we only need to do stuff that might generate error
|
||||
-- messages or warnings.
|
||||
|
@ -10867,7 +10897,7 @@ package body Sem_Ch13 is
|
|||
-- This is not needed in the generic case
|
||||
|
||||
if Ada_Version >= Ada_2005
|
||||
and then Non_Generic_Case
|
||||
and then Nongeneric_Case
|
||||
and then Ekind (E) = E_Record_Type
|
||||
and then Is_Tagged_Type (E)
|
||||
and then not Is_Interface (E)
|
||||
|
@ -11003,7 +11033,7 @@ package body Sem_Ch13 is
|
|||
-- predefined primitives.
|
||||
|
||||
if Is_Type (E)
|
||||
and then Non_Generic_Case
|
||||
and then Nongeneric_Case
|
||||
and then not Within_Internal_Subprogram
|
||||
and then Has_Predicates (E)
|
||||
then
|
||||
|
@ -11019,7 +11049,7 @@ package body Sem_Ch13 is
|
|||
|
||||
-- This is also not needed in the generic case
|
||||
|
||||
if Non_Generic_Case
|
||||
if Nongeneric_Case
|
||||
and then Has_Delayed_Aspects (E)
|
||||
and then Scope (E) = Current_Scope
|
||||
then
|
||||
|
|
|
@ -4848,7 +4848,7 @@ package body Sem_Ch3 is
|
|||
and then not Is_Constrained (Underlying_Type (T))
|
||||
and then not Is_Aliased (Id)
|
||||
and then not Is_Class_Wide_Type (T)
|
||||
and then not Is_Controlled_Active (T)
|
||||
and then not Is_Controlled (T)
|
||||
and then not Has_Controlled_Component (Base_Type (T))
|
||||
and then Expander_Active
|
||||
then
|
||||
|
@ -6157,7 +6157,7 @@ package body Sem_Ch3 is
|
|||
Set_Has_Controlled_Component
|
||||
(Implicit_Base,
|
||||
Has_Controlled_Component (Element_Type)
|
||||
or else Is_Controlled_Active (Element_Type));
|
||||
or else Is_Controlled (Element_Type));
|
||||
Set_Packed_Array_Impl_Type
|
||||
(Implicit_Base, Empty);
|
||||
|
||||
|
@ -6178,7 +6178,7 @@ package body Sem_Ch3 is
|
|||
Set_Has_Controlled_Component (T, Has_Controlled_Component
|
||||
(Element_Type)
|
||||
or else
|
||||
Is_Controlled_Active (Element_Type));
|
||||
Is_Controlled (Element_Type));
|
||||
Set_Finalize_Storage_Only (T, Finalize_Storage_Only
|
||||
(Element_Type));
|
||||
Set_Default_SSO (T);
|
||||
|
@ -7897,18 +7897,21 @@ package body Sem_Ch3 is
|
|||
Error_Msg_N ("cannot add discriminants to untagged type", N);
|
||||
end if;
|
||||
|
||||
Set_Stored_Constraint (Derived_Type, No_Elist);
|
||||
Set_Is_Constrained (Derived_Type, Is_Constrained (Parent_Type));
|
||||
Set_Is_Controlled (Derived_Type, Is_Controlled (Parent_Type));
|
||||
Set_Disable_Controlled (Derived_Type, Disable_Controlled
|
||||
(Parent_Type));
|
||||
Set_Stored_Constraint (Derived_Type, No_Elist);
|
||||
Set_Is_Constrained (Derived_Type, Is_Constrained (Parent_Type));
|
||||
|
||||
Set_Is_Controlled_Active
|
||||
(Derived_Type, Is_Controlled_Active (Parent_Type));
|
||||
|
||||
Set_Disable_Controlled
|
||||
(Derived_Type, Disable_Controlled (Parent_Type));
|
||||
|
||||
Set_Has_Controlled_Component
|
||||
(Derived_Type, Has_Controlled_Component
|
||||
(Parent_Type));
|
||||
(Derived_Type, Has_Controlled_Component (Parent_Type));
|
||||
|
||||
-- Direct controlled types do not inherit Finalize_Storage_Only flag
|
||||
|
||||
if not Is_Controlled_Active (Parent_Type) then
|
||||
if not Is_Controlled (Parent_Type) then
|
||||
Set_Finalize_Storage_Only
|
||||
(Base_Type (Derived_Type), Finalize_Storage_Only (Parent_Type));
|
||||
end if;
|
||||
|
@ -9206,9 +9209,10 @@ package body Sem_Ch3 is
|
|||
and then Chars (Scope (Scope (Derived_Type))) = Name_Ada
|
||||
and then Scope (Scope (Scope (Derived_Type))) = Standard_Standard
|
||||
then
|
||||
Set_Is_Controlled (Derived_Type);
|
||||
Set_Is_Controlled_Active (Derived_Type);
|
||||
else
|
||||
Set_Is_Controlled (Derived_Type, Is_Controlled (Parent_Base));
|
||||
Set_Is_Controlled_Active
|
||||
(Derived_Type, Is_Controlled_Active (Parent_Base));
|
||||
end if;
|
||||
|
||||
-- Minor optimization: there is no need to generate the class-wide
|
||||
|
@ -9475,19 +9479,20 @@ package body Sem_Ch3 is
|
|||
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));
|
||||
Propagate_Concurrent_Flags (Derived_Type, Parent_Base);
|
||||
|
||||
Set_Size_Info (Derived_Type, Parent_Type);
|
||||
Set_RM_Size (Derived_Type, RM_Size (Parent_Type));
|
||||
Set_Is_Controlled (Derived_Type, Is_Controlled (Parent_Type));
|
||||
Set_Disable_Controlled (Derived_Type, Disable_Controlled (Parent_Type));
|
||||
Set_Size_Info (Derived_Type, Parent_Type);
|
||||
Set_RM_Size (Derived_Type, RM_Size (Parent_Type));
|
||||
|
||||
Set_Is_Tagged_Type (Derived_Type, Is_Tagged_Type (Parent_Type));
|
||||
Set_Is_Volatile (Derived_Type, Is_Volatile (Parent_Type));
|
||||
Set_Is_Controlled_Active
|
||||
(Derived_Type, Is_Controlled_Active (Parent_Type));
|
||||
|
||||
Set_Disable_Controlled (Derived_Type, Disable_Controlled (Parent_Type));
|
||||
Set_Is_Tagged_Type (Derived_Type, Is_Tagged_Type (Parent_Type));
|
||||
Set_Is_Volatile (Derived_Type, Is_Volatile (Parent_Type));
|
||||
|
||||
if Is_Tagged_Type (Derived_Type) then
|
||||
Set_No_Tagged_Streams_Pragma
|
||||
|
@ -21799,7 +21804,7 @@ package body Sem_Ch3 is
|
|||
end;
|
||||
end if;
|
||||
|
||||
Final_Storage_Only := not Is_Controlled_Active (T);
|
||||
Final_Storage_Only := not Is_Controlled (T);
|
||||
|
||||
-- Ada 2005: Check whether an explicit Limited is present in a derived
|
||||
-- type declaration.
|
||||
|
@ -21859,8 +21864,7 @@ package body Sem_Ch3 is
|
|||
elsif not Is_Class_Wide_Equivalent_Type (T)
|
||||
and then (Has_Controlled_Component (Etype (Component))
|
||||
or else (Chars (Component) /= Name_uParent
|
||||
and then Is_Controlled_Active
|
||||
(Etype (Component))))
|
||||
and then Is_Controlled (Etype (Component))))
|
||||
then
|
||||
Set_Has_Controlled_Component (T, True);
|
||||
Final_Storage_Only :=
|
||||
|
|
|
@ -2644,7 +2644,8 @@ package body Sem_Ch7 is
|
|||
end if;
|
||||
|
||||
if Priv_Is_Base_Type then
|
||||
Set_Is_Controlled (Priv, Is_Controlled (Full_Base));
|
||||
Set_Is_Controlled_Active
|
||||
(Priv, Is_Controlled_Active (Full_Base));
|
||||
Set_Finalize_Storage_Only
|
||||
(Priv, Finalize_Storage_Only (Full_Base));
|
||||
Set_Has_Controlled_Component
|
||||
|
|
|
@ -6013,6 +6013,7 @@ package body Sem_Ch8 is
|
|||
and then Ekind (Scope (Id)) = E_Package
|
||||
and then Ekind (Id) = E_Package
|
||||
and then Renamed_Entity (Id) = Scope (Id)
|
||||
and then Is_Immediately_Visible (P_Name)
|
||||
then
|
||||
Is_New_Candidate := True;
|
||||
|
||||
|
|
Loading…
Reference in New Issue