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 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 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, T2 : Entity_Id;
Decl : Node_Id;
procedure Diagnose_Non_Variable_Lhs (N : Node_Id);
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);
return;
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);
return;
elsif Ekind (Entity (N)) = E_Loop_Parameter then
Error_Msg_N
("assignment to loop parameter not allowed", N);
return;
end if;
elsif Nkind (N) = N_Indexed_Component
or else Nkind (N) = N_Selected_Component
then
Diagnose_Non_Variable_Lhs (Prefix (N));
return;
end if;
Error_Msg_N ("left hand side of assignment must be a variable", N);
end Diagnose_Non_Variable_Lhs;
procedure Set_Assignment_Type
(Opnd : Node_Id;
Opnd_Type : in out Entity_Id)
is
begin
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)
then
Opnd_Type := Get_Actual_Subtype (Opnd);
elsif Nkind (Opnd) = N_Selected_Component
or else Nkind (Opnd) = N_Explicit_Dereference
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 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
return;
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);
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);
return;
end if;
T1 := Etype (Lhs);
Set_Assignment_Type (Lhs, T1);
Resolve (Rhs, T1);
if Rhs = Error then
return;
end if;
T2 := Etype (Rhs);
Check_Unset_Reference (Rhs);
Note_Possible_Modification (Lhs);
if Covers (T1, T2) then
null;
else
Wrong_Type (Rhs, Etype (Lhs));
return;
end if;
Set_Assignment_Type (Rhs, T2);
if T1 = Any_Type or else T2 = Any_Type then
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 not Expander_Active
and then Is_Class_Wide_Type (T1)
and then Is_Tag_Indeterminate (Rhs)
then
Propagate_Tag (Lhs, Rhs);
end if;
if Is_Scalar_Type (T1) then
Apply_Scalar_Range_Check (Rhs, Etype (Lhs));
elsif Is_Array_Type (T1) then
Apply_Length_Check (Rhs, Etype (Lhs));
else
null;
end if;
if Warn_On_Redundant_Constructs
and then Comes_From_Source (N)
and then Is_Entity_Name (Lhs)
and then Is_Entity_Name (Rhs)
and then Entity (Lhs) = Entity (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;
end Analyze_Assignment;
procedure Analyze_Block_Statement (N : Node_Id) is
Decls : constant List_Id := Declarations (N);
Id : constant Node_Id := Identifier (N);
Ent : Entity_Id;
begin
if Present (Id) then
Analyze (Id);
Ent := Entity (Id);
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;
else
Ent := New_Internal_Entity (E_Block, Current_Scope, Sloc (N), 'B');
Set_Identifier (N, New_Occurrence_Of (Ent, Sloc (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 (Handled_Statement_Sequence (N));
Process_End_Label (Handled_Statement_Sequence (N), 'e', Ent);
if Present (Handled_Statement_Sequence (N))
and then Present (Exception_Handlers (Handled_Statement_Sequence (N)))
then
declare
S : Entity_Id := Scope (Ent);
begin
loop
Set_Has_Nested_Block_With_Handler (S);
exit when Is_Overloadable (S)
or else Ekind (S) = E_Package
or else Ekind (S) = E_Generic_Function
or else Ekind (S) = E_Generic_Package
or else Ekind (S) = E_Generic_Procedure;
S := Scope (S);
end loop;
end;
end if;
Check_References (Ent);
End_Scope;
end Analyze_Block_Statement;
procedure Analyze_Case_Statement (N : Node_Id) is
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
Error_Msg_N ("choice given in case statement is not static", Choice);
end Non_Static_Choice_Error;
procedure Process_Statements (Alternative : Node_Id) is
begin
Unblocked_Exit_Count := Unblocked_Exit_Count + 1;
Statements_Analyzed := True;
Analyze_Statements (Statements (Alternative));
end Process_Statements;
Exp : Node_Id;
Exp_Type : Entity_Id;
Exp_Btype : Entity_Id;
Case_Table : Choice_Table_Type (1 .. Number_Of_Choices (N));
Last_Choice : Nat;
Dont_Care : Boolean;
Others_Present : Boolean;
begin
Unblocked_Exit_Count := 0;
Exp := Expression (N);
Analyze_And_Resolve (Exp, Any_Discrete);
Check_Unset_Reference (Exp);
Exp_Type := Etype (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_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;
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;
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);
if Del then
Analyze_Statements (Tstm);
elsif Compile_Time_Known_Value (Cond) then
if Is_True (Expr_Value (Cond)) then
Analyze_Statements (Tstm);
Del := True;
Expander_Mode_Save_And_Set (False);
else Expander_Mode_Save_And_Set (False);
Analyze_Statements (Tstm);
Expander_Mode_Restore;
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;
end if;
end Analyze_If_Statement;
procedure Analyze_Implicit_Label_Declaration (N : Node_Id) is
Id : 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
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);
F : List_Id;
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;
Analyze (DS);
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;
Make_Index (DS, LP);
Set_Ekind (Id, E_Loop_Parameter);
Set_Etype (Id, Etype (DS));
Set_Is_Known_Valid (Id, True);
F := Freeze_Entity (Id, Sloc (LP));
pragma Assert (F = No_List);
if Nkind (DS) = N_Range
and then Comes_From_Source (N)
and then not Inside_A_Generic
and then not In_Instance
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
Error_Msg_N
("?loop range is null, loop will not execute",
DS);
elsif Reverse_Present (LP)
and then Nkind (H) = N_Integer_Literal
and then (Intval (H) = Uint_0
or else
Intval (H) = Uint_1)
and then Lhi > Hhi
then
Warn_On_Instance := True;
Error_Msg_N ("?loop range may be null", DS);
Warn_On_Instance := False;
end if;
end;
end if;
end;
end if;
end;
end if;
end Analyze_Iteration_Scheme;
procedure Analyze_Label (N : Node_Id) is
Lab : Entity_Id;
begin
Analyze (Identifier (N));
Lab := Entity (Identifier (N));
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), N);
end if;
else
Error_Msg_Sloc := Sloc (Lab);
Error_Msg_N
("implicit label declaration for & is hidden#",
Identifier (N));
end if;
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;
New_Scope (Ent);
Analyze_Iteration_Scheme (Iteration_Scheme (N));
Analyze_Statements (Statements (N));
Process_End_Label (N, 'e', Ent);
End_Scope;
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;
begin
S := First (L);
while Present (S) loop
if Nkind (S) = N_Label then
Analyze_Label (S);
end if;
Next (S);
end loop;
S := First (L);
while Present (S) loop
if Nkind (S) /= N_Label then
Analyze (S);
end if;
Next (S);
end loop;
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_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 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 not Is_Statement (Nxt);
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);
else
return;
end if;
Unblocked_Exit_Count := Unblocked_Exit_Count - 1;
end if;
end;
end if;
end Check_Unreachable_Code;
end Sem_Ch5;