diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 42707a4d6c1..f488cd7a39e 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 d88ff56edec..87777860820 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 001e49b032a..7e8d8196098 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 f3f20fc4652..d018d4c426c 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 3f37ad32ceb..4e986f70893 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 29dc27322d9..06145f525e0 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 83652d36e5e..d82cd72d488 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 848643c61d3..b573ba8ee00 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; -----------------------------------