Skip to content

R
riscv-gcc-1
Commit 176dadf6 by Arnaud Charlet
Options

[multiple changes] 

2011-08-02  Robert Dewar  <dewar@adacore.com>

	* sem_ch3.adb: Minor reformatting
	Minor comment addition
	Minor error msg text change

2011-08-02  Javier Miranda  <miranda@adacore.com>

	* sem_ch5.adb (Analyze_Iteration_Scheme.Uses_Secondary_Stack): New
	function. Used to be more precise when we generate a variable plus one
	assignment to remove side effects in the evaluation of the Bound
	expressions.
	(Analyze_Iteration_Scheme): Clean attribute analyzed in all the nodes
	of the bound expression to force its re-analysis and thus expand the
	associated transient scope (if required). Code cleanup replacing the
	previous code that declared the constant entity by an invocation to
	routine Force_Evaluation which centralizes this work in the frontend.

From-SVN: r177124
parent d8b962d8
Showing with 237 additions and 169 deletions
gcc/ada/ChangeLog
2011-08-02 Robert Dewar <dewar@adacore.com> 2011-08-02 Robert Dewar <dewar@adacore.com>
* sem_ch3.adb: Minor reformatting
Minor comment addition
Minor error msg text change
2011-08-02 Javier Miranda <miranda@adacore.com>
* sem_ch5.adb (Analyze_Iteration_Scheme.Uses_Secondary_Stack): New
function. Used to be more precise when we generate a variable plus one
assignment to remove side effects in the evaluation of the Bound
expressions.
(Analyze_Iteration_Scheme): Clean attribute analyzed in all the nodes
of the bound expression to force its re-analysis and thus expand the
associated transient scope (if required). Code cleanup replacing the
previous code that declared the constant entity by an invocation to
routine Force_Evaluation which centralizes this work in the frontend.
2011-08-02 Robert Dewar <dewar@adacore.com>
* einfo.adb (Is_Base_Type): Improve efficiency by using a flag table * einfo.adb (Is_Base_Type): Improve efficiency by using a flag table
(Base_Type): Now uses improved Is_Base_Type function (Base_Type): Now uses improved Is_Base_Type function
* einfo.ads (Base_Type): Inline this function * einfo.ads (Base_Type): Inline this function
......
gcc/ada/sem_ch3.adb
...@@ -1666,10 +1666,12 @@ package body Sem_Ch3 is ...@@ -1666,10 +1666,12 @@ package body Sem_Ch3 is
----------------------------------- -----------------------------------
procedure Analyze_Component_Declaration (N : Node_Id) is procedure Analyze_Component_Declaration (N : Node_Id) is
Id : constant Entity_Id := Defining_Identifier (N); Id : constant Entity_Id := Defining_Identifier (N);
E : constant Node_Id := Expression (N); E : constant Node_Id := Expression (N);
T : Entity_Id; Typ : constant Node_Id :=
P : Entity_Id; Subtype_Indication (Component_Definition (N));
T : Entity_Id;
P : Entity_Id;
function Contains_POC (Constr : Node_Id) return Boolean; function Contains_POC (Constr : Node_Id) return Boolean;
-- Determines whether a constraint uses the discriminant of a record -- Determines whether a constraint uses the discriminant of a record
...@@ -1773,8 +1775,6 @@ package body Sem_Ch3 is ...@@ -1773,8 +1775,6 @@ package body Sem_Ch3 is
end if; end if;
end Is_Known_Limited; end Is_Known_Limited;
Typ : constant Node_Id := Subtype_Indication (Component_Definition (N));
-- Start of processing for Analyze_Component_Declaration -- Start of processing for Analyze_Component_Declaration
begin begin
...@@ -4005,8 +4005,9 @@ package body Sem_Ch3 is ...@@ -4005,8 +4005,9 @@ package body Sem_Ch3 is
("subtype of Boolean cannot have constraint", N); ("subtype of Boolean cannot have constraint", N);
end if; end if;
-- Subtype of String shall have a lower index bound equal to 1 in SPARK -- String subtype must have a lower bound of 1 in SPARK/ALFA. Note that
-- or ALFA. -- we do not need to test for the non-static case here, since that was
-- already taken care of in Process_Range_Expr_In_Decl.
if Base_Type (T) = Standard_String if Base_Type (T) = Standard_String
and then Nkind (Subtype_Indication (N)) = N_Subtype_Indication and then Nkind (Subtype_Indication (N)) = N_Subtype_Indication
...@@ -4015,6 +4016,7 @@ package body Sem_Ch3 is ...@@ -4015,6 +4016,7 @@ package body Sem_Ch3 is
Cstr : constant Node_Id := Constraint (Subtype_Indication (N)); Cstr : constant Node_Id := Constraint (Subtype_Indication (N));
Drange : Node_Id; Drange : Node_Id;
Low : Node_Id; Low : Node_Id;
begin begin
if Nkind (Cstr) = N_Index_Or_Discriminant_Constraint if Nkind (Cstr) = N_Index_Or_Discriminant_Constraint
and then List_Length (Constraints (Cstr)) = 1 and then List_Length (Constraints (Cstr)) = 1
...@@ -4028,7 +4030,7 @@ package body Sem_Ch3 is ...@@ -4028,7 +4030,7 @@ package body Sem_Ch3 is
and then Expr_Value (Low) /= 1 and then Expr_Value (Low) /= 1
then then
Check_Formal_Restriction Check_Formal_Restriction
("subtype of String must have 1 as lower bound", N); ("String subtype must have lower bound of 1", N);
end if; end if;
end if; end if;
end if; end if;
...@@ -19011,6 +19013,7 @@ package body Sem_Ch3 is ...@@ -19011,6 +19013,7 @@ package body Sem_Ch3 is
declare declare
Typ : Node_Id; Typ : Node_Id;
Ctxt : Node_Id; Ctxt : Node_Id;
begin begin
if Nkind (Parent (Def)) = N_Full_Type_Declaration then if Nkind (Parent (Def)) = N_Full_Type_Declaration then
Typ := Parent (Def); Typ := Parent (Def);
...@@ -19027,14 +19030,12 @@ package body Sem_Ch3 is ...@@ -19027,14 +19030,12 @@ package body Sem_Ch3 is
then then
Check_Formal_Restriction Check_Formal_Restriction
("type should be defined in package specification", Typ); ("type should be defined in package specification", Typ);
elsif Nkind (Ctxt) /= N_Package_Specification elsif Nkind (Ctxt) /= N_Package_Specification
or else or else Nkind (Parent (Parent (Ctxt))) /= N_Compilation_Unit
Nkind (Parent (Parent (Ctxt))) /= N_Compilation_Unit
then then
Check_Formal_Restriction Check_Formal_Restriction
("type should be defined in library unit package", Typ); ("type should be defined in library unit package", Typ);
else
null;
end if; end if;
end; end;
end if; end if;
......
gcc/ada/sem_ch5.adb
...@@ -95,9 +95,9 @@ package body Sem_Ch5 is ...@@ -95,9 +95,9 @@ package body Sem_Ch5 is
procedure Set_Assignment_Type procedure Set_Assignment_Type
(Opnd : Node_Id; (Opnd : Node_Id;
Opnd_Type : in out Entity_Id); Opnd_Type : in out Entity_Id);
-- Opnd is either the Lhs or Rhs of the assignment, and Opnd_Type -- Opnd is either the Lhs or Rhs of the assignment, and Opnd_Type is the
-- is the nominal subtype. This procedure is used to deal with cases -- nominal subtype. This procedure is used to deal with cases where the
-- where the nominal subtype must be replaced by the actual subtype. -- nominal subtype must be replaced by the actual subtype.
------------------------------- -------------------------------
-- Diagnose_Non_Variable_Lhs -- -- Diagnose_Non_Variable_Lhs --
...@@ -105,8 +105,8 @@ package body Sem_Ch5 is ...@@ -105,8 +105,8 @@ package body Sem_Ch5 is
procedure Diagnose_Non_Variable_Lhs (N : Node_Id) is procedure Diagnose_Non_Variable_Lhs (N : Node_Id) is
begin begin
-- Not worth posting another error if left hand side already -- Not worth posting another error if left hand side already flagged
-- flagged as being illegal in some respect. -- as being illegal in some respect.
if Error_Posted (N) then if Error_Posted (N) then
return; return;
...@@ -130,8 +130,8 @@ package body Sem_Ch5 is ...@@ -130,8 +130,8 @@ package body Sem_Ch5 is
elsif (Is_Prival (Ent) elsif (Is_Prival (Ent)
and then and then
(Ekind (Current_Scope) = E_Function (Ekind (Current_Scope) = E_Function
or else Ekind (Enclosing_Dynamic_Scope ( or else Ekind (Enclosing_Dynamic_Scope
Current_Scope)) = E_Function)) (Current_Scope)) = E_Function))
or else or else
(Ekind (Ent) = E_Component (Ekind (Ent) = E_Component
and then Is_Protected_Type (Scope (Ent))) and then Is_Protected_Type (Scope (Ent)))
...@@ -202,10 +202,10 @@ package body Sem_Ch5 is ...@@ -202,10 +202,10 @@ package body Sem_Ch5 is
Require_Entity (Opnd); Require_Entity (Opnd);
-- If the assignment operand is an in-out or out parameter, then we -- If the assignment operand is an in-out or out parameter, then we
-- get the actual subtype (needed for the unconstrained case). -- get the actual subtype (needed for the unconstrained case). If the
-- If the operand is the actual in an entry declaration, then within -- operand is the actual in an entry declaration, then within the
-- the accept statement it is replaced with a local renaming, which -- accept statement it is replaced with a local renaming, which may
-- may also have an actual subtype. -- also have an actual subtype.
if Is_Entity_Name (Opnd) if Is_Entity_Name (Opnd)
and then (Ekind (Entity (Opnd)) = E_Out_Parameter and then (Ekind (Entity (Opnd)) = E_Out_Parameter
...@@ -344,8 +344,8 @@ package body Sem_Ch5 is ...@@ -344,8 +344,8 @@ package body Sem_Ch5 is
end if; end if;
end if; end if;
-- The resulting assignment type is T1, so now we will resolve the -- The resulting assignment type is T1, so now we will resolve the left
-- left hand side of the assignment using this determined type. -- hand side of the assignment using this determined type.
Resolve (Lhs, T1); Resolve (Lhs, T1);
...@@ -353,8 +353,8 @@ package body Sem_Ch5 is ...@@ -353,8 +353,8 @@ package body Sem_Ch5 is
if not Is_Variable (Lhs) then if not Is_Variable (Lhs) then
-- Ada 2005 (AI-327): Check assignment to the attribute Priority of -- Ada 2005 (AI-327): Check assignment to the attribute Priority of a
-- a protected object. -- protected object.
declare declare
Ent : Entity_Id; Ent : Entity_Id;
...@@ -452,9 +452,9 @@ package body Sem_Ch5 is ...@@ -452,9 +452,9 @@ package body Sem_Ch5 is
("target of assignment operation must not be abstract", Lhs); ("target of assignment operation must not be abstract", Lhs);
end if; end if;
-- Resolution may have updated the subtype, in case the left-hand -- Resolution may have updated the subtype, in case the left-hand side
-- side is a private protected component. Use the correct subtype -- is a private protected component. Use the correct subtype to avoid
-- to avoid scoping issues in the back-end. -- scoping issues in the back-end.
T1 := Etype (Lhs); T1 := Etype (Lhs);
...@@ -631,7 +631,7 @@ package body Sem_Ch5 is ...@@ -631,7 +631,7 @@ package body Sem_Ch5 is
Apply_Scalar_Range_Check (Rhs, Etype (Lhs)); Apply_Scalar_Range_Check (Rhs, Etype (Lhs));
-- For array types, verify that lengths match. If the right hand side -- For array types, verify that lengths match. If the right hand side
-- if a function call that has been inlined, the assignment has been -- is a function call that has been inlined, the assignment has been
-- rewritten as a block, and the constraint check will be applied to the -- rewritten as a block, and the constraint check will be applied to the
-- assignment within the block. -- assignment within the block.
...@@ -648,8 +648,8 @@ package body Sem_Ch5 is ...@@ -648,8 +648,8 @@ package body Sem_Ch5 is
-- side is a type conversion to an unconstrained type, a length check -- side is a type conversion to an unconstrained type, a length check
-- is performed on the expression itself during expansion. In rare -- is performed on the expression itself during expansion. In rare
-- cases, the redundant length check is computed on an index type -- cases, the redundant length check is computed on an index type
-- with a different representation, triggering incorrect code in -- with a different representation, triggering incorrect code in the
-- the back end. -- back end.
Apply_Length_Check (Rhs, Etype (Lhs)); Apply_Length_Check (Rhs, Etype (Lhs));
...@@ -679,11 +679,11 @@ package body Sem_Ch5 is ...@@ -679,11 +679,11 @@ package body Sem_Ch5 is
and then Same_Object (Lhs, Original_Node (Rhs)) and then Same_Object (Lhs, Original_Node (Rhs))
-- But exclude the case where the right side was an operation -- But exclude the case where the right side was an operation that
-- that got rewritten (e.g. JUNK + K, where K was known to be -- got rewritten (e.g. JUNK + K, where K was known to be zero). We
-- zero). We don't want to warn in such a case, since it is -- don't want to warn in such a case, since it is reasonable to write
-- reasonable to write such expressions especially when K is -- such expressions especially when K is defined symbolically in some
-- defined symbolically in some other package. -- other package.
and then Nkind (Original_Node (Rhs)) not in N_Op and then Nkind (Original_Node (Rhs)) not in N_Op
then then
...@@ -722,11 +722,11 @@ package body Sem_Ch5 is ...@@ -722,11 +722,11 @@ package body Sem_Ch5 is
Set_Referenced_Modified (Lhs, Out_Param => False); Set_Referenced_Modified (Lhs, Out_Param => False);
end if; end if;
-- Final step. If left side is an entity, then we may be able to -- Final step. If left side is an entity, then we may be able to reset
-- reset the current tracked values to new safe values. We only have -- the current tracked values to new safe values. We only have something
-- something to do if the left side is an entity name, and expansion -- to do if the left side is an entity name, and expansion has not
-- has not modified the node into something other than an assignment, -- modified the node into something other than an assignment, and of
-- and of course we only capture values if it is safe to do so. -- course we only capture values if it is safe to do so.
if Is_Entity_Name (Lhs) if Is_Entity_Name (Lhs)
and then Nkind (N) = N_Assignment_Statement and then Nkind (N) = N_Assignment_Statement
...@@ -739,8 +739,8 @@ package body Sem_Ch5 is ...@@ -739,8 +739,8 @@ package body Sem_Ch5 is
-- If simple variable on left side, warn if this assignment -- If simple variable on left side, warn if this assignment
-- blots out another one (rendering it useless) and note -- blots out another one (rendering it useless) and note
-- location of assignment in case no one references value. -- location of assignment in case no one references value. We
-- We only do this for source assignments, otherwise we can -- only do this for source assignments, otherwise we can
-- generate bogus warnings when an assignment is rewritten as -- generate bogus warnings when an assignment is rewritten as
-- another assignment, and gets tied up with itself. -- another assignment, and gets tied up with itself.
...@@ -809,9 +809,8 @@ package body Sem_Ch5 is ...@@ -809,9 +809,8 @@ package body Sem_Ch5 is
begin begin
Check_Formal_Restriction ("block statement is not allowed", N); Check_Formal_Restriction ("block statement is not allowed", N);
-- If no handled statement sequence is present, things are really -- If no handled statement sequence is present, things are really messed
-- messed up, and we just return immediately (this is a defence -- up, and we just return immediately (defence against previous errors).
-- against previous errors).
if No (HSS) then if No (HSS) then
return; return;
...@@ -843,10 +842,9 @@ package body Sem_Ch5 is ...@@ -843,10 +842,9 @@ package body Sem_Ch5 is
Analyze (Id); Analyze (Id);
Ent := Entity (Id); Ent := Entity (Id);
-- An error defense. If we have an identifier, but no entity, -- An error defense. If we have an identifier, but no entity, then
-- then something is wrong. If we have previous errors, then -- something is wrong. If previous errors, then just remove the
-- just remove the identifier and continue, otherwise raise -- identifier and continue, otherwise raise an exception.
-- an exception.
if No (Ent) then if No (Ent) then
if Total_Errors_Detected /= 0 then if Total_Errors_Detected /= 0 then
...@@ -887,9 +885,9 @@ package body Sem_Ch5 is ...@@ -887,9 +885,9 @@ package body Sem_Ch5 is
Analyze (HSS); Analyze (HSS);
Process_End_Label (HSS, 'e', Ent); Process_End_Label (HSS, 'e', Ent);
-- If exception handlers are present, then we indicate that -- If exception handlers are present, then we indicate that enclosing
-- enclosing scopes contain a block with handlers. We only -- scopes contain a block with handlers. We only need to mark non-
-- need to mark non-generic scopes. -- generic scopes.
if Present (EH) then if Present (EH) then
S := Scope (Ent); S := Scope (Ent);
...@@ -932,17 +930,17 @@ package body Sem_Ch5 is ...@@ -932,17 +930,17 @@ package body Sem_Ch5 is
-- Don't care about assigned values -- Don't care about assigned values
Statements_Analyzed : Boolean := False; Statements_Analyzed : Boolean := False;
-- Set True if at least some statement sequences get analyzed. -- Set True if at least some statement sequences get analyzed. If False
-- If False on exit, means we had a serious error that prevented -- on exit, means we had a serious error that prevented full analysis of
-- full analysis of the case statement, and as a result it is not -- the case statement, and as a result it is not a good idea to output
-- a good idea to output warning messages about unreachable code. -- warning messages about unreachable code.
Save_Unblocked_Exit_Count : constant Nat := Unblocked_Exit_Count; Save_Unblocked_Exit_Count : constant Nat := Unblocked_Exit_Count;
-- Recursively save value of this global, will be restored on exit -- Recursively save value of this global, will be restored on exit
procedure Non_Static_Choice_Error (Choice : Node_Id); procedure Non_Static_Choice_Error (Choice : Node_Id);
-- Error routine invoked by the generic instantiation below when -- Error routine invoked by the generic instantiation below when the
-- the case statement has a non static choice. -- case statement has a non static choice.
procedure Process_Statements (Alternative : Node_Id); procedure Process_Statements (Alternative : Node_Id);
-- Analyzes all the statements associated with a case alternative. -- Analyzes all the statements associated with a case alternative.
...@@ -981,16 +979,16 @@ package body Sem_Ch5 is ...@@ -981,16 +979,16 @@ package body Sem_Ch5 is
Statements_Analyzed := True; Statements_Analyzed := True;
-- An interesting optimization. If the case statement expression -- An interesting optimization. If the case statement expression
-- is a simple entity, then we can set the current value within -- is a simple entity, then we can set the current value within an
-- an alternative if the alternative has one possible value. -- alternative if the alternative has one possible value.
-- case N is -- case N is
-- when 1 => alpha -- when 1 => alpha
-- when 2 | 3 => beta -- when 2 | 3 => beta
-- when others => gamma -- when others => gamma
-- Here we know that N is initially 1 within alpha, but for beta -- Here we know that N is initially 1 within alpha, but for beta and
-- and gamma, we do not know anything more about the initial value. -- gamma, we do not know anything more about the initial value.
if Is_Entity_Name (Exp) then if Is_Entity_Name (Exp) then
Ent := Entity (Exp); Ent := Entity (Exp);
...@@ -1080,10 +1078,10 @@ package body Sem_Ch5 is ...@@ -1080,10 +1078,10 @@ package body Sem_Ch5 is
return; return;
end if; end if;
-- If the case expression is a formal object of mode in out, then -- If the case expression is a formal object of mode in out, then treat
-- treat it as having a nonstatic subtype by forcing use of the base -- it as having a nonstatic subtype by forcing use of the base type
-- type (which has to get passed to Check_Case_Choices below). Also -- (which has to get passed to Check_Case_Choices below). Also use base
-- use base type when the case expression is parenthesized. -- type when the case expression is parenthesized.
if Paren_Count (Exp) > 0 if Paren_Count (Exp) > 0
or else (Is_Entity_Name (Exp) or else (Is_Entity_Name (Exp)
...@@ -1148,13 +1146,16 @@ package body Sem_Ch5 is ...@@ -1148,13 +1146,16 @@ package body Sem_Ch5 is
---------------------------- ----------------------------
-- If the exit includes a name, it must be the name of a currently open -- If the exit includes a name, it must be the name of a currently open
-- loop. Otherwise there must be an innermost open loop on the stack, -- loop. Otherwise there must be an innermost open loop on the stack, to
-- to which the statement implicitly refers. -- which the statement implicitly refers.
-- Additionally, in formal mode: -- Additionally, in formal mode:
-- * the exit can only name the closest enclosing loop;
-- * an exit with a when clause must be directly contained in a loop; -- The exit can only name the closest enclosing loop;
-- * an exit without a when clause must be directly contained in an
-- An exit with a when clause must be directly contained in a loop;
-- An exit without a when clause must be directly contained in an
-- if-statement with no elsif or else, which is itself directly contained -- if-statement with no elsif or else, which is itself directly contained
-- in a loop. The exit must be the last statement in the if-statement. -- in a loop. The exit must be the last statement in the if-statement.
...@@ -1177,6 +1178,7 @@ package body Sem_Ch5 is ...@@ -1177,6 +1178,7 @@ package body Sem_Ch5 is
if not In_Open_Scopes (U_Name) or else Ekind (U_Name) /= E_Loop then if not In_Open_Scopes (U_Name) or else Ekind (U_Name) /= E_Loop then
Error_Msg_N ("invalid loop name in exit statement", N); Error_Msg_N ("invalid loop name in exit statement", N);
return; return;
else else
if Has_Loop_In_Inner_Open_Scopes (U_Name) then if Has_Loop_In_Inner_Open_Scopes (U_Name) then
Check_Formal_Restriction Check_Formal_Restriction
...@@ -1185,6 +1187,7 @@ package body Sem_Ch5 is ...@@ -1185,6 +1187,7 @@ package body Sem_Ch5 is
Set_Has_Exit (U_Name); Set_Has_Exit (U_Name);
end if; end if;
else else
U_Name := Empty; U_Name := Empty;
end if; end if;
...@@ -1194,7 +1197,8 @@ package body Sem_Ch5 is ...@@ -1194,7 +1197,8 @@ package body Sem_Ch5 is
Kind := Ekind (Scope_Id); Kind := Ekind (Scope_Id);
if Kind = E_Loop if Kind = E_Loop
and then (No (Target) or else Scope_Id = U_Name) then and then (No (Target) or else Scope_Id = U_Name)
then
Set_Has_Exit (Scope_Id); Set_Has_Exit (Scope_Id);
exit; exit;
...@@ -1339,15 +1343,14 @@ package body Sem_Ch5 is ...@@ -1339,15 +1343,14 @@ package body Sem_Ch5 is
-- A special complication arises in the analysis of if statements -- A special complication arises in the analysis of if statements
-- The expander has circuitry to completely delete code that it -- The expander has circuitry to completely delete code that it can tell
-- can tell will not be executed (as a result of compile time known -- will not be executed (as a result of compile time known conditions). In
-- conditions). In the analyzer, we ensure that code that will be -- the analyzer, we ensure that code that will be deleted in this manner is
-- deleted in this manner is analyzed but not expanded. This is -- analyzed but not expanded. This is obviously more efficient, but more
-- obviously more efficient, but more significantly, difficulties -- significantly, difficulties arise if code is expanded and then
-- arise if code is expanded and then eliminated (e.g. exception -- eliminated (e.g. exception table entries disappear). Similarly, itypes
-- table entries disappear). Similarly, itypes generated in deleted -- generated in deleted code must be frozen from start, because the nodes
-- code must be frozen from start, because the nodes on which they -- on which they depend will not be available at the freeze point.
-- depend will not be available at the freeze point.
procedure Analyze_If_Statement (N : Node_Id) is procedure Analyze_If_Statement (N : Node_Id) is
E : Node_Id; E : Node_Id;
...@@ -1358,13 +1361,13 @@ package body Sem_Ch5 is ...@@ -1358,13 +1361,13 @@ package body Sem_Ch5 is
Save_In_Deleted_Code : Boolean; Save_In_Deleted_Code : Boolean;
Del : Boolean := False; Del : Boolean := False;
-- This flag gets set True if a True condition has been found, -- This flag gets set True if a True condition has been found, which
-- which means that remaining ELSE/ELSIF parts are deleted. -- means that remaining ELSE/ELSIF parts are deleted.
procedure Analyze_Cond_Then (Cnode : Node_Id); procedure Analyze_Cond_Then (Cnode : Node_Id);
-- This is applied to either the N_If_Statement node itself or -- This is applied to either the N_If_Statement node itself or to an
-- to an N_Elsif_Part node. It deals with analyzing the condition -- N_Elsif_Part node. It deals with analyzing the condition and the THEN
-- and the THEN statements associated with it. -- statements associated with it.
----------------------- -----------------------
-- Analyze_Cond_Then -- -- Analyze_Cond_Then --
...@@ -1390,8 +1393,8 @@ package body Sem_Ch5 is ...@@ -1390,8 +1393,8 @@ package body Sem_Ch5 is
elsif Compile_Time_Known_Value (Cond) then elsif Compile_Time_Known_Value (Cond) then
Save_In_Deleted_Code := In_Deleted_Code; Save_In_Deleted_Code := In_Deleted_Code;
-- If condition is True, then analyze the THEN statements -- If condition is True, then analyze the THEN statements and set
-- and set no expansion for ELSE and ELSIF parts. -- no expansion for ELSE and ELSIF parts.
if Is_True (Expr_Value (Cond)) then if Is_True (Expr_Value (Cond)) then
Analyze_Statements (Tstm); Analyze_Statements (Tstm);
...@@ -1419,9 +1422,9 @@ package body Sem_Ch5 is ...@@ -1419,9 +1422,9 @@ package body Sem_Ch5 is
-- Start of Analyze_If_Statement -- Start of Analyze_If_Statement
begin begin
-- Initialize exit count for else statements. If there is no else -- Initialize exit count for else statements. If there is no else part,
-- part, this count will stay non-zero reflecting the fact that the -- this count will stay non-zero reflecting the fact that the uncovered
-- uncovered else case is an unblocked exit. -- else case is an unblocked exit.
Unblocked_Exit_Count := 1; Unblocked_Exit_Count := 1;
Analyze_Cond_Then (N); Analyze_Cond_Then (N);
...@@ -1481,9 +1484,8 @@ package body Sem_Ch5 is ...@@ -1481,9 +1484,8 @@ package body Sem_Ch5 is
-- Analyze_Implicit_Label_Declaration -- -- Analyze_Implicit_Label_Declaration --
---------------------------------------- ----------------------------------------
-- An implicit label declaration is generated in the innermost -- An implicit label declaration is generated in the innermost enclosing
-- enclosing declarative part. This is done for labels as well as -- declarative part. This is done for labels, and block and loop names.
-- block and loop names.
-- Note: any changes in this routine may need to be reflected in -- Note: any changes in this routine may need to be reflected in
-- Analyze_Label_Entity. -- Analyze_Label_Entity.
...@@ -1517,6 +1519,12 @@ package body Sem_Ch5 is ...@@ -1517,6 +1519,12 @@ package body Sem_Ch5 is
-- to capture the bounds, so that the function result can be finalized -- to capture the bounds, so that the function result can be finalized
-- in timely fashion. -- in timely fashion.
function Has_Call_Using_Secondary_Stack (N : Node_Id) return Boolean;
-- N is the node for an arbitrary construct. This function searches the
-- construct N to see if any expressions within it contain function
-- calls that use the secondary stack, returning True if any such call
-- is found, and False otherwise.
-------------------- --------------------
-- Process_Bounds -- -- Process_Bounds --
-------------------- --------------------
...@@ -1571,8 +1579,6 @@ package body Sem_Ch5 is ...@@ -1571,8 +1579,6 @@ package body Sem_Ch5 is
Analyze_And_Resolve (Original_Bound, Typ); Analyze_And_Resolve (Original_Bound, Typ);
Id := Make_Temporary (Loc, 'S', Original_Bound);
-- Normally, the best approach is simply to generate a constant -- Normally, the best approach is simply to generate a constant
-- declaration that captures the bound. However, there is a nasty -- declaration that captures the bound. However, there is a nasty
-- case where this is wrong. If the bound is complex, and has a -- case where this is wrong. If the bound is complex, and has a
...@@ -1584,33 +1590,13 @@ package body Sem_Ch5 is ...@@ -1584,33 +1590,13 @@ package body Sem_Ch5 is
-- proper trace of the value, useful in optimizations that get rid -- proper trace of the value, useful in optimizations that get rid
-- of junk range checks. -- of junk range checks.
-- Probably we want something like the Side_Effect_Free routine if not Has_Call_Using_Secondary_Stack (N) then
-- in Exp_Util, but for now, we just optimize the cases of 'Last Force_Evaluation (Original_Bound);
-- and 'First applied to an entity, since these are the important return Original_Bound;
-- cases for range check optimizations.
if Nkind (Original_Bound) = N_Attribute_Reference
and then (Attribute_Name (Original_Bound) = Name_First
or else
Attribute_Name (Original_Bound) = Name_Last)
and then Is_Entity_Name (Prefix (Original_Bound))
then
Decl :=
Make_Object_Declaration (Loc,
Defining_Identifier => Id,
Constant_Present => True,
Object_Definition => New_Occurrence_Of (Typ, Loc),
Expression => Relocate_Node (Original_Bound));
-- Insert declaration at proper place. If loop comes from an
-- enclosing quantified expression, the insertion point is
-- arbitrarily far up in the tree.
Insert_Action (Parent (N), Decl);
Rewrite (Original_Bound, New_Occurrence_Of (Id, Loc));
return Expression (Decl);
end if; end if;
Id := Make_Temporary (Loc, 'R', Original_Bound);
-- Here we make a declaration with a separate assignment -- Here we make a declaration with a separate assignment
-- statement, and insert before loop header. -- statement, and insert before loop header.
...@@ -1624,6 +1610,14 @@ package body Sem_Ch5 is ...@@ -1624,6 +1610,14 @@ package body Sem_Ch5 is
Name => New_Occurrence_Of (Id, Loc), Name => New_Occurrence_Of (Id, Loc),
Expression => Relocate_Node (Original_Bound)); Expression => Relocate_Node (Original_Bound));
-- We must recursively clean in the relocated expression the flag
-- analyzed to ensure that the expression is reanalyzed. Required
-- to ensure that the transient scope is established now (because
-- Establish_Transient_Scope discarded generating transient scopes
-- in the analysis of the iteration scheme).
Reset_Analyzed_Flags (Expression (Assign));
Insert_Actions (Parent (N), New_List (Decl, Assign)); Insert_Actions (Parent (N), New_List (Decl, Assign));
Rewrite (Original_Bound, New_Occurrence_Of (Id, Loc)); Rewrite (Original_Bound, New_Occurrence_Of (Id, Loc));
...@@ -1638,11 +1632,11 @@ package body Sem_Ch5 is ...@@ -1638,11 +1632,11 @@ package body Sem_Ch5 is
-- Start of processing for Process_Bounds -- Start of processing for Process_Bounds
begin begin
-- Determine expected type of range by analyzing separate copy -- Determine expected type of range by analyzing separate copy Do the
-- Do the analysis and resolution of the copy of the bounds with -- analysis and resolution of the copy of the bounds with expansion
-- expansion disabled, to prevent the generation of finalization -- disabled, to prevent the generation of finalization actions on
-- actions on each bound. This prevents memory leaks when the -- each bound. This prevents memory leaks when the bounds contain
-- bounds contain calls to functions returning controlled arrays. -- calls to functions returning controlled arrays.
Set_Parent (R_Copy, Parent (R)); Set_Parent (R_Copy, Parent (R));
Save_Analysis := Full_Analysis; Save_Analysis := Full_Analysis;
...@@ -1699,11 +1693,10 @@ package body Sem_Ch5 is ...@@ -1699,11 +1693,10 @@ package body Sem_Ch5 is
Typ := Etype (R_Copy); Typ := Etype (R_Copy);
-- If the type of the discrete range is Universal_Integer, then -- If the type of the discrete range is Universal_Integer, then the
-- the bound's type must be resolved to Integer, and any object -- bound's type must be resolved to Integer, and any object used to
-- used to hold the bound must also have type Integer, unless the -- hold the bound must also have type Integer, unless the literal
-- literal bounds are constant-folded expressions that carry a user- -- bounds are constant-folded expressions with a user-defined type.
-- defined type.
if Typ = Universal_Integer then if Typ = Universal_Integer then
if Nkind (Lo) = N_Integer_Literal if Nkind (Lo) = N_Integer_Literal
...@@ -1789,12 +1782,70 @@ package body Sem_Ch5 is ...@@ -1789,12 +1782,70 @@ package body Sem_Ch5 is
end if; end if;
end Check_Controlled_Array_Attribute; end Check_Controlled_Array_Attribute;
------------------------------------
-- Has_Call_Using_Secondary_Stack --
------------------------------------
function Has_Call_Using_Secondary_Stack (N : Node_Id) return Boolean is
function Check_Call (N : Node_Id) return Traverse_Result;
-- Check if N is a function call which uses the secondary stack
----------------
-- Check_Call --
----------------
function Check_Call (N : Node_Id) return Traverse_Result is
Nam : Node_Id;
Subp : Entity_Id;
Return_Typ : Entity_Id;
begin
if Nkind (N) = N_Function_Call then
Nam := Name (N);
-- Call using access to subprogram with explicit dereference
if Nkind (Nam) = N_Explicit_Dereference then
Subp := Etype (Nam);
-- Normal case
else
Subp := Entity (Nam);
end if;
Return_Typ := Etype (Subp);
if Is_Composite_Type (Return_Typ)
and then not Is_Constrained (Return_Typ)
then
return Abandon;
elsif Sec_Stack_Needed_For_Return (Subp) then
return Abandon;
end if;
end if;
-- Continue traversing the tree
return OK;
end Check_Call;
function Check_Calls is new Traverse_Func (Check_Call);
-- Start of processing for Has_Call_Using_Secondary_Stack
begin
return Check_Calls (N) = Abandon;
end Has_Call_Using_Secondary_Stack;
-- Start of processing for Analyze_Iteration_Scheme -- Start of processing for Analyze_Iteration_Scheme
begin begin
-- If this is a rewritten quantified expression, the iteration -- If this is a rewritten quantified expression, the iteration scheme
-- scheme has been analyzed already. Do no repeat analysis because -- has been analyzed already. Do no repeat analysis because the loop
-- the loop variable is already declared. -- variable is already declared.
if Analyzed (N) then if Analyzed (N) then
return; return;
...@@ -1812,8 +1863,8 @@ package body Sem_Ch5 is ...@@ -1812,8 +1863,8 @@ package body Sem_Ch5 is
Cond : constant Node_Id := Condition (N); Cond : constant Node_Id := Condition (N);
begin begin
-- For WHILE loop, verify that the condition is a Boolean -- For WHILE loop, verify that the condition is a Boolean expression
-- expression and resolve and check it. -- and resolve and check it.
if Present (Cond) then if Present (Cond) then
Analyze_And_Resolve (Cond, Any_Boolean); Analyze_And_Resolve (Cond, Any_Boolean);
...@@ -1835,8 +1886,8 @@ package body Sem_Ch5 is ...@@ -1835,8 +1886,8 @@ package body Sem_Ch5 is
begin begin
Enter_Name (Id); Enter_Name (Id);
-- We always consider the loop variable to be referenced, -- We always consider the loop variable to be referenced, since
-- since the loop may be used just for counting purposes. -- the loop may be used just for counting purposes.
Generate_Reference (Id, N, ' '); Generate_Reference (Id, N, ' ');
...@@ -2000,8 +2051,8 @@ package body Sem_Ch5 is ...@@ -2000,8 +2051,8 @@ package body Sem_Ch5 is
if not Inside_A_Generic if not Inside_A_Generic
and then not In_Instance and then not In_Instance
then then
-- Specialize msg if invalid values could make -- Specialize msg if invalid values could make the
-- the loop non-null after all. -- loop non-null after all.
if Compile_Time_Compare if Compile_Time_Compare
(L, H, Assume_Valid => False) = GT (L, H, Assume_Valid => False) = GT
...@@ -2010,9 +2061,9 @@ package body Sem_Ch5 is ...@@ -2010,9 +2061,9 @@ package body Sem_Ch5 is
("?loop range is null, loop will not execute", ("?loop range is null, loop will not execute",
DS); DS);
-- Since we know the range of the loop is -- Since we know the range of the loop is null,
-- null, set the appropriate flag to remove -- set the appropriate flag to remove the loop
-- the loop entirely during expansion. -- entirely during expansion.
Set_Is_Null_Loop (Parent (N)); Set_Is_Null_Loop (Parent (N));
...@@ -2179,8 +2230,8 @@ package body Sem_Ch5 is ...@@ -2179,8 +2230,8 @@ package body Sem_Ch5 is
begin begin
if Present (Id) then if Present (Id) then
-- Make name visible, e.g. for use in exit statements. Loop -- Make name visible, e.g. for use in exit statements. Loop labels
-- labels are always considered to be referenced. -- are always considered to be referenced.
Analyze (Id); Analyze (Id);
Ent := Entity (Id); Ent := Entity (Id);
...@@ -2227,10 +2278,10 @@ package body Sem_Ch5 is ...@@ -2227,10 +2278,10 @@ package body Sem_Ch5 is
Set_Parent (Ent, Loop_Statement); Set_Parent (Ent, Loop_Statement);
end if; end if;
-- Kill current values on entry to loop, since statements in body of -- Kill current values on entry to loop, since statements in the body of
-- loop may have been executed before the loop is entered. Similarly we -- the loop may have been executed before the loop is entered. Similarly
-- kill values after the loop, since we do not know that the body of the -- we kill values after the loop, since we do not know that the body of
-- loop was executed. -- the loop was executed.
Kill_Current_Values; Kill_Current_Values;
Push_Scope (Ent); Push_Scope (Ent);
...@@ -2251,8 +2302,8 @@ package body Sem_Ch5 is ...@@ -2251,8 +2302,8 @@ package body Sem_Ch5 is
Check_Infinite_Loop_Warning (N); Check_Infinite_Loop_Warning (N);
end if; end if;
-- Code after loop is unreachable if the loop has no WHILE or FOR -- Code after loop is unreachable if the loop has no WHILE or FOR and
-- and contains no EXIT statements within the body of the loop. -- contains no EXIT statements within the body of the loop.
if No (Iter) and then not Has_Exit (Ent) then if No (Iter) and then not Has_Exit (Ent) then
Check_Unreachable_Code (N); Check_Unreachable_Code (N);
...@@ -2282,9 +2333,9 @@ package body Sem_Ch5 is ...@@ -2282,9 +2333,9 @@ package body Sem_Ch5 is
begin begin
-- The labels declared in the statement list are reachable from -- The labels declared in the statement list are reachable from
-- statements in the list. We do this as a prepass so that any -- statements in the list. We do this as a prepass so that any goto
-- goto statement will be properly flagged if its target is not -- statement will be properly flagged if its target is not reachable.
-- reachable. This is not required, but is nice behavior! -- This is not required, but is nice behavior!
S := First (L); S := First (L);
while Present (S) loop while Present (S) loop
...@@ -2331,10 +2382,9 @@ package body Sem_Ch5 is ...@@ -2331,10 +2382,9 @@ package body Sem_Ch5 is
Conditional_Statements_End; Conditional_Statements_End;
-- Make labels unreachable. Visibility is not sufficient, because -- Make labels unreachable. Visibility is not sufficient, because labels
-- labels in one if-branch for example are not reachable from the -- in one if-branch for example are not reachable from the other branch,
-- other branch, even though their declarations are in the enclosing -- even though their declarations are in the enclosing declarative part.
-- declarative part.
S := First (L); S := First (L);
while Present (S) loop while Present (S) loop
...@@ -2365,9 +2415,8 @@ package body Sem_Ch5 is ...@@ -2365,9 +2415,8 @@ package body Sem_Ch5 is
Nxt := Original_Node (Next (N)); Nxt := Original_Node (Next (N));
-- If a label follows us, then we never have dead code, since -- If a label follows us, then we never have dead code, since
-- someone could branch to the label, so we just ignore it, -- someone could branch to the label, so we just ignore it, unless
-- unless we are in formal mode where goto statements are not -- we are in formal mode where goto statements are not allowed.
-- allowed.
if Nkind (Nxt) = N_Label and then not Formal_Verification_Mode then if Nkind (Nxt) = N_Label and then not Formal_Verification_Mode then
return; return;
...@@ -2433,10 +2482,10 @@ package body Sem_Ch5 is ...@@ -2433,10 +2482,10 @@ package body Sem_Ch5 is
end if; end if;
end if; end if;
-- If the unconditional transfer of control instruction is -- If the unconditional transfer of control instruction is the
-- the last statement of a sequence, then see if our parent -- last statement of a sequence, then see if our parent is one of
-- is one of the constructs for which we count unblocked exits, -- the constructs for which we count unblocked exits, and if so,
-- and if so, adjust the count. -- adjust the count.
else else
P := Parent (N); P := Parent (N);
......
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