OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

einfo.ads (Extra_Accessibility_Of_Result): New function...

Browse Source 
2011-09-06  Steve Baird  <baird@adacore.com>

	* 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
This commit is contained in:
Steve Baird 2011-09-06 07:46:28 +00:00 committed by Arnaud Charlet
parent 1a982c6e28
commit 63585f754c
8 changed files with 618 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

57
gcc/ada/ChangeLog
View File

@ -1,3 +1,60 @@
2011-09-06 Steve Baird <baird@adacore.com>
* 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 <charlet@adacore.com>
* gcc-interface/Makefile.in (X86_TARGET_PAIRS): Remove duplicate

16
gcc/ada/einfo.adb
View File

@ -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;

14
gcc/ada/einfo.ads
View File

@ -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);

39
gcc/ada/exp_ch4.adb
View File

@ -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;

461
gcc/ada/exp_ch6.adb
View File

@ -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;

13
gcc/ada/exp_ch6.ads
View File

@ -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;

12
gcc/ada/sem_ch6.adb
View File

@ -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;
<<Test_For_BIP_Extras>>
<<Test_For_Func_Result_Extras>>
-- 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.

27
gcc/ada/sem_util.adb
View File

@ -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;
-----------------------------------