From: Steve Baird Date: Tue, 6 Sep 2011 07:46:28 +0000 (+0000) Subject: einfo.ads (Extra_Accessibility_Of_Result): New function... X-Git-Tag: releases/gcc-4.7.0~3936 X-Git-Url: https://gcc.gnu.org/git/?a=commitdiff_plain;h=63585f754c2048b49f8e1607323f8f693e6649bf;p=gcc.git einfo.ads (Extra_Accessibility_Of_Result): New function... 2011-09-06 Steve Baird * einfo.ads (Extra_Accessibility_Of_Result): New function; in the (Ada2012) cases described in AI05-0234 where the accessibility level of a function result is "determined by the point of call", an implicit parameter representing that accessibility level is passed in. Extra_Accessibilty_Of_Result yields this additional formal parameter. Extra_Accessibility_Of_Result is analogous to the existing Extra_Accessibility function used in the implementation of access parameters. (Set_Extra_Accessibility_Of_Result): New procedure; sets Extra_Accessibility_Of_Result attribute. * einfo.adb (Extra_Accessibility_Of_Result): New function. (Set_Extra_Accessibility_Of_Result): New procedure. (Write_Field19_Name): Display Extra_Accessibilty_Of_Result attribute. * sem_util.adb (Dynamic_Accessibility_Level): Set Etype of an accessibility level literal to Natural; introduce a nested function, Make_Level_Literal, to do this. * exp_ch6.ads (Needs_Result_Accessibility_Level): New function; determines whether a given function (or access-to-function type) needs to have an implicitly-declared accessibility-level parameter added to its profile. (Add_Extra_Actual_To_Call): Export an existing procedure which was previously declared in the body of Exp_Ch6. * exp_ch6.adb (Add_Extra_Actual_To_Call): Export declaration by moving it to exp_ch6.ads. (Has_Unconstrained_Access_Discriminants): New Function; a predicate on subtype entities which returns True if the given subtype is unconstrained and has one or more access discriminants. (Expand_Call): When expanding a call to a function which takes an Extra_Accessibility_Of_Result parameter, pass in the appropriate actual parameter value. In the case of a function call which is used to initialize an allocator, this may not be possible because the Etype of the allocator may not have been set yet. In this case, we defer passing in the parameter and handle it later in Expand_Allocator_Expression. (Expand_Simple_Function_Return): When returning from a function which returns an unconstrained subtype having at least one access discriminant, generate the accessibility check needed to ensure that the function result will not outlive any objects designated by its discriminants. (Needs_Result_Accessibility_Level): New function; see exp_ch6.ads description. * exp_ch4.adb (Expand_Allocator_Expression): When a function call is used to initialize an allocator, we may need to pass in "the accessibility level determined by the point of call" (AI05-0234) to the function. Expand_Call, where such actual parameters are usually generated, is too early in this case because the Etype of the allocator (which is used in determining the level to be passed in) may not have been set yet when Expand_Call executes. Instead, we generate code to pass in the appropriate actual parameter in Expand_Allocator_Expression. * sem_ch6.adb (Create_Extra_Formals): Create the new Extra_Accessibility_Of_Result formal if Needs_Result_Accessibility_Level returns True. This includes the introduction of a nested procedure, Check_Against_Result_Level. From-SVN: r178567 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 42707a4d6c16..f488cd7a39e1 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,60 @@ +2011-09-06 Steve Baird + + * einfo.ads (Extra_Accessibility_Of_Result): New function; in the + (Ada2012) cases described in AI05-0234 where the accessibility + level of a function result is "determined by the point of + call", an implicit parameter representing that accessibility + level is passed in. Extra_Accessibilty_Of_Result yields this + additional formal parameter. Extra_Accessibility_Of_Result + is analogous to the existing Extra_Accessibility + function used in the implementation of access parameters. + (Set_Extra_Accessibility_Of_Result): New procedure; sets + Extra_Accessibility_Of_Result attribute. + * einfo.adb (Extra_Accessibility_Of_Result): New function. + (Set_Extra_Accessibility_Of_Result): New procedure. + (Write_Field19_Name): Display Extra_Accessibilty_Of_Result attribute. + * sem_util.adb (Dynamic_Accessibility_Level): Set Etype of + an accessibility level literal to Natural; introduce a nested + function, Make_Level_Literal, to do this. + * exp_ch6.ads (Needs_Result_Accessibility_Level): New function; + determines whether a given function (or access-to-function + type) needs to have an implicitly-declared accessibility-level + parameter added to its profile. + (Add_Extra_Actual_To_Call): Export an existing procedure which was + previously declared in the body of Exp_Ch6. + * exp_ch6.adb (Add_Extra_Actual_To_Call): Export declaration by moving + it to exp_ch6.ads. + (Has_Unconstrained_Access_Discriminants): New Function; a + predicate on subtype entities which returns True if the given + subtype is unconstrained and has one or more access discriminants. + (Expand_Call): When expanding a call to a function which takes an + Extra_Accessibility_Of_Result parameter, pass in the appropriate + actual parameter value. In the case of a function call which is + used to initialize an allocator, this may not be possible because + the Etype of the allocator may not have been set yet. In this + case, we defer passing in the parameter and handle it later in + Expand_Allocator_Expression. + (Expand_Simple_Function_Return): When returning from a function which + returns an unconstrained subtype having at least one access + discriminant, generate the accessibility check needed to ensure that + the function result will not outlive any objects designated by its + discriminants. + (Needs_Result_Accessibility_Level): New function; see exp_ch6.ads + description. + * exp_ch4.adb (Expand_Allocator_Expression): When a function call + is used to initialize an allocator, we may need to pass in "the + accessibility level determined by the point of call" (AI05-0234) + to the function. Expand_Call, where such actual parameters are + usually generated, is too early in this case because the Etype of + the allocator (which is used in determining the level to be passed + in) may not have been set yet when Expand_Call executes. Instead, + we generate code to pass in the appropriate actual parameter + in Expand_Allocator_Expression. + * sem_ch6.adb (Create_Extra_Formals): Create + the new Extra_Accessibility_Of_Result formal if + Needs_Result_Accessibility_Level returns True. This includes the + introduction of a nested procedure, Check_Against_Result_Level. + 2011-09-06 Arnaud Charlet * gcc-interface/Makefile.in (X86_TARGET_PAIRS): Remove duplicate diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index d88ff56edec3..877778608201 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -161,6 +161,7 @@ package body Einfo is -- Body_Entity Node19 -- Corresponding_Discriminant Node19 + -- Extra_Accessibility_Of_Result Node19 -- Parent_Subtype Node19 -- Related_Array_Object Node19 -- Size_Check_Code Node19 @@ -1043,6 +1044,12 @@ package body Einfo is return Node13 (Id); end Extra_Accessibility; + function Extra_Accessibility_Of_Result (Id : E) return E is + begin + pragma Assert (Ekind_In (Id, E_Function, E_Operator, E_Subprogram_Type)); + return Node19 (Id); + end Extra_Accessibility_Of_Result; + function Extra_Constrained (Id : E) return E is begin pragma Assert (Is_Formal (Id) or else Ekind (Id) = E_Variable); @@ -3519,6 +3526,12 @@ package body Einfo is Set_Node13 (Id, V); end Set_Extra_Accessibility; + procedure Set_Extra_Accessibility_Of_Result (Id : E; V : E) is + begin + pragma Assert (Ekind_In (Id, E_Function, E_Operator, E_Subprogram_Type)); + Set_Node19 (Id, V); + end Set_Extra_Accessibility_Of_Result; + procedure Set_Extra_Constrained (Id : E; V : E) is begin pragma Assert (Is_Formal (Id) or else Ekind (Id) = E_Variable); @@ -8312,6 +8325,9 @@ package body Einfo is when Private_Kind => Write_Str ("Underlying_Full_View"); + when E_Function | E_Operator | E_Subprogram_Type => + Write_Str ("Extra_Accessibility_Of_Result"); + when others => Write_Str ("Field19??"); end case; diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 001e49b032a5..7e8d8196098a 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -1131,6 +1131,15 @@ package Einfo is -- must be retrieved through the entity designed by this field instead of -- being computed. +-- Extra_Accessibility_Of_Result (Node19) +-- Present in (non-generic) Function, Operator, and Subprogram_Type +-- entities if expansion is active. Normally Empty, but if a function is +-- one for which "the accessibility level of the result ... determined +-- by the point of call" (AI05-0234) is needed, then an extra formal of +-- subtype Natural is created (see description of field Extra_Formal), +-- and the Extra_Accessibility_Of_Result field of the function points to +-- the entity for this extra formal. + -- Extra_Constrained (Node23) -- Present in formal parameters in the non-generic case if expansion is -- active. Normally Empty, but if a parameter is one for which a dynamic @@ -5235,6 +5244,7 @@ package Einfo is -- First_Entity (Node17) -- Alias (Node18) (non-generic case only) -- Renamed_Entity (Node18) (generic case only) + -- Extra_Accessibility_Of_Result (Node19) (non-generic case only) -- Last_Entity (Node20) -- Interface_Name (Node21) -- Scope_Depth_Value (Uint22) @@ -5389,6 +5399,7 @@ package Einfo is -- E_Operator -- First_Entity (Node17) -- Alias (Node18) + -- Extra_Accessibility_Of_Result (Node19) -- Last_Entity (Node20) -- Overridden_Operation (Node26) -- Subprograms_For_Type (Node29) @@ -5680,6 +5691,7 @@ package Einfo is -- Scope_Depth (synth) -- E_Subprogram_Type + -- Extra_Accessibility_Of_Result (Node19) -- Directly_Designated_Type (Node20) -- Extra_Formals (Node28) -- First_Formal (synth) @@ -6068,6 +6080,7 @@ package Einfo is function Esize (Id : E) return U; function Exception_Code (Id : E) return U; function Extra_Accessibility (Id : E) return E; + function Extra_Accessibility_Of_Result (Id : E) return E; function Extra_Constrained (Id : E) return E; function Extra_Formal (Id : E) return E; function Extra_Formals (Id : E) return E; @@ -6656,6 +6669,7 @@ package Einfo is procedure Set_Esize (Id : E; V : U); procedure Set_Exception_Code (Id : E; V : U); procedure Set_Extra_Accessibility (Id : E; V : E); + procedure Set_Extra_Accessibility_Of_Result (Id : E; V : E); procedure Set_Extra_Constrained (Id : E; V : E); procedure Set_Extra_Formal (Id : E; V : E); procedure Set_Extra_Formals (Id : E; V : E); diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index f3f20fc46524..d018d4c426cd 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -765,11 +765,38 @@ package body Exp_Ch4 is -- Start of processing for Expand_Allocator_Expression begin - -- WOuld be nice to comment the branches of this very long if ??? + -- Messy??? - if Is_Tagged_Type (T) - or else Needs_Finalization (T) - then + -- In the case of an Ada2012 allocator whose initial value comes from a + -- function call, pass "the accessibility level determined by the point + -- of call" (AI05-0234) to the function. Conceptually, this belongs in + -- Expand_Call but it couldn't be done there (because the Etype of the + -- allocator wasn't set then) so we generate the parameter here. See + -- the Boolean variable Defer in (a block within) Expand_Call. + + if Ada_Version >= Ada_2012 and then Nkind (Exp) = N_Function_Call then + declare + Subp : Entity_Id; + + begin + if Nkind (Name (Exp)) = N_Explicit_Dereference then + Subp := Designated_Type (Etype (Prefix (Name (Exp)))); + else + Subp := Entity (Name (Exp)); + end if; + + if Present (Extra_Accessibility_Of_Result (Subp)) then + Add_Extra_Actual_To_Call + (Subprogram_Call => Exp, + Extra_Formal => Extra_Accessibility_Of_Result (Subp), + Extra_Actual => Dynamic_Accessibility_Level (PtrT)); + end if; + end; + end if; + + -- Would be nice to comment the branches of this very long if ??? + + if Is_Tagged_Type (T) or else Needs_Finalization (T) then if Is_CPP_Constructor_Call (Exp) then -- Generate: @@ -811,10 +838,10 @@ package body Exp_Ch4 is Insert_List_After_And_Analyze (P, Build_Initialization_Call (Loc, - Id_Ref => + Id_Ref => Make_Explicit_Dereference (Loc, Prefix => New_Reference_To (Temp, Loc)), - Typ => Etype (Exp), + Typ => Etype (Exp), Constructor_Ref => Exp)); end; diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 3f37ad32cebf..4e986f70893a 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -104,13 +104,6 @@ package body Exp_Ch6 is -- present, then use it, otherwise pass a literal corresponding to the -- Alloc_Form parameter (which must not be Unspecified in that case). - procedure Add_Extra_Actual_To_Call - (Subprogram_Call : Node_Id; - Extra_Formal : Entity_Id; - Extra_Actual : Node_Id); - -- Adds Extra_Actual as a named parameter association for the formal - -- Extra_Formal in Subprogram_Call. - procedure Add_Finalization_Master_Actual_To_Build_In_Place_Call (Func_Call : Node_Id; Func_Id : Entity_Id; @@ -196,6 +189,11 @@ package body Exp_Ch6 is -- reference to the object itself, and the call becomes a call to the -- corresponding protected subprogram. + function Has_Unconstrained_Access_Discriminants + (Subtyp : Entity_Id) return Boolean; + -- Returns True if the given subtype is unconstrained and has one + -- or more access discriminants. + procedure Expand_Simple_Function_Return (N : Node_Id); -- Expand simple return from function. In the case where we are returning -- from a function body this is called by Expand_N_Simple_Return_Statement. @@ -2751,6 +2749,108 @@ package body Exp_Ch6 is Next_Formal (Formal); end loop; + -- If we are calling an Ada2012 function which needs to have the + -- "accessibility level determined by the point of call" (AI05-0234) + -- passed in to it, then pass it in. + + if Ada_Version >= Ada_2012 + and then Ekind_In (Subp, E_Function, E_Operator, E_Subprogram_Type) + and then Present (Extra_Accessibility_Of_Result (Subp)) + then + declare + Ancestor : Node_Id := Parent (Call_Node); + Level : Node_Id := Empty; + Defer : Boolean := False; + + begin + -- Unimplemented: if Subp returns an anonymous access type, then + -- a) if the call is the operand of an explict conversion, then + -- the target type of the conversion (a named access type) + -- determines the accessibility level pass in; + -- b) if the call defines an access discriminant of an object + -- (e.g., the discriminant of an object being created by an + -- allocator, or the discriminant of a function result), + -- then the accessibility level to pass in is that of the + -- discriminated object being initialized). + + while Nkind (Ancestor) = N_Qualified_Expression + loop + Ancestor := Parent (Ancestor); + end loop; + + case Nkind (Ancestor) is + when N_Allocator => + -- Messy. + -- + -- 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; + + when N_Object_Declaration | N_Object_Renaming_Declaration => + declare + Def_Id : constant Entity_Id := + Defining_Identifier (Ancestor); + begin + if Is_Return_Object (Def_Id) then + if Present (Extra_Accessibility_Of_Result + (Return_Applies_To (Scope (Def_Id)))) + then + -- Pass along value that was passed in if the + -- routine we are returning from also has an + -- Accessibility_Of_Result formal. + + Level := + New_Occurrence_Of + (Extra_Accessibility_Of_Result + (Return_Applies_To (Scope (Def_Id))), Loc); + end if; + else + Level := Make_Integer_Literal (Loc, + 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)))) + then + -- Pass along value that was passed in if the routine + -- we are returning from also has an + -- Accessibility_Of_Result formal. + + Level := + New_Occurrence_Of + (Extra_Accessibility_Of_Result + (Return_Applies_To + (Return_Statement_Entity (Ancestor))), Loc); + end if; + + when others => + null; + end case; + + if not Defer then + if not Present (Level) then + -- The "innermost master that evaluates the function call". + -- + -- ??? - Shuld 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)? + + Level := Make_Integer_Literal (Loc, + Scope_Depth (Current_Scope) + 1); + end if; + + Add_Extra_Actual (Level, Extra_Accessibility_Of_Result (Subp)); + end if; + end; + end if; + -- If we are expanding a rhs of an assignment we need to check if tag -- propagation is needed. You might expect this processing to be in -- Analyze_Assignment but has to be done earlier (bottom-up) because the @@ -6146,6 +6246,31 @@ package body Exp_Ch6 is end if; end Expand_Protected_Subprogram_Call; + -------------------------------------------- + -- Has_Unconstrained_Access_Discriminants -- + -------------------------------------------- + + function Has_Unconstrained_Access_Discriminants + (Subtyp : Entity_Id) return Boolean + is + Discr : Entity_Id; + + begin + if Has_Discriminants (Subtyp) + and then not Is_Constrained (Subtyp) + then + Discr := First_Discriminant (Subtyp); + while Present (Discr) loop + if Ekind (Etype (Discr)) = E_Anonymous_Access_Type then + return True; + end if; + + Next_Discriminant (Discr); + end loop; + end if; + return False; + end Has_Unconstrained_Access_Discriminants; + ----------------------------------- -- Expand_Simple_Function_Return -- ----------------------------------- @@ -6604,6 +6729,216 @@ package body Exp_Ch6 is Suppress => All_Checks); end if; + -- AI05-0234: RM 6.5(21/3). Check access discriminants to + -- ensure that the function result does not outlive an + -- object designated by one of it discriminants. + + if Ada_Version >= Ada_2012 + and then Has_Unconstrained_Access_Discriminants (R_Type) + then + declare + Discrim_Source : Node_Id := Exp; + + 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_Against_Result_Level -- + -------------------------------- + + procedure Check_Against_Result_Level (Level : Node_Id) is + begin + Insert_Action (N, + Make_Raise_Program_Error (Loc, + Condition => + Make_Op_Gt (Loc, + Left_Opnd => Level, + Right_Opnd => + New_Occurrence_Of + (Extra_Accessibility_Of_Result (Scope_Id), Loc)), + Reason => PE_Accessibility_Check_Failed)); + end Check_Against_Result_Level; + begin + while Nkind (Discrim_Source) = N_Qualified_Expression loop + Discrim_Source := Expression (Discrim_Source); + end loop; + + 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 + Discrim_Source := Etype (Discrim_Source); + else + Discrim_Source := Expression (Parent (Discrim_Source)); + end if; + + elsif Nkind (Discrim_Source) = N_Identifier + 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; + + case Nkind (Discrim_Source) is + when N_Defining_Identifier => + + pragma Assert (Is_Composite_Type (Discrim_Source) and then + Has_Discriminants (Discrim_Source) and then + Is_Constrained (Discrim_Source)); + + declare + Discrim : Entity_Id := + First_Discriminant (Base_Type (R_Type)); + Disc_Elmt : Elmt_Id := + First_Elmt (Discriminant_Constraint + (Discrim_Source)); + begin + loop + if Ekind (Etype (Discrim)) = + E_Anonymous_Access_Type then + + Check_Against_Result_Level + (Dynamic_Accessibility_Level (Node (Disc_Elmt))); + end if; + + Next_Elmt (Disc_Elmt); + Next_Discriminant (Discrim); + exit when not Present (Discrim); + end loop; + end; + + when N_Aggregate | N_Extension_Aggregate => + + -- Unimplemented: extension aggregate case where + -- discrims come from ancestor part, not extension part. + + declare + Discrim : Entity_Id := + First_Discriminant (Base_Type (R_Type)); + + Disc_Exp : Node_Id := Empty; + + Positionals_Exhausted + : Boolean := not Present (Expressions + (Discrim_Source)); + + function Associated_Expr + (Comp_Id : Entity_Id; + Associations : List_Id) return Node_Id; + + -- Given a component and a component associations list, + -- locate the expression for that component; returns + -- Empty if no such expression is found. + + --------------------- + -- Associated_Expr -- + --------------------- + + function Associated_Expr + (Comp_Id : Entity_Id; + Associations : List_Id) return Node_Id + is + Assoc : Node_Id := First (Associations); + Choice : Node_Id; + begin + -- Simple linear search seems ok here + + while Present (Assoc) loop + Choice := First (Choices (Assoc)); + + while Present (Choice) loop + if (Nkind (Choice) = N_Identifier + and then Chars (Choice) = Chars (Comp_Id)) + or else (Nkind (Choice) = N_Others_Choice) + then + return Expression (Assoc); + end if; + + Next (Choice); + end loop; + + Next (Assoc); + end loop; + + return Empty; + end Associated_Expr; + + -- Start of processing for Expand_Simple_Function_Return + + begin + if not Positionals_Exhausted then + Disc_Exp := First (Expressions (Discrim_Source)); + end if; + + loop + if Positionals_Exhausted then + Disc_Exp := Associated_Expr (Discrim, + Component_Associations (Discrim_Source)); + end if; + + if Ekind (Etype (Discrim)) = + E_Anonymous_Access_Type then + + Check_Against_Result_Level + (Dynamic_Accessibility_Level (Disc_Exp)); + end if; + + Next_Discriminant (Discrim); + exit when not Present (Discrim); + + if not Positionals_Exhausted then + Next (Disc_Exp); + Positionals_Exhausted := not Present (Disc_Exp); + end if; + end loop; + end; + + when N_Function_Call => + -- No check needed; check performed by callee. + null; + + when others => + + declare + Level : constant Node_Id := + Make_Integer_Literal (Loc, + Object_Access_Level (Discrim_Source)); + begin + -- Unimplemented: check for name prefix that includes + -- a dereference of an access value with a dynamic + -- accessibility level (e.g., an access param or a + -- saooaaat) and use dynamic level in that case. For + -- example: + -- return Access_Param.all(Some_Index).Some_Component; + + Set_Etype (Level, Standard_Natural); + Check_Against_Result_Level (Level); + end; + + end case; + end; + end if; + -- If we are returning an object that may not be bit-aligned, then copy -- the value into a temporary first. This copy may need to expand to a -- loop of component operations. @@ -7923,4 +8258,116 @@ package body Exp_Ch6 is return not Is_Constrained (Func_Typ) or else Is_Tagged_Type (Func_Typ); end Needs_BIP_Alloc_Form; + -------------------------------------- + -- Needs_Result_Accessibility_Level -- + -------------------------------------- + + function Needs_Result_Accessibility_Level + (Func_Id : Entity_Id) return Boolean + 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. + + ----------------------------------------------------- + -- Has_Unconstrained_Access_Discriminant_Component -- + ----------------------------------------------------- + + function Has_Unconstrained_Access_Discriminant_Component + (Comp_Typ : Entity_Id) return Boolean + is + begin + if not Is_Limited_Type (Comp_Typ) then + return False; + -- Only limited types can have access discriminants with + -- defaults. + + elsif Has_Unconstrained_Access_Discriminants (Comp_Typ) then + return True; + + elsif Is_Array_Type (Comp_Typ) then + return Has_Unconstrained_Access_Discriminant_Component + (Underlying_Type (Component_Type (Comp_Typ))); + + elsif Is_Record_Type (Comp_Typ) then + declare + Comp : Entity_Id := First_Component (Comp_Typ); + begin + while Present (Comp) loop + if Has_Unconstrained_Access_Discriminant_Component + (Underlying_Type (Etype (Comp))) + then + return True; + end if; + + Next_Component (Comp); + end loop; + end; + end if; + + return False; + end Has_Unconstrained_Access_Discriminant_Component; + + -- Start of processing for Needs_Result_Accessibility_Level + + begin + if not Present (Func_Typ) -- ??? completion unavailable + + or else Func_Typ = Standard_Void_Type -- not a function + + or else Is_Scalar_Type (Func_Typ) -- handle enum-lit renames + 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. + -- + -- 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 + return False; + end if; + + if 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 + -- for this extra parameter might not be obvious. This function + -- returns True for all tagged types for compatibility reasons. + -- A function with, say, a tagged null controlling result type might + -- be overridden by a primitive of an extension having an access + -- discriminant and the overrider and overridden must have compatible + -- calling conventions (including implicitly declared parameters). + -- Similarly, values of one access-to-subprogram type might designate + -- both a primitive subprogram of a given type and a function + -- which is, for example, not a primitive subprogram of any type. + -- Again, this requires calling convention compatibility. + -- It might be possible to solve these issues by introducing + -- wrappers, but that is not the approach that was chosen. + + return True; + end if; + + if Has_Unconstrained_Access_Discriminants (Func_Typ) then + return True; + end if; + + if Has_Unconstrained_Access_Discriminant_Component (Func_Typ) then + return True; + end if; + + return False; + end Needs_Result_Accessibility_Level; + end Exp_Ch6; diff --git a/gcc/ada/exp_ch6.ads b/gcc/ada/exp_ch6.ads index 29dc27322d97..06145f525e03 100644 --- a/gcc/ada/exp_ch6.ads +++ b/gcc/ada/exp_ch6.ads @@ -205,4 +205,17 @@ package Exp_Ch6 is -- Ada 2005 (AI-318-02): Return True if the function needs an implicit -- BIP_Alloc_Form parameter (see type BIP_Formal_Kind). + function Needs_Result_Accessibility_Level + (Func_Id : Entity_Id) return Boolean; + -- Ada 2012 (AI05-0234): Return True if the function needs an implicit + -- parameter to identify the accessibility level of the function result + -- "determined by the point of call". + + procedure Add_Extra_Actual_To_Call + (Subprogram_Call : Node_Id; + Extra_Formal : Entity_Id; + Extra_Actual : Node_Id); + -- Adds Extra_Actual as a named parameter association for the formal + -- Extra_Formal in Subprogram_Call. + end Exp_Ch6; diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 83652d36e5e4..d82cd72d4887 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -6296,7 +6296,7 @@ package body Sem_Ch6 is -- build-in-place formals are needed in some cases (limited 'Input). if Is_Predefined_Internal_Operation (E) then - goto Test_For_BIP_Extras; + goto Test_For_Func_Result_Extras; end if; Formal := First_Formal (E); @@ -6395,7 +6395,15 @@ package body Sem_Ch6 is Next_Formal (Formal); end loop; - <> + <> + + -- Ada 2012 (AI05-234): "the accessibility level of the result of a + -- function call is ... determined by the point of call ...". + + if Needs_Result_Accessibility_Level (E) then + Set_Extra_Accessibility_Of_Result + (E, Add_Extra_Formal (E, Standard_Natural, E, "L")); + end if; -- Ada 2005 (AI-318-02): In the case of build-in-place functions, add -- appropriate extra formals. See type Exp_Ch6.BIP_Formal_Kind. diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 848643c61d30..b573ba8ee000 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -2878,6 +2878,22 @@ package body Sem_Util is function Dynamic_Accessibility_Level (Expr : Node_Id) return Node_Id is E : Entity_Id; Loc : constant Source_Ptr := Sloc (Expr); + + function Make_Level_Literal (Level : Uint) return Node_Id; + -- Construct an integer literal representing an accessibility level. + + --------------------------------- + -- function Make_Level_Literal -- + --------------------------------- + + function Make_Level_Literal (Level : Uint) return Node_Id is + Result : constant Node_Id := + Make_Integer_Literal (Loc, Level); + begin + Set_Etype (Result, Standard_Natural); + return Result; + end Make_Level_Literal; + begin if Is_Entity_Name (Expr) then E := Entity (Expr); @@ -2903,7 +2919,7 @@ package body Sem_Util is and then Ekind (Etype (Entity (Selector_Name (Expr)))) = E_Anonymous_Access_Type then - return Make_Integer_Literal (Loc, Object_Access_Level (Expr)); + return Make_Level_Literal (Object_Access_Level (Expr)); end if; when N_Attribute_Reference => @@ -2912,15 +2928,14 @@ package body Sem_Util is -- For X'Access, the level of the prefix X when Attribute_Access => - return Make_Integer_Literal (Loc, - Object_Access_Level (Prefix (Expr))); + return Make_Level_Literal + (Object_Access_Level (Prefix (Expr))); -- Treat the unchecked attributes as library-level when Attribute_Unchecked_Access | Attribute_Unrestricted_Access => - return Make_Integer_Literal (Loc, - Scope_Depth (Standard_Standard)); + return Make_Level_Literal (Scope_Depth (Standard_Standard)); -- No other access-valued attributes @@ -2947,7 +2962,7 @@ package body Sem_Util is null; end case; - return Make_Integer_Literal (Loc, Type_Access_Level (Etype (Expr))); + return Make_Level_Literal (Type_Access_Level (Etype (Expr))); end Dynamic_Accessibility_Level; -----------------------------------