From 8926c29c5f512203b6ed6e1e944738fc0a6f0c4c Mon Sep 17 00:00:00 2001 From: Bob Duff Date: Thu, 22 Apr 2021 14:07:34 -0400 Subject: [PATCH] [Ada] Refactoring related to Returns_By_Ref gcc/ada/ * sem_util.ads, sem_util.adb (Compute_Returns_By_Ref): New procedure to compute Returns_By_Ref, to avoid some code duplication. This will likely change soon, so it's good to have the code in one place. (CW_Or_Has_Controlled_Part): Move here from Exp_Ch7, because it's called by Compute_Returns_By_Ref, and this is a better place for it anyway. (Needs_Finalization): Fix comment to be vague instead of wrong. * exp_ch6.adb (Expand_N_Subprogram_Body, Freeze_Subprogram): Call Compute_Returns_By_Ref. * sem_ch6.adb (Check_Delayed_Subprogram): Call Compute_Returns_By_Ref. * exp_ch7.ads, exp_ch7.adb (CW_Or_Has_Controlled_Part): Move to Sem_Util. (Has_New_Controlled_Component): Remove unused function. --- gcc/ada/exp_ch6.adb | 26 ++------------------------ gcc/ada/exp_ch7.adb | 40 ---------------------------------------- gcc/ada/exp_ch7.ads | 11 ----------- gcc/ada/sem_ch6.adb | 14 +------------- gcc/ada/sem_util.adb | 26 ++++++++++++++++++++++++++ gcc/ada/sem_util.ads | 12 ++++++++++-- 6 files changed, 39 insertions(+), 90 deletions(-) diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index b81216fb0c73..3542411f4009 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -6431,18 +6431,7 @@ package body Exp_Ch6 is -- Returns_By_Ref flag is normally set when the subprogram is frozen but -- subprograms with no specs are not frozen. - declare - Typ : constant Entity_Id := Etype (Spec_Id); - Utyp : constant Entity_Id := Underlying_Type (Typ); - - begin - if Is_Limited_View (Typ) then - Set_Returns_By_Ref (Spec_Id); - - elsif Present (Utyp) and then CW_Or_Has_Controlled_Part (Utyp) then - Set_Returns_By_Ref (Spec_Id); - end if; - end; + Compute_Returns_By_Ref (Spec_Id); -- For a procedure, we add a return for all possible syntactic ends of -- the subprogram. @@ -7851,18 +7840,7 @@ package body Exp_Ch6 is -- of the normal semantic analysis of the spec since the underlying -- returned type may not be known yet (for private types). - declare - Typ : constant Entity_Id := Etype (Subp); - Utyp : constant Entity_Id := Underlying_Type (Typ); - - begin - if Is_Limited_View (Typ) then - Set_Returns_By_Ref (Subp); - - elsif Present (Utyp) and then CW_Or_Has_Controlled_Part (Utyp) then - Set_Returns_By_Ref (Subp); - end if; - end; + Compute_Returns_By_Ref (Subp); -- Wnen freezing a null procedure, analyze its delayed aspects now -- because we may not have reached the end of the declarative list when diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index a534370db028..469c9fbfb88f 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -5118,15 +5118,6 @@ package body Exp_Ch7 is end if; end Convert_View; - ------------------------------- - -- CW_Or_Has_Controlled_Part -- - ------------------------------- - - function CW_Or_Has_Controlled_Part (T : Entity_Id) return Boolean is - begin - return Is_Class_Wide_Type (T) or else Needs_Finalization (T); - end CW_Or_Has_Controlled_Part; - ------------------------ -- Enclosing_Function -- ------------------------ @@ -6130,37 +6121,6 @@ package body Exp_Ch7 is return Empty; end Find_Transient_Context; - ---------------------------------- - -- Has_New_Controlled_Component -- - ---------------------------------- - - function Has_New_Controlled_Component (E : Entity_Id) return Boolean is - Comp : Entity_Id; - - begin - if not Is_Tagged_Type (E) then - return Has_Controlled_Component (E); - elsif not Is_Derived_Type (E) then - return Has_Controlled_Component (E); - end if; - - Comp := First_Component (E); - while Present (Comp) loop - if Chars (Comp) = Name_uParent then - null; - - elsif Scope (Original_Record_Component (Comp)) = E - and then Needs_Finalization (Etype (Comp)) - then - return True; - end if; - - Next_Component (Comp); - end loop; - - return False; - end Has_New_Controlled_Component; - --------------------------------- -- Has_Simple_Protected_Object -- --------------------------------- diff --git a/gcc/ada/exp_ch7.ads b/gcc/ada/exp_ch7.ads index 62fdb8abb29d..ef1bf675c267 100644 --- a/gcc/ada/exp_ch7.ads +++ b/gcc/ada/exp_ch7.ads @@ -153,17 +153,6 @@ package Exp_Ch7 is -- triggered by an abort, E_Id denotes the defining identifier of a local -- exception occurrence, Raised_Id is the entity of a local boolean flag. - function CW_Or_Has_Controlled_Part (T : Entity_Id) return Boolean; - -- True if T is a class-wide type, or if it has controlled parts ("part" - -- means T or any of its subcomponents). Same as Needs_Finalization, except - -- when pragma Restrictions (No_Finalization) applies, in which case we - -- know that class-wide objects do not contain controlled parts. - - function Has_New_Controlled_Component (E : Entity_Id) return Boolean; - -- E is a type entity. Give the same result as Has_Controlled_Component - -- except for tagged extensions where the result is True only if the - -- latest extension contains a controlled component. - function Make_Adjust_Call (Obj_Ref : Node_Id; Typ : Entity_Id; diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index c361acc49373..ffab332f82d5 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -36,7 +36,6 @@ with Errout; use Errout; with Expander; use Expander; with Exp_Ch3; use Exp_Ch3; with Exp_Ch6; use Exp_Ch6; -with Exp_Ch7; use Exp_Ch7; with Exp_Ch9; use Exp_Ch9; with Exp_Dbug; use Exp_Dbug; with Exp_Tss; use Exp_Tss; @@ -6748,18 +6747,7 @@ package body Sem_Ch6 is -- may not be known yet (for private types). if not Has_Delayed_Freeze (Designator) and then Expander_Active then - declare - Typ : constant Entity_Id := Etype (Designator); - Utyp : constant Entity_Id := Underlying_Type (Typ); - - begin - if Is_Limited_View (Typ) then - Set_Returns_By_Ref (Designator); - - elsif Present (Utyp) and then CW_Or_Has_Controlled_Part (Utyp) then - Set_Returns_By_Ref (Designator); - end if; - end; + Compute_Returns_By_Ref (Designator); end if; end Check_Delayed_Subprogram; diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index a54326805e5b..e7e0c8443016 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -6672,6 +6672,23 @@ package body Sem_Util is return N; end Compile_Time_Constraint_Error; + ---------------------------- + -- Compute_Returns_By_Ref -- + ---------------------------- + + procedure Compute_Returns_By_Ref (Func : Entity_Id) is + Typ : constant Entity_Id := Etype (Func); + Utyp : constant Entity_Id := Underlying_Type (Typ); + + begin + if Is_Limited_View (Typ) then + Set_Returns_By_Ref (Func); + + elsif Present (Utyp) and then CW_Or_Has_Controlled_Part (Utyp) then + Set_Returns_By_Ref (Func); + end if; + end Compute_Returns_By_Ref; + -------------------------------- -- Collect_Types_In_Hierarchy -- -------------------------------- @@ -7072,6 +7089,15 @@ package body Sem_Util is end if; end Current_Subprogram; + ------------------------------- + -- CW_Or_Has_Controlled_Part -- + ------------------------------- + + function CW_Or_Has_Controlled_Part (T : Entity_Id) return Boolean is + begin + return Is_Class_Wide_Type (T) or else Needs_Finalization (T); + end CW_Or_Has_Controlled_Part; + ------------------------------- -- Deepest_Type_Access_Level -- ------------------------------- diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 10375ff9563f..9f15f4406138 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -582,6 +582,9 @@ package Sem_Util is -- emitted immediately after the main message (and before output of any -- message indicating that Constraint_Error will be raised). + procedure Compute_Returns_By_Ref (Func : Entity_Id); + -- Set the Returns_By_Ref flag on Func if appropriate + generic with function Predicate (Typ : Entity_Id) return Boolean; function Collect_Types_In_Hierarchy @@ -653,6 +656,12 @@ package Sem_Util is -- Current_Scope is returned. The returned value is Empty if this is called -- from a library package which is not within any subprogram. + function CW_Or_Has_Controlled_Part (T : Entity_Id) return Boolean; + -- True if T is a class-wide type, or if it has controlled parts ("part" + -- means T or any of its subcomponents). Same as Needs_Finalization, except + -- when pragma Restrictions (No_Finalization) applies, in which case we + -- know that class-wide objects do not contain controlled parts. + function Deepest_Type_Access_Level (Typ : Entity_Id) return Uint; -- Same as Type_Access_Level, except that if the type is the type of an Ada -- 2012 stand-alone object of an anonymous access type, then return the @@ -2556,8 +2565,7 @@ package Sem_Util is -- entity E. If no such instance exits, return Empty. function Needs_Finalization (Typ : Entity_Id) return Boolean; - -- Determine whether type Typ is controlled and thus requires finalization - -- actions. + -- True if Typ requires finalization actions function Needs_One_Actual (E : Entity_Id) return Boolean; -- Returns True if a function has defaults for all but its first formal, -- 2.47.2