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

[multiple changes]

Browse Source 
2011-08-30  Steve Baird  <baird@adacore.com>

	* sem_util.ads (Deepest_Type_Access_Level): New function; for the type
	of a saooaaat (i.e, a stand-alone object of an anonymous access type),
	returns the (static) accessibility level of the object. Otherwise, the
	same as Type_Access_Level.
	(Dynamic_Accessibility_Level): New function; given an expression which
	could occur as the rhs of an assignment to a saooaaat (i.e., an
	expression of an access-to-object type), return the new value for the
	saooaaat's associated Extra_Accessibility object.
	(Effective_Extra_Accessibility): New function; same as
	Einfo.Extra_Accessibility except that object renames are looked through.
	* sem_util.adb 
	(Deepest_Type_Access_Level): New function; see sem_util.ads description.
	(Dynamic_Accessibility_Level): New function; see sem_util.ads
	description.
	(Effective_Extra_Accessibility): New function; see sem_util.ads
	description.
	* einfo.ads (Is_Local_Anonymous_Access): Update comments.
	(Extra_Accessibility): Update comments.
	(Init_Object_Size_Align): New procedure; same as Init_Size_Align
	except RM_Size field (which is only for types) is unaffected.
	* einfo.adb
	(Extra_Accessibility): Expand domain to allow objects, not just formals.
	(Set_Extra_Accessibility): Expand domain to allow objects, not just
	formals.
	(Init_Size): Add assertion that we are not trashing the
	Extra_Accessibility attribute of an object.
	(Init_Size_Align): Add assertion that we are not trashing the
	Extra_Accessibility attribute of an object.
	(Init_Object_Size_Align): New procedure; see einfo.ads description.
	* sem_ch3.adb (Find_Type_Of_Object): Set Is_Local_Anonymous_Access
	differently for the type of a (non-library-level) saooaaat depending
	whether Ada_Version < Ada_2012. This is the only point where Ada_Version
	is queried in this set of changes - everything else (in particular,
	setting of the Extra_Accessibility attribute in exp_ch3.adb) is
	driven off of the setting of the Is_Local_Anonymous_Access attribute.
	The special treatment of library-level saooaaats is an optimization,
	not required for correctnesss. This is based on the observation that the
	Ada2012 rules (static and dynamic) for saooaaats turn out to be
	equivalent to the Ada2005 rules in the case of a library-level saooaaat.
	* exp_ch3.adb
	(Expand_N_Object_Declaration): If Is_Local_Anonymous_Access is
	false for the type of a saooaaat, declare and initialize its
	accessibility level object and set the Extra_Accessibility attribute
	of the saooaaat to refer to this object.
	* checks.adb (Apply_Accessibility_Check): Add Ada 2012 saooaaat support.
	* exp_ch4.adb (Expand_N_In): Replace some Extra_Accessibility calls with
	calls to Effective_Extra_Accessibility in order to support
	renames of saooaaats.
	(Expand_N_Type_Conversion): Add new local function,
	Has_Extra_Accessibility, and call it when determining whether an
	accessibility check is needed.
	It returns True iff Present (Effective_Extra_Accessibility (Id)) would
	evaluate to True (without raising an exception).
	* exp_ch5.adb
	(Expand_N_Assignment_Statement): When assigning to an Ada2012
	saooaaat, update its associated Extra_Accessibility object (if
	it has one). This includes an accessibility check.
	* exp_ch6.adb (Add_Call_By_Copy_Code): When parameter copy-back updates
	a saooaaat, update its Extra_Accessibility object too (if it
	has one).
	(Expand_Call): Replace a couple of calls to Type_Access_Level
	with calls to Dynamic_Access_Level to handle cases where
	passing a literal (any literal) is incorrect.
	* sem_attr.adb (Resolve_Attribute): Handle the static accessibility
	checks associated with "Saooaat := Some_Object'Access;"; this must
	be rejected if Some_Object is declared in a more nested scope
	than Saooaat.
	* sem_ch5.adb (Analyze_Assignment): Force accessibility checking for an
	assignment to a saooaaat even if Is_Local_Anonymous_Access
	returns False for its type (indicating a 2012-style saooaaat).
	* sem_ch8.adb
	(Analyze_Object_Renaming): Replace a call to Init_Size_Align
	(which is only appropriate for objects, not types) with a call
	of Init_Object_Size_Align in order to avoid trashing the
	Extra_Accessibility attribute of a rename (the two attributes
	share storage).
	* sem_res.adb
	(Valid_Conversion) Replace six calls to Type_Access_Level with
	calls to Deepest_Type_Access_Level. This is a bit tricky. For an
	Ada2012 non-library-level saooaaat, the former returns library level
	while the latter returns the (static) accessibility level of the
	saooaaat. A type conversion to the anonymous type of a saooaaat
	can only occur as part of an assignment to the saooaaat, so we
	know that such a conversion must be in a lhs context, so Deepest
	yields the result that we need. If such a conversion could occur,
	say, as the operand of an equality operator, then this might not
	be right. Also add a test so that static accessibilty checks are
	performed for converting to a saooaaat's type even if
	Is_Local_Anonymous_Access yields False for the type.

2011-08-30  Javier Miranda  <miranda@adacore.com>

	* sem_disp.adb (Check_Dispatching_Operation): Complete condition that
	controls generation of a warning associated with late declaration of
	dispatching functions. Required to avoid generating spurious
	warnings.

From-SVN: r178299
This commit is contained in:
Arnaud Charlet 2011-08-30 15:22:13 +02:00
parent 9645d43461
commit d15f94220d
16 changed files with 477 additions and 43 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

99
gcc/ada/ChangeLog
View File

@ -1,3 +1,102 @@
2011-08-30 Steve Baird <baird@adacore.com>
* sem_util.ads (Deepest_Type_Access_Level): New function; for the type
of a saooaaat (i.e, a stand-alone object of an anonymous access type),
returns the (static) accessibility level of the object. Otherwise, the
same as Type_Access_Level.
(Dynamic_Accessibility_Level): New function; given an expression which
could occur as the rhs of an assignment to a saooaaat (i.e., an
expression of an access-to-object type), return the new value for the
saooaaat's associated Extra_Accessibility object.
(Effective_Extra_Accessibility): New function; same as
Einfo.Extra_Accessibility except that object renames are looked through.
* sem_util.adb
(Deepest_Type_Access_Level): New function; see sem_util.ads description.
(Dynamic_Accessibility_Level): New function; see sem_util.ads
description.
(Effective_Extra_Accessibility): New function; see sem_util.ads
description.
* einfo.ads (Is_Local_Anonymous_Access): Update comments.
(Extra_Accessibility): Update comments.
(Init_Object_Size_Align): New procedure; same as Init_Size_Align
except RM_Size field (which is only for types) is unaffected.
* einfo.adb
(Extra_Accessibility): Expand domain to allow objects, not just formals.
(Set_Extra_Accessibility): Expand domain to allow objects, not just
formals.
(Init_Size): Add assertion that we are not trashing the
Extra_Accessibility attribute of an object.
(Init_Size_Align): Add assertion that we are not trashing the
Extra_Accessibility attribute of an object.
(Init_Object_Size_Align): New procedure; see einfo.ads description.
* sem_ch3.adb (Find_Type_Of_Object): Set Is_Local_Anonymous_Access
differently for the type of a (non-library-level) saooaaat depending
whether Ada_Version < Ada_2012. This is the only point where Ada_Version
is queried in this set of changes - everything else (in particular,
setting of the Extra_Accessibility attribute in exp_ch3.adb) is
driven off of the setting of the Is_Local_Anonymous_Access attribute.
The special treatment of library-level saooaaats is an optimization,
not required for correctnesss. This is based on the observation that the
Ada2012 rules (static and dynamic) for saooaaats turn out to be
equivalent to the Ada2005 rules in the case of a library-level saooaaat.
* exp_ch3.adb
(Expand_N_Object_Declaration): If Is_Local_Anonymous_Access is
false for the type of a saooaaat, declare and initialize its
accessibility level object and set the Extra_Accessibility attribute
of the saooaaat to refer to this object.
* checks.adb (Apply_Accessibility_Check): Add Ada 2012 saooaaat support.
* exp_ch4.adb (Expand_N_In): Replace some Extra_Accessibility calls with
calls to Effective_Extra_Accessibility in order to support
renames of saooaaats.
(Expand_N_Type_Conversion): Add new local function,
Has_Extra_Accessibility, and call it when determining whether an
accessibility check is needed.
It returns True iff Present (Effective_Extra_Accessibility (Id)) would
evaluate to True (without raising an exception).
* exp_ch5.adb
(Expand_N_Assignment_Statement): When assigning to an Ada2012
saooaaat, update its associated Extra_Accessibility object (if
it has one). This includes an accessibility check.
* exp_ch6.adb (Add_Call_By_Copy_Code): When parameter copy-back updates
a saooaaat, update its Extra_Accessibility object too (if it
has one).
(Expand_Call): Replace a couple of calls to Type_Access_Level
with calls to Dynamic_Access_Level to handle cases where
passing a literal (any literal) is incorrect.
* sem_attr.adb (Resolve_Attribute): Handle the static accessibility
checks associated with "Saooaat := Some_Object'Access;"; this must
be rejected if Some_Object is declared in a more nested scope
than Saooaat.
* sem_ch5.adb (Analyze_Assignment): Force accessibility checking for an
assignment to a saooaaat even if Is_Local_Anonymous_Access
returns False for its type (indicating a 2012-style saooaaat).
* sem_ch8.adb
(Analyze_Object_Renaming): Replace a call to Init_Size_Align
(which is only appropriate for objects, not types) with a call
of Init_Object_Size_Align in order to avoid trashing the
Extra_Accessibility attribute of a rename (the two attributes
share storage).
* sem_res.adb
(Valid_Conversion) Replace six calls to Type_Access_Level with
calls to Deepest_Type_Access_Level. This is a bit tricky. For an
Ada2012 non-library-level saooaaat, the former returns library level
while the latter returns the (static) accessibility level of the
saooaaat. A type conversion to the anonymous type of a saooaaat
can only occur as part of an assignment to the saooaaat, so we
know that such a conversion must be in a lhs context, so Deepest
yields the result that we need. If such a conversion could occur,
say, as the operand of an equality operator, then this might not
be right. Also add a test so that static accessibilty checks are
performed for converting to a saooaaat's type even if
Is_Local_Anonymous_Access yields False for the type.
2011-08-30 Javier Miranda <miranda@adacore.com>
* sem_disp.adb (Check_Dispatching_Operation): Complete condition that
controls generation of a warning associated with late declaration of
dispatching functions. Required to avoid generating spurious
warnings.
2011-08-30 Gary Dismukes <dismukes@adacore.com>
* sem_ch6.adb (Check_Return_Subtype_Indication): Issue error if the

24
gcc/ada/checks.adb
View File

@ -479,11 +479,26 @@ package body Checks is
Insert_Node : Node_Id)
is
Loc : constant Source_Ptr := Sloc (N);
Param_Ent : constant Entity_Id := Param_Entity (N);
Param_Ent : Entity_Id := Param_Entity (N);
Param_Level : Node_Id;
Type_Level : Node_Id;
begin
if Ada_Version >= Ada_2012
and then not Present (Param_Ent)
and then Is_Entity_Name (N)
and then Ekind_In (Entity (N), E_Constant, E_Variable)
and then Present (Effective_Extra_Accessibility (Entity (N)))
then
Param_Ent := Entity (N);
while Present (Renamed_Object (Param_Ent)) loop
-- Renamed_Object must return an Entity_Name here
-- because of preceding "Present (E_E_A (...))" test.
Param_Ent := Entity (Renamed_Object (Param_Ent));
end loop;
end if;
if Inside_A_Generic then
return;
@ -494,15 +509,16 @@ package body Checks is
elsif Present (Param_Ent)
and then Present (Extra_Accessibility (Param_Ent))
and then UI_Gt (Object_Access_Level (N), Type_Access_Level (Typ))
and then UI_Gt (Object_Access_Level (N),
Deepest_Type_Access_Level (Typ))
and then not Accessibility_Checks_Suppressed (Param_Ent)
and then not Accessibility_Checks_Suppressed (Typ)
then
Param_Level :=
New_Occurrence_Of (Extra_Accessibility (Param_Ent), Loc);
Type_Level :=
Make_Integer_Literal (Loc, Type_Access_Level (Typ));
Type_Level := Make_Integer_Literal (Loc,
Deepest_Type_Access_Level (Typ));
-- Raise Program_Error if the accessibility level of the access
-- parameter is deeper than the level of the target access type.

18
gcc/ada/einfo.adb
View File

@ -1038,7 +1038,8 @@ package body Einfo is
function Extra_Accessibility (Id : E) return E is
begin
pragma Assert (Is_Formal (Id) or else Ekind (Id) = E_Variable);
pragma Assert
(Is_Formal (Id) or else Ekind_In (Id, E_Variable, E_Constant));
return Node13 (Id);
end Extra_Accessibility;
@ -3506,7 +3507,8 @@ package body Einfo is
procedure Set_Extra_Accessibility (Id : E; V : E) is
begin
pragma Assert (Is_Formal (Id) or else Ekind (Id) = E_Variable);
pragma Assert
(Is_Formal (Id) or else Ekind_In (Id, E_Variable, E_Constant));
Set_Node13 (Id, V);
end Set_Extra_Accessibility;
@ -5466,6 +5468,7 @@ package body Einfo is
procedure Init_Size (Id : E; V : Int) is
begin
Set_Uint12 (Id, UI_From_Int (V)); -- Esize
pragma Assert (not Is_Object (Id));
Set_Uint13 (Id, UI_From_Int (V)); -- RM_Size
end Init_Size;
@ -5476,10 +5479,21 @@ package body Einfo is
procedure Init_Size_Align (Id : E) is
begin
Set_Uint12 (Id, Uint_0); -- Esize
pragma Assert (not Is_Object (Id));
Set_Uint13 (Id, Uint_0); -- RM_Size
Set_Uint14 (Id, Uint_0); -- Alignment
end Init_Size_Align;
----------------------------
-- Init_Object_Size_Align --
----------------------------
procedure Init_Object_Size_Align (Id : E) is
begin
Set_Uint12 (Id, Uint_0); -- Esize
Set_Uint14 (Id, Uint_0); -- Alignment
end Init_Object_Size_Align;
----------------------------------------------
-- Type Representation Attribute Predicates --
----------------------------------------------

12
gcc/ada/einfo.ads
View File

@ -2446,10 +2446,11 @@ package Einfo is
-- Is_Local_Anonymous_Access (Flag194)
-- Present in access types. Set for an anonymous access type to indicate
-- that the type is created for a record component with an access
-- definition, an array component, or a stand-alone object. Such
-- anonymous types have an accessibility level equal to that of the
-- definition, an array component, or (pre-Ada2012) a stand-alone object.
-- Such anonymous types have an accessibility level equal to that of the
-- declaration in which they appear, unlike the anonymous access types
-- that are created for access parameters and access discriminants.
-- that are created for access parameters, access discriminants, and
-- (as of Ada2012) stand-alone objects.
-- Is_Machine_Code_Subprogram (Flag137)
-- Present in subprogram entities. Set to indicate that the subprogram
@ -5050,6 +5051,7 @@ package Einfo is
-- Discriminal_Link (Node10) (discriminals only)
-- Full_View (Node11)
-- Esize (Uint12)
-- Extra_Accessibility (Node13) (constants only)
-- Alignment (Uint14)
-- Return_Flag_Or_Transient_Decl (Node15) (constants only)
-- Actual_Subtype (Node17)
@ -7017,6 +7019,10 @@ package Einfo is
-- This procedure initializes both size fields and the alignment
-- field to all be Unknown.
procedure Init_Object_Size_Align (Id : E);
-- Same as Init_Size_Align except RM_Size field (which is only for types)
-- is unaffected.
procedure Init_Size (Id : E; V : Int);
-- Initialize both the Esize and RM_Size fields of E to V

41
gcc/ada/exp_ch3.adb
View File

@ -5261,6 +5261,47 @@ package body Exp_Ch3 is
end if;
end if;
if Nkind (N) = N_Object_Declaration
and then Nkind (Object_Definition (N)) = N_Access_Definition
and then not Is_Local_Anonymous_Access (Etype (Def_Id))
then
-- An Ada 2012 stand-alone object of an anonymous access type
declare
Loc : constant Source_Ptr := Sloc (N);
Level : constant Entity_Id :=
Make_Defining_Identifier (Sloc (N),
Chars => New_External_Name (Chars (Def_Id),
Suffix => "L"));
Level_Expr : Node_Id;
Level_Decl : Node_Id;
begin
Set_Ekind (Level, Ekind (Def_Id));
Set_Etype (Level, Standard_Natural);
Set_Scope (Level, Scope (Def_Id));
if No (Expr) then
Level_Expr := Make_Integer_Literal (Loc,
-- accessibility level of null
Intval => Scope_Depth (Standard_Standard));
else
Level_Expr := Dynamic_Accessibility_Level (Expr);
end if;
Level_Decl := Make_Object_Declaration (Loc,
Defining_Identifier => Level,
Object_Definition => New_Occurrence_Of (Standard_Natural, Loc),
Expression => Level_Expr,
Constant_Present => Constant_Present (N),
Has_Init_Expression => True);
Insert_Action_After (Init_After, Level_Decl);
Set_Extra_Accessibility (Def_Id, Level);
end;
end if;
-- Exception on library entity not available
exception

33
gcc/ada/exp_ch4.adb
View File

@ -4996,14 +4996,15 @@ package body Exp_Ch4 is
else
if Present (Expr_Entity)
and then Present (Extra_Accessibility (Expr_Entity))
and then Present
(Effective_Extra_Accessibility (Expr_Entity))
and then UI_Gt
(Object_Access_Level (Lop),
Type_Access_Level (Rtyp))
then
Param_Level :=
New_Occurrence_Of
(Extra_Accessibility (Expr_Entity), Loc);
(Effective_Extra_Accessibility (Expr_Entity), Loc);
Type_Level :=
Make_Integer_Literal (Loc, Type_Access_Level (Rtyp));
@ -8279,6 +8280,10 @@ package body Exp_Ch4 is
procedure Real_Range_Check;
-- Handles generation of range check for real target value
function Has_Extra_Accessibility (Id : Entity_Id) return Boolean;
-- True iff Present (Effective_Extra_Accessibility (Id)) successfully
-- evaluates to True.
-----------------------------------
-- Handle_Changed_Representation --
-----------------------------------
@ -8578,6 +8583,22 @@ package body Exp_Ch4 is
Analyze_And_Resolve (N, Btyp);
end Real_Range_Check;
-----------------------------
-- Has_Extra_Accessibility --
-----------------------------
-- Returns true for a formal of an anonymous access type or for
-- an Ada 2012-style stand-alone object of an anonymous access type.
function Has_Extra_Accessibility (Id : Entity_Id) return Boolean is
begin
if Is_Formal (Id) or else Ekind_In (Id, E_Constant, E_Variable) then
return Present (Effective_Extra_Accessibility (Id));
else
return False;
end if;
end Has_Extra_Accessibility;
-- Start of processing for Expand_N_Type_Conversion
begin
@ -8736,13 +8757,7 @@ package body Exp_Ch4 is
-- as tagged type checks).
if Is_Entity_Name (Operand)
and then
(Is_Formal (Entity (Operand))
or else
(Present (Renamed_Object (Entity (Operand)))
and then Is_Entity_Name (Renamed_Object (Entity (Operand)))
and then Is_Formal
(Entity (Renamed_Object (Entity (Operand))))))
and then Has_Extra_Accessibility (Entity (Operand))
and then Ekind (Etype (Operand)) = E_Anonymous_Access_Type
and then (Nkind (Original_Node (N)) /= N_Attribute_Reference
or else Attribute_Name (Original_Node (N)) = Name_Access)

51
gcc/ada/exp_ch5.adb
View File

@ -1885,6 +1885,57 @@ package body Exp_Ch5 is
Apply_Constraint_Check (Rhs, Etype (Lhs));
end if;
-- Ada 2012 (AI05-148): Update current accessibility level if
-- Rhs is a stand-alone obj of an anonymous access type.
if Is_Access_Type (Typ)
and then Is_Entity_Name (Lhs)
and then Present (Effective_Extra_Accessibility (Entity (Lhs))) then
declare
function Lhs_Entity return Entity_Id;
-- Look through renames to find the underlying entity.
-- For assignment to a rename, we don't care about the
-- Enclosing_Dynamic_Scope of the rename declaration.
----------------
-- Lhs_Entity --
----------------
function Lhs_Entity return Entity_Id is
Result : Entity_Id := Entity (Lhs);
begin
while Present (Renamed_Object (Result)) loop
-- Renamed_Object must return an Entity_Name here
-- because of preceding "Present (E_E_A (...))" test.
Result := Entity (Renamed_Object (Result));
end loop;
return Result;
end Lhs_Entity;
Access_Check : constant Node_Id :=
Make_Raise_Program_Error (Loc,
Condition =>
Make_Op_Gt (Loc,
Left_Opnd => Dynamic_Accessibility_Level (Rhs),
Right_Opnd =>
Make_Integer_Literal (Loc,
Scope_Depth (Enclosing_Dynamic_Scope (Lhs_Entity)))),
Reason => PE_Accessibility_Check_Failed);
Access_Level_Update : constant Node_Id :=
Make_Assignment_Statement (Loc,
Name => New_Occurrence_Of (
Effective_Extra_Accessibility (Entity (Lhs)), Loc),
Expression => Dynamic_Accessibility_Level (Rhs));
begin
if not Accessibility_Checks_Suppressed (Entity (Lhs)) then
Insert_Action (N, Access_Check);
end if;
Insert_Action (N, Access_Level_Update);
end;
end if;
-- Case of assignment to a bit packed array element. If there is a
-- change of representation this must be expanded into components,
-- otherwise this is a bit-field assignment.

59
gcc/ada/exp_ch6.adb
View File

@ -1201,10 +1201,46 @@ package body Exp_Ch6 is
Set_Assignment_OK (Lhs);
Append_To (Post_Call,
Make_Assignment_Statement (Loc,
Name => Lhs,
Expression => Expr));
if Is_Access_Type (E_Formal)
and then Is_Entity_Name (Lhs)
and then Present (Effective_Extra_Accessibility
(Entity (Lhs)))
then
-- Copyback target is an Ada 2012 stand-alone object
-- of an anonymous access type
pragma Assert (Ada_Version >= Ada_2012);
if Type_Access_Level (E_Formal) >
Object_Access_Level (Lhs) then
Append_To (Post_Call, Make_Raise_Program_Error (Loc,
Reason => PE_Accessibility_Check_Failed));
end if;
Append_To (Post_Call,
Make_Assignment_Statement (Loc,
Name => Lhs,
Expression => Expr));
-- We would like to somehow suppress generation of
-- the extra_accessibility assignment generated by
-- the expansion of the above assignment statement.
-- It's not a correctness issue because the following
-- assignment renders it dead, but generating back-to-back
-- assignments to the same target is undesirable. ???
Append_To (Post_Call,
Make_Assignment_Statement (Loc,
Name => New_Occurrence_Of (
Effective_Extra_Accessibility (Entity (Lhs)), Loc),
Expression => Make_Integer_Literal (Loc,
Type_Access_Level (E_Formal))));
else
Append_To (Post_Call,
Make_Assignment_Statement (Loc,
Name => Lhs,
Expression => Expr));
end if;
end;
end if;
end Add_Call_By_Copy_Code;
@ -2406,8 +2442,7 @@ package body Exp_Ch6 is
else
Add_Extra_Actual
(Make_Integer_Literal (Loc,
Intval => Type_Access_Level (Etype (Prev_Orig))),
(Dynamic_Accessibility_Level (Prev_Orig),
Extra_Accessibility (Formal));
end if;
@ -2497,15 +2532,15 @@ package body Exp_Ch6 is
Intval => Scope_Depth (Current_Scope) + 1),
Extra_Accessibility (Formal));
-- For other cases we simply pass the level of the actual's
-- access type. The type is retrieved from Prev rather than
-- Prev_Orig, because in some cases Prev_Orig denotes an
-- original expression that has not been analyzed.
-- For most other cases we simply pass the level of the
-- actual's access type. The type is retrieved from
-- Prev rather than Prev_Orig, because in some cases
-- Prev_Orig denotes an original expression that has
-- not been analyzed.
when others =>
Add_Extra_Actual
(Make_Integer_Literal (Loc,
Intval => Type_Access_Level (Etype (Prev))),
(Dynamic_Accessibility_Level (Prev),
Extra_Accessibility (Formal));
end case;
end if;

12
gcc/ada/sem_attr.adb
View File

@ -8312,8 +8312,16 @@ package body Sem_Attr is
-- the level is the same of the enclosing composite type.
if Ada_Version >= Ada_2005
and then Is_Local_Anonymous_Access (Btyp)
and then Object_Access_Level (P) > Type_Access_Level (Btyp)
and then (Is_Local_Anonymous_Access (Btyp)
-- Handle cases where Btyp is the
-- anonymous access type of an Ada 2012
-- stand-alone object.
or else Nkind (Associated_Node_For_Itype
(Btyp)) = N_Object_Declaration)
and then Object_Access_Level (P)
> Deepest_Type_Access_Level (Btyp)
and then Attr_Id = Attribute_Access
then
-- In an instance, this is a runtime check, but one we

5
gcc/ada/sem_ch3.adb
View File

@ -15122,7 +15122,10 @@ package body Sem_Ch3 is
elsif Def_Kind = N_Access_Definition then
T := Access_Definition (Related_Nod, Obj_Def);
Set_Is_Local_Anonymous_Access (T);
Set_Is_Local_Anonymous_Access (T, V => (Ada_Version < Ada_2012)
or else (Nkind (P) /= N_Object_Declaration)
or else Is_Library_Level_Entity (Defining_Identifier (P)));
-- Otherwise, the object definition is just a subtype_mark

8
gcc/ada/sem_ch5.adb
View File

@ -601,6 +601,14 @@ package body Sem_Ch5 is
then
if Is_Local_Anonymous_Access (T1)
or else Ekind (T2) = E_Anonymous_Access_Subprogram_Type
-- Handle assignment to an Ada 2012 stand-alone object
-- of an anonymous access type.
or else (Ekind (T1) = E_Anonymous_Access_Type
and then Nkind (Associated_Node_For_Itype (T1))
= N_Object_Declaration)
then
Rewrite (Rhs, Convert_To (T1, Relocate_Node (Rhs)));
Analyze_And_Resolve (Rhs, T1);

2
gcc/ada/sem_ch8.adb
View File

@ -1137,7 +1137,7 @@ package body Sem_Ch8 is
end if;
Set_Ekind (Id, E_Variable);
Init_Size_Align (Id);
Init_Object_Size_Align (Id);
if T = Any_Type or else Etype (Nam) = Any_Type then
return;

5
gcc/ada/sem_disp.adb
View File

@ -850,9 +850,12 @@ package body Sem_Disp is
Typ := Etype (Subp);
end if;
if not Is_Class_Wide_Type (Typ)
if Comes_From_Source (Subp)
and then Is_Interface (Typ)
and then not Is_Class_Wide_Type (Typ)
and then not Is_Derived_Type (Typ)
and then not Is_Generic_Type (Typ)
and then not In_Instance
then
Error_Msg_N ("?declaration of& is too late!", Subp);
Error_Msg_NE

19
gcc/ada/sem_res.adb
View File

@ -10530,8 +10530,9 @@ package body Sem_Res is
if Ekind (Target_Type) /= E_Anonymous_Access_Type then
if Type_Access_Level (Opnd_Type) >
Type_Access_Level (Target_Type)
Deepest_Type_Access_Level (Target_Type)
then
-- In an instance, this is a run-time check, but one we know
-- will fail, so generate an appropriate warning. The raise
-- will be generated by Expand_N_Type_Conversion.
@ -10562,7 +10563,7 @@ package body Sem_Res is
if Nkind (Operand) = N_Selected_Component
and then Object_Access_Level (Operand) >
Type_Access_Level (Target_Type)
Deepest_Type_Access_Level (Target_Type)
then
-- In an instance, this is a run-time check, but one we know
-- will fail, so generate an appropriate warning. The raise
@ -10630,6 +10631,8 @@ package body Sem_Res is
if Ekind (Target_Type) /= E_Anonymous_Access_Type
or else Is_Local_Anonymous_Access (Target_Type)
or else Nkind (Associated_Node_For_Itype (Target_Type)) =
N_Object_Declaration
then
-- Ada 2012 (AI05-0149): Perform legality checking on implicit
-- conversions from an anonymous access type to a named general
@ -10687,8 +10690,8 @@ package body Sem_Res is
-- statically less deep than that of the target type, else
-- implicit conversion is disallowed (by RM12-8.6(27.1/3)).
elsif Type_Access_Level (Opnd_Type)
> Type_Access_Level (Target_Type)
elsif Type_Access_Level (Opnd_Type) >
Deepest_Type_Access_Level (Target_Type)
then
Error_Msg_N
("implicit conversion of anonymous access value " &
@ -10697,8 +10700,8 @@ package body Sem_Res is
end if;
end if;
elsif Type_Access_Level (Opnd_Type)
> Type_Access_Level (Target_Type)
elsif Type_Access_Level (Opnd_Type) >
Deepest_Type_Access_Level (Target_Type)
then
-- In an instance, this is a run-time check, but one we know
@ -10737,7 +10740,7 @@ package body Sem_Res is
if Nkind (Operand) = N_Selected_Component
and then Object_Access_Level (Operand) >
Type_Access_Level (Target_Type)
Deepest_Type_Access_Level (Target_Type)
then
-- In an instance, this is a run-time check, but one we know
-- will fail, so generate an appropriate warning. The raise
@ -10909,7 +10912,7 @@ package body Sem_Res is
-- Check the static accessibility rule of 4.6(20)
if Type_Access_Level (Opnd_Type) >
Type_Access_Level (Target_Type)
Deepest_Type_Access_Level (Target_Type)
then
Error_Msg_N
("operand type has deeper accessibility level than target",

113
gcc/ada/sem_util.adb
View File

@ -2372,6 +2372,26 @@ package body Sem_Util is
end if;
end Current_Subprogram;
----------------------------------
-- Deepest_Type_Access_Level --
----------------------------------
function Deepest_Type_Access_Level (Typ : Entity_Id) return Uint is
begin
if Ekind (Typ) = E_Anonymous_Access_Type
and then not Is_Local_Anonymous_Access (Typ)
and then Nkind (Associated_Node_For_Itype (Typ)) = N_Object_Declaration
then
-- Typ is the type of an Ada 2012 stand-alone object of an
-- anonymous access type.
return Scope_Depth (Enclosing_Dynamic_Scope (Defining_Identifier (
Associated_Node_For_Itype (Typ))));
else
return Type_Access_Level (Typ);
end if;
end Deepest_Type_Access_Level;
---------------------
-- Defining_Entity --
---------------------
@ -2848,6 +2868,99 @@ package body Sem_Util is
end if;
end Designate_Same_Unit;
------------------------------------------
-- function Dynamic_Accessibility_Level --
------------------------------------------
function Dynamic_Accessibility_Level (Expr : Node_Id) return Node_Id is
E : Entity_Id;
Loc : constant Source_Ptr := Sloc (Expr);
begin
if Is_Entity_Name (Expr) then
E := Entity (Expr);
if Present (Renamed_Object (E)) then
return Dynamic_Accessibility_Level (Renamed_Object (E));
end if;
if Is_Formal (E) or else Ekind_In (E, E_Variable, E_Constant) then
if Present (Extra_Accessibility (E)) then
return New_Occurrence_Of (Extra_Accessibility (E), Loc);
end if;
end if;
end if;
-- unimplemented: Ptr.all'Access, where Ptr has Extra_Accessibility ???
case Nkind (Expr) is
-- for access discriminant, the level of the enclosing object
when N_Selected_Component =>
if Ekind (Entity (Selector_Name (Expr))) = E_Discriminant
and then Ekind (Etype (Entity (Selector_Name (Expr)))) =
E_Anonymous_Access_Type then
return Make_Integer_Literal (Loc, Object_Access_Level (Expr));
end if;
when N_Attribute_Reference =>
case Get_Attribute_Id (Attribute_Name (Expr)) is
-- For X'Access, the level of the prefix X
when Attribute_Access =>
return Make_Integer_Literal (Loc,
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));
-- No other access-valued attributes
when others =>
raise Program_Error;
end case;
when N_Allocator =>
-- Unimplemented: depends on context. As an actual
-- parameter where formal type is anonymous, use
-- Scope_Depth (Current_Scope) + 1.
-- For other cases, see 3.10.2(14/3) and following. ???
null;
when N_Type_Conversion =>
if not Is_Local_Anonymous_Access (Etype (Expr)) then
-- Handle type conversions introduced for a
-- rename of an Ada2012 stand-alone object of an
-- anonymous access type.
return Dynamic_Accessibility_Level (Expression (Expr));
end if;
when others =>
null;
end case;
return Make_Integer_Literal (Loc, Type_Access_Level (Etype (Expr)));
end Dynamic_Accessibility_Level;
-----------------------------------
-- Effective_Extra_Accessibility --
-----------------------------------
function Effective_Extra_Accessibility (Id : Entity_Id) return Entity_Id is
begin
if Present (Renamed_Object (Id))
and then Is_Entity_Name (Renamed_Object (Id)) then
return Effective_Extra_Accessibility (Entity (Renamed_Object (Id)));
end if;
return Extra_Accessibility (Id);
end Effective_Extra_Accessibility;
--------------------------
-- Enclosing_CPP_Parent --
--------------------------

19
gcc/ada/sem_util.ads
View File

@ -292,6 +292,15 @@ package Sem_Util is
-- Current_Scope is returned. The returned value is Empty if this is called
-- from a library package which is not within any subprogram.
function Deepest_Type_Access_Level (Typ : Entity_Id) return Uint;
-- Same as Type_Access_Level, except that if the
-- type is the type of an Ada 2012 stand-alone object of an
-- anonymous access type, then return the static accesssibility level
-- of the object. In that case, the dynamic accessibility level
-- of the object may take on values in a range. The low bound of
-- of that range is returned by Type_Access_Level; this
-- function yields the high bound of that range.
function Defining_Entity (N : Node_Id) return Entity_Id;
-- Given a declaration N, returns the associated defining entity. If the
-- declaration has a specification, the entity is obtained from the
@ -332,6 +341,16 @@ package Sem_Util is
-- these names is supposed to be a selected component name, an expanded
-- name, a defining program unit name or an identifier.
function Dynamic_Accessibility_Level (Expr : Node_Id) return Node_Id;
-- Expr should be an expression of an access type.
-- Builds an integer literal except in cases involving anonymous
-- access types where accessibility levels are tracked at runtime
-- (access parameters and Ada 2012 stand-alone objects).
function Effective_Extra_Accessibility (Id : Entity_Id) return Entity_Id;
-- Same as Einfo.Extra_Accessibility except thtat object renames
-- are looked through.
function Enclosing_CPP_Parent (Typ : Entity_Id) return Entity_Id;
-- Returns the closest ancestor of Typ that is a CPP type.