Skip to content

R
riscv-gcc-1
Commit ed789fe9 by Cyrille Comar Committed by Arnaud Charlet
Options

exp_ch5.adb (Expand_N_Assignment_Statement, [...]): For an assignment of a value… 

exp_ch5.adb (Expand_N_Assignment_Statement, [...]): For an assignment of a value of a tagged type that has been rewritten to a...

2005-11-14  Cyrille Comar  <comar@adacore.com>
	    Thomas Quinot  <quinot@adacore.com>

	* exp_ch5.adb (Expand_N_Assignment_Statement, Tagged_Case): For an
	assignment of a value of a tagged type that has been rewritten to a
	block statement, it is known by construction that no checks are
	necessary for the statements within the block: analyze it with checks
	suppressed.
	(Expand_N_If_Statement): When killing a dead then-branch in an
	if-statement that has elsif_parts, recompute the Current_Value node
	for any entity whose value is known from the condition of the first
	elsif_part.
	(Expand_N_Return_Statement): When returning a mutable record, convert
	the return value into its actual subtype in order to help the backend
	to return the actual size instead of the maximum. This is another
	aftermath of not returning mutable records on the sec-stack anymore.

	* sem_ch5.ads, sem_ch5.adb (Analyze_Iteration_Scheme): Minor change to
	handling of error msg for suspicious reverse range iteration.
	(Check_Possible_Current_Value_Condition): Move declaration from body to
	spec, to allow this subprogram to be called from exp_ch5.

