with Atree; use Atree;
with Checks; use Checks;
with Einfo; use Einfo;
with Errout; use Errout;
with Expander; use Expander;
with Exp_Util; use Exp_Util;
with Freeze; use Freeze;
with Lib.Xref; use Lib.Xref;
with Nlists; use Nlists;
with Nmake; use Nmake;
with Opt; use Opt;
with Sem; use Sem;
with Sem_Case; use Sem_Case;
with Sem_Ch3; use Sem_Ch3;
with Sem_Ch8; use Sem_Ch8;
with Sem_Disp; use Sem_Disp;
with Sem_Eval; use Sem_Eval;
with Sem_Res; use Sem_Res;
with Sem_Type; use Sem_Type;
with Sem_Util; use Sem_Util;
with Sem_Warn; use Sem_Warn;
with Stand; use Stand;
with Sinfo; use Sinfo;
with Targparm; use Targparm;
with Tbuild; use Tbuild;
with Uintp; use Uintp;
package body Sem_Ch5 is
Unblocked_Exit_Count : Nat := 0;
procedure Analyze_Iteration_Scheme (N : Node_Id);
procedure Analyze_Assignment (N : Node_Id) is
Lhs : constant Node_Id := Name (N);
Rhs : constant Node_Id := Expression (N);
T1 : Entity_Id;
T2 : Entity_Id;
Decl : Node_Id;
procedure Diagnose_Non_Variable_Lhs (N : Node_Id);
procedure Kill_Lhs;
procedure Set_Assignment_Type
(Opnd : Node_Id;
Opnd_Type : in out Entity_Id);
procedure Diagnose_Non_Variable_Lhs (N : Node_Id) is
begin
if Error_Posted (N) then
return;
elsif Is_Entity_Name (N) then
if Ekind (Entity (N)) = E_In_Parameter then
Error_Msg_N
("assignment to IN mode parameter not allowed", N);
elsif Present (Scope (Entity (N)))
and then Is_Protected_Type (Scope (Entity (N)))
and then
(Ekind (Current_Scope) = E_Function
or else
Ekind (Enclosing_Dynamic_Scope (Current_Scope)) = E_Function)
then
Error_Msg_N
("protected function cannot modify protected object", N);
elsif Ekind (Entity (N)) = E_Loop_Parameter then
Error_Msg_N
("assignment to loop parameter not allowed", N);
else
Error_Msg_N
("left hand side of assignment must be a variable", N);
end if;
elsif Nkind (N) = N_Indexed_Component then
Diagnose_Non_Variable_Lhs (Prefix (N));
elsif Nkind (N) = N_Selected_Component then
if Present (Entity (Selector_Name (N)))
and then Ekind (Entity (Selector_Name (N))) = E_Discriminant
then
Error_Msg_N
("assignment to discriminant not allowed", N);
else
Diagnose_Non_Variable_Lhs (Prefix (N));
end if;
else
Error_Msg_N ("left hand side of assignment must be a variable", N);
end if;
end Diagnose_Non_Variable_Lhs;
procedure Kill_Lhs is
begin
if Is_Entity_Name (Lhs) then
declare
Ent : constant Entity_Id := Entity (Lhs);
begin
if Present (Ent) then
Kill_Current_Values (Ent);
end if;
end;
end if;
end Kill_Lhs;
procedure Set_Assignment_Type
(Opnd : Node_Id;
Opnd_Type : in out Entity_Id)
is
begin
Require_Entity (Opnd);
if Is_Entity_Name (Opnd)
and then (Ekind (Entity (Opnd)) = E_Out_Parameter
or else Ekind (Entity (Opnd)) =
E_In_Out_Parameter
or else Ekind (Entity (Opnd)) =
E_Generic_In_Out_Parameter
or else
(Ekind (Entity (Opnd)) = E_Variable
and then Nkind (Parent (Entity (Opnd))) =
N_Object_Renaming_Declaration
and then Nkind (Parent (Parent (Entity (Opnd)))) =
N_Accept_Statement))
then
Opnd_Type := Get_Actual_Subtype (Opnd);
elsif
(Nkind (Opnd) = N_Selected_Component
or else Nkind (Opnd) = N_Explicit_Dereference)
and then not Is_Unchecked_Union (Opnd_Type)
then
Decl := Build_Actual_Subtype_Of_Component (Opnd_Type, Opnd);
if Present (Decl) then
Insert_Action (N, Decl);
Mark_Rewrite_Insertion (Decl);
Analyze (Decl);
Opnd_Type := Defining_Identifier (Decl);
Set_Etype (Opnd, Opnd_Type);
Freeze_Itype (Opnd_Type, N);
elsif Is_Constrained (Etype (Opnd)) then
Opnd_Type := Etype (Opnd);
end if;
elsif Nkind (Opnd) = N_Slice then
Opnd_Type := Etype (Opnd);
end if;
end Set_Assignment_Type;
begin
Analyze (Rhs);
Analyze (Lhs);
T1 := Etype (Lhs);
if Is_Overloaded (Lhs) then
declare
I : Interp_Index;
It : Interp;
begin
T1 := Any_Type;
Get_First_Interp (Lhs, I, It);
while Present (It.Typ) loop
if Has_Compatible_Type (Rhs, It.Typ) then
if T1 /= Any_Type then
if Nkind (Lhs) = N_Explicit_Dereference then
declare
PI : Interp_Index;
PI1 : Interp_Index := 0;
PIt : Interp;
Found : Boolean;
begin
Found := False;
Get_First_Interp (Prefix (Lhs), PI, PIt);
while Present (PIt.Typ) loop
if Is_Access_Type (PIt.Typ)
and then Has_Compatible_Type
(Rhs, Designated_Type (PIt.Typ))
then
if Found then
PIt :=
Disambiguate (Prefix (Lhs),
PI1, PI, Any_Type);
if PIt = No_Interp then
Error_Msg_N
("ambiguous left-hand side"
& " in assignment", Lhs);
exit;
else
Resolve (Prefix (Lhs), PIt.Typ);
end if;
exit;
else
Found := True;
PI1 := PI;
end if;
end if;
Get_Next_Interp (PI, PIt);
end loop;
end;
else
Error_Msg_N
("ambiguous left-hand side in assignment", Lhs);
exit;
end if;
else
T1 := It.Typ;
end if;
end if;
Get_Next_Interp (I, It);
end loop;
end;
if T1 = Any_Type then
Error_Msg_N
("no valid types for left-hand side for assignment", Lhs);
Kill_Lhs;
return;
end if;
end if;
Resolve (Lhs, T1);
if not Is_Variable (Lhs) then
Diagnose_Non_Variable_Lhs (Lhs);
return;
elsif Is_Limited_Type (T1)
and then not Assignment_OK (Lhs)
and then not Assignment_OK (Original_Node (Lhs))
then
Error_Msg_N
("left hand of assignment must not be limited type", Lhs);
Explain_Limited_Type (T1, Lhs);
return;
end if;
T1 := Etype (Lhs);
if Nkind (Lhs) = N_Explicit_Dereference
and then Ekind (T1) = E_Incomplete_Type
then
Error_Msg_N ("invalid use of incomplete type", Lhs);
Kill_Lhs;
return;
end if;
Set_Assignment_Type (Lhs, T1);
Resolve (Rhs, T1);
Check_Unset_Reference (Rhs);
if Rhs = Error then
Kill_Lhs;
return;
end if;
T2 := Etype (Rhs);
if not Covers (T1, T2) then
Wrong_Type (Rhs, Etype (Lhs));
Kill_Lhs;
return;
end if;
if Nkind (Rhs) = N_Explicit_Dereference
and then Ekind (T2) = E_Incomplete_Type
and then Is_Tagged_Type (T2)
and then Present (Non_Limited_View (T2))
then
T2 := Non_Limited_View (T2);
end if;
Set_Assignment_Type (Rhs, T2);
if Total_Errors_Detected /= 0 then
if No (T1) then
T1 := Any_Type;
end if;
if No (T2) then
T2 := Any_Type;
end if;
end if;
if T1 = Any_Type or else T2 = Any_Type then
Kill_Lhs;
return;
end if;
if (Is_Class_Wide_Type (T2) or else Is_Dynamically_Tagged (Rhs))
and then not Is_Class_Wide_Type (T1)
then
Error_Msg_N ("dynamically tagged expression not allowed!", Rhs);
elsif Is_Class_Wide_Type (T1)
and then not Is_Class_Wide_Type (T2)
and then not Is_Tag_Indeterminate (Rhs)
and then not Is_Dynamically_Tagged (Rhs)
then
Error_Msg_N ("dynamically tagged expression required!", Rhs);
end if;
if Is_Class_Wide_Type (T1)
and then Is_Tag_Indeterminate (Rhs)
then
Propagate_Tag (Lhs, Rhs);
end if;
if Ada_Version >= Ada_05
and then Ekind (T1) = E_Anonymous_Access_Type
then
Rewrite (Rhs, Convert_To (T1, Relocate_Node (Rhs)));
Analyze_And_Resolve (Rhs, T1);
end if;
if Ada_Version >= Ada_05
and then Can_Never_Be_Null (T1)
and then not Assignment_OK (Lhs)
then
if Nkind (Rhs) = N_Null then
Apply_Compile_Time_Constraint_Error
(N => Rhs,
Msg => "(Ada 2005) NULL not allowed in null-excluding objects?",
Reason => CE_Null_Not_Allowed);
return;
elsif not Can_Never_Be_Null (T2) then
Rewrite (Rhs,
Convert_To (T1, Relocate_Node (Rhs)));
Analyze_And_Resolve (Rhs, T1);
end if;
end if;
if Is_Scalar_Type (T1) then
Apply_Scalar_Range_Check (Rhs, Etype (Lhs));
elsif Is_Array_Type (T1)
and then
(Nkind (Rhs) /= N_Type_Conversion
or else Is_Constrained (Etype (Rhs)))
and then
(Nkind (Rhs) /= N_Function_Call
or else Nkind (N) /= N_Block_Statement)
then
Apply_Length_Check (Rhs, Etype (Lhs));
else
null;
end if;
Note_Possible_Modification (Lhs);
if Warn_On_Redundant_Constructs
and then Comes_From_Source (N)
and then Is_Entity_Name (Lhs)
and then Is_Entity_Name (Original_Node (Rhs))
and then Entity (Lhs) = Entity (Original_Node (Rhs))
and then Nkind (Original_Node (Rhs)) not in N_Op
then
Error_Msg_NE
("?useless assignment of & to itself", N, Entity (Lhs));
end if;
if not Support_Composite_Assign_On_Target
and then (Is_Array_Type (T1) or else Is_Record_Type (T1))
and then (not Has_Size_Clause (T1) or else Esize (T1) > 64)
then
Error_Msg_CRT ("composite assignment", N);
end if;
if Is_Entity_Name (Lhs)
and then Nkind (N) = N_Assignment_Statement
then
declare
Ent : constant Entity_Id := Entity (Lhs);
begin
if Safe_To_Capture_Value (N, Ent) then
if Is_Access_Type (T1) then
if Known_Non_Null (Rhs) then
Set_Is_Known_Non_Null (Ent, True);
elsif Known_Null (Rhs)
and then not Can_Never_Be_Null (Ent)
then
Set_Is_Known_Null (Ent, True);
else
Set_Is_Known_Null (Ent, False);
if not Can_Never_Be_Null (Ent) then
Set_Is_Known_Non_Null (Ent, False);
end if;
end if;
elsif Is_Discrete_Type (T1)
and then Compile_Time_Known_Value (Rhs)
then
Set_Current_Value (Ent, Rhs);
else
Set_Current_Value (Ent, Empty);
end if;
else
Kill_Lhs;
end if;
end;
end if;
end Analyze_Assignment;
procedure Analyze_Block_Statement (N : Node_Id) is
Decls : constant List_Id := Declarations (N);
Id : constant Node_Id := Identifier (N);
HSS : constant Node_Id := Handled_Statement_Sequence (N);
begin
if No (HSS) then
return;
end if;
declare
EH : constant List_Id := Exception_Handlers (HSS);
Ent : Entity_Id := Empty;
S : Entity_Id;
Save_Unblocked_Exit_Count : constant Nat := Unblocked_Exit_Count;
begin
Unblocked_Exit_Count := 1;
if Present (EH) then
Unblocked_Exit_Count := Unblocked_Exit_Count + List_Length (EH);
end if;
if Present (Id) then
Analyze (Id);
Ent := Entity (Id);
if No (Ent) then
if Total_Errors_Detected /= 0 then
Set_Identifier (N, Empty);
else
raise Program_Error;
end if;
else
Set_Ekind (Ent, E_Block);
Generate_Reference (Ent, N, ' ');
Generate_Definition (Ent);
if Nkind (Parent (Ent)) = N_Implicit_Label_Declaration then
Set_Label_Construct (Parent (Ent), N);
end if;
end if;
end if;
if No (Ent) then
Ent := New_Internal_Entity (E_Block, Current_Scope, Sloc (N), 'B');
Set_Identifier (N, New_Occurrence_Of (Ent, Sloc (N)));
Set_Parent (Ent, N);
end if;
Set_Etype (Ent, Standard_Void_Type);
Set_Block_Node (Ent, Identifier (N));
New_Scope (Ent);
if Present (Decls) then
Analyze_Declarations (Decls);
Check_Completion;
end if;
Analyze (HSS);
Process_End_Label (HSS, 'e', Ent);
if Present (EH) then
S := Scope (Ent);
loop
Set_Has_Nested_Block_With_Handler (S);
exit when Is_Overloadable (S)
or else Ekind (S) = E_Package
or else Is_Generic_Unit (S);
S := Scope (S);
end loop;
end if;
Check_References (Ent);
End_Scope;
if Unblocked_Exit_Count = 0 then
Unblocked_Exit_Count := Save_Unblocked_Exit_Count;
Check_Unreachable_Code (N);
else
Unblocked_Exit_Count := Save_Unblocked_Exit_Count;
end if;
end;
end Analyze_Block_Statement;
procedure Analyze_Case_Statement (N : Node_Id) is
Exp : Node_Id;
Exp_Type : Entity_Id;
Exp_Btype : Entity_Id;
Last_Choice : Nat;
Dont_Care : Boolean;
Others_Present : Boolean;
Statements_Analyzed : Boolean := False;
Save_Unblocked_Exit_Count : constant Nat := Unblocked_Exit_Count;
procedure Non_Static_Choice_Error (Choice : Node_Id);
procedure Process_Statements (Alternative : Node_Id);
package Case_Choices_Processing is new
Generic_Choices_Processing
(Get_Alternatives => Alternatives,
Get_Choices => Discrete_Choices,
Process_Empty_Choice => No_OP,
Process_Non_Static_Choice => Non_Static_Choice_Error,
Process_Associated_Node => Process_Statements);
use Case_Choices_Processing;
procedure Non_Static_Choice_Error (Choice : Node_Id) is
begin
Flag_Non_Static_Expr
("choice given in case statement is not static!", Choice);
end Non_Static_Choice_Error;
procedure Process_Statements (Alternative : Node_Id) is
Choices : constant List_Id := Discrete_Choices (Alternative);
Ent : Entity_Id;
begin
Unblocked_Exit_Count := Unblocked_Exit_Count + 1;
Statements_Analyzed := True;
if Is_Entity_Name (Exp) then
Ent := Entity (Exp);
if Ekind (Ent) = E_Variable
or else
Ekind (Ent) = E_In_Out_Parameter
or else
Ekind (Ent) = E_Out_Parameter
then
if List_Length (Choices) = 1
and then Nkind (First (Choices)) in N_Subexpr
and then Compile_Time_Known_Value (First (Choices))
then
Set_Current_Value (Entity (Exp), First (Choices));
end if;
Analyze_Statements (Statements (Alternative));
Set_Current_Value (Entity (Exp), Empty);
return;
end if;
end if;
Analyze_Statements (Statements (Alternative));
end Process_Statements;
Case_Table : Choice_Table_Type (1 .. Number_Of_Choices (N));
begin
Unblocked_Exit_Count := 0;
Exp := Expression (N);
Analyze (Exp);
if not Is_Overloaded (Exp)
and then not Comes_From_Source (N)
and then Is_Private_Type (Etype (Exp))
and then Present (Full_View (Etype (Exp)))
and then Is_Discrete_Type (Full_View (Etype (Exp)))
then
Resolve (Exp, Etype (Exp));
Exp_Type := Full_View (Etype (Exp));
else
Analyze_And_Resolve (Exp, Any_Discrete);
Exp_Type := Etype (Exp);
end if;
Check_Unset_Reference (Exp);
Exp_Btype := Base_Type (Exp_Type);
if Exp_Btype = Any_Discrete
or else Exp_Btype = Any_Type
then
return;
elsif Exp_Btype = Any_Character then
Error_Msg_N
("character literal as case expression is ambiguous", Exp);
return;
elsif Ada_Version = Ada_83
and then (Is_Generic_Type (Exp_Btype)
or else Is_Generic_Type (Root_Type (Exp_Btype)))
then
Error_Msg_N
("(Ada 83) case expression cannot be of a generic type", Exp);
return;
end if;
if Paren_Count (Exp) > 0
or else (Is_Entity_Name (Exp)
and then Ekind (Entity (Exp)) = E_Generic_In_Out_Parameter)
then
Exp_Type := Exp_Btype;
end if;
Analyze_Choices
(N, Exp_Type, Case_Table, Last_Choice, Dont_Care, Others_Present);
if Exp_Type = Universal_Integer and then not Others_Present then
Error_Msg_N ("case on universal integer requires OTHERS choice", Exp);
end if;
if Unblocked_Exit_Count = 0 and then Statements_Analyzed then
Unblocked_Exit_Count := Save_Unblocked_Exit_Count;
Check_Unreachable_Code (N);
else
Unblocked_Exit_Count := Save_Unblocked_Exit_Count;
end if;
if not Expander_Active
and then Compile_Time_Known_Value (Expression (N))
and then Serious_Errors_Detected = 0
then
declare
Chosen : constant Node_Id := Find_Static_Alternative (N);
Alt : Node_Id;
begin
Alt := First (Alternatives (N));
while Present (Alt) loop
if Alt /= Chosen then
Remove_Warning_Messages (Statements (Alt));
end if;
Next (Alt);
end loop;
end;
end if;
end Analyze_Case_Statement;
procedure Analyze_Exit_Statement (N : Node_Id) is
Target : constant Node_Id := Name (N);
Cond : constant Node_Id := Condition (N);
Scope_Id : Entity_Id;
U_Name : Entity_Id;
Kind : Entity_Kind;
begin
if No (Cond) then
Check_Unreachable_Code (N);
end if;
if Present (Target) then
Analyze (Target);
U_Name := Entity (Target);
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);
return;
else
Set_Has_Exit (U_Name);
end if;
else
U_Name := Empty;
end if;
for J in reverse 0 .. Scope_Stack.Last loop
Scope_Id := Scope_Stack.Table (J).Entity;
Kind := Ekind (Scope_Id);
if Kind = E_Loop
and then (No (Target) or else Scope_Id = U_Name) then
Set_Has_Exit (Scope_Id);
exit;
elsif Kind = E_Block or else Kind = E_Loop then
null;
else
Error_Msg_N
("cannot exit from program unit or accept statement", N);
exit;
end if;
end loop;
if Present (Cond) then
Analyze_And_Resolve (Cond, Any_Boolean);
Check_Unset_Reference (Cond);
end if;
end Analyze_Exit_Statement;
procedure Analyze_Goto_Statement (N : Node_Id) is
Label : constant Node_Id := Name (N);
Scope_Id : Entity_Id;
Label_Scope : Entity_Id;
begin
Check_Unreachable_Code (N);
Analyze (Label);
if Entity (Label) = Any_Id then
return;
elsif Ekind (Entity (Label)) /= E_Label then
Error_Msg_N ("target of goto statement must be a label", Label);
return;
elsif not Reachable (Entity (Label)) then
Error_Msg_N ("target of goto statement is not reachable", Label);
return;
end if;
Label_Scope := Enclosing_Scope (Entity (Label));
for J in reverse 0 .. Scope_Stack.Last loop
Scope_Id := Scope_Stack.Table (J).Entity;
if Label_Scope = Scope_Id
or else (Ekind (Scope_Id) /= E_Block
and then Ekind (Scope_Id) /= E_Loop)
then
if Scope_Id /= Label_Scope then
Error_Msg_N
("cannot exit from program unit or accept statement", N);
end if;
return;
end if;
end loop;
raise Program_Error;
end Analyze_Goto_Statement;
procedure Analyze_If_Statement (N : Node_Id) is
E : Node_Id;
Save_Unblocked_Exit_Count : constant Nat := Unblocked_Exit_Count;
Save_In_Deleted_Code : Boolean;
Del : Boolean := False;
procedure Analyze_Cond_Then (Cnode : Node_Id);
procedure Analyze_Cond_Then (Cnode : Node_Id) is
Cond : constant Node_Id := Condition (Cnode);
Tstm : constant List_Id := Then_Statements (Cnode);
begin
Unblocked_Exit_Count := Unblocked_Exit_Count + 1;
Analyze_And_Resolve (Cond, Any_Boolean);
Check_Unset_Reference (Cond);
Check_Possible_Current_Value_Condition (Cnode);
if Del then
Analyze_Statements (Tstm);
elsif Compile_Time_Known_Value (Cond) then
Save_In_Deleted_Code := In_Deleted_Code;
if Is_True (Expr_Value (Cond)) then
Analyze_Statements (Tstm);
Del := True;
Expander_Mode_Save_And_Set (False);
In_Deleted_Code := True;
else Expander_Mode_Save_And_Set (False);
In_Deleted_Code := True;
Analyze_Statements (Tstm);
Expander_Mode_Restore;
In_Deleted_Code := Save_In_Deleted_Code;
end if;
else
Analyze_Statements (Tstm);
end if;
end Analyze_Cond_Then;
begin
Unblocked_Exit_Count := 1;
Analyze_Cond_Then (N);
if Present (Elsif_Parts (N)) then
E := First (Elsif_Parts (N));
while Present (E) loop
Analyze_Cond_Then (E);
Next (E);
end loop;
end if;
if Present (Else_Statements (N)) then
Analyze_Statements (Else_Statements (N));
end if;
if Unblocked_Exit_Count = 0 then
Unblocked_Exit_Count := Save_Unblocked_Exit_Count;
Check_Unreachable_Code (N);
else
Unblocked_Exit_Count := Save_Unblocked_Exit_Count;
end if;
if Del then
Expander_Mode_Restore;
In_Deleted_Code := Save_In_Deleted_Code;
end if;
if not Expander_Active
and then Compile_Time_Known_Value (Condition (N))
and then Serious_Errors_Detected = 0
then
if Is_True (Expr_Value (Condition (N))) then
Remove_Warning_Messages (Else_Statements (N));
if Present (Elsif_Parts (N)) then
E := First (Elsif_Parts (N));
while Present (E) loop
Remove_Warning_Messages (Then_Statements (E));
Next (E);
end loop;
end if;
else
Remove_Warning_Messages (Then_Statements (N));
end if;
end if;
end Analyze_If_Statement;
procedure Analyze_Implicit_Label_Declaration (N : Node_Id) is
Id : constant Node_Id := Defining_Identifier (N);
begin
Enter_Name (Id);
Set_Ekind (Id, E_Label);
Set_Etype (Id, Standard_Void_Type);
Set_Enclosing_Scope (Id, Current_Scope);
end Analyze_Implicit_Label_Declaration;
procedure Analyze_Iteration_Scheme (N : Node_Id) is
procedure Process_Bounds (R : Node_Id);
procedure Check_Controlled_Array_Attribute (DS : Node_Id);
procedure Process_Bounds (R : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
R_Copy : constant Node_Id := New_Copy_Tree (R);
Lo : constant Node_Id := Low_Bound (R);
Hi : constant Node_Id := High_Bound (R);
New_Lo_Bound : Node_Id := Empty;
New_Hi_Bound : Node_Id := Empty;
Typ : Entity_Id;
Save_Analysis : Boolean;
function One_Bound
(Original_Bound : Node_Id;
Analyzed_Bound : Node_Id) return Node_Id;
function One_Bound
(Original_Bound : Node_Id;
Analyzed_Bound : Node_Id) return Node_Id
is
Assign : Node_Id;
Id : Entity_Id;
Decl : Node_Id;
begin
if Analyzed (Original_Bound) then
return Original_Bound;
elsif Nkind (Analyzed_Bound) = N_Integer_Literal
or else Is_Entity_Name (Analyzed_Bound)
then
Analyze_And_Resolve (Original_Bound, Typ);
return Original_Bound;
else
Analyze_And_Resolve (Original_Bound, Typ);
end if;
Id :=
Make_Defining_Identifier (Loc,
Chars => New_Internal_Name ('S'));
Decl :=
Make_Object_Declaration (Loc,
Defining_Identifier => Id,
Object_Definition => New_Occurrence_Of (Typ, Loc));
Insert_Before (Parent (N), Decl);
Analyze (Decl);
Assign :=
Make_Assignment_Statement (Loc,
Name => New_Occurrence_Of (Id, Loc),
Expression => Relocate_Node (Original_Bound));
Insert_Before (Parent (N), Assign);
Analyze (Assign);
Rewrite (Original_Bound, New_Occurrence_Of (Id, Loc));
if Nkind (Assign) = N_Assignment_Statement then
return Expression (Assign);
else
return Original_Bound;
end if;
end One_Bound;
begin
Set_Parent (R_Copy, Parent (R));
Save_Analysis := Full_Analysis;
Full_Analysis := False;
Expander_Mode_Save_And_Set (False);
Analyze (R_Copy);
if Is_Overloaded (R_Copy) then
declare
I : Interp_Index;
It : Interp;
Found : Entity_Id := Empty;
begin
Get_First_Interp (R_Copy, I, It);
while Present (It.Typ) loop
if Is_Discrete_Type (It.Typ) then
if No (Found) then
Found := It.Typ;
else
if Scope (Found) = Standard_Standard then
null;
elsif Scope (It.Typ) = Standard_Standard then
Found := It.Typ;
else
Error_Msg_N
("ambiguous bounds in range of iteration",
R_Copy);
Error_Msg_N ("\possible interpretations:", R_Copy);
Error_Msg_NE ("\} ", R_Copy, Found);
Error_Msg_NE ("\} ", R_Copy, It.Typ);
exit;
end if;
end if;
end if;
Get_Next_Interp (I, It);
end loop;
end;
end if;
Resolve (R_Copy);
Expander_Mode_Restore;
Full_Analysis := Save_Analysis;
Typ := Etype (R_Copy);
if Typ = Universal_Integer then
Typ := Standard_Integer;
end if;
Set_Etype (R, Typ);
New_Lo_Bound := One_Bound (Lo, Low_Bound (R_Copy));
New_Hi_Bound := One_Bound (Hi, High_Bound (R_Copy));
if New_Lo_Bound /= Lo
and then Is_Static_Expression (New_Lo_Bound)
then
Rewrite (Low_Bound (R), New_Copy (New_Lo_Bound));
end if;
if New_Hi_Bound /= Hi
and then Is_Static_Expression (New_Hi_Bound)
then
Rewrite (High_Bound (R), New_Copy (New_Hi_Bound));
end if;
end Process_Bounds;
procedure Check_Controlled_Array_Attribute (DS : Node_Id) is
begin
if Nkind (DS) = N_Attribute_Reference
and then Is_Entity_Name (Prefix (DS))
and then Ekind (Entity (Prefix (DS))) = E_Function
and then Is_Array_Type (Etype (Entity (Prefix (DS))))
and then
Is_Controlled (
Component_Type (Etype (Entity (Prefix (DS)))))
and then Expander_Active
then
declare
Loc : constant Source_Ptr := Sloc (N);
Arr : constant Entity_Id :=
Etype (Entity (Prefix (DS)));
Indx : constant Entity_Id :=
Base_Type (Etype (First_Index (Arr)));
Subt : constant Entity_Id :=
Make_Defining_Identifier
(Loc, New_Internal_Name ('S'));
Decl : Node_Id;
begin
Decl :=
Make_Subtype_Declaration (Loc,
Defining_Identifier => Subt,
Subtype_Indication =>
Make_Subtype_Indication (Loc,
Subtype_Mark => New_Reference_To (Indx, Loc),
Constraint =>
Make_Range_Constraint (Loc,
Relocate_Node (DS))));
Insert_Before (Parent (N), Decl);
Analyze (Decl);
Rewrite (DS,
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Subt, Loc),
Attribute_Name => Attribute_Name (DS)));
Analyze (DS);
end;
end if;
end Check_Controlled_Array_Attribute;
begin
if No (N) then
return;
else
declare
Cond : constant Node_Id := Condition (N);
begin
if Present (Cond) then
Analyze_And_Resolve (Cond, Any_Boolean);
Check_Unset_Reference (Cond);
else
declare
LP : constant Node_Id := Loop_Parameter_Specification (N);
Id : constant Entity_Id := Defining_Identifier (LP);
DS : constant Node_Id := Discrete_Subtype_Definition (LP);
begin
Enter_Name (Id);
Generate_Reference (Id, N, ' ');
declare
H : constant Entity_Id := Homonym (Id);
begin
if Present (H)
and then Enclosing_Dynamic_Scope (H) =
Enclosing_Dynamic_Scope (Id)
and then Ekind (H) = E_Variable
and then Is_Discrete_Type (Etype (H))
then
Set_Hiding_Loop_Variable (H, Id);
end if;
end;
if Nkind (DS) = N_Range
and then Expander_Active
then
Process_Bounds (DS);
else
Analyze (DS);
end if;
if DS = Error then
return;
end if;
if Is_Entity_Name (DS)
and then Present (Entity (DS))
and then Is_Type (Entity (DS))
and then Ekind (Entity (DS)) = E_Incomplete_Type
then
Set_Entity (DS, Get_Full_View (Entity (DS)));
Set_Etype (DS, Entity (DS));
end if;
if not Is_Discrete_Type (Etype (DS)) then
Wrong_Type (DS, Any_Discrete);
Set_Etype (DS, Any_Type);
end if;
Check_Controlled_Array_Attribute (DS);
Make_Index (DS, LP);
Set_Ekind (Id, E_Loop_Parameter);
Set_Etype (Id, Etype (DS));
Set_Is_Known_Valid (Id, True);
declare
Flist : constant List_Id := Freeze_Entity (Id, Sloc (N));
begin
if Is_Non_Empty_List (Flist) then
Insert_Actions (N, Flist);
end if;
end;
if Nkind (DS) = N_Range
and then Comes_From_Source (N)
then
declare
L : constant Node_Id := Low_Bound (DS);
H : constant Node_Id := High_Bound (DS);
Llo : Uint;
Lhi : Uint;
LOK : Boolean;
Hlo : Uint;
Hhi : Uint;
HOK : Boolean;
begin
Determine_Range (L, LOK, Llo, Lhi);
Determine_Range (H, HOK, Hlo, Hhi);
if (LOK and HOK) and then Llo > Hhi then
if not Inside_A_Generic
and then not In_Instance
then
Error_Msg_N
("?loop range is null, loop will not execute",
DS);
end if;
Set_Is_Null_Loop (Parent (N));
elsif Reverse_Present (LP)
and then Nkind (Original_Node (H)) =
N_Integer_Literal
and then (Intval (H) = Uint_0
or else
Intval (H) = Uint_1)
and then Lhi > Hhi
then
Error_Msg_N ("?loop range may be null", DS);
Error_Msg_N ("\?bounds may be wrong way round", DS);
end if;
end;
end if;
end;
end if;
end;
end if;
end Analyze_Iteration_Scheme;
procedure Analyze_Label (N : Node_Id) is
pragma Warnings (Off, N);
begin
Kill_Current_Values;
end Analyze_Label;
procedure Analyze_Label_Entity (E : Entity_Id) is
begin
Set_Ekind (E, E_Label);
Set_Etype (E, Standard_Void_Type);
Set_Enclosing_Scope (E, Current_Scope);
Set_Reachable (E, True);
end Analyze_Label_Entity;
procedure Analyze_Loop_Statement (N : Node_Id) is
Id : constant Node_Id := Identifier (N);
Ent : Entity_Id;
begin
if Present (Id) then
Analyze (Id);
Ent := Entity (Id);
Generate_Reference (Ent, N, ' ');
Generate_Definition (Ent);
if Ekind (Ent) = E_Label then
Set_Ekind (Ent, E_Loop);
if Nkind (Parent (Ent)) = N_Implicit_Label_Declaration then
Set_Label_Construct (Parent (Ent), N);
end if;
end if;
else
Ent := New_Internal_Entity (E_Loop, Current_Scope, Sloc (N), 'L');
Set_Etype (Ent, Standard_Void_Type);
Set_Parent (Ent, N);
end if;
Kill_Current_Values;
New_Scope (Ent);
Analyze_Iteration_Scheme (Iteration_Scheme (N));
Analyze_Statements (Statements (N));
Process_End_Label (N, 'e', Ent);
End_Scope;
Kill_Current_Values;
end Analyze_Loop_Statement;
procedure Analyze_Null_Statement (N : Node_Id) is
pragma Warnings (Off, N);
begin
null;
end Analyze_Null_Statement;
procedure Analyze_Statements (L : List_Id) is
S : Node_Id;
Lab : Entity_Id;
begin
S := First (L);
while Present (S) loop
if Nkind (S) = N_Label then
Analyze (Identifier (S));
Lab := Entity (Identifier (S));
if Ekind (Lab) = E_Label then
Generate_Definition (Lab);
Set_Reachable (Lab);
if Nkind (Parent (Lab)) = N_Implicit_Label_Declaration then
Set_Label_Construct (Parent (Lab), S);
end if;
else
Error_Msg_Sloc := Sloc (Lab);
Error_Msg_N
("implicit label declaration for & is hidden#",
Identifier (S));
end if;
end if;
Next (S);
end loop;
Conditional_Statements_Begin;
S := First (L);
while Present (S) loop
Analyze (S);
Next (S);
end loop;
Conditional_Statements_End;
S := First (L);
while Present (S) loop
if Nkind (S) = N_Label then
Set_Reachable (Entity (Identifier (S)), False);
end if;
Next (S);
end loop;
end Analyze_Statements;
procedure Check_Possible_Current_Value_Condition (Cnode : Node_Id) is
Cond : Node_Id;
begin
Cond := Condition (Cnode);
while Nkind (Cond) = N_Op_Not loop
Cond := Right_Opnd (Cond);
end loop;
if Nkind (Cond) = N_Op_Eq
or else
Nkind (Cond) = N_Op_Ne
or else
Nkind (Cond) = N_Op_Ge
or else
Nkind (Cond) = N_Op_Le
or else
Nkind (Cond) = N_Op_Gt
or else
Nkind (Cond) = N_Op_Lt
then
if Compile_Time_Known_Value (Right_Opnd (Cond))
and then Nkind (Left_Opnd (Cond)) = N_Identifier
then
declare
Ent : constant Entity_Id := Entity (Left_Opnd (Cond));
begin
if Ekind (Ent) = E_Variable
or else
Ekind (Ent) = E_Constant
or else
Is_Formal (Ent)
or else
Ekind (Ent) = E_Loop_Parameter
then
if Nkind (Current_Value (Ent)) not in N_Subexpr then
Set_Current_Value (Ent, Cnode);
end if;
end if;
end;
end if;
end if;
end Check_Possible_Current_Value_Condition;
procedure Check_Unreachable_Code (N : Node_Id) is
Error_Loc : Source_Ptr;
P : Node_Id;
begin
if Is_List_Member (N)
and then Comes_From_Source (N)
then
declare
Nxt : Node_Id;
begin
Nxt := Original_Node (Next (N));
if Nkind (Nxt) = N_Label then
return;
elsif Present (Nxt)
and then Comes_From_Source (Nxt)
and then Is_Statement (Nxt)
then
if Nkind (Original_Node (N)) /= N_Raise_Statement
or else Nkind (Nxt) /= N_Return_Statement
then
Error_Loc := Sloc (Nxt);
if Operating_Mode = Generate_Code then
loop
Nxt := Next (N);
exit when No (Nxt) or else Nkind (Nxt) = N_Label;
Analyze (Nxt);
Remove (Nxt);
Kill_Dead_Code (Nxt);
end loop;
end if;
Error_Msg ("?unreachable code", Error_Loc);
end if;
else
P := Parent (N);
if Nkind (P) = N_If_Statement then
null;
elsif Nkind (P) = N_Elsif_Part then
P := Parent (P);
pragma Assert (Nkind (P) = N_If_Statement);
elsif Nkind (P) = N_Case_Statement_Alternative then
P := Parent (P);
pragma Assert (Nkind (P) = N_Case_Statement);
elsif Nkind (P) = N_Handled_Sequence_Of_Statements
and then Nkind (Parent (P)) = N_Block_Statement
then
null;
elsif Nkind (P) = N_Exception_Handler
and then Nkind (Parent (P)) = N_Handled_Sequence_Of_Statements
and then Nkind (Parent (Parent (P))) = N_Block_Statement
then
null;
else
return;
end if;
Unblocked_Exit_Count := Unblocked_Exit_Count - 1;
end if;
end;
end if;
end Check_Unreachable_Code;
end Sem_Ch5;