From patchwork Tue Sep 6 07:47:12 2011 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Arnaud Charlet X-Patchwork-Id: 113500 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) by ozlabs.org (Postfix) with SMTP id AAF9FB6F71 for ; Tue, 6 Sep 2011 17:47:44 +1000 (EST) Received: (qmail 31599 invoked by alias); 6 Sep 2011 07:47:39 -0000 Received: (qmail 30633 invoked by uid 22791); 6 Sep 2011 07:47:32 -0000 X-SWARE-Spam-Status: No, hits=-1.8 required=5.0 tests=AWL,BAYES_00 X-Spam-Check-By: sourceware.org Received: from rock.gnat.com (HELO rock.gnat.com) (205.232.38.15) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Tue, 06 Sep 2011 07:47:14 +0000 Received: from localhost (localhost.localdomain [127.0.0.1]) by filtered-rock.gnat.com (Postfix) with ESMTP id 156FE2BB274; Tue, 6 Sep 2011 03:47:13 -0400 (EDT) Received: from rock.gnat.com ([127.0.0.1]) by localhost (rock.gnat.com [127.0.0.1]) (amavisd-new, port 10024) with LMTP id bK0Npnxs2MuY; Tue, 6 Sep 2011 03:47:13 -0400 (EDT) Received: from kwai.gnat.com (kwai.gnat.com [205.232.38.4]) by rock.gnat.com (Postfix) with ESMTP id D4BA72BB276; Tue, 6 Sep 2011 03:47:12 -0400 (EDT) Received: by kwai.gnat.com (Postfix, from userid 4192) id CDC613FEE8; Tue, 6 Sep 2011 03:47:12 -0400 (EDT) Date: Tue, 6 Sep 2011 03:47:12 -0400 From: Arnaud Charlet To: gcc-patches@gcc.gnu.org Cc: Steve Baird Subject: [Ada] Ada 2012 accessibility checking Message-ID: <20110906074712.GA24304@adacore.com> MIME-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.20 (2009-06-14) Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Delivered-To: mailing list gcc-patches@gcc.gnu.org This set of changes implements support for AI05-0234's rules about how the accessibility level of a function result object may be determined by the point of call. The implementation involves passing in an additional accessibility-level parameter to some functions, similar in some ways to the Extra_Accessibility parameters that are already used in implementing access parameters. Initially this new parameter is only used to perform accessibility checks associated with function results which have access discriminants. Tested on x86_64-pc-linux-gnu, committed on trunk 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. Index: einfo.adb =================================================================== --- einfo.adb (revision 178565) +++ einfo.adb (working copy) @@ -161,6 +161,7 @@ -- 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 @@ 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 @@ 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 @@ 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; Index: einfo.ads =================================================================== --- einfo.ads (revision 178565) +++ einfo.ads (working copy) @@ -1131,6 +1131,15 @@ -- 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 @@ -- 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 @@ -- 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 @@ -- 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 @@ 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 @@ 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); Index: sem_util.adb =================================================================== --- sem_util.adb (revision 178565) +++ sem_util.adb (working copy) @@ -2878,6 +2878,22 @@ 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 @@ 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 @@ -- 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 @@ 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; ----------------------------------- Index: exp_ch4.adb =================================================================== --- exp_ch4.adb (revision 178565) +++ exp_ch4.adb (working copy) @@ -765,11 +765,38 @@ -- 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 @@ 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; Index: exp_ch6.adb =================================================================== --- exp_ch6.adb (revision 178565) +++ exp_ch6.adb (working copy) @@ -104,13 +104,6 @@ -- 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 @@ -- 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 @@ 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 @@ 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 @@ 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 @@ 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; Index: exp_ch6.ads =================================================================== --- exp_ch6.ads (revision 178565) +++ exp_ch6.ads (working copy) @@ -205,4 +205,17 @@ -- 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; Index: sem_ch6.adb =================================================================== --- sem_ch6.adb (revision 178565) +++ sem_ch6.adb (working copy) @@ -6296,7 +6296,7 @@ -- 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,8 +6395,16 @@ 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.