From-SVN: r106972
parent 5dcc05e6
Showing with 164 additions and 123 deletions
gcc/ada/exp_ch5.adb
...@@ -45,6 +45,7 @@ with Rtsfind; use Rtsfind; ...@@ -45,6 +45,7 @@ with Rtsfind; use Rtsfind;
with Sinfo; use Sinfo; with Sinfo; use Sinfo;
with Sem; use Sem; with Sem; use Sem;
with Sem_Ch3; use Sem_Ch3; with Sem_Ch3; use Sem_Ch3;
with Sem_Ch5; use Sem_Ch5;
with Sem_Ch8; use Sem_Ch8; with Sem_Ch8; use Sem_Ch8;
with Sem_Ch13; use Sem_Ch13; with Sem_Ch13; use Sem_Ch13;
with Sem_Eval; use Sem_Eval; with Sem_Eval; use Sem_Eval;
...@@ -1808,7 +1809,11 @@ package body Exp_Ch5 is ...@@ -1808,7 +1809,11 @@ package body Exp_Ch5 is
end; end;
end if; end if;
Analyze (N); -- N has been rewritten to a block statement for which it is
-- known by construction that no checks are necessary: analyze
-- it with all checks suppressed.
Analyze (N, Suppress => All_Checks);
return; return;
end Tagged_Case; end Tagged_Case;
...@@ -2259,6 +2264,13 @@ package body Exp_Ch5 is ...@@ -2259,6 +2264,13 @@ package body Exp_Ch5 is
Set_Condition (N, Condition (Hed)); Set_Condition (N, Condition (Hed));
Set_Then_Statements (N, Then_Statements (Hed)); Set_Then_Statements (N, Then_Statements (Hed));
-- Hed might have been captured as the condition determining
-- the current value for an entity. Now it is detached from
-- the tree, so a Current_Value pointer in the condition might
-- need to be updated.
Check_Possible_Current_Value_Condition (N);
if Is_Empty_List (Elsif_Parts (N)) then if Is_Empty_List (Elsif_Parts (N)) then
Set_Elsif_Parts (N, No_List); Set_Elsif_Parts (N, No_List);
end if; end if;
...@@ -2762,123 +2774,38 @@ package body Exp_Ch5 is ...@@ -2762,123 +2774,38 @@ package body Exp_Ch5 is
Analyze (Exp); Analyze (Exp);
end if; end if;
-- Implement the rules of 6.5(8-10), which require a tag check in
-- the case of a limited tagged return type, and tag reassignment
-- for nonlimited tagged results. These actions are needed when
-- the return type is a specific tagged type and the result
-- expression is a conversion or a formal parameter, because in
-- that case the tag of the expression might differ from the tag
-- of the specific result type.
if Is_Tagged_Type (Utyp)
and then not Is_Class_Wide_Type (Utyp)
and then (Nkind (Exp) = N_Type_Conversion
or else Nkind (Exp) = N_Unchecked_Type_Conversion
or else (Is_Entity_Name (Exp)
and then Ekind (Entity (Exp)) in Formal_Kind))
then
-- When the return type is limited, perform a check that the
-- tag of the result is the same as the tag of the return type.
if Is_Limited_Type (Return_Type) then
Insert_Action (Exp,
Make_Raise_Constraint_Error (Loc,
Condition =>
Make_Op_Ne (Loc,
Left_Opnd =>
Make_Selected_Component (Loc,
Prefix => Duplicate_Subexpr (Exp),
Selector_Name =>
New_Reference_To (First_Tag_Component (Utyp), Loc)),
Right_Opnd =>
Unchecked_Convert_To (RTE (RE_Tag),
New_Reference_To
(Node (First_Elmt
(Access_Disp_Table (Base_Type (Utyp)))),
Loc))),
Reason => CE_Tag_Check_Failed));
-- If the result type is a specific nonlimited tagged type,
-- then we have to ensure that the tag of the result is that
-- of the result type. This is handled by making a copy of the
-- expression in the case where it might have a different tag,
-- namely when the expression is a conversion or a formal
-- parameter. We create a new object of the result type and
-- initialize it from the expression, which will implicitly
-- force the tag to be set appropriately.
else
Result_Id :=
Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
Result_Exp := New_Reference_To (Result_Id, Loc);
Result_Obj :=
Make_Object_Declaration (Loc,
Defining_Identifier => Result_Id,
Object_Definition => New_Reference_To (Return_Type, Loc),
Constant_Present => True,
Expression => Relocate_Node (Exp));
Set_Assignment_OK (Result_Obj);
Insert_Action (Exp, Result_Obj);
Rewrite (Exp, Result_Exp);
Analyze_And_Resolve (Exp, Return_Type);
end if;
-- Ada 2005 (AI-344): If the result type is class-wide, then insert
-- a check that the level of the return expression's underlying type
-- is not deeper than the level of the master enclosing the function.
-- Always generate the check when the type of the return expression
-- is class-wide, when it's a type conversion, or when it's a formal
-- parameter. Otherwise, suppress the check in the case where the
-- return expression has a specific type whose level is known not to
-- be statically deeper than the function's result type.
elsif Ada_Version >= Ada_05
and then Is_Class_Wide_Type (Return_Type)
and then not Scope_Suppress (Accessibility_Check)
and then
(Is_Class_Wide_Type (Etype (Exp))
or else Nkind (Exp) = N_Type_Conversion
or else Nkind (Exp) = N_Unchecked_Type_Conversion
or else (Is_Entity_Name (Exp)
and then Ekind (Entity (Exp)) in Formal_Kind)
or else Scope_Depth (Enclosing_Dynamic_Scope (Etype (Exp))) >
Scope_Depth (Enclosing_Dynamic_Scope (Scope_Id)))
then
Insert_Action (Exp,
Make_Raise_Program_Error (Loc,
Condition =>
Make_Op_Gt (Loc,
Left_Opnd =>
Make_Function_Call (Loc,
Name =>
New_Reference_To
(RTE (RE_Get_Access_Level), Loc),
Parameter_Associations =>
New_List (Make_Attribute_Reference (Loc,
Prefix =>
Duplicate_Subexpr (Exp),
Attribute_Name =>
Name_Tag))),
Right_Opnd =>
Make_Integer_Literal (Loc,
Scope_Depth (Enclosing_Dynamic_Scope (Scope_Id)))),
Reason => PE_Accessibility_Check_Failed));
end if;
-- Deal with returning variable length objects and controlled types -- Deal with returning variable length objects and controlled types
-- Nothing to do if we are returning by reference, or this is not -- Nothing to do if we are returning by reference, or this is not
-- a type that requires special processing (indicated by the fact -- a type that requires special processing (indicated by the fact
-- that it requires a cleanup scope for the secondary stack case) -- that it requires a cleanup scope for the secondary stack case)
if Is_Return_By_Reference_Type (T) if Is_Return_By_Reference_Type (T) then
or else not Requires_Transient_Scope (Return_Type)
then
null; null;
elsif not Requires_Transient_Scope (Return_Type) then
-- mutable records with no variable length components are not
-- returned on the sec-stack so we need to make sure that the
-- backend will only copy back the size of the actual value and not
-- the maximum size. We create an actual subtype for this purpose
declare
Ubt : constant Entity_Id := Underlying_Type (Base_Type (T));
Decl : Node_Id;
Ent : Entity_Id;
begin
if Has_Discriminants (Ubt)
and then not Is_Constrained (Ubt)
and then not Has_Unchecked_Union (Ubt)
then
Decl := Build_Actual_Subtype (Ubt, Exp);
Ent := Defining_Identifier (Decl);
Insert_Action (Exp, Decl);
Rewrite (Exp, Unchecked_Convert_To (Ent, Exp));
end if;
end;
-- Case of secondary stack not used -- Case of secondary stack not used
elsif Function_Returns_With_DSP (Scope_Id) then elsif Function_Returns_With_DSP (Scope_Id) then
...@@ -3063,6 +2990,12 @@ package body Exp_Ch5 is ...@@ -3063,6 +2990,12 @@ package body Exp_Ch5 is
then then
Set_By_Ref (N); Set_By_Ref (N);
-- Remove side effects from the expression now so that
-- other part of the expander do not have to reanalyze
-- this node without this optimization
Rewrite (Exp, Duplicate_Subexpr_No_Checks (Exp));
-- For controlled types, do the allocation on the sec-stack -- For controlled types, do the allocation on the sec-stack
-- manually in order to call adjust at the right time -- manually in order to call adjust at the right time
-- type Anon1 is access Return_Type; -- type Anon1 is access Return_Type;
...@@ -3128,6 +3061,112 @@ package body Exp_Ch5 is ...@@ -3128,6 +3061,112 @@ package body Exp_Ch5 is
end if; end if;
end if; end if;
-- Implement the rules of 6.5(8-10), which require a tag check in
-- the case of a limited tagged return type, and tag reassignment
-- for nonlimited tagged results. These actions are needed when
-- the return type is a specific tagged type and the result
-- expression is a conversion or a formal parameter, because in
-- that case the tag of the expression might differ from the tag
-- of the specific result type.
if Is_Tagged_Type (Utyp)
and then not Is_Class_Wide_Type (Utyp)
and then (Nkind (Exp) = N_Type_Conversion
or else Nkind (Exp) = N_Unchecked_Type_Conversion
or else (Is_Entity_Name (Exp)
and then Ekind (Entity (Exp)) in Formal_Kind))
then
-- When the return type is limited, perform a check that the
-- tag of the result is the same as the tag of the return type.
if Is_Limited_Type (Return_Type) then
Insert_Action (Exp,
Make_Raise_Constraint_Error (Loc,
Condition =>
Make_Op_Ne (Loc,
Left_Opnd =>
Make_Selected_Component (Loc,
Prefix => Duplicate_Subexpr (Exp),
Selector_Name =>
New_Reference_To (First_Tag_Component (Utyp), Loc)),
Right_Opnd =>
Unchecked_Convert_To (RTE (RE_Tag),
New_Reference_To
(Node (First_Elmt
(Access_Disp_Table (Base_Type (Utyp)))),
Loc))),
Reason => CE_Tag_Check_Failed));
-- If the result type is a specific nonlimited tagged type,
-- then we have to ensure that the tag of the result is that
-- of the result type. This is handled by making a copy of the
-- expression in the case where it might have a different tag,
-- namely when the expression is a conversion or a formal
-- parameter. We create a new object of the result type and
-- initialize it from the expression, which will implicitly
-- force the tag to be set appropriately.
else
Result_Id :=
Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
Result_Exp := New_Reference_To (Result_Id, Loc);
Result_Obj :=
Make_Object_Declaration (Loc,
Defining_Identifier => Result_Id,
Object_Definition => New_Reference_To (Return_Type, Loc),
Constant_Present => True,
Expression => Relocate_Node (Exp));
Set_Assignment_OK (Result_Obj);
Insert_Action (Exp, Result_Obj);
Rewrite (Exp, Result_Exp);
Analyze_And_Resolve (Exp, Return_Type);
end if;
-- Ada 2005 (AI-344): If the result type is class-wide, then insert
-- a check that the level of the return expression's underlying type
-- is not deeper than the level of the master enclosing the function.
-- Always generate the check when the type of the return expression
-- is class-wide, when it's a type conversion, or when it's a formal
-- parameter. Otherwise, suppress the check in the case where the
-- return expression has a specific type whose level is known not to
-- be statically deeper than the function's result type.
elsif Ada_Version >= Ada_05
and then Is_Class_Wide_Type (Return_Type)
and then not Scope_Suppress (Accessibility_Check)
and then
(Is_Class_Wide_Type (Etype (Exp))
or else Nkind (Exp) = N_Type_Conversion
or else Nkind (Exp) = N_Unchecked_Type_Conversion
or else (Is_Entity_Name (Exp)
and then Ekind (Entity (Exp)) in Formal_Kind)
or else Scope_Depth (Enclosing_Dynamic_Scope (Etype (Exp))) >
Scope_Depth (Enclosing_Dynamic_Scope (Scope_Id)))
then
Insert_Action (Exp,
Make_Raise_Program_Error (Loc,
Condition =>
Make_Op_Gt (Loc,
Left_Opnd =>
Make_Function_Call (Loc,
Name =>
New_Reference_To
(RTE (RE_Get_Access_Level), Loc),
Parameter_Associations =>
New_List (Make_Attribute_Reference (Loc,
Prefix =>
Duplicate_Subexpr (Exp),
Attribute_Name =>
Name_Tag))),
Right_Opnd =>
Make_Integer_Literal (Loc,
Scope_Depth (Enclosing_Dynamic_Scope (Scope_Id)))),
Reason => PE_Accessibility_Check_Failed));
end if;
exception exception
when RE_Not_Available => when RE_Not_Available =>
return; return;
...@@ -3175,7 +3214,7 @@ package body Exp_Ch5 is ...@@ -3175,7 +3214,7 @@ package body Exp_Ch5 is
if not Ctrl_Act then if not Ctrl_Act then
null; null;
-- The left hand side is an uninitialized temporary -- The left hand side is an uninitialized temporary
elsif Nkind (L) = N_Type_Conversion elsif Nkind (L) = N_Type_Conversion
and then Is_Entity_Name (Expression (L)) and then Is_Entity_Name (Expression (L))
......
gcc/ada/sem_ch5.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 1992-2005 Free Software Foundation, Inc. -- -- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -71,15 +71,6 @@ package body Sem_Ch5 is ...@@ -71,15 +71,6 @@ package body Sem_Ch5 is
procedure Analyze_Iteration_Scheme (N : Node_Id); procedure Analyze_Iteration_Scheme (N : Node_Id);
procedure Check_Possible_Current_Value_Condition (Cnode : Node_Id);
-- Cnode is N_If_Statement, N_Elsif_Part, or N_Iteration_Scheme
-- (the latter when a WHILE condition is present). This call checks
-- if Condition (Cnode) is of the form ([NOT] var op val), where var
-- is a simple object, val is known at compile time, and op is one
-- of the six relational operators. If this is the case, and the
-- Current_Value field of "var" is not set, then it is set to Cnode.
-- See Exp_Util.Set_Current_Value_Condition for further details.
------------------------ ------------------------
-- Analyze_Assignment -- -- Analyze_Assignment --
------------------------ ------------------------
...@@ -1526,13 +1517,15 @@ package body Sem_Ch5 is ...@@ -1526,13 +1517,15 @@ package body Sem_Ch5 is
-- of reversing the bounds incorrectly in the range. -- of reversing the bounds incorrectly in the range.
elsif Reverse_Present (LP) elsif Reverse_Present (LP)
and then Nkind (H) = N_Integer_Literal and then Nkind (Original_Node (H)) =
N_Integer_Literal
and then (Intval (H) = Uint_0 and then (Intval (H) = Uint_0
or else or else
Intval (H) = Uint_1) Intval (H) = Uint_1)
and then Lhi > Hhi and then Lhi > Hhi
then then
Error_Msg_N ("?loop range may be null", DS); Error_Msg_N ("?loop range may be null", DS);
Error_Msg_N ("\?bounds may be wrong way round", DS);
end if; end if;
end; end;
end if; end if;
......
gcc/ada/sem_ch5.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 1992-2002 Free Software Foundation, Inc. -- -- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -47,6 +47,15 @@ package Sem_Ch5 is ...@@ -47,6 +47,15 @@ package Sem_Ch5 is
-- care of setting Reachable, since labels defined by the expander can -- care of setting Reachable, since labels defined by the expander can
-- be assumed to be reachable. -- be assumed to be reachable.
procedure Check_Possible_Current_Value_Condition (Cnode : Node_Id);
-- Cnode is N_If_Statement, N_Elsif_Part, or N_Iteration_Scheme
-- (the latter when a WHILE condition is present). This call checks
-- if Condition (Cnode) is of the form ([NOT] var op val), where var
-- is a simple object, val is known at compile time, and op is one
-- of the six relational operators. If this is the case, and the
-- Current_Value field of "var" is not set, then it is set to Cnode.
-- See Exp_Util.Set_Current_Value_Condition for further details.
procedure Check_Unreachable_Code (N : Node_Id); procedure Check_Unreachable_Code (N : Node_Id);
-- This procedure is called with N being the node for a statement that -- This procedure is called with N being the node for a statement that
-- is an unconditional transfer of control. It checks to see if the -- is an unconditional transfer of control. It checks to see if the
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment