[Ada] Missing check for 'Access of component of dereferenced access formal
Arnaud Charlet
charlet@adacore.com
Thu Jul 31 13:46:00 GMT 2008
The compiler neglected to emit an accessibility level check when applying
the Access attribute to an aliased subcomponent of a dereference of an
access parameter. This is addressed by testing the outermost prefix object
of a selected or indexed component for being a derferenced access paramter,
rather than testing only the immediate prefix of the attribute, and then
applying an accessibility check directly to the access parameter. This
replaces the old code that rewrote the prefix as an access type conversion.
This is necessary, since generating a conversion in the subcomponent case
is problematic (no appropriate target access type is available), and simpler
in any case. Also, a fix was made to use the proper accessibility level when
passing an access discriminant as an actual for an access parameter, now
properly implementing RM05-3.10.2(12.4/2), which defines the level to be
that of the enclosing object.
See gnat.dg/missing_acc_check.adb
Tested on i686-pc-linux-gnu, committed on trunk
2008-07-31 Gary Dismukes <dismukes@adacore.com>
* exp_attr.adb (Enclosing_Object): New function local to handling of
access attributes,
for retrieving the innermost enclosing object prefix of a compound name.
(Expand_N_Attribute_Reference, N_Attribute_Access): In the case where an
Access attribute has a prefix that is a dereference of an access
parameter (or the prefix is a subcomponent selected from such a
dereference), apply an accessibility check to the access parameter.
Replaces code that rewrote the prefix as a type conversion (and that
didn't handle subcomponent cases).
Also, this is now only applied in the case of 'Access.
* exp_ch6.adb (Expand_Call): Add handling for the case of an access
discriminant passed as an actual to an access formal, passing the
Object_Access_Level of the object containing the access discriminant.
-------------- next part --------------
Index: exp_attr.adb
===================================================================
--- exp_attr.adb (revision 138383)
+++ exp_attr.adb (working copy)
@@ -651,6 +651,37 @@ package body Exp_Attr is
Btyp_DDT : constant Entity_Id := Directly_Designated_Type (Btyp);
Ref_Object : constant Node_Id := Get_Referenced_Object (Pref);
+ function Enclosing_Object (N : Node_Id) return Node_Id;
+ -- If N denotes a compound name (selected component, indexed
+ -- component, or slice), returns the name of the outermost
+ -- such enclosing object. Otherwise returns N. If the object
+ -- is a renaming, then the renamed object is returned.
+
+ ----------------------
+ -- Enclosing_Object --
+ ----------------------
+
+ function Enclosing_Object (N : Node_Id) return Node_Id is
+ Obj_Name : Node_Id;
+
+ begin
+ Obj_Name := N;
+ while Nkind_In (Obj_Name, N_Selected_Component,
+ N_Indexed_Component,
+ N_Slice)
+ loop
+ Obj_Name := Prefix (Obj_Name);
+ end loop;
+
+ return Get_Referenced_Object (Obj_Name);
+ end Enclosing_Object;
+
+ -- Local declarations
+
+ Enc_Object : constant Node_Id := Enclosing_Object (Ref_Object);
+
+ -- Start of processing for Access_Cases
+
begin
-- In order to improve the text of error messages, the designated
-- type of access-to-subprogram itypes is set by the semantics as
@@ -800,35 +831,28 @@ package body Exp_Attr is
end;
-- If the prefix of an Access attribute is a dereference of an
- -- access parameter (or a renaming of such a dereference) and
- -- the context is a general access type (but not an anonymous
- -- access type), then rewrite the attribute as a conversion of
- -- the access parameter to the context access type. This will
- -- result in an accessibility check being performed, if needed.
-
- -- (X.all'Access => Acc_Type (X))
-
- -- Note: Limit the expansion of an attribute applied to a
- -- dereference of an access parameter so that it's only done
- -- for 'Access. This fixes a problem with 'Unrestricted_Access
- -- that leads to errors in the case where the attribute type
- -- is access-to-variable and the access parameter is
- -- access-to-constant. The conversion is only done to get
- -- accessibility checks, so it makes sense to limit it to
- -- 'Access.
-
- elsif Nkind (Ref_Object) = N_Explicit_Dereference
- and then Is_Entity_Name (Prefix (Ref_Object))
+ -- access parameter (or a renaming of such a dereference, or a
+ -- subcomponent of such a dereference) and the context is a
+ -- general access type (but not an anonymous access type), then
+ -- apply an accessibility check to the access parameter. We used
+ -- to rewrite the access parameter as a type conversion, but that
+ -- could only be done if the immediate prefix of the Access
+ -- attribute was the dereference, and didn't handle cases where
+ -- the attribute is applied to a subcomponent of the dereference,
+ -- since there's generally no available, appropriate access type
+ -- to convert to in that case.
+
+ elsif Id = Attribute_Access
+ and then Nkind (Enc_Object) = N_Explicit_Dereference
+ and then Is_Entity_Name (Prefix (Enc_Object))
and then Ekind (Btyp) = E_General_Access_Type
- and then Ekind (Entity (Prefix (Ref_Object))) in Formal_Kind
- and then Ekind (Etype (Entity (Prefix (Ref_Object))))
+ and then Ekind (Entity (Prefix (Enc_Object))) in Formal_Kind
+ and then Ekind (Etype (Entity (Prefix (Enc_Object))))
= E_Anonymous_Access_Type
and then Present (Extra_Accessibility
- (Entity (Prefix (Ref_Object))))
+ (Entity (Prefix (Enc_Object))))
then
- Rewrite (N,
- Convert_To (Typ, New_Copy_Tree (Prefix (Ref_Object))));
- Analyze_And_Resolve (N, Typ);
+ Apply_Accessibility_Check (Prefix (Enc_Object), Typ);
-- Ada 2005 (AI-251): If the designated type is an interface we
-- add an implicit conversion to force the displacement of the
Index: exp_ch6.adb
===================================================================
--- exp_ch6.adb (revision 138386)
+++ exp_ch6.adb (working copy)
@@ -1,4 +1,4 @@
------------------------------------------------------------------------------
+------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
@@ -2070,16 +2070,16 @@ package body Exp_Ch6 is
if Ekind (Etype (Prev)) in Private_Kind
and then not Has_Discriminants (Base_Type (Etype (Prev)))
then
- Add_Extra_Actual (
- New_Occurrence_Of (Standard_False, Loc),
- Extra_Constrained (Formal));
+ Add_Extra_Actual
+ (New_Occurrence_Of (Standard_False, Loc),
+ Extra_Constrained (Formal));
elsif Is_Constrained (Etype (Formal))
or else not Has_Discriminants (Etype (Prev))
then
- Add_Extra_Actual (
- New_Occurrence_Of (Standard_True, Loc),
- Extra_Constrained (Formal));
+ Add_Extra_Actual
+ (New_Occurrence_Of (Standard_True, Loc),
+ Extra_Constrained (Formal));
-- Do not produce extra actuals for Unchecked_Union parameters.
-- Jump directly to the end of the loop.
@@ -2220,7 +2220,7 @@ package body Exp_Ch6 is
else
Add_Extra_Actual
(Make_Integer_Literal (Loc,
- Intval => Scope_Depth (Standard_Standard)),
+ Intval => Scope_Depth (Standard_Standard)),
Extra_Accessibility (Formal));
end if;
end;
@@ -2231,11 +2231,25 @@ package body Exp_Ch6 is
else
Add_Extra_Actual
(Make_Integer_Literal (Loc,
- Intval => Type_Access_Level (Etype (Prev_Orig))),
+ Intval => Type_Access_Level (Etype (Prev_Orig))),
Extra_Accessibility (Formal));
end if;
- -- All cases other than thunks
+ -- If the actual is an access discriminant, then pass the level
+ -- of the enclosing object (RM05-3.10.2(12.4/2)).
+
+ elsif Nkind (Prev_Orig) = N_Selected_Component
+ and then Ekind (Entity (Selector_Name (Prev_Orig))) =
+ E_Discriminant
+ and then Ekind (Etype (Entity (Selector_Name (Prev_Orig)))) =
+ E_Anonymous_Access_Type
+ then
+ Add_Extra_Actual
+ (Make_Integer_Literal (Loc,
+ Intval => Object_Access_Level (Prefix (Prev_Orig))),
+ Extra_Accessibility (Formal));
+
+ -- All other cases
else
case Nkind (Prev_Orig) is
@@ -2246,20 +2260,20 @@ package body Exp_Ch6 is
-- For X'Access, pass on the level of the prefix X
when Attribute_Access =>
- Add_Extra_Actual (
- Make_Integer_Literal (Loc,
- Intval =>
- Object_Access_Level (Prefix (Prev_Orig))),
- Extra_Accessibility (Formal));
+ Add_Extra_Actual
+ (Make_Integer_Literal (Loc,
+ Intval =>
+ Object_Access_Level (Prefix (Prev_Orig))),
+ Extra_Accessibility (Formal));
-- Treat the unchecked attributes as library-level
when Attribute_Unchecked_Access |
Attribute_Unrestricted_Access =>
- Add_Extra_Actual (
- Make_Integer_Literal (Loc,
- Intval => Scope_Depth (Standard_Standard)),
- Extra_Accessibility (Formal));
+ Add_Extra_Actual
+ (Make_Integer_Literal (Loc,
+ Intval => Scope_Depth (Standard_Standard)),
+ Extra_Accessibility (Formal));
-- No other cases of attributes returning access
-- values that can be passed to access parameters
@@ -2274,19 +2288,19 @@ package body Exp_Ch6 is
-- current scope level.
when N_Allocator =>
- Add_Extra_Actual (
- Make_Integer_Literal (Loc,
- Scope_Depth (Current_Scope) + 1),
- Extra_Accessibility (Formal));
+ Add_Extra_Actual
+ (Make_Integer_Literal (Loc,
+ Intval => Scope_Depth (Current_Scope) + 1),
+ Extra_Accessibility (Formal));
-- For other cases we simply pass the level of the
-- actual's access type.
when others =>
- Add_Extra_Actual (
- Make_Integer_Literal (Loc,
- Intval => Type_Access_Level (Etype (Prev_Orig))),
- Extra_Accessibility (Formal));
+ Add_Extra_Actual
+ (Make_Integer_Literal (Loc,
+ Intval => Type_Access_Level (Etype (Prev_Orig))),
+ Extra_Accessibility (Formal));
end case;
end if;
More information about the Gcc-patches
mailing list