mirror of
git://gcc.gnu.org/git/gcc.git
synced 2025-04-10 21:41:14 +08:00
[multiple changes]
2015-05-26 Robert Dewar <dewar@adacore.com> * aspects.ads, aspects.adb: Add aspect Disable_Controlled. * einfo.ads, einfo.adb (Disable_Controlled): New flag. (Is_Controlled_Active): New function. * exp_ch3.adb (Expand_Freeze_Record_Type): Use Is_Controlled_Active. * exp_util.adb (Needs_Finalization): Finalization not needed if Disable_Controlled set. * freeze.adb (Freeze_Array_Type): Do not set Has_Controlled_Component if the component has Disable_Controlled. (Freeze_Record_Type): ditto. * sem_ch13.adb (Decorate): Minor reformatting. (Analyze_Aspect_Specifications): Implement Disable_Controlled. * sem_ch3.adb (Analyze_Object_Declaration): Handle Disable_Controlled. (Array_Type_Declaration): ditto. (Build_Derived_Private_Type): ditto. (Build_Derived_Type): ditto. (Record_Type_Definition): ditto. * snames.ads-tmpl: Add Name_Disable_Controlled. 2015-05-26 Eric Botcazou <ebotcazou@adacore.com> * exp_ch6.adb (Expand_Actuals): Use a constant declaration instead of a renaming to capture the return value of a function call. (Expand_Simple_Function_Return): Call Remove_Side_Effects instead of removing side effects manually before the call to _Postconditions. From-SVN: r223667
This commit is contained in:
parent
2945460b98
commit
c859345327
@ -1,3 +1,33 @@
|
||||
2015-05-26 Robert Dewar <dewar@adacore.com>
|
||||
|
||||
* aspects.ads, aspects.adb: Add aspect Disable_Controlled.
|
||||
* einfo.ads, einfo.adb (Disable_Controlled): New flag.
|
||||
(Is_Controlled_Active): New function.
|
||||
* exp_ch3.adb (Expand_Freeze_Record_Type): Use
|
||||
Is_Controlled_Active.
|
||||
* exp_util.adb (Needs_Finalization): Finalization not needed
|
||||
if Disable_Controlled set.
|
||||
* freeze.adb (Freeze_Array_Type): Do not set
|
||||
Has_Controlled_Component if the component has Disable_Controlled.
|
||||
(Freeze_Record_Type): ditto.
|
||||
* sem_ch13.adb (Decorate): Minor reformatting.
|
||||
(Analyze_Aspect_Specifications): Implement Disable_Controlled.
|
||||
* sem_ch3.adb (Analyze_Object_Declaration): Handle
|
||||
Disable_Controlled.
|
||||
(Array_Type_Declaration): ditto.
|
||||
(Build_Derived_Private_Type): ditto.
|
||||
(Build_Derived_Type): ditto.
|
||||
(Record_Type_Definition): ditto.
|
||||
* snames.ads-tmpl: Add Name_Disable_Controlled.
|
||||
|
||||
2015-05-26 Eric Botcazou <ebotcazou@adacore.com>
|
||||
|
||||
* exp_ch6.adb (Expand_Actuals): Use a constant declaration instead
|
||||
of a renaming to capture the return value of a function call.
|
||||
(Expand_Simple_Function_Return): Call Remove_Side_Effects
|
||||
instead of removing side effects manually before the call to
|
||||
_Postconditions.
|
||||
|
||||
2015-05-26 Robert Dewar <dewar@adacore.com>
|
||||
|
||||
* exp_ch4.adb (Expand_N_Op_Expon): Deal with problem of wrong
|
||||
|
@ -517,6 +517,7 @@ package body Aspects is
|
||||
Aspect_Depends => Aspect_Depends,
|
||||
Aspect_Dimension => Aspect_Dimension,
|
||||
Aspect_Dimension_System => Aspect_Dimension_System,
|
||||
Aspect_Disable_Controlled => Aspect_Disable_Controlled,
|
||||
Aspect_Discard_Names => Aspect_Discard_Names,
|
||||
Aspect_Dispatching_Domain => Aspect_Dispatching_Domain,
|
||||
Aspect_Dynamic_Predicate => Aspect_Predicate,
|
||||
|
@ -171,6 +171,7 @@ package Aspects is
|
||||
Aspect_Asynchronous,
|
||||
Aspect_Atomic,
|
||||
Aspect_Atomic_Components,
|
||||
Aspect_Disable_Controlled, -- GNAT
|
||||
Aspect_Discard_Names,
|
||||
Aspect_Effective_Reads, -- GNAT
|
||||
Aspect_Effective_Writes, -- GNAT
|
||||
@ -414,6 +415,7 @@ package Aspects is
|
||||
Aspect_Depends => Name_Depends,
|
||||
Aspect_Dimension => Name_Dimension,
|
||||
Aspect_Dimension_System => Name_Dimension_System,
|
||||
Aspect_Disable_Controlled => Name_Disable_Controlled,
|
||||
Aspect_Discard_Names => Name_Discard_Names,
|
||||
Aspect_Dispatching_Domain => Name_Dispatching_Domain,
|
||||
Aspect_Dynamic_Predicate => Name_Dynamic_Predicate,
|
||||
@ -704,6 +706,7 @@ package Aspects is
|
||||
Aspect_Depends => Never_Delay,
|
||||
Aspect_Dimension => Never_Delay,
|
||||
Aspect_Dimension_System => Never_Delay,
|
||||
Aspect_Disable_Controlled => Never_Delay,
|
||||
Aspect_Effective_Reads => Never_Delay,
|
||||
Aspect_Effective_Writes => Never_Delay,
|
||||
Aspect_Extensions_Visible => Never_Delay,
|
||||
|
@ -558,6 +558,7 @@ package body Einfo is
|
||||
|
||||
-- Has_Implicit_Dereference Flag251
|
||||
-- Is_Processed_Transient Flag252
|
||||
-- Disable_Controlled Flag253
|
||||
-- Is_Implementation_Defined Flag254
|
||||
-- Is_Predicate_Function Flag255
|
||||
-- Is_Predicate_Function_M Flag256
|
||||
@ -595,7 +596,6 @@ package body Einfo is
|
||||
-- Is_Volatile_Full_Access Flag285
|
||||
-- Needs_Typedef Flag286
|
||||
|
||||
-- (unused) Flag253
|
||||
-- (unused) Flag287
|
||||
-- (unused) Flag288
|
||||
-- (unused) Flag289
|
||||
@ -1026,6 +1026,11 @@ package body Einfo is
|
||||
return Node20 (Id);
|
||||
end Directly_Designated_Type;
|
||||
|
||||
function Disable_Controlled (Id : E) return B is
|
||||
begin
|
||||
return Flag253 (Base_Type (Id));
|
||||
end Disable_Controlled;
|
||||
|
||||
function Discard_Names (Id : E) return B is
|
||||
begin
|
||||
return Flag88 (Id);
|
||||
@ -3941,6 +3946,12 @@ package body Einfo is
|
||||
Set_Node20 (Id, V);
|
||||
end Set_Directly_Designated_Type;
|
||||
|
||||
procedure Set_Disable_Controlled (Id : E; V : B := True) is
|
||||
begin
|
||||
pragma Assert (Is_Type (Id) and then Is_Base_Type (Id));
|
||||
Set_Flag253 (Id, V);
|
||||
end Set_Disable_Controlled;
|
||||
|
||||
procedure Set_Discard_Names (Id : E; V : B := True) is
|
||||
begin
|
||||
Set_Flag88 (Id, V);
|
||||
@ -7394,6 +7405,15 @@ 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 --
|
||||
--------------------------
|
||||
|
||||
function Is_Controlled_Active (Id : E) return B is
|
||||
begin
|
||||
return Is_Controlled (Id) and then not Disable_Controlled (Id);
|
||||
end Is_Controlled_Active;
|
||||
|
||||
--------------------
|
||||
-- Is_Discriminal --
|
||||
--------------------
|
||||
|
@ -911,6 +911,10 @@ package Einfo is
|
||||
-- Designated_Type obtains this full type in the case of access to an
|
||||
-- incomplete type.
|
||||
|
||||
-- Disable_Controlled (Flag253)
|
||||
-- Present in all entities. Set for controlled type (Is_Controlled flag
|
||||
-- set) if the aspect Disable_Controlled is active for the type.
|
||||
|
||||
-- Discard_Names (Flag88)
|
||||
-- Defined in types and exception entities. Set if pragma Discard_Names
|
||||
-- applies to the entity. It is also set for declarative regions and
|
||||
@ -2337,6 +2341,10 @@ package Einfo is
|
||||
-- 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_Controlling_Formal (Flag97)
|
||||
-- Defined in all Formal_Kind entities. Marks the controlling parameters
|
||||
-- of dispatching operations.
|
||||
@ -5413,6 +5421,7 @@ package Einfo is
|
||||
-- Linker_Section_Pragma (Node33)
|
||||
|
||||
-- Depends_On_Private (Flag14)
|
||||
-- Disable_Controlled (Flag253)
|
||||
-- Discard_Names (Flag88)
|
||||
-- Finalize_Storage_Only (Flag158) (base type only)
|
||||
-- From_Limited_With (Flag159)
|
||||
@ -5491,6 +5500,7 @@ package Einfo is
|
||||
-- Invariant_Procedure (synth)
|
||||
-- Is_Access_Protected_Subprogram_Type (synth)
|
||||
-- Is_Atomic_Or_VFA (synth)
|
||||
-- Is_Controlled_Active (synth)
|
||||
-- Predicate_Function (synth)
|
||||
-- Predicate_Function_M (synth)
|
||||
-- Root_Type (synth)
|
||||
@ -6724,6 +6734,7 @@ package Einfo is
|
||||
function Digits_Value (Id : E) return U;
|
||||
function Direct_Primitive_Operations (Id : E) return L;
|
||||
function Directly_Designated_Type (Id : E) return E;
|
||||
function Disable_Controlled (Id : E) return B;
|
||||
function Discard_Names (Id : E) return B;
|
||||
function Discriminal (Id : E) return E;
|
||||
function Discriminal_Link (Id : E) return E;
|
||||
@ -7206,6 +7217,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_Discriminal (Id : E) return B;
|
||||
function Is_Dynamic_Scope (Id : E) return B;
|
||||
function Is_External_State (Id : E) return B;
|
||||
@ -7380,6 +7392,7 @@ package Einfo is
|
||||
procedure Set_Digits_Value (Id : E; V : U);
|
||||
procedure Set_Direct_Primitive_Operations (Id : E; V : L);
|
||||
procedure Set_Directly_Designated_Type (Id : E; V : E);
|
||||
procedure Set_Disable_Controlled (Id : E; V : B := True);
|
||||
procedure Set_Discard_Names (Id : E; V : B := True);
|
||||
procedure Set_Discriminal (Id : E; V : E);
|
||||
procedure Set_Discriminal_Link (Id : E; V : E);
|
||||
@ -8155,6 +8168,7 @@ package Einfo is
|
||||
pragma Inline (Digits_Value);
|
||||
pragma Inline (Direct_Primitive_Operations);
|
||||
pragma Inline (Directly_Designated_Type);
|
||||
pragma Inline (Disable_Controlled);
|
||||
pragma Inline (Discard_Names);
|
||||
pragma Inline (Discriminal);
|
||||
pragma Inline (Discriminal_Link);
|
||||
@ -8658,6 +8672,7 @@ package Einfo is
|
||||
pragma Inline (Set_Digits_Value);
|
||||
pragma Inline (Set_Direct_Primitive_Operations);
|
||||
pragma Inline (Set_Directly_Designated_Type);
|
||||
pragma Inline (Set_Disable_Controlled);
|
||||
pragma Inline (Set_Discard_Names);
|
||||
pragma Inline (Set_Discriminal);
|
||||
pragma Inline (Set_Discriminal_Link);
|
||||
@ -9062,6 +9077,7 @@ package Einfo is
|
||||
|
||||
pragma Inline (Base_Type);
|
||||
pragma Inline (Is_Base_Type);
|
||||
pragma Inline (Is_Controlled_Active);
|
||||
pragma Inline (Is_Package_Or_Generic_Package);
|
||||
pragma Inline (Is_Packed_Array);
|
||||
pragma Inline (Is_Subprogram_Or_Generic_Subprogram);
|
||||
|
@ -6936,9 +6936,10 @@ package body Exp_Ch3 is
|
||||
-- type. See Make_CW_Equivalent_Type.
|
||||
|
||||
if not Is_Class_Wide_Equivalent_Type (Def_Id)
|
||||
and then (Has_Controlled_Component (Comp_Typ)
|
||||
or else (Chars (Comp) /= Name_uParent
|
||||
and then Is_Controlled (Comp_Typ)))
|
||||
and then
|
||||
(Has_Controlled_Component (Comp_Typ)
|
||||
or else (Chars (Comp) /= Name_uParent
|
||||
and then (Is_Controlled_Active (Comp_Typ))))
|
||||
then
|
||||
Set_Has_Controlled_Component (Def_Id);
|
||||
end if;
|
||||
|
@ -1979,7 +1979,7 @@ package body Exp_Ch6 is
|
||||
-- To deal with this, we replace the call by
|
||||
|
||||
-- do
|
||||
-- Tnnn : function-result-type renames function-call;
|
||||
-- Tnnn : constant function-result-type := function-call;
|
||||
-- Post_Call actions
|
||||
-- in
|
||||
-- Tnnn;
|
||||
@ -1996,10 +1996,11 @@ package body Exp_Ch6 is
|
||||
|
||||
begin
|
||||
Prepend_To (Post_Call,
|
||||
Make_Object_Renaming_Declaration (Loc,
|
||||
Make_Object_Declaration (Loc,
|
||||
Defining_Identifier => Tnnn,
|
||||
Subtype_Mark => New_Occurrence_Of (FRTyp, Loc),
|
||||
Name => Name));
|
||||
Object_Definition => New_Occurrence_Of (FRTyp, Loc),
|
||||
Constant_Present => True,
|
||||
Expression => Name));
|
||||
|
||||
Rewrite (N,
|
||||
Make_Expression_With_Actions (Loc,
|
||||
@ -6619,111 +6620,23 @@ package body Exp_Ch6 is
|
||||
if Ekind (Scope_Id) = E_Function
|
||||
and then Present (Postconditions_Proc (Scope_Id))
|
||||
then
|
||||
-- In the case of discriminated objects, we have created a
|
||||
-- constrained subtype above, and used the underlying type. This
|
||||
-- transformation is post-analysis and harmless, except that now the
|
||||
-- call to the post-condition will be analyzed and the type kinds
|
||||
-- have to match.
|
||||
|
||||
if Nkind (Exp) = N_Unchecked_Type_Conversion
|
||||
and then Is_Private_Type (R_Type) /= Is_Private_Type (Etype (Exp))
|
||||
then
|
||||
Rewrite (Exp, Expression (Relocate_Node (Exp)));
|
||||
end if;
|
||||
|
||||
-- We are going to reference the returned value twice in this case,
|
||||
-- once in the call to _Postconditions, and once in the actual return
|
||||
-- statement, but we can't have side effects happening twice, and in
|
||||
-- any case for efficiency we don't want to do the computation twice.
|
||||
-- statement, but we can't have side effects happening twice.
|
||||
|
||||
-- If the returned expression is an entity name, we don't need to
|
||||
-- worry since it is efficient and safe to reference it twice, that's
|
||||
-- also true for literals other than string literals, and for the
|
||||
-- case of X.all where X is an entity name.
|
||||
|
||||
if Is_Entity_Name (Exp)
|
||||
or else Nkind_In (Exp, N_Character_Literal,
|
||||
N_Integer_Literal,
|
||||
N_Real_Literal)
|
||||
or else (Nkind (Exp) = N_Explicit_Dereference
|
||||
and then Is_Entity_Name (Prefix (Exp)))
|
||||
then
|
||||
null;
|
||||
|
||||
-- Otherwise we are going to need a temporary to capture the value
|
||||
|
||||
else
|
||||
declare
|
||||
ExpR : Node_Id := Relocate_Node (Exp);
|
||||
Tnn : constant Entity_Id := Make_Temporary (Loc, 'T', ExpR);
|
||||
|
||||
begin
|
||||
-- In the case of discriminated objects, we have created a
|
||||
-- constrained subtype above, and used the underlying type.
|
||||
-- This transformation is post-analysis and harmless, except
|
||||
-- that now the call to the post-condition will be analyzed and
|
||||
-- type kinds have to match.
|
||||
|
||||
if Nkind (ExpR) = N_Unchecked_Type_Conversion
|
||||
and then
|
||||
Is_Private_Type (R_Type) /= Is_Private_Type (Etype (ExpR))
|
||||
then
|
||||
ExpR := Expression (ExpR);
|
||||
end if;
|
||||
|
||||
-- For a complex expression of an elementary type, capture
|
||||
-- value in the temporary and use it as the reference.
|
||||
|
||||
if Is_Elementary_Type (R_Type) then
|
||||
Insert_Action (Exp,
|
||||
Make_Object_Declaration (Loc,
|
||||
Defining_Identifier => Tnn,
|
||||
Constant_Present => True,
|
||||
Object_Definition => New_Occurrence_Of (R_Type, Loc),
|
||||
Expression => ExpR),
|
||||
Suppress => All_Checks);
|
||||
|
||||
Rewrite (Exp, New_Occurrence_Of (Tnn, Loc));
|
||||
|
||||
-- If we have something we can rename, generate a renaming of
|
||||
-- the object and replace the expression with a reference
|
||||
|
||||
elsif Is_Object_Reference (Exp) then
|
||||
Insert_Action (Exp,
|
||||
Make_Object_Renaming_Declaration (Loc,
|
||||
Defining_Identifier => Tnn,
|
||||
Subtype_Mark => New_Occurrence_Of (R_Type, Loc),
|
||||
Name => ExpR),
|
||||
Suppress => All_Checks);
|
||||
|
||||
Rewrite (Exp, New_Occurrence_Of (Tnn, Loc));
|
||||
|
||||
-- Otherwise we have something like a string literal or an
|
||||
-- aggregate. We could copy the value, but that would be
|
||||
-- inefficient. Instead we make a reference to the value and
|
||||
-- capture this reference with a renaming, the expression is
|
||||
-- then replaced by a dereference of this renaming.
|
||||
|
||||
else
|
||||
-- For now, copy the value, since the code below does not
|
||||
-- seem to work correctly ???
|
||||
|
||||
Insert_Action (Exp,
|
||||
Make_Object_Declaration (Loc,
|
||||
Defining_Identifier => Tnn,
|
||||
Constant_Present => True,
|
||||
Object_Definition => New_Occurrence_Of (R_Type, Loc),
|
||||
Expression => Relocate_Node (Exp)),
|
||||
Suppress => All_Checks);
|
||||
|
||||
Rewrite (Exp, New_Occurrence_Of (Tnn, Loc));
|
||||
|
||||
-- Insert_Action (Exp,
|
||||
-- Make_Object_Renaming_Declaration (Loc,
|
||||
-- Defining_Identifier => Tnn,
|
||||
-- Access_Definition =>
|
||||
-- Make_Access_Definition (Loc,
|
||||
-- All_Present => True,
|
||||
-- Subtype_Mark => New_Occurrence_Of (R_Type, Loc)),
|
||||
-- Name =>
|
||||
-- Make_Reference (Loc,
|
||||
-- Prefix => Relocate_Node (Exp))),
|
||||
-- Suppress => All_Checks);
|
||||
|
||||
-- Rewrite (Exp,
|
||||
-- Make_Explicit_Dereference (Loc,
|
||||
-- Prefix => New_Occurrence_Of (Tnn, Loc)));
|
||||
end if;
|
||||
end;
|
||||
end if;
|
||||
Remove_Side_Effects (Exp);
|
||||
|
||||
-- Generate call to _Postconditions
|
||||
|
||||
@ -6731,7 +6644,7 @@ package body Exp_Ch6 is
|
||||
Make_Procedure_Call_Statement (Loc,
|
||||
Name =>
|
||||
New_Occurrence_Of (Postconditions_Proc (Scope_Id), Loc),
|
||||
Parameter_Associations => New_List (Duplicate_Subexpr (Exp))));
|
||||
Parameter_Associations => New_List (New_Copy_Tree (Exp))));
|
||||
end if;
|
||||
|
||||
-- Ada 2005 (AI-251): If this return statement corresponds with an
|
||||
|
@ -6848,12 +6848,16 @@ package body Exp_Util is
|
||||
then
|
||||
return False;
|
||||
|
||||
-- Never needs finalization if Disable_Controlled set
|
||||
|
||||
elsif Disable_Controlled (T) then
|
||||
return False;
|
||||
|
||||
else
|
||||
-- Class-wide types are treated as controlled because derivations
|
||||
-- from the root type can introduce controlled components.
|
||||
|
||||
return
|
||||
Is_Class_Wide_Type (T)
|
||||
return Is_Class_Wide_Type (T)
|
||||
or else Is_Controlled (T)
|
||||
or else Has_Controlled_Component (T)
|
||||
or else Has_Some_Controlled_Component (T)
|
||||
|
@ -2226,7 +2226,7 @@ package body Freeze is
|
||||
|
||||
-- Propagate flags for component type
|
||||
|
||||
if Is_Controlled (Component_Type (Arr))
|
||||
if Is_Controlled_Active (Component_Type (Arr))
|
||||
or else Has_Controlled_Component (Ctyp)
|
||||
then
|
||||
Set_Has_Controlled_Component (Arr);
|
||||
@ -4106,7 +4106,7 @@ package body Freeze is
|
||||
(Has_Controlled_Component (Etype (Comp))
|
||||
or else
|
||||
(Chars (Comp) /= Name_uParent
|
||||
and then Is_Controlled (Etype (Comp)))
|
||||
and then Is_Controlled_Active (Etype (Comp)))
|
||||
or else
|
||||
(Is_Protected_Type (Etype (Comp))
|
||||
and then
|
||||
|
@ -1205,8 +1205,7 @@ package body Sem_Ch13 is
|
||||
|
||||
procedure Analyze_Aspect_Specifications (N : Node_Id; E : Entity_Id) is
|
||||
procedure Decorate (Asp : Node_Id; Prag : Node_Id);
|
||||
-- Establish linkages between an aspect and its corresponding
|
||||
-- pragma.
|
||||
-- Establish linkages between an aspect and its corresponding pragma
|
||||
|
||||
procedure Insert_After_SPARK_Mode
|
||||
(Prag : Node_Id;
|
||||
@ -1235,7 +1234,7 @@ package body Sem_Ch13 is
|
||||
|
||||
procedure Decorate (Asp : Node_Id; Prag : Node_Id) is
|
||||
begin
|
||||
Set_Aspect_Rep_Item (Asp, Prag);
|
||||
Set_Aspect_Rep_Item (Asp, Prag);
|
||||
Set_Corresponding_Aspect (Prag, Asp);
|
||||
Set_From_Aspect_Specification (Prag);
|
||||
Set_Parent (Prag, Asp);
|
||||
@ -3055,7 +3054,7 @@ package body Sem_Ch13 is
|
||||
-- Case 5: Special handling for aspects with an optional
|
||||
-- boolean argument.
|
||||
|
||||
-- In the general case, the corresponding pragma cannot be
|
||||
-- In the delayed case, the corresponding pragma cannot be
|
||||
-- generated yet because the evaluation of the boolean needs
|
||||
-- to be delayed till the freeze point.
|
||||
|
||||
@ -3144,6 +3143,25 @@ package body Sem_Ch13 is
|
||||
end if;
|
||||
end if;
|
||||
|
||||
goto Continue;
|
||||
|
||||
-- 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 not Present (Expr)
|
||||
or else Is_True (Static_Boolean (Expr))
|
||||
then
|
||||
Set_Disable_Controlled (E);
|
||||
end if;
|
||||
|
||||
goto Continue;
|
||||
end if;
|
||||
|
||||
|
@ -4386,7 +4386,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 (T)
|
||||
and then not Is_Controlled_Active (T)
|
||||
and then not Has_Controlled_Component (Base_Type (T))
|
||||
and then Expander_Active
|
||||
then
|
||||
@ -5614,7 +5614,7 @@ package body Sem_Ch3 is
|
||||
Set_Packed_Array_Impl_Type (Implicit_Base, Empty);
|
||||
Set_Has_Controlled_Component (Implicit_Base,
|
||||
Has_Controlled_Component (Element_Type)
|
||||
or else Is_Controlled (Element_Type));
|
||||
or else Is_Controlled_Active (Element_Type));
|
||||
Set_Finalize_Storage_Only (Implicit_Base,
|
||||
Finalize_Storage_Only (Element_Type));
|
||||
|
||||
@ -5640,7 +5640,7 @@ package body Sem_Ch3 is
|
||||
Set_Has_Controlled_Component (T, Has_Controlled_Component
|
||||
(Element_Type)
|
||||
or else
|
||||
Is_Controlled (Element_Type));
|
||||
Is_Controlled_Active (Element_Type));
|
||||
Set_Finalize_Storage_Only (T, Finalize_Storage_Only
|
||||
(Element_Type));
|
||||
Set_Default_SSO (T);
|
||||
@ -7351,16 +7351,18 @@ 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_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_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 (Parent_Type) then
|
||||
if not Is_Controlled_Active (Parent_Type) then
|
||||
Set_Finalize_Storage_Only
|
||||
(Base_Type (Derived_Type), Finalize_Storage_Only (Parent_Type));
|
||||
end if;
|
||||
@ -8974,16 +8976,18 @@ 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));
|
||||
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));
|
||||
Set_Has_Task (Derived_Type, Has_Task (Parent_Base));
|
||||
Set_Has_Protected (Derived_Type, Has_Protected (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_Controlled (Derived_Type, Is_Controlled (Parent_Type));
|
||||
Set_Is_Tagged_Type (Derived_Type, Is_Tagged_Type (Parent_Type));
|
||||
Set_Is_Volatile (Derived_Type, Is_Volatile (Parent_Type));
|
||||
|
||||
@ -21174,7 +21178,7 @@ package body Sem_Ch3 is
|
||||
end;
|
||||
end if;
|
||||
|
||||
Final_Storage_Only := not Is_Controlled (T);
|
||||
Final_Storage_Only := not Is_Controlled_Active (T);
|
||||
|
||||
-- Ada 2005: Check whether an explicit Limited is present in a derived
|
||||
-- type declaration.
|
||||
@ -21240,7 +21244,8 @@ 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 (Etype (Component))))
|
||||
and then Is_Controlled_Active
|
||||
(Etype (Component))))
|
||||
then
|
||||
Set_Has_Controlled_Component (T, True);
|
||||
Final_Storage_Only :=
|
||||
|
@ -141,6 +141,7 @@ package Snames is
|
||||
Name_Default_Component_Value : constant Name_Id := N + $;
|
||||
Name_Dimension : constant Name_Id := N + $;
|
||||
Name_Dimension_System : constant Name_Id := N + $;
|
||||
Name_Disable_Controlled : constant Name_Id := N + $;
|
||||
Name_Dynamic_Predicate : constant Name_Id := N + $;
|
||||
Name_Static_Predicate : constant Name_Id := N + $;
|
||||
Name_Synchronization : constant Name_Id := N + $;
|
||||
|
Loading…
x
Reference in New Issue
Block a user