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
+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
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;
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.
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;
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;
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;
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 --
----------------------------------------------
-- 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
-- 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)
-- 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
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
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));
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 --
-----------------------------------
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
-- 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)
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.
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;
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;
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;
-- 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
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
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);
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;
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
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.
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
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
-- 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 " &
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
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
-- 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",
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 --
---------------------
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 --
--------------------------
-- 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
-- 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.
projects / thirdparty / gcc.git / commitdiff
