diff options
author | Pierre-Marie de Rodat <pmderodat@gcc.gnu.org> | 2017-09-13 09:53:05 +0000 |
---|---|---|
committer | Pierre-Marie de Rodat <pmderodat@gcc.gnu.org> | 2017-09-13 09:53:05 +0000 |
commit | 0cb81445f403aa2b24813e6dd8df6f84314f2aa7 (patch) | |
tree | 12b7f017e97782cf79c630dfe7f78da7b790f7e6 | |
parent | caf3dcdf25eb77b655d7bdf8e55fff3eacd487f8 (diff) | |
download | gcc-0cb81445f403aa2b24813e6dd8df6f84314f2aa7.zip gcc-0cb81445f403aa2b24813e6dd8df6f84314f2aa7.tar.gz gcc-0cb81445f403aa2b24813e6dd8df6f84314f2aa7.tar.bz2 |
[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
-rw-r--r-- | gcc/ada/ChangeLog | 53 | ||||
-rw-r--r-- | gcc/ada/clean.adb | 2 | ||||
-rw-r--r-- | gcc/ada/einfo.adb | 24 | ||||
-rw-r--r-- | gcc/ada/einfo.ads | 35 | ||||
-rw-r--r-- | gcc/ada/exp_ch3.adb | 2 | ||||
-rw-r--r-- | gcc/ada/exp_util.adb | 83 | ||||
-rw-r--r-- | gcc/ada/exp_util.ads | 8 | ||||
-rw-r--r-- | gcc/ada/freeze.adb | 4 | ||||
-rw-r--r-- | gcc/ada/sem_ch13.adb | 96 | ||||
-rw-r--r-- | gcc/ada/sem_ch3.adb | 52 | ||||
-rw-r--r-- | gcc/ada/sem_ch7.adb | 3 | ||||
-rw-r--r-- | gcc/ada/sem_ch8.adb | 1 |
12 files changed, 226 insertions, 137 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index afa7b1b..4f04cc0 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -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. diff --git a/gcc/ada/clean.adb b/gcc/ada/clean.adb index b3ce560..2b3d033 100644 --- a/gcc/ada/clean.adb +++ b/gcc/ada/clean.adb @@ -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; diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index 435f816..21d8838 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -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)); diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 2270556..fa349cd 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -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); diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index b41754b..9ed8ea0 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -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; diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 05e0759..b8c528e 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -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. - else - -- Class-wide types are treated as controlled because derivations - -- from the root type can introduce controlled components. + 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 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 diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads index 70ae80b..9950058 100644 --- a/gcc/ada/exp_util.ads +++ b/gcc/ada/exp_util.ads @@ -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 diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index 7ed6ccd..cff742a 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -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 diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index a263c1f7..3ab8b35 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -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 diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 46d8349..803ff81 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -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 := diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb index 7b0761b..030d4f0 100644 --- a/gcc/ada/sem_ch7.adb +++ b/gcc/ada/sem_ch7.adb @@ -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 diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index f6ddc7f..8947841 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -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; |