From ebf494ec2813a1adf5e0b060b12da6864b8932dd Mon Sep 17 00:00:00 2001 From: Robert Dewar Date: Tue, 6 Sep 2011 07:56:50 +0000 Subject: [PATCH] sem_util.adb, [...]: Minor reformatting and code reorganization. 2011-09-06 Robert Dewar * sem_util.adb, exp_ch6.adb: Minor reformatting and code reorganization. From-SVN: r178568 --- gcc/ada/ChangeLog | 4 ++ gcc/ada/exp_ch6.adb | 95 ++++++++++++++++++++++++++------------------ gcc/ada/sem_util.adb | 40 +++++++++++-------- 3 files changed, 83 insertions(+), 56 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index f488cd7a39e..8d875b6de8d 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,7 @@ +2011-09-06 Robert Dewar + + * sem_util.adb, exp_ch6.adb: Minor reformatting and code reorganization. + 2011-09-06 Steve Baird * einfo.ads (Extra_Accessibility_Of_Result): New function; in the diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 4e986f70893..7c9ce179ace 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -2780,12 +2780,16 @@ package body Exp_Ch6 is case Nkind (Ancestor) is when N_Allocator => - -- Messy. - -- + + -- Messy code, could use a cleanup??? + -- At this point, we'd like to assign + -- Level := Dynamic_Accessibility_Level (Ancestor); + -- but Etype of Ancestor may not have been set yet, -- so that doesn't work. + -- Handle this later in Expand_Allocator_Expression. Defer := True; @@ -2794,6 +2798,7 @@ package body Exp_Ch6 is declare Def_Id : constant Entity_Id := Defining_Identifier (Ancestor); + begin if Is_Return_Object (Def_Id) then if Present (Extra_Accessibility_Of_Result @@ -2806,17 +2811,19 @@ package body Exp_Ch6 is Level := New_Occurrence_Of (Extra_Accessibility_Of_Result - (Return_Applies_To (Scope (Def_Id))), Loc); + (Return_Applies_To (Scope (Def_Id))), Loc); end if; else - Level := Make_Integer_Literal (Loc, - Object_Access_Level (Def_Id)); + Level := + Make_Integer_Literal (Loc, + Intval => Object_Access_Level (Def_Id)); end if; end; when N_Simple_Return_Statement => if Present (Extra_Accessibility_Of_Result - (Return_Applies_To (Return_Statement_Entity (Ancestor)))) + (Return_Applies_To + (Return_Statement_Entity (Ancestor)))) then -- Pass along value that was passed in if the routine -- we are returning from also has an @@ -2835,9 +2842,10 @@ package body Exp_Ch6 is if not Defer then if not Present (Level) then + -- The "innermost master that evaluates the function call". - -- - -- ??? - Shuld we use Integer'Last here instead + + -- ??? - Shpuld we use Integer'Last here instead -- in order to deal with (some of) the problems -- associated with calls to subps whose enclosing -- scope is unknown (e.g., Anon_Access_To_Subp_Param.all)? @@ -6268,6 +6276,7 @@ package body Exp_Ch6 is Next_Discriminant (Discr); end loop; end if; + return False; end Has_Unconstrained_Access_Discriminants; @@ -6715,16 +6724,19 @@ package body Exp_Ch6 is Make_Op_Ne (Loc, Left_Opnd => Duplicate_Subexpr (Exp), Right_Opnd => Make_Null (Loc)), + Right_Opnd => Make_Op_Ne (Loc, Left_Opnd => Make_Selected_Component (Loc, Prefix => Duplicate_Subexpr (Exp), Selector_Name => Make_Identifier (Loc, Name_uTag)), + Right_Opnd => Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Designated_Type (R_Type), Loc), Attribute_Name => Name_Tag))), + Reason => CE_Tag_Check_Failed), Suppress => All_Checks); end if; @@ -6737,11 +6749,11 @@ package body Exp_Ch6 is and then Has_Unconstrained_Access_Discriminants (R_Type) then declare - Discrim_Source : Node_Id := Exp; + Discrim_Source : Node_Id; procedure Check_Against_Result_Level (Level : Node_Id); - -- Check the given accessibility level against the - -- level determined by the point of call" (AI05-0234). + -- Check the given accessibility level against the level + -- determined by the point of call. (AI05-0234). -------------------------------- -- Check_Against_Result_Level -- @@ -6759,7 +6771,9 @@ package body Exp_Ch6 is (Extra_Accessibility_Of_Result (Scope_Id), Loc)), Reason => PE_Accessibility_Check_Failed)); end Check_Against_Result_Level; + begin + Discrim_Source := Exp; while Nkind (Discrim_Source) = N_Qualified_Expression loop Discrim_Source := Expression (Discrim_Source); end loop; @@ -6767,7 +6781,6 @@ package body Exp_Ch6 is if Nkind (Discrim_Source) = N_Identifier and then Is_Return_Object (Entity (Discrim_Source)) then - Discrim_Source := Entity (Discrim_Source); if Is_Constrained (Etype (Discrim_Source)) then @@ -6780,22 +6793,18 @@ package body Exp_Ch6 is and then Nkind_In (Original_Node (Discrim_Source), N_Aggregate, N_Extension_Aggregate) then - Discrim_Source := Original_Node (Discrim_Source); elsif Nkind (Discrim_Source) = N_Explicit_Dereference and then Nkind (Original_Node (Discrim_Source)) = N_Function_Call then - Discrim_Source := Original_Node (Discrim_Source); - end if; while Nkind_In (Discrim_Source, N_Qualified_Expression, N_Type_Conversion, N_Unchecked_Type_Conversion) loop - Discrim_Source := Expression (Discrim_Source); end loop; @@ -8268,9 +8277,9 @@ package body Exp_Ch6 is Func_Typ : constant Entity_Id := Underlying_Type (Etype (Func_Id)); function Has_Unconstrained_Access_Discriminant_Component - (Comp_Typ : Entity_Id) return Boolean; - -- Returns True if any component of the type has - -- an unconstrained access discriminant. + (Comp_Typ : Entity_Id) return Boolean; + -- Returns True if any component of the type has an unconstrained access + -- discriminant. ----------------------------------------------------- -- Has_Unconstrained_Access_Discriminant_Component -- @@ -8282,6 +8291,7 @@ package body Exp_Ch6 is begin if not Is_Limited_Type (Comp_Typ) then return False; + -- Only limited types can have access discriminants with -- defaults. @@ -8294,8 +8304,10 @@ package body Exp_Ch6 is elsif Is_Record_Type (Comp_Typ) then declare - Comp : Entity_Id := First_Component (Comp_Typ); + Comp : Entity_Id; + begin + Comp := First_Component (Comp_Typ); while Present (Comp) loop if Has_Unconstrained_Access_Discriminant_Component (Underlying_Type (Etype (Comp))) @@ -8314,32 +8326,36 @@ package body Exp_Ch6 is -- Start of processing for Needs_Result_Accessibility_Level begin - if not Present (Func_Typ) -- ??? completion unavailable + -- False if completion unavailable (how does this happen???) - or else Func_Typ = Standard_Void_Type -- not a function + if not Present (Func_Typ) then + return False; - or else Is_Scalar_Type (Func_Typ) -- handle enum-lit renames + -- False if not a function, also handle enum-lit renames case + + elsif Func_Typ = Standard_Void_Type + or else Is_Scalar_Type (Func_Typ) then return False; - end if; - if Present (Alias (Func_Id)) then - -- Handle a corner case, a cross-dialect subp renaming. For example, - -- an Ada2012 renaming of an Ada05 subprogram. This can occur when - -- a non-Ada2012 unit references predefined runtime units. - -- + -- Handle a corner case, a cross-dialect subp renaming. For example, + -- an Ada2012 renaming of an Ada05 subprogram. This can occur when a + -- non-Ada2012 unit references predefined runtime units. + + elsif Present (Alias (Func_Id)) then + -- Unimplemented: a cross-dialect subp renaming which does not set -- the Alias attribute (e.g., a rename of a dereference of an access -- to subprogram value). return Present (Extra_Accessibility_Of_Result (Alias (Func_Id))); - end if; - if Ada_Version < Ada_2012 then + -- Remaining cases require Ada 2012 mode + + elsif Ada_Version < Ada_2012 then return False; - end if; - if Ekind (Func_Typ) = E_Anonymous_Access_Type + elsif Ekind (Func_Typ) = E_Anonymous_Access_Type or else Is_Tagged_Type (Func_Typ) then -- In the case of, say, a null tagged record result type, the need @@ -8357,17 +8373,18 @@ package body Exp_Ch6 is -- wrappers, but that is not the approach that was chosen. return True; - end if; - if Has_Unconstrained_Access_Discriminants (Func_Typ) then + elsif Has_Unconstrained_Access_Discriminants (Func_Typ) then return True; - end if; - if Has_Unconstrained_Access_Discriminant_Component (Func_Typ) then + elsif Has_Unconstrained_Access_Discriminant_Component (Func_Typ) then return True; - end if; - return False; + -- False for all other cases + + else + return False; + end if; end Needs_Result_Accessibility_Level; end Exp_Ch6; diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index b573ba8ee00..f92eb064996 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -2880,20 +2880,22 @@ package body Sem_Util is Loc : constant Source_Ptr := Sloc (Expr); function Make_Level_Literal (Level : Uint) return Node_Id; - -- Construct an integer literal representing an accessibility level. + -- Construct an integer literal representing an accessibility level + -- with its type set to Natural. - --------------------------------- - -- function Make_Level_Literal -- - --------------------------------- + ------------------------ + -- Make_Level_Literal -- + ------------------------ function Make_Level_Literal (Level : Uint) return Node_Id is - Result : constant Node_Id := - Make_Integer_Literal (Loc, Level); + Result : constant Node_Id := Make_Integer_Literal (Loc, Level); begin Set_Etype (Result, Standard_Natural); return Result; end Make_Level_Literal; + -- Start of processing for Dynamic_Accessibility_Level + begin if Is_Entity_Name (Expr) then E := Entity (Expr); @@ -2909,16 +2911,17 @@ package body Sem_Util is end if; end if; - -- unimplemented: Ptr.all'Access, where Ptr has Extra_Accessibility ??? + -- Unimplemented: Ptr.all'Access, where Ptr has Extra_Accessibility ??? case Nkind (Expr) is - -- for access discriminant, the level of the enclosing object + + -- For access discriminant, the level of the enclosing object when N_Selected_Component => if Ekind (Entity (Selector_Name (Expr))) = E_Discriminant and then Ekind (Etype (Entity (Selector_Name (Expr)))) = - E_Anonymous_Access_Type then - + E_Anonymous_Access_Type + then return Make_Level_Literal (Object_Access_Level (Expr)); end if; @@ -2933,8 +2936,8 @@ package body Sem_Util is -- Treat the unchecked attributes as library-level - when Attribute_Unchecked_Access | - Attribute_Unrestricted_Access => + when Attribute_Unchecked_Access | + Attribute_Unrestricted_Access => return Make_Level_Literal (Scope_Depth (Standard_Standard)); -- No other access-valued attributes @@ -2944,17 +2947,20 @@ package body Sem_Util is end case; when N_Allocator => - -- Unimplemented: depends on context. As an actual - -- parameter where formal type is anonymous, use + + -- Unimplemented: depends on context. As an actual parameter where + -- formal type is anonymous, use -- Scope_Depth (Current_Scope) + 1. -- For other cases, see 3.10.2(14/3) and following. ??? + null; when N_Type_Conversion => if not Is_Local_Anonymous_Access (Etype (Expr)) then - -- Handle type conversions introduced for a - -- rename of an Ada2012 stand-alone object of an - -- anonymous access type. + + -- Handle type conversions introduced for a rename of an + -- Ada2012 stand-alone object of an anonymous access type. + return Dynamic_Accessibility_Level (Expression (Expr)); end if;