case Nkind (Ancestor) is
when N_Allocator =>
- -- Messy.
- --
+
+ -- Messy code, could use a cleanup???
+
-- 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;
declare
Def_Id : constant Entity_Id :=
Defining_Identifier (Ancestor);
+
begin
if Is_Return_Object (Def_Id) then
if Present (Extra_Accessibility_Of_Result
Level :=
New_Occurrence_Of
(Extra_Accessibility_Of_Result
- (Return_Applies_To (Scope (Def_Id))), Loc);
+ (Return_Applies_To (Scope (Def_Id))), Loc);
end if;
else
- Level := Make_Integer_Literal (Loc,
- Object_Access_Level (Def_Id));
+ Level :=
+ Make_Integer_Literal (Loc,
+ Intval => 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))))
+ (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
if not Defer then
if not Present (Level) then
+
-- The "innermost master that evaluates the function call".
- --
- -- ??? - Shuld we use Integer'Last here instead
+
+ -- ??? - Shpuld 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)?
Next_Discriminant (Discr);
end loop;
end if;
+
return False;
end Has_Unconstrained_Access_Discriminants;
Make_Op_Ne (Loc,
Left_Opnd => Duplicate_Subexpr (Exp),
Right_Opnd => Make_Null (Loc)),
+
Right_Opnd => Make_Op_Ne (Loc,
Left_Opnd =>
Make_Selected_Component (Loc,
Prefix => Duplicate_Subexpr (Exp),
Selector_Name => Make_Identifier (Loc, Name_uTag)),
+
Right_Opnd =>
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (Designated_Type (R_Type), Loc),
Attribute_Name => Name_Tag))),
+
Reason => CE_Tag_Check_Failed),
Suppress => All_Checks);
end if;
and then Has_Unconstrained_Access_Discriminants (R_Type)
then
declare
- Discrim_Source : Node_Id := Exp;
+ Discrim_Source : Node_Id;
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 the given accessibility level against the level
+ -- determined by the point of call. (AI05-0234).
--------------------------------
-- Check_Against_Result_Level --
(Extra_Accessibility_Of_Result (Scope_Id), Loc)),
Reason => PE_Accessibility_Check_Failed));
end Check_Against_Result_Level;
+
begin
+ Discrim_Source := Exp;
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
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;
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.
+ (Comp_Typ : Entity_Id) return Boolean;
+ -- Returns True if any component of the type has an unconstrained access
+ -- discriminant.
-----------------------------------------------------
-- Has_Unconstrained_Access_Discriminant_Component --
begin
if not Is_Limited_Type (Comp_Typ) then
return False;
+
-- Only limited types can have access discriminants with
-- defaults.
elsif Is_Record_Type (Comp_Typ) then
declare
- Comp : Entity_Id := First_Component (Comp_Typ);
+ Comp : Entity_Id;
+
begin
+ Comp := First_Component (Comp_Typ);
while Present (Comp) loop
if Has_Unconstrained_Access_Discriminant_Component
(Underlying_Type (Etype (Comp)))
-- Start of processing for Needs_Result_Accessibility_Level
begin
- if not Present (Func_Typ) -- ??? completion unavailable
+ -- False if completion unavailable (how does this happen???)
+
+ if not Present (Func_Typ) then
+ return False;
- or else Func_Typ = Standard_Void_Type -- not a function
+ -- False if not a function, also handle enum-lit renames case
- or else Is_Scalar_Type (Func_Typ) -- handle enum-lit renames
+ elsif Func_Typ = Standard_Void_Type
+ or else Is_Scalar_Type (Func_Typ)
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.
- --
+ -- 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.
+
+ elsif Present (Alias (Func_Id)) then
+
-- 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
+ -- Remaining cases require Ada 2012 mode
+
+ elsif Ada_Version < Ada_2012 then
return False;
- end if;
- if Ekind (Func_Typ) = E_Anonymous_Access_Type
+ elsif 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
-- wrappers, but that is not the approach that was chosen.
return True;
- end if;
- if Has_Unconstrained_Access_Discriminants (Func_Typ) then
+ elsif Has_Unconstrained_Access_Discriminants (Func_Typ) then
return True;
- end if;
- if Has_Unconstrained_Access_Discriminant_Component (Func_Typ) then
+ elsif Has_Unconstrained_Access_Discriminant_Component (Func_Typ) then
return True;
- end if;
- return False;
+ -- False for all other cases
+
+ else
+ return False;
+ end if;
end Needs_Result_Accessibility_Level;
end Exp_Ch6;
Loc : constant Source_Ptr := Sloc (Expr);
function Make_Level_Literal (Level : Uint) return Node_Id;
- -- Construct an integer literal representing an accessibility level.
+ -- Construct an integer literal representing an accessibility level
+ -- with its type set to Natural.
- ---------------------------------
- -- function Make_Level_Literal --
- ---------------------------------
+ ------------------------
+ -- Make_Level_Literal --
+ ------------------------
function Make_Level_Literal (Level : Uint) return Node_Id is
- Result : constant Node_Id :=
- Make_Integer_Literal (Loc, Level);
+ Result : constant Node_Id := Make_Integer_Literal (Loc, Level);
begin
Set_Etype (Result, Standard_Natural);
return Result;
end Make_Level_Literal;
+ -- Start of processing for Dynamic_Accessibility_Level
+
begin
if Is_Entity_Name (Expr) then
E := Entity (Expr);
end if;
end if;
- -- unimplemented: Ptr.all'Access, where Ptr has Extra_Accessibility ???
+ -- Unimplemented: Ptr.all'Access, where Ptr has Extra_Accessibility ???
case Nkind (Expr) is
- -- for access discriminant, the level of the enclosing object
+
+ -- 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
-
+ E_Anonymous_Access_Type
+ then
return Make_Level_Literal (Object_Access_Level (Expr));
end if;
-- Treat the unchecked attributes as library-level
- when Attribute_Unchecked_Access |
- Attribute_Unrestricted_Access =>
+ when Attribute_Unchecked_Access |
+ Attribute_Unrestricted_Access =>
return Make_Level_Literal (Scope_Depth (Standard_Standard));
-- No other access-valued attributes
end case;
when N_Allocator =>
- -- Unimplemented: depends on context. As an actual
- -- parameter where formal type is anonymous, use
+
+ -- 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.
+
+ -- 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;
OSDN Git Service
