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

sem_util.adb, [...]: Minor reformatting and code reorganization. 

2011-09-06  Robert Dewar  <dewar@adacore.com>

	* sem_util.adb, exp_ch6.adb: Minor reformatting and code reorganization.

From-SVN: r178568
This commit is contained in:
Robert Dewar 2011-09-06 07:56:50 +00:00 committed by Arnaud Charlet
parent 63585f754c
commit ebf494ec28
3 changed files with 83 additions and 56 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
gcc/ada/ChangeLog
View File

@ -1,3 +1,7 @@
2011-09-06 Robert Dewar <dewar@adacore.com>
* sem_util.adb, exp_ch6.adb: Minor reformatting and code reorganization.
2011-09-06 Steve Baird <baird@adacore.com>
* einfo.ads (Extra_Accessibility_Of_Result): New function; in the

95
gcc/ada/exp_ch6.adb
View File

@ -2780,12 +2780,16 @@ package body Exp_Ch6 is
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;
@ -2794,6 +2798,7 @@ package body Exp_Ch6 is
declare
Def_Id : constant Entity_Id :=
Defining_Identifier (Ancestor);
begin
if Is_Return_Object (Def_Id) then
if Present (Extra_Accessibility_Of_Result
@ -2806,17 +2811,19 @@ package body Exp_Ch6 is
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
@ -2835,9 +2842,10 @@ package body Exp_Ch6 is
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)?
@ -6268,6 +6276,7 @@ package body Exp_Ch6 is
Next_Discriminant (Discr);
end loop;
end if;
return False;
end Has_Unconstrained_Access_Discriminants;
@ -6715,16 +6724,19 @@ package body Exp_Ch6 is
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;
@ -6737,11 +6749,11 @@ package body Exp_Ch6 is
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 --
@ -6759,7 +6771,9 @@ package body Exp_Ch6 is
(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;
@ -6767,7 +6781,6 @@ package body Exp_Ch6 is
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
@ -6780,22 +6793,18 @@ package body Exp_Ch6 is
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;
@ -8268,9 +8277,9 @@ package body Exp_Ch6 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.
(Comp_Typ : Entity_Id) return Boolean;
-- Returns True if any component of the type has an unconstrained access
-- discriminant.
-----------------------------------------------------
-- Has_Unconstrained_Access_Discriminant_Component --
@ -8282,6 +8291,7 @@ package body Exp_Ch6 is
begin
if not Is_Limited_Type (Comp_Typ) then
return False;
-- Only limited types can have access discriminants with
-- defaults.
@ -8294,8 +8304,10 @@ package body Exp_Ch6 is
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)))
@ -8314,32 +8326,36 @@ package body Exp_Ch6 is
-- Start of processing for Needs_Result_Accessibility_Level
begin
if not Present (Func_Typ) -- ??? completion unavailable
-- False if completion unavailable (how does this happen???)
or else Func_Typ = Standard_Void_Type -- not a function
if not Present (Func_Typ) then
return False;
or else Is_Scalar_Type (Func_Typ) -- handle enum-lit renames
-- False if not a function, also handle enum-lit renames case
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
@ -8357,17 +8373,18 @@ package body Exp_Ch6 is
-- 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;

40
gcc/ada/sem_util.adb
View File

@ -2880,20 +2880,22 @@ package body Sem_Util is
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);
@ -2909,16 +2911,17 @@ package body Sem_Util is
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;
@ -2933,8 +2936,8 @@ package body Sem_Util is
-- 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
@ -2944,17 +2947,20 @@ package body Sem_Util is
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;