with Atree; use Atree;
with Checks; use Checks;
with Debug; use Debug;
with Debug_A; use Debug_A;
with Einfo; use Einfo;
with Errout; use Errout;
with Expander; use Expander;
with Exp_Ch7; use Exp_Ch7;
with Exp_Util; use Exp_Util;
with Freeze; use Freeze;
with Itypes; use Itypes;
with Lib; use Lib;
with Lib.Xref; use Lib.Xref;
with Namet; use Namet;
with Nmake; use Nmake;
with Nlists; use Nlists;
with Opt; use Opt;
with Output; use Output;
with Restrict; use Restrict;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
with Sem_Aggr; use Sem_Aggr;
with Sem_Attr; use Sem_Attr;
with Sem_Cat; use Sem_Cat;
with Sem_Ch4; use Sem_Ch4;
with Sem_Ch6; use Sem_Ch6;
with Sem_Ch8; use Sem_Ch8;
with Sem_Disp; use Sem_Disp;
with Sem_Dist; use Sem_Dist;
with Sem_Elab; use Sem_Elab;
with Sem_Eval; use Sem_Eval;
with Sem_Intr; use Sem_Intr;
with Sem_Util; use Sem_Util;
with Sem_Type; use Sem_Type;
with Sem_Warn; use Sem_Warn;
with Sinfo; use Sinfo;
with Stand; use Stand;
with Stringt; use Stringt;
with Targparm; use Targparm;
with Tbuild; use Tbuild;
with Uintp; use Uintp;
with Urealp; use Urealp;
package body Sem_Res is
procedure Ambiguous_Character (C : Node_Id);
procedure Check_Discriminant_Use (N : Node_Id);
procedure Check_For_Visible_Operator (N : Node_Id; T : Entity_Id);
function Check_Infinite_Recursion (N : Node_Id) return Boolean;
procedure Check_Initialization_Call (N : Entity_Id; Nam : Entity_Id);
function Is_Predefined_Op (Nam : Entity_Id) return Boolean;
procedure Replace_Actual_Discriminants (N : Node_Id; Default : Node_Id);
procedure Resolve_Allocator (N : Node_Id; Typ : Entity_Id);
procedure Resolve_Arithmetic_Op (N : Node_Id; Typ : Entity_Id);
procedure Resolve_Call (N : Node_Id; Typ : Entity_Id);
procedure Resolve_Character_Literal (N : Node_Id; Typ : Entity_Id);
procedure Resolve_Comparison_Op (N : Node_Id; Typ : Entity_Id);
procedure Resolve_Conditional_Expression (N : Node_Id; Typ : Entity_Id);
procedure Resolve_Equality_Op (N : Node_Id; Typ : Entity_Id);
procedure Resolve_Explicit_Dereference (N : Node_Id; Typ : Entity_Id);
procedure Resolve_Entity_Name (N : Node_Id; Typ : Entity_Id);
procedure Resolve_Indexed_Component (N : Node_Id; Typ : Entity_Id);
procedure Resolve_Integer_Literal (N : Node_Id; Typ : Entity_Id);
procedure Resolve_Logical_Op (N : Node_Id; Typ : Entity_Id);
procedure Resolve_Membership_Op (N : Node_Id; Typ : Entity_Id);
procedure Resolve_Null (N : Node_Id; Typ : Entity_Id);
procedure Resolve_Operator_Symbol (N : Node_Id; Typ : Entity_Id);
procedure Resolve_Op_Concat (N : Node_Id; Typ : Entity_Id);
procedure Resolve_Op_Expon (N : Node_Id; Typ : Entity_Id);
procedure Resolve_Op_Not (N : Node_Id; Typ : Entity_Id);
procedure Resolve_Qualified_Expression (N : Node_Id; Typ : Entity_Id);
procedure Resolve_Range (N : Node_Id; Typ : Entity_Id);
procedure Resolve_Real_Literal (N : Node_Id; Typ : Entity_Id);
procedure Resolve_Reference (N : Node_Id; Typ : Entity_Id);
procedure Resolve_Selected_Component (N : Node_Id; Typ : Entity_Id);
procedure Resolve_Shift (N : Node_Id; Typ : Entity_Id);
procedure Resolve_Short_Circuit (N : Node_Id; Typ : Entity_Id);
procedure Resolve_Slice (N : Node_Id; Typ : Entity_Id);
procedure Resolve_String_Literal (N : Node_Id; Typ : Entity_Id);
procedure Resolve_Subprogram_Info (N : Node_Id; Typ : Entity_Id);
procedure Resolve_Type_Conversion (N : Node_Id; Typ : Entity_Id);
procedure Resolve_Unary_Op (N : Node_Id; Typ : Entity_Id);
procedure Resolve_Unchecked_Expression (N : Node_Id; Typ : Entity_Id);
procedure Resolve_Unchecked_Type_Conversion (N : Node_Id; Typ : Entity_Id);
function Operator_Kind
(Op_Name : Name_Id;
Is_Binary : Boolean)
return Node_Kind;
procedure Resolve_Actuals (N : Node_Id; Nam : Entity_Id);
procedure Resolve_Entry_Call (N : Node_Id; Typ : Entity_Id);
procedure Resolve_Intrinsic_Operator (N : Node_Id; Typ : Entity_Id);
procedure Rewrite_Operator_As_Call (N : Node_Id; Nam : Entity_Id);
procedure Make_Call_Into_Operator
(N : Node_Id;
Typ : Entity_Id;
Op_Id : Entity_Id);
procedure Rewrite_Renamed_Operator (N : Node_Id; Op : Entity_Id);
procedure Set_String_Literal_Subtype (N : Node_Id; Typ : Entity_Id);
procedure Set_Slice_Subtype (N : Node_Id);
function Unique_Fixed_Point_Type (N : Node_Id) return Entity_Id;
function Valid_Conversion
(N : Node_Id;
Target : Entity_Id;
Operand : Node_Id)
return Boolean;
procedure Ambiguous_Character (C : Node_Id) is
E : Entity_Id;
begin
if Nkind (C) = N_Character_Literal then
Error_Msg_N ("ambiguous character literal", C);
Error_Msg_N
("\possible interpretations: Character, Wide_Character!", C);
E := Current_Entity (C);
if Present (E) then
while Present (E) loop
Error_Msg_NE ("\possible interpretation:}!", C, Etype (E));
E := Homonym (E);
end loop;
end if;
end if;
end Ambiguous_Character;
procedure Analyze_And_Resolve (N : Node_Id) is
begin
Analyze (N);
Resolve (N, Etype (N));
end Analyze_And_Resolve;
procedure Analyze_And_Resolve (N : Node_Id; Typ : Entity_Id) is
begin
Analyze (N);
Resolve (N, Typ);
end Analyze_And_Resolve;
procedure Analyze_And_Resolve
(N : Node_Id;
Typ : Entity_Id;
Suppress : Check_Id)
is
Scop : Entity_Id := Current_Scope;
begin
if Suppress = All_Checks then
declare
Svg : constant Suppress_Record := Scope_Suppress;
begin
Scope_Suppress := (others => True);
Analyze_And_Resolve (N, Typ);
Scope_Suppress := Svg;
end;
else
declare
Svg : constant Boolean := Get_Scope_Suppress (Suppress);
begin
Set_Scope_Suppress (Suppress, True);
Analyze_And_Resolve (N, Typ);
Set_Scope_Suppress (Suppress, Svg);
end;
end if;
if Current_Scope /= Scop
and then Scope_Is_Transient
then
Scope_Stack.Table (Scope_Stack.Last).Save_Scope_Suppress :=
Scope_Suppress;
end if;
end Analyze_And_Resolve;
procedure Analyze_And_Resolve
(N : Node_Id;
Suppress : Check_Id)
is
Scop : Entity_Id := Current_Scope;
begin
if Suppress = All_Checks then
declare
Svg : constant Suppress_Record := Scope_Suppress;
begin
Scope_Suppress := (others => True);
Analyze_And_Resolve (N);
Scope_Suppress := Svg;
end;
else
declare
Svg : constant Boolean := Get_Scope_Suppress (Suppress);
begin
Set_Scope_Suppress (Suppress, True);
Analyze_And_Resolve (N);
Set_Scope_Suppress (Suppress, Svg);
end;
end if;
if Current_Scope /= Scop
and then Scope_Is_Transient
then
Scope_Stack.Table (Scope_Stack.Last).Save_Scope_Suppress :=
Scope_Suppress;
end if;
end Analyze_And_Resolve;
procedure Check_Discriminant_Use (N : Node_Id) is
PN : constant Node_Id := Parent (N);
Disc : constant Entity_Id := Entity (N);
P : Node_Id;
D : Node_Id;
begin
if In_Default_Expression then
null;
elsif Nkind (PN) = N_Range then
P := Parent (PN);
if Nkind (P) = N_Range_Constraint
and then Nkind (Parent (P)) = N_Subtype_Indication
and then Nkind (Parent (Parent (P))) = N_Component_Declaration
then
Error_Msg_N ("discriminant cannot constrain scalar type", N);
elsif Nkind (P) = N_Index_Or_Discriminant_Constraint then
if Ekind (Current_Scope) = E_Record_Type
and then Scope (Disc) = Current_Scope
and then not
(Nkind (Parent (P)) = N_Subtype_Indication
and then
(Nkind (Parent (Parent (P))) = N_Component_Declaration
or else Nkind (Parent (Parent (P))) = N_Subtype_Declaration)
and then Paren_Count (N) = 0)
then
Error_Msg_N
("discriminant must appear alone in component constraint", N);
return;
end if;
declare
SI : Node_Id;
T : Entity_Id;
TB : Node_Id;
CB : Entity_Id;
function Large_Storage_Type (T : Entity_Id) return Boolean;
function Large_Storage_Type (T : Entity_Id) return Boolean is
begin
return
T = Standard_Integer
or else
T = Standard_Positive
or else
T = Standard_Natural;
end Large_Storage_Type;
begin
if not Large_Storage_Type (Etype (Disc)) then
goto No_Danger;
end if;
if Is_Limited_Type (Scope (Disc)) then
goto No_Danger;
end if;
if N /= High_Bound (PN)
or else not Present (Discriminant_Default_Value (Disc))
then
goto No_Danger;
end if;
SI := Parent (P);
if Nkind (SI) /= N_Subtype_Indication then
goto No_Danger;
end if;
T := Entity (Subtype_Mark (SI));
if not Is_Array_Type (T) then
goto No_Danger;
end if;
TB := First_Index (T);
CB := First (Constraints (P));
while True
and then Present (TB)
and then Present (CB)
and then CB /= PN
loop
Next_Index (TB);
Next (CB);
end loop;
if CB /= PN then
goto No_Danger;
end if;
if not Large_Storage_Type (Etype (TB)) then
goto No_Danger;
end if;
Error_Msg_N
("creation of object of this type may raise Storage_Error?",
N);
<<No_Danger>>
null;
end;
end if;
elsif Nkind (PN) = N_Index_Or_Discriminant_Constraint
or else Nkind (PN) = N_Discriminant_Association
then
if Paren_Count (N) > 0 then
Error_Msg_N
("discriminant in constraint must appear alone", N);
end if;
return;
else
D := PN;
P := Parent (PN);
while Nkind (P) /= N_Component_Declaration
and then Nkind (P) /= N_Subtype_Indication
and then Nkind (P) /= N_Entry_Declaration
loop
D := P;
P := Parent (P);
exit when No (P);
end loop;
if (Nkind (P) = N_Subtype_Indication
and then
(Nkind (Parent (P)) = N_Component_Declaration
or else Nkind (Parent (P)) = N_Derived_Type_Definition)
and then D = Constraint (P))
or else (Nkind (P) = N_Subtype_Indication
and then Nkind (Parent (P)) = N_Index_Or_Discriminant_Constraint)
or else Nkind (P) = N_Entry_Declaration
or else Nkind (D) = N_Defining_Identifier
then
Error_Msg_N
("discriminant in constraint must appear alone", N);
end if;
end if;
end Check_Discriminant_Use;
procedure Check_For_Visible_Operator (N : Node_Id; T : Entity_Id) is
Orig_Node : Node_Id := Original_Node (N);
begin
if Comes_From_Source (Orig_Node)
and then not In_Open_Scopes (Scope (T))
and then not Is_Potentially_Use_Visible (T)
and then not In_Use (T)
and then not In_Use (Scope (T))
and then (not Present (Entity (N))
or else Ekind (Entity (N)) /= E_Function)
and then (Nkind (Orig_Node) /= N_Function_Call
or else Nkind (Name (Orig_Node)) /= N_Expanded_Name
or else Entity (Prefix (Name (Orig_Node))) /= Scope (T))
and then not In_Instance
then
Error_Msg_NE
("operator for} is not directly visible!", N, First_Subtype (T));
Error_Msg_N ("use clause would make operation legal!", N);
end if;
end Check_For_Visible_Operator;
function Check_Infinite_Recursion (N : Node_Id) return Boolean is
P : Node_Id;
C : Node_Id;
function Same_Argument_List return Boolean;
function Same_Argument_List return Boolean is
A : Node_Id;
F : Entity_Id;
Subp : Entity_Id;
begin
if not Is_Entity_Name (Name (N)) then
return False;
else
Subp := Entity (Name (N));
end if;
F := First_Formal (Subp);
A := First_Actual (N);
while Present (F) and then Present (A) loop
if not Is_Entity_Name (A)
or else Entity (A) /= F
then
return False;
end if;
Next_Actual (A);
Next_Formal (F);
end loop;
return True;
end Same_Argument_List;
begin
C := N;
loop
P := Parent (C);
exit when Nkind (P) = N_Subprogram_Body;
if Nkind (P) = N_Or_Else or else
Nkind (P) = N_And_Then or else
Nkind (P) = N_If_Statement or else
Nkind (P) = N_Case_Statement
then
return False;
elsif Nkind (P) = N_Handled_Sequence_Of_Statements
and then C /= First (Statements (P))
then
if Nkind (Parent (N)) = N_Return_Statement
and then Same_Argument_List
then
exit when not Is_List_Member (Parent (N))
or else (Nkind (Prev (Parent (N))) /= N_Raise_Statement
and then
(Nkind (Prev (Parent (N))) not in N_Raise_xxx_Error
or else
Present (Condition (Prev (Parent (N))))));
end if;
return False;
else
C := P;
end if;
end loop;
Warn_On_Instance := True;
Error_Msg_N ("possible infinite recursion?", N);
Error_Msg_N ("\Storage_Error may be raised at run time?", N);
Warn_On_Instance := False;
return True;
end Check_Infinite_Recursion;
procedure Check_Initialization_Call (N : Entity_Id; Nam : Entity_Id) is
Typ : Entity_Id := Etype (First_Formal (Nam));
function Uses_SS (T : Entity_Id) return Boolean;
function Uses_SS (T : Entity_Id) return Boolean is
Comp : Entity_Id;
Expr : Node_Id;
begin
if Is_Controlled (T) then
return False;
elsif Is_Array_Type (T) then
return Uses_SS (Component_Type (T));
elsif Is_Record_Type (T) then
Comp := First_Component (T);
while Present (Comp) loop
if Ekind (Comp) = E_Component
and then Nkind (Parent (Comp)) = N_Component_Declaration
then
Expr := Expression (Parent (Comp));
if Nkind (Expr) = N_Function_Call
and then Requires_Transient_Scope (Etype (Expr))
then
return True;
elsif Uses_SS (Etype (Comp)) then
return True;
end if;
end if;
Next_Component (Comp);
end loop;
return False;
else
return False;
end if;
end Uses_SS;
begin
if Functions_Return_By_DSP_On_Target then
return;
elsif Uses_SS (Typ) then
Establish_Transient_Scope (First_Actual (N), Sec_Stack => True);
end if;
end Check_Initialization_Call;
procedure Check_Parameterless_Call (N : Node_Id) is
Nam : Node_Id;
begin
if Total_Errors_Detected /= 0 then
if Nkind (N) in N_Has_Etype and then Etype (N) = Any_Type then
return;
elsif Nkind (N) in N_Has_Chars
and then Chars (N) in Error_Name_Or_No_Name
then
return;
end if;
end if;
if (Is_Entity_Name (N)
and then Is_Overloadable (Entity (N))
and then (Ekind (Entity (N)) /= E_Enumeration_Literal
or else Is_Overloaded (N)))
or else
(Nkind (N) = N_Explicit_Dereference
and then Ekind (Etype (N)) = E_Subprogram_Type
and then Base_Type (Etype (Etype (N))) /= Standard_Void_Type)
or else
(Nkind (N) = N_Selected_Component
and then (Ekind (Entity (Selector_Name (N))) = E_Function
or else ((Ekind (Entity (Selector_Name (N))) = E_Entry
or else
Ekind (Entity (Selector_Name (N))) = E_Procedure)
and then Is_Overloaded (Selector_Name (N)))))
then
if Nkind (Parent (N)) /= N_Function_Call
or else N /= Name (Parent (N))
then
Nam := New_Copy (N);
Save_Interps (N, Nam);
Change_Node (N, N_Function_Call);
Set_Name (N, Nam);
Set_Sloc (N, Sloc (Nam));
Analyze_Call (N);
end if;
elsif Nkind (N) = N_Parameter_Association then
Check_Parameterless_Call (Explicit_Actual_Parameter (N));
end if;
end Check_Parameterless_Call;
function Is_Predefined_Op (Nam : Entity_Id) return Boolean is
begin
return Is_Intrinsic_Subprogram (Nam)
and then not Is_Generic_Instance (Nam)
and then Chars (Nam) in Any_Operator_Name
and then (No (Alias (Nam))
or else Is_Predefined_Op (Alias (Nam)));
end Is_Predefined_Op;
procedure Make_Call_Into_Operator
(N : Node_Id;
Typ : Entity_Id;
Op_Id : Entity_Id)
is
Op_Name : constant Name_Id := Chars (Op_Id);
Act1 : Node_Id := First_Actual (N);
Act2 : Node_Id := Next_Actual (Act1);
Error : Boolean := False;
Is_Binary : constant Boolean := Present (Act2);
Op_Node : Node_Id;
Opnd_Type : Entity_Id;
Orig_Type : Entity_Id := Empty;
Pack : Entity_Id;
type Kind_Test is access function (E : Entity_Id) return Boolean;
function Is_Definite_Access_Type (E : Entity_Id) return Boolean;
function Operand_Type_In_Scope (S : Entity_Id) return Boolean;
function Type_In_P (Test : Kind_Test) return Entity_Id;
function Is_Definite_Access_Type (E : Entity_Id) return Boolean is
Btyp : constant Entity_Id := Base_Type (E);
begin
return Ekind (Btyp) = E_Access_Type
or else (Ekind (Btyp) = E_Access_Subprogram_Type
and then Comes_From_Source (Btyp));
end Is_Definite_Access_Type;
function Operand_Type_In_Scope (S : Entity_Id) return Boolean is
Nod : constant Node_Id := Right_Opnd (Op_Node);
I : Interp_Index;
It : Interp;
begin
if not Is_Overloaded (Nod) then
return Scope (Base_Type (Etype (Nod))) = S;
else
Get_First_Interp (Nod, I, It);
while Present (It.Typ) loop
if Scope (Base_Type (It.Typ)) = S then
return True;
end if;
Get_Next_Interp (I, It);
end loop;
return False;
end if;
end Operand_Type_In_Scope;
function Type_In_P (Test : Kind_Test) return Entity_Id is
E : Entity_Id;
function In_Decl return Boolean;
function In_Decl return Boolean is
Decl_Node : constant Node_Id := Parent (E);
N2 : Node_Id;
begin
N2 := N;
if Etype (E) = Any_Type then
return True;
elsif No (Decl_Node) then
return False;
else
while Present (N2)
and then Nkind (N2) /= N_Compilation_Unit
loop
if N2 = Decl_Node then
return True;
else
N2 := Parent (N2);
end if;
end loop;
return False;
end if;
end In_Decl;
begin
if Scope (Base_Type (Typ)) = Pack
and then Test (Typ)
then
return Base_Type (Typ);
else
E := First_Entity (Pack);
while Present (E) loop
if Test (E)
and then not In_Decl
then
return E;
end if;
Next_Entity (E);
end loop;
return Empty;
end if;
end Type_In_P;
begin
Op_Node := New_Node (Operator_Kind (Op_Name, Is_Binary), Sloc (N));
if Is_Binary then
Set_Left_Opnd (Op_Node, Relocate_Node (Act1));
Set_Right_Opnd (Op_Node, Relocate_Node (Act2));
Save_Interps (Act1, Left_Opnd (Op_Node));
Save_Interps (Act2, Right_Opnd (Op_Node));
Act1 := Left_Opnd (Op_Node);
Act2 := Right_Opnd (Op_Node);
else
Set_Right_Opnd (Op_Node, Relocate_Node (Act1));
Save_Interps (Act1, Right_Opnd (Op_Node));
Act1 := Right_Opnd (Op_Node);
end if;
if Nkind (Name (N)) = N_Expanded_Name then
Pack := Entity (Prefix (Name (N)));
if Scope (Entity (Name (N))) = Pack
and then Pack /= Standard_Standard
then
null;
elsif (Op_Name = Name_Op_Multiply
or else Op_Name = Name_Op_Divide)
and then Is_Fixed_Point_Type (Etype (Left_Opnd (Op_Node)))
and then Is_Fixed_Point_Type (Etype (Right_Opnd (Op_Node)))
then
if Pack /= Standard_Standard then
Error := True;
end if;
else
Opnd_Type := Base_Type (Etype (Right_Opnd (Op_Node)));
if Op_Name = Name_Op_Concat then
Opnd_Type := Base_Type (Typ);
elsif (Scope (Opnd_Type) = Standard_Standard
and then Is_Binary)
or else (Nkind (Right_Opnd (Op_Node)) = N_Attribute_Reference
and then Is_Binary
and then not Comes_From_Source (Opnd_Type))
then
Opnd_Type := Base_Type (Etype (Left_Opnd (Op_Node)));
end if;
if Scope (Opnd_Type) = Standard_Standard then
if Pack /= Standard_Standard then
if Opnd_Type = Universal_Integer then
Orig_Type := Type_In_P (Is_Integer_Type'Access);
elsif Opnd_Type = Universal_Real then
Orig_Type := Type_In_P (Is_Real_Type'Access);
elsif Opnd_Type = Any_String then
Orig_Type := Type_In_P (Is_String_Type'Access);
elsif Opnd_Type = Any_Access then
Orig_Type := Type_In_P (Is_Definite_Access_Type'Access);
elsif Opnd_Type = Any_Composite then
Orig_Type := Type_In_P (Is_Composite_Type'Access);
if Present (Orig_Type) then
if Has_Private_Component (Orig_Type) then
Orig_Type := Empty;
else
Set_Etype (Act1, Orig_Type);
if Is_Binary then
Set_Etype (Act2, Orig_Type);
end if;
end if;
end if;
else
Orig_Type := Empty;
end if;
Error := No (Orig_Type);
end if;
elsif Ekind (Opnd_Type) = E_Allocator_Type
and then No (Type_In_P (Is_Definite_Access_Type'Access))
then
Error := True;
elsif Scope (Opnd_Type) /= Pack
and then Scope (Op_Id) /= Pack
and then (No (System_Aux_Id)
or else Scope (Opnd_Type) /= System_Aux_Id
or else Pack /= Scope (System_Aux_Id))
then
Error := True;
elsif Pack = Standard_Standard
and then not Operand_Type_In_Scope (Standard_Standard)
then
Error := True;
end if;
end if;
if Error then
Error_Msg_Node_2 := Pack;
Error_Msg_NE
("& not declared in&", N, Selector_Name (Name (N)));
Set_Etype (N, Any_Type);
return;
end if;
end if;
Set_Chars (Op_Node, Op_Name);
Set_Etype (Op_Node, Base_Type (Etype (N)));
Set_Entity (Op_Node, Op_Id);
Generate_Reference (Op_Id, N, ' ');
Rewrite (N, Op_Node);
Resolve (N, Typ);
if Present (Orig_Type) then
Set_Etype (Act1, Orig_Type);
Freeze_Expression (Act1);
end if;
end Make_Call_Into_Operator;
function Operator_Kind
(Op_Name : Name_Id;
Is_Binary : Boolean)
return Node_Kind
is
Kind : Node_Kind;
begin
if Is_Binary then
if Op_Name = Name_Op_And then Kind := N_Op_And;
elsif Op_Name = Name_Op_Or then Kind := N_Op_Or;
elsif Op_Name = Name_Op_Xor then Kind := N_Op_Xor;
elsif Op_Name = Name_Op_Eq then Kind := N_Op_Eq;
elsif Op_Name = Name_Op_Ne then Kind := N_Op_Ne;
elsif Op_Name = Name_Op_Lt then Kind := N_Op_Lt;
elsif Op_Name = Name_Op_Le then Kind := N_Op_Le;
elsif Op_Name = Name_Op_Gt then Kind := N_Op_Gt;
elsif Op_Name = Name_Op_Ge then Kind := N_Op_Ge;
elsif Op_Name = Name_Op_Add then Kind := N_Op_Add;
elsif Op_Name = Name_Op_Subtract then Kind := N_Op_Subtract;
elsif Op_Name = Name_Op_Concat then Kind := N_Op_Concat;
elsif Op_Name = Name_Op_Multiply then Kind := N_Op_Multiply;
elsif Op_Name = Name_Op_Divide then Kind := N_Op_Divide;
elsif Op_Name = Name_Op_Mod then Kind := N_Op_Mod;
elsif Op_Name = Name_Op_Rem then Kind := N_Op_Rem;
elsif Op_Name = Name_Op_Expon then Kind := N_Op_Expon;
else
raise Program_Error;
end if;
else
if Op_Name = Name_Op_Add then Kind := N_Op_Plus;
elsif Op_Name = Name_Op_Subtract then Kind := N_Op_Minus;
elsif Op_Name = Name_Op_Abs then Kind := N_Op_Abs;
elsif Op_Name = Name_Op_Not then Kind := N_Op_Not;
else
raise Program_Error;
end if;
end if;
return Kind;
end Operator_Kind;
procedure Pre_Analyze_And_Resolve (N : Node_Id; T : Entity_Id) is
Save_Full_Analysis : constant Boolean := Full_Analysis;
begin
Full_Analysis := False;
Expander_Mode_Save_And_Set (False);
Analyze_And_Resolve (N, T, Suppress => All_Checks);
Expander_Mode_Restore;
Full_Analysis := Save_Full_Analysis;
end Pre_Analyze_And_Resolve;
procedure Pre_Analyze_And_Resolve (N : Node_Id) is
Save_Full_Analysis : constant Boolean := Full_Analysis;
begin
Full_Analysis := False;
Expander_Mode_Save_And_Set (False);
Analyze (N);
Resolve (N, Etype (N), Suppress => All_Checks);
Expander_Mode_Restore;
Full_Analysis := Save_Full_Analysis;
end Pre_Analyze_And_Resolve;
procedure Replace_Actual_Discriminants (N : Node_Id; Default : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Tsk : Node_Id := Empty;
function Process_Discr (Nod : Node_Id) return Traverse_Result;
function Process_Discr (Nod : Node_Id) return Traverse_Result is
Ent : Entity_Id;
begin
if Nkind (Nod) = N_Identifier then
Ent := Entity (Nod);
if Present (Ent)
and then Ekind (Ent) = E_Discriminant
then
Rewrite (Nod,
Make_Selected_Component (Loc,
Prefix => New_Copy_Tree (Tsk, New_Sloc => Loc),
Selector_Name => Make_Identifier (Loc, Chars (Ent))));
Set_Etype (Nod, Etype (Ent));
end if;
end if;
return OK;
end Process_Discr;
procedure Replace_Discrs is new Traverse_Proc (Process_Discr);
begin
if not Expander_Active then
return;
end if;
if Nkind (Name (N)) = N_Selected_Component then
Tsk := Prefix (Name (N));
elsif Nkind (Name (N)) = N_Indexed_Component then
Tsk := Prefix (Prefix (Name (N)));
end if;
if No (Tsk) then
return;
else
Replace_Discrs (Default);
end if;
end Replace_Actual_Discriminants;
procedure Resolve (N : Node_Id; Typ : Entity_Id) is
I : Interp_Index;
I1 : Interp_Index := 0; It : Interp;
It1 : Interp;
Found : Boolean := False;
Seen : Entity_Id := Empty; Ctx_Type : Entity_Id := Typ;
Expr_Type : Entity_Id := Empty; Ambiguous : Boolean := False;
procedure Patch_Up_Value (N : Node_Id; Typ : Entity_Id);
procedure Resolution_Failed;
procedure Patch_Up_Value (N : Node_Id; Typ : Entity_Id) is
begin
if Nkind (N) = N_Integer_Literal
and then Is_Real_Type (Typ)
then
Rewrite (N,
Make_Real_Literal (Sloc (N),
Realval => UR_From_Uint (Intval (N))));
Set_Etype (N, Universal_Real);
Set_Is_Static_Expression (N);
elsif Nkind (N) = N_Real_Literal
and then Is_Integer_Type (Typ)
then
Rewrite (N,
Make_Integer_Literal (Sloc (N),
Intval => UR_To_Uint (Realval (N))));
Set_Etype (N, Universal_Integer);
Set_Is_Static_Expression (N);
elsif Nkind (N) = N_String_Literal
and then Is_Character_Type (Typ)
then
Set_Character_Literal_Name (Char_Code (Character'Pos ('A')));
Rewrite (N,
Make_Character_Literal (Sloc (N),
Chars => Name_Find,
Char_Literal_Value => Char_Code (Character'Pos ('A'))));
Set_Etype (N, Any_Character);
Set_Is_Static_Expression (N);
elsif Nkind (N) /= N_String_Literal
and then Is_String_Type (Typ)
then
Rewrite (N,
Make_String_Literal (Sloc (N),
Strval => End_String));
elsif Nkind (N) = N_Range then
Patch_Up_Value (Low_Bound (N), Typ);
Patch_Up_Value (High_Bound (N), Typ);
end if;
end Patch_Up_Value;
procedure Resolution_Failed is
begin
Patch_Up_Value (N, Typ);
Set_Etype (N, Typ);
Debug_A_Exit ("resolving ", N, " (done, resolution failed)");
Set_Is_Overloaded (N, False);
Set_Analyzed (N, True);
return;
end Resolution_Failed;
begin
if N = Error then
return;
end if;
if Nkind (N) = N_Attribute_Reference
and then (Attribute_Name (N) = Name_Access
or else Attribute_Name (N) = Name_Unrestricted_Access
or else Attribute_Name (N) = Name_Unchecked_Access)
and then Comes_From_Source (N)
and then Is_Entity_Name (Prefix (N))
and then Is_Subprogram (Entity (Prefix (N)))
and then Is_Remote_Call_Interface (Entity (Prefix (N)))
and then not Is_Remote_Access_To_Subprogram_Type (Typ)
then
Error_Msg_N
("prefix must statically denote a non-remote subprogram", N);
end if;
if Nkind (N) = N_Attribute_Reference
and then Comes_From_Source (N)
and then (Is_Remote_Call_Interface (Typ)
or else Is_Remote_Types (Typ))
then
declare
Attr : constant Attribute_Id :=
Get_Attribute_Id (Attribute_Name (N));
Pref : constant Node_Id := Prefix (N);
Decl : Node_Id;
Spec : Node_Id;
Is_Remote : Boolean := True;
begin
if
(Ekind (Typ) = E_Access_Subprogram_Type
and then Present (Equivalent_Type (Typ)))
or else
(Ekind (Typ) = E_Record_Type
and then Present (Corresponding_Remote_Type (Typ)))
then
if Attr = Attribute_Access then
Decl := Unit_Declaration_Node (Entity (Pref));
if Nkind (Decl) = N_Subprogram_Body then
Spec := Corresponding_Spec (Decl);
if not No (Spec) then
Decl := Unit_Declaration_Node (Spec);
end if;
end if;
Spec := Parent (Decl);
if not Is_Entity_Name (Prefix (N))
or else Nkind (Spec) /= N_Package_Specification
or else
not Is_Remote_Call_Interface (Defining_Entity (Spec))
then
Is_Remote := False;
Error_Msg_N
("prefix must statically denote a remote subprogram ",
N);
end if;
end if;
if Attr = Attribute_Access
or else Attr = Attribute_Unchecked_Access
or else Attr = Attribute_Unrestricted_Access
then
Check_Subtype_Conformant
(New_Id => Entity (Prefix (N)),
Old_Id => Designated_Type
(Corresponding_Remote_Type (Typ)),
Err_Loc => N);
if Is_Remote then
Process_Remote_AST_Attribute (N, Typ);
end if;
end if;
end if;
end;
end if;
Debug_A_Entry ("resolving ", N);
if Comes_From_Source (N) then
if Is_Fixed_Point_Type (Typ) then
Check_Restriction (No_Fixed_Point, N);
elsif Is_Floating_Point_Type (Typ)
and then Typ /= Universal_Real
and then Typ /= Any_Real
then
Check_Restriction (No_Floating_Point, N);
end if;
end if;
if Analyzed (N) then
Debug_A_Exit ("resolving ", N, " (done, already analyzed)");
return;
elsif Etype (N) = Any_Type then
Debug_A_Exit ("resolving ", N, " (done, Etype = Any_Type)");
return;
end if;
Check_Parameterless_Call (N);
if not Is_Overloaded (N) then
Found := Covers (Typ, Etype (N));
Expr_Type := Etype (N);
else
Get_First_Interp (N, I, It);
Interp_Loop : while Present (It.Typ) loop
if Covers (Typ, It.Typ) then
if not Found then
Found := True;
I1 := I;
Seen := It.Nam;
Expr_Type := It.Typ;
else
Error_Msg_Sloc := Sloc (Seen);
It1 := Disambiguate (N, I1, I, Typ);
if It1 = No_Interp then
if Nkind (N) = N_Function_Call
or else Nkind (N) = N_Procedure_Call_Statement
then
declare
A : Node_Id := First_Actual (N);
E : Node_Id;
begin
while Present (A) loop
E := A;
if Nkind (E) = N_Parameter_Association then
E := Explicit_Actual_Parameter (E);
end if;
if Etype (E) = Any_Type then
if Debug_Flag_V then
Write_Str ("Any_Type in call");
Write_Eol;
end if;
exit Interp_Loop;
end if;
Next_Actual (A);
end loop;
end;
elsif Nkind (N) in N_Binary_Op
and then (Etype (Left_Opnd (N)) = Any_Type
or else Etype (Right_Opnd (N)) = Any_Type)
then
exit Interp_Loop;
elsif Nkind (N) in N_Unary_Op
and then Etype (Right_Opnd (N)) = Any_Type
then
exit Interp_Loop;
end if;
if not Ambiguous then
Error_Msg_NE
("ambiguous expression (cannot resolve&)!",
N, It.Nam);
Error_Msg_N
("possible interpretation#!", N);
Ambiguous := True;
end if;
Error_Msg_Sloc := Sloc (It.Nam);
Error_Msg_N ("possible interpretation#!", N);
else
Seen := It1.Nam;
Expr_Type := It1.Typ;
while Present (It.Typ) loop
Get_Next_Interp (I, It);
end loop;
end if;
end if;
if Nkind (N) in N_Op then
Set_Entity (N, Seen);
Generate_Reference (Seen, N);
elsif Nkind (N) = N_Character_Literal then
Set_Etype (N, Expr_Type);
elsif Nkind (N) = N_Explicit_Dereference
or else Nkind (N) = N_Attribute_Reference
or else Nkind (N) = N_And_Then
or else Nkind (N) = N_Indexed_Component
or else Nkind (N) = N_Or_Else
or else Nkind (N) = N_Range
or else Nkind (N) = N_Selected_Component
or else Nkind (N) = N_Slice
or else Nkind (Name (N)) = N_Explicit_Dereference
then
null;
elsif (Nkind (N) = N_Procedure_Call_Statement
or else Nkind (N) = N_Function_Call)
and then (Is_Entity_Name (Name (N))
or else Nkind (Name (N)) = N_Operator_Symbol)
then
Set_Etype (Name (N), Expr_Type);
Set_Entity (Name (N), Seen);
Generate_Reference (Seen, Name (N));
elsif Nkind (N) = N_Function_Call
and then Nkind (Name (N)) = N_Selected_Component
then
Set_Etype (Name (N), Expr_Type);
Set_Entity (Selector_Name (Name (N)), Seen);
Generate_Reference (Seen, Selector_Name (Name (N)));
else
Set_Etype (Name (N), Expr_Type);
end if;
else
if Debug_Flag_V then
Write_Str (" intepretation incompatible with context");
Write_Eol;
end if;
end if;
exit Interp_Loop when not Present (It.Typ);
Get_Next_Interp (I, It);
end loop Interp_Loop;
end if;
if not Found then
if Typ /= Any_Type then
if Typ = Standard_Void_Type then
Error_Msg_N ("expect procedure name in procedure call", N);
Found := True;
elsif Nkind (N) = N_Allocator
and then Ekind (Typ) in Access_Kind
and then Ekind (Etype (N)) in Access_Kind
and then Designated_Type (Etype (N)) = Typ
then
Wrong_Type (Expression (N), Designated_Type (Typ));
Found := True;
elsif (In_Instance or else In_Inlined_Body)
and then (Nkind (N) = N_Null)
and then Is_Private_Type (Typ)
and then Is_Access_Type (Full_View (Typ))
then
Resolve (N, Full_View (Typ));
Set_Etype (N, Typ);
return;
elsif Nkind (N) = N_Aggregate
and then Etype (N) = Any_Composite
then
Expander_Active := False;
declare
procedure Check_Aggr (Aggr : Node_Id);
procedure Check_Elmt (Aelmt : Node_Id);
procedure Check_Aggr (Aggr : Node_Id) is
Elmt : Node_Id;
begin
if Present (Expressions (Aggr)) then
Elmt := First (Expressions (Aggr));
while Present (Elmt) loop
Check_Elmt (Elmt);
Next (Elmt);
end loop;
end if;
if Present (Component_Associations (Aggr)) then
Elmt := First (Component_Associations (Aggr));
while Present (Elmt) loop
Check_Elmt (Expression (Elmt));
Next (Elmt);
end loop;
end if;
end Check_Aggr;
procedure Check_Elmt (Aelmt : Node_Id) is
begin
if Nkind (Aelmt) = N_Aggregate then
Check_Aggr (Aelmt);
else
Analyze (Aelmt);
if not Is_Overloaded (Aelmt)
and then Etype (Aelmt) /= Any_Fixed
then
Resolve (Aelmt, Etype (Aelmt));
end if;
if Etype (Aelmt) = Any_Type then
Found := True;
end if;
end if;
end Check_Elmt;
begin
Check_Aggr (N);
end;
end if;
if not Found then
if Is_Overloaded (N)
and then Nkind (N) = N_Function_Call
then
Error_Msg_Node_2 := Typ;
Error_Msg_NE ("no visible interpretation of&" &
" matches expected type&", N, Name (N));
if All_Errors_Mode then
declare
Index : Interp_Index;
It : Interp;
begin
Error_Msg_N ("\possible interpretations:", N);
Get_First_Interp (Name (N), Index, It);
while Present (It.Nam) loop
Error_Msg_Sloc := Sloc (It.Nam);
Error_Msg_Node_2 := It.Typ;
Error_Msg_NE ("\& declared#, type&",
N, It.Nam);
Get_Next_Interp (Index, It);
end loop;
end;
else
Error_Msg_N ("\use -gnatf for details", N);
end if;
else
Wrong_Type (N, Typ);
end if;
end if;
end if;
Resolution_Failed;
return;
elsif Ambiguous then
Resolution_Failed;
return;
else
if Nkind (N) in N_Op
and then Present (Entity (N))
and then Ekind (Entity (N)) /= E_Operator
then
if not Is_Predefined_Op (Entity (N)) then
Rewrite_Operator_As_Call (N, Entity (N));
elsif Present (Alias (Entity (N))) then
Rewrite_Renamed_Operator (N, Alias (Entity (N)));
end if;
end if;
if Typ = Any_Integer
or else Typ = Any_Boolean
or else Typ = Any_Modular
or else Typ = Any_Real
or else Typ = Any_Discrete
then
Ctx_Type := Expr_Type;
if Typ = Any_Real
and then Expr_Type = Any_Fixed
then
Error_Msg_N ("Illegal context for mixed mode operation", N);
Set_Etype (N, Universal_Real);
Ctx_Type := Universal_Real;
end if;
end if;
case N_Subexpr'(Nkind (N)) is
when N_Aggregate => Resolve_Aggregate (N, Ctx_Type);
when N_Allocator => Resolve_Allocator (N, Ctx_Type);
when N_And_Then | N_Or_Else
=> Resolve_Short_Circuit (N, Ctx_Type);
when N_Attribute_Reference
=> Resolve_Attribute (N, Ctx_Type);
when N_Character_Literal
=> Resolve_Character_Literal (N, Ctx_Type);
when N_Conditional_Expression
=> Resolve_Conditional_Expression (N, Ctx_Type);
when N_Expanded_Name
=> Resolve_Entity_Name (N, Ctx_Type);
when N_Extension_Aggregate
=> Resolve_Extension_Aggregate (N, Ctx_Type);
when N_Explicit_Dereference
=> Resolve_Explicit_Dereference (N, Ctx_Type);
when N_Function_Call
=> Resolve_Call (N, Ctx_Type);
when N_Identifier
=> Resolve_Entity_Name (N, Ctx_Type);
when N_In | N_Not_In
=> Resolve_Membership_Op (N, Ctx_Type);
when N_Indexed_Component
=> Resolve_Indexed_Component (N, Ctx_Type);
when N_Integer_Literal
=> Resolve_Integer_Literal (N, Ctx_Type);
when N_Null => Resolve_Null (N, Ctx_Type);
when N_Op_And | N_Op_Or | N_Op_Xor
=> Resolve_Logical_Op (N, Ctx_Type);
when N_Op_Eq | N_Op_Ne
=> Resolve_Equality_Op (N, Ctx_Type);
when N_Op_Lt | N_Op_Le | N_Op_Gt | N_Op_Ge
=> Resolve_Comparison_Op (N, Ctx_Type);
when N_Op_Not => Resolve_Op_Not (N, Ctx_Type);
when N_Op_Add | N_Op_Subtract | N_Op_Multiply |
N_Op_Divide | N_Op_Mod | N_Op_Rem
=> Resolve_Arithmetic_Op (N, Ctx_Type);
when N_Op_Concat => Resolve_Op_Concat (N, Ctx_Type);
when N_Op_Expon => Resolve_Op_Expon (N, Ctx_Type);
when N_Op_Plus | N_Op_Minus | N_Op_Abs
=> Resolve_Unary_Op (N, Ctx_Type);
when N_Op_Shift => Resolve_Shift (N, Ctx_Type);
when N_Procedure_Call_Statement
=> Resolve_Call (N, Ctx_Type);
when N_Operator_Symbol
=> Resolve_Operator_Symbol (N, Ctx_Type);
when N_Qualified_Expression
=> Resolve_Qualified_Expression (N, Ctx_Type);
when N_Raise_xxx_Error
=> Set_Etype (N, Ctx_Type);
when N_Range => Resolve_Range (N, Ctx_Type);
when N_Real_Literal
=> Resolve_Real_Literal (N, Ctx_Type);
when N_Reference => Resolve_Reference (N, Ctx_Type);
when N_Selected_Component
=> Resolve_Selected_Component (N, Ctx_Type);
when N_Slice => Resolve_Slice (N, Ctx_Type);
when N_String_Literal
=> Resolve_String_Literal (N, Ctx_Type);
when N_Subprogram_Info
=> Resolve_Subprogram_Info (N, Ctx_Type);
when N_Type_Conversion
=> Resolve_Type_Conversion (N, Ctx_Type);
when N_Unchecked_Expression =>
Resolve_Unchecked_Expression (N, Ctx_Type);
when N_Unchecked_Type_Conversion =>
Resolve_Unchecked_Type_Conversion (N, Ctx_Type);
end case;
if Nkind (N) not in N_Subexpr then
Debug_A_Exit ("resolving ", N, " (done)");
Expand (N);
return;
end if;
Set_Is_Overloaded (N, False);
Debug_A_Exit ("resolving ", N, " (done)");
Freeze_Expression (N);
Expand (N);
end if;
end Resolve;
procedure Resolve (N : Node_Id; Typ : Entity_Id; Suppress : Check_Id) is
begin
if Suppress = All_Checks then
declare
Svg : constant Suppress_Record := Scope_Suppress;
begin
Scope_Suppress := (others => True);
Resolve (N, Typ);
Scope_Suppress := Svg;
end;
else
declare
Svg : constant Boolean := Get_Scope_Suppress (Suppress);
begin
Set_Scope_Suppress (Suppress, True);
Resolve (N, Typ);
Set_Scope_Suppress (Suppress, Svg);
end;
end if;
end Resolve;
procedure Resolve_Actuals (N : Node_Id; Nam : Entity_Id) is
Loc : constant Source_Ptr := Sloc (N);
A : Node_Id;
F : Entity_Id;
A_Typ : Entity_Id;
F_Typ : Entity_Id;
Prev : Node_Id := Empty;
procedure Insert_Default;
procedure Insert_Default is
Actval : Node_Id;
Assoc : Node_Id;
begin
if Present (Default_Value (F)) then
Actval := New_Copy_Tree (Default_Value (F),
New_Scope => Current_Scope, New_Sloc => Loc);
if Is_Concurrent_Type (Scope (Nam))
and then Has_Discriminants (Scope (Nam))
then
Replace_Actual_Discriminants (N, Actval);
end if;
if Is_Overloadable (Nam)
and then Present (Alias (Nam))
then
if Base_Type (Etype (F)) /= Base_Type (Etype (Actval))
and then not Is_Tagged_Type (Etype (F))
then
if Nkind (Actval) = N_Real_Literal then
Set_Etype (Actval, Base_Type (Etype (F)));
else
Actval := Unchecked_Convert_To (Etype (F), Actval);
end if;
end if;
if Is_Scalar_Type (Etype (F)) then
Enable_Range_Check (Actval);
end if;
Set_Parent (Actval, N);
Analyze_And_Resolve (Actval, Etype (Actval));
else
Set_Parent (Actval, N);
if Nkind (Actval) = N_Aggregate
and then Has_Discriminants (Etype (Actval))
then
Analyze_And_Resolve (Actval, Base_Type (Etype (Actval)));
else
Analyze_And_Resolve (Actval, Etype (Actval));
end if;
end if;
if Is_Controlling_Formal (F)
and then Nkind (Default_Value (F)) = N_Function_Call
then
Set_Is_Controlling_Actual (Actval);
end if;
else
return;
end if;
if Raises_Constraint_Error (Actval) then
Rewrite (Actval,
Make_Raise_Constraint_Error (Loc,
Reason => CE_Range_Check_Failed));
Set_Raises_Constraint_Error (Actval);
Set_Etype (Actval, Etype (F));
end if;
Assoc :=
Make_Parameter_Association (Loc,
Explicit_Actual_Parameter => Actval,
Selector_Name => Make_Identifier (Loc, Chars (F)));
if No (Prev) or else
Nkind (Parent (Prev)) /= N_Parameter_Association
then
Set_Next_Named_Actual (Assoc, First_Named_Actual (N));
Set_First_Named_Actual (N, Actval);
if No (Prev) then
if not Present (Parameter_Associations (N)) then
Set_Parameter_Associations (N, New_List (Assoc));
else
Append (Assoc, Parameter_Associations (N));
end if;
else
Insert_After (Prev, Assoc);
end if;
else
Set_Next_Named_Actual
(Assoc, Next_Named_Actual (Parent (Prev)));
Set_Next_Named_Actual (Parent (Prev), Actval);
Append (Assoc, Parameter_Associations (N));
end if;
Mark_Rewrite_Insertion (Assoc);
Mark_Rewrite_Insertion (Actval);
Prev := Actval;
end Insert_Default;
begin
A := First_Actual (N);
F := First_Formal (Nam);
while Present (F) loop
if (No (A) or else Etype (A) = Any_Type or else Etype (F) = Any_Type)
and then Total_Errors_Detected /= 0
then
Set_Etype (N, Any_Type);
return;
end if;
if Present (A)
and then (Nkind (Parent (A)) /= N_Parameter_Association
or else
Chars (Selector_Name (Parent (A))) = Chars (F))
then
if Ekind (F) /= E_In_Parameter
and then Nkind (A) = N_Type_Conversion
and then not Is_Class_Wide_Type (Etype (Expression (A)))
then
if Ekind (F) = E_In_Out_Parameter
and then Is_Array_Type (Etype (F))
and then Has_Aliased_Components (Etype (Expression (A)))
/= Has_Aliased_Components (Etype (F))
then
Error_Msg_N
("both component types in a view conversion must be"
& " aliased, or neither", A);
end if;
if Conversion_OK (A)
or else Valid_Conversion (A, Etype (A), Expression (A))
then
Resolve (Expression (A), Etype (Expression (A)));
end if;
else
Resolve (A, Etype (F));
end if;
A_Typ := Etype (A);
F_Typ := Etype (F);
if Ekind (F) /= E_In_Parameter
and then not Is_OK_Variable_For_Out_Formal (A)
then
if Is_Entity_Name (A)
and then Chars (Entity (A)) = Name_uObject
and then Ekind (Current_Scope) = E_Function
and then Convention (Current_Scope) = Convention_Protected
and then Ekind (Nam) /= E_Function
then
Error_Msg_N ("within protected function, protected " &
"object is constant", A);
Error_Msg_N ("\cannot call operation that may modify it", A);
else
Error_Msg_NE ("actual for& must be a variable", A, F);
end if;
end if;
if Etype (A) = Any_Type then
Set_Etype (N, Any_Type);
return;
end if;
if Ekind (F) /= E_Out_Parameter then
Check_Unset_Reference (A);
if Ada_83
and then Is_Entity_Name (A)
and then Ekind (Entity (A)) = E_Out_Parameter
then
Error_Msg_N ("(Ada 83) illegal reading of out parameter", A);
end if;
end if;
if Ekind (F) = E_In_Parameter
or else Ekind (F) = E_In_Out_Parameter
then
if Is_Scalar_Type (Etype (A)) then
Apply_Scalar_Range_Check (A, F_Typ);
elsif Is_Array_Type (Etype (A)) then
Apply_Length_Check (A, F_Typ);
elsif Is_Record_Type (F_Typ)
and then Has_Discriminants (F_Typ)
and then Is_Constrained (F_Typ)
and then (not Is_Derived_Type (F_Typ)
or else Comes_From_Source (Nam))
then
Apply_Discriminant_Check (A, F_Typ);
elsif Is_Access_Type (F_Typ)
and then Is_Array_Type (Designated_Type (F_Typ))
and then Is_Constrained (Designated_Type (F_Typ))
then
Apply_Length_Check (A, F_Typ);
elsif Is_Access_Type (F_Typ)
and then Has_Discriminants (Designated_Type (F_Typ))
and then Is_Constrained (Designated_Type (F_Typ))
then
Apply_Discriminant_Check (A, F_Typ);
else
Apply_Range_Check (A, F_Typ);
end if;
end if;
if Ekind (F) = E_Out_Parameter
or else Ekind (F) = E_In_Out_Parameter
then
if Nkind (A) = N_Type_Conversion then
if Is_Scalar_Type (A_Typ) then
Apply_Scalar_Range_Check
(Expression (A), Etype (Expression (A)), A_Typ);
else
Apply_Range_Check
(Expression (A), Etype (Expression (A)), A_Typ);
end if;
else
if Is_Scalar_Type (F_Typ) then
Apply_Scalar_Range_Check (A, A_Typ, F_Typ);
elsif Is_Array_Type (F_Typ)
and then Ekind (F) = E_Out_Parameter
then
Apply_Length_Check (A, F_Typ);
else
Apply_Range_Check (A, A_Typ, F_Typ);
end if;
end if;
end if;
if Ekind (F_Typ) = E_Anonymous_Access_Type then
if not Valid_Conversion (A, F_Typ, A) then
Error_Msg_N
("invalid implicit conversion for access parameter", A);
end if;
end if;
if Is_By_Reference_Type (Etype (F))
and then Comes_From_Source (N)
then
if Is_Atomic_Object (A)
and then not Is_Atomic (Etype (F))
then
Error_Msg_N
("cannot pass atomic argument to non-atomic formal",
N);
elsif Is_Volatile_Object (A)
and then not Is_Volatile (Etype (F))
then
Error_Msg_N
("cannot pass volatile argument to non-volatile formal",
N);
end if;
end if;
if Is_Controlling_Formal (F) then
Set_Is_Controlling_Actual (A);
elsif Nkind (A) = N_Explicit_Dereference then
Validate_Remote_Access_To_Class_Wide_Type (A);
end if;
if (Is_Class_Wide_Type (A_Typ) or else Is_Dynamically_Tagged (A))
and then not Is_Class_Wide_Type (F_Typ)
and then not Is_Controlling_Formal (F)
then
Error_Msg_N ("class-wide argument not allowed here!", A);
if Is_Subprogram (Nam)
and then Comes_From_Source (Nam)
then
Error_Msg_Node_2 := F_Typ;
Error_Msg_NE
("& is not a primitive operation of &!", A, Nam);
end if;
elsif Is_Access_Type (A_Typ)
and then Is_Access_Type (F_Typ)
and then Ekind (F_Typ) /= E_Access_Subprogram_Type
and then (Is_Class_Wide_Type (Designated_Type (A_Typ))
or else (Nkind (A) = N_Attribute_Reference
and then
Is_Class_Wide_Type (Etype (Prefix (A)))))
and then not Is_Class_Wide_Type (Designated_Type (F_Typ))
and then not Is_Controlling_Formal (F)
then
Error_Msg_N
("access to class-wide argument not allowed here!", A);
if Is_Subprogram (Nam)
and then Comes_From_Source (Nam)
then
Error_Msg_Node_2 := Designated_Type (F_Typ);
Error_Msg_NE
("& is not a primitive operation of &!", A, Nam);
end if;
end if;
Eval_Actual (A);
if Nkind (Parent (A)) = N_Parameter_Association then
Set_Entity (Selector_Name (Parent (A)), F);
Generate_Reference (F, Selector_Name (Parent (A)));
Set_Etype (Selector_Name (Parent (A)), F_Typ);
Generate_Reference (F_Typ, N, ' ');
end if;
Prev := A;
Next_Actual (A);
else
Insert_Default;
end if;
Next_Formal (F);
end loop;
end Resolve_Actuals;
procedure Resolve_Allocator (N : Node_Id; Typ : Entity_Id) is
E : constant Node_Id := Expression (N);
Subtyp : Entity_Id;
Discrim : Entity_Id;
Constr : Node_Id;
Disc_Exp : Node_Id;
function In_Dispatching_Context return Boolean;
function In_Dispatching_Context return Boolean is
Par : constant Node_Id := Parent (N);
begin
return (Nkind (Par) = N_Function_Call
or else Nkind (Par) = N_Procedure_Call_Statement)
and then Is_Entity_Name (Name (Par))
and then Is_Dispatching_Operation (Entity (Name (Par)));
end In_Dispatching_Context;
begin
if Ekind (Etype (N)) = E_Allocator_Type then
Set_Etype (N, Base_Type (Typ));
end if;
if Is_Abstract (Typ) then
Error_Msg_N ("type of allocator cannot be abstract", N);
end if;
if Nkind (E) = N_Qualified_Expression then
if Is_Class_Wide_Type (Etype (E))
and then not Is_Class_Wide_Type (Designated_Type (Typ))
and then not In_Dispatching_Context
then
Error_Msg_N
("class-wide allocator not allowed for this access type", N);
end if;
Resolve (Expression (E), Etype (E));
Check_Unset_Reference (Expression (E));
else
Freeze_Expression (E);
if Is_Access_Constant (Typ) and then not No_Initialization (N) then
Error_Msg_N
("initialization required for access-to-constant allocator", N);
end if;
if Nkind (Original_Node (E)) = N_Subtype_Indication
and then Ekind (Typ) /= E_Anonymous_Access_Type
then
Subtyp := Entity (Subtype_Mark (Original_Node (E)));
if Has_Discriminants (Subtyp) then
Discrim := First_Discriminant (Base_Type (Subtyp));
Constr := First (Constraints (Constraint (Original_Node (E))));
while Present (Discrim) and then Present (Constr) loop
if Ekind (Etype (Discrim)) = E_Anonymous_Access_Type then
if Nkind (Constr) = N_Discriminant_Association then
Disc_Exp := Original_Node (Expression (Constr));
else
Disc_Exp := Original_Node (Constr);
end if;
if Type_Access_Level (Etype (Disc_Exp))
> Type_Access_Level (Typ)
then
Error_Msg_N
("operand type has deeper level than allocator type",
Disc_Exp);
elsif Nkind (Disc_Exp) = N_Attribute_Reference
and then Get_Attribute_Id (Attribute_Name (Disc_Exp))
= Attribute_Access
and then Object_Access_Level (Prefix (Disc_Exp))
> Type_Access_Level (Typ)
then
Error_Msg_N
("prefix of attribute has deeper level than"
& " allocator type", Disc_Exp);
elsif Ekind (Etype (Disc_Exp)) = E_Anonymous_Access_Type
and then Nkind (Disc_Exp) = N_Selected_Component
and then Object_Access_Level (Prefix (Disc_Exp))
> Type_Access_Level (Typ)
then
Error_Msg_N
("access discriminant has deeper level than"
& " allocator type", Disc_Exp);
end if;
end if;
Next_Discriminant (Discrim);
Next (Constr);
end loop;
end if;
end if;
end if;
if No_Pool_Assigned (Typ) then
declare
Loc : constant Source_Ptr := Sloc (N);
begin
Error_Msg_N ("?allocation from empty storage pool!", N);
Error_Msg_N ("?Storage_Error will be raised at run time!", N);
Insert_Action (N,
Make_Raise_Storage_Error (Loc,
Reason => SE_Empty_Storage_Pool));
end;
end if;
end Resolve_Allocator;
procedure Resolve_Arithmetic_Op (N : Node_Id; Typ : Entity_Id) is
L : constant Node_Id := Left_Opnd (N);
R : constant Node_Id := Right_Opnd (N);
T : Entity_Id;
TL : Entity_Id := Base_Type (Etype (L));
TR : Entity_Id := Base_Type (Etype (R));
B_Typ : constant Entity_Id := Base_Type (Typ);
function Is_Integer_Or_Universal (N : Node_Id) return Boolean;
procedure Set_Mixed_Mode_Operand (N : Node_Id; T : Entity_Id);
procedure Set_Operand_Type (N : Node_Id);
function Universal_Interpretation (N : Node_Id) return Entity_Id;
function Is_Integer_Or_Universal (N : Node_Id) return Boolean is
T : Entity_Id;
Index : Interp_Index;
It : Interp;
begin
if not Is_Overloaded (N) then
T := Etype (N);
return Base_Type (T) = Base_Type (Standard_Integer)
or else T = Universal_Integer
or else T = Universal_Real;
else
Get_First_Interp (N, Index, It);
while Present (It.Typ) loop
if Base_Type (It.Typ) = Base_Type (Standard_Integer)
or else It.Typ = Universal_Integer
or else It.Typ = Universal_Real
then
return True;
end if;
Get_Next_Interp (Index, It);
end loop;
end if;
return False;
end Is_Integer_Or_Universal;
procedure Set_Mixed_Mode_Operand (N : Node_Id; T : Entity_Id) is
Index : Interp_Index;
It : Interp;
begin
if Universal_Interpretation (N) = Universal_Integer then
if Is_Fixed_Point_Type (T) then
Resolve (N, Universal_Integer);
else
Resolve (N, Standard_Integer);
end if;
elsif Universal_Interpretation (N) = Universal_Real
and then (T = Base_Type (Standard_Integer)
or else T = Universal_Integer
or else T = Universal_Real)
then
Resolve (N, B_Typ);
elsif Etype (N) = Base_Type (Standard_Integer)
and then T = Universal_Real
and then Is_Overloaded (N)
then
Resolve (N, Universal_Integer);
elsif Etype (N) = T
and then B_Typ /= Universal_Fixed
then
Resolve (N, B_Typ);
elsif Etype (N) = Any_Fixed then
Resolve (N, B_Typ);
elsif Is_Fixed_Point_Type (T)
and then B_Typ = Universal_Fixed
and then Is_Overloaded (N)
then
Resolve (N, Any_Fixed);
elsif Is_Fixed_Point_Type (B_Typ)
and then (T = Universal_Real
or else Is_Fixed_Point_Type (T))
and then Is_Overloaded (N)
then
Get_First_Interp (N, Index, It);
while Present (It.Typ) loop
if Base_Type (It.Typ) = Base_Type (Standard_Integer) then
if Analyzed (N) then
Error_Msg_N ("ambiguous operand in fixed operation", N);
else
Resolve (N, Standard_Integer);
end if;
elsif Is_Fixed_Point_Type (It.Typ) then
if Analyzed (N) then
Error_Msg_N ("ambiguous operand in fixed operation", N);
else
Resolve (N, It.Typ);
end if;
end if;
Get_Next_Interp (Index, It);
end loop;
if N = L then
Set_Analyzed (R, False);
Resolve (R, B_Typ);
else
Set_Analyzed (L, False);
Resolve (L, B_Typ);
end if;
else
Resolve (N, Etype (N));
end if;
end Set_Mixed_Mode_Operand;
procedure Set_Operand_Type (N : Node_Id) is
begin
if Etype (N) = Universal_Integer
or else Etype (N) = Universal_Real
then
Set_Etype (N, T);
end if;
end Set_Operand_Type;
function Universal_Interpretation (N : Node_Id) return Entity_Id is
Index : Interp_Index;
It : Interp;
begin
if not Is_Overloaded (N) then
if Etype (N) = Universal_Integer
or else Etype (N) = Universal_Real
then
return Etype (N);
else
return Empty;
end if;
else
Get_First_Interp (N, Index, It);
while Present (It.Typ) loop
if It.Typ = Universal_Integer
or else It.Typ = Universal_Real
then
return It.Typ;
end if;
Get_Next_Interp (Index, It);
end loop;
return Empty;
end if;
end Universal_Interpretation;
begin
if Comes_From_Source (N)
and then Ekind (Entity (N)) = E_Function
and then Is_Imported (Entity (N))
and then Present (First_Rep_Item (Entity (N)))
then
Resolve_Intrinsic_Operator (N, Typ);
return;
elsif (B_Typ = Universal_Integer
or else B_Typ = Universal_Real)
and then Present (Universal_Interpretation (L))
and then Present (Universal_Interpretation (R))
then
Resolve (L, Universal_Interpretation (L));
Resolve (R, Universal_Interpretation (R));
Set_Etype (N, B_Typ);
elsif (B_Typ = Universal_Real
or else Etype (N) = Universal_Fixed
or else (Etype (N) = Any_Fixed
and then Is_Fixed_Point_Type (B_Typ))
or else (Is_Fixed_Point_Type (B_Typ)
and then (Is_Integer_Or_Universal (L)
or else
Is_Integer_Or_Universal (R))))
and then (Nkind (N) = N_Op_Multiply or else
Nkind (N) = N_Op_Divide)
then
if TL = Universal_Integer or else TR = Universal_Integer then
Check_For_Visible_Operator (N, B_Typ);
end if;
if Is_Fixed_Point_Type (B_Typ)
and then (Base_Type (TL) = Base_Type (Standard_Integer)
or else TL = Universal_Integer)
then
Resolve (R, B_Typ);
Resolve (L, TL);
elsif Is_Fixed_Point_Type (B_Typ)
and then (Base_Type (TR) = Base_Type (Standard_Integer)
or else TR = Universal_Integer)
then
Resolve (L, B_Typ);
Resolve (R, TR);
else
Set_Mixed_Mode_Operand (L, TR);
Set_Mixed_Mode_Operand (R, TL);
end if;
if Etype (N) = Universal_Fixed
or else Etype (N) = Any_Fixed
then
if B_Typ = Universal_Fixed
and then Nkind (Parent (N)) /= N_Type_Conversion
and then Nkind (Parent (N)) /= N_Unchecked_Type_Conversion
then
Error_Msg_N
("type cannot be determined from context!", N);
Error_Msg_N
("\explicit conversion to result type required", N);
Set_Etype (L, Any_Type);
Set_Etype (R, Any_Type);
else
if Ada_83
and then Etype (N) = Universal_Fixed
and then Nkind (Parent (N)) /= N_Type_Conversion
and then Nkind (Parent (N)) /= N_Unchecked_Type_Conversion
then
Error_Msg_N
("(Ada 83) fixed-point operation " &
"needs explicit conversion",
N);
end if;
Set_Etype (N, B_Typ);
end if;
elsif Is_Fixed_Point_Type (B_Typ)
and then (Is_Integer_Or_Universal (L)
or else Nkind (L) = N_Real_Literal
or else Nkind (R) = N_Real_Literal
or else
Is_Integer_Or_Universal (R))
then
Set_Etype (N, B_Typ);
elsif Etype (N) = Any_Fixed then
Set_Etype (N, B_Typ);
end if;
else
if (TL = Universal_Integer or else TL = Universal_Real)
and then (TR = Universal_Integer or else TR = Universal_Real)
then
Check_For_Visible_Operator (N, B_Typ);
end if;
if B_Typ = Universal_Fixed
and then Etype (L) = Universal_Fixed
then
T := Unique_Fixed_Point_Type (N);
if T = Any_Type then
Set_Etype (N, T);
return;
else
Resolve (L, T);
Resolve (R, T);
end if;
else
Resolve (L, B_Typ);
Resolve (R, B_Typ);
end if;
T := Intersect_Types (L, R);
Set_Etype (N, Base_Type (T));
Set_Operand_Type (L);
Set_Operand_Type (R);
end if;
Generate_Operator_Reference (N);
Eval_Arithmetic_Op (N);
if Nkind (N) in N_Op then
if not Overflow_Checks_Suppressed (Etype (N)) then
Set_Do_Overflow_Check (N);
end if;
if (Nkind (N) = N_Op_Divide
or else Nkind (N) = N_Op_Rem
or else Nkind (N) = N_Op_Mod)
and then not Division_Checks_Suppressed (Etype (N))
then
Set_Do_Division_Check (N);
end if;
end if;
Check_Unset_Reference (L);
Check_Unset_Reference (R);
end Resolve_Arithmetic_Op;
procedure Resolve_Call (N : Node_Id; Typ : Entity_Id) is
Loc : constant Source_Ptr := Sloc (N);
Subp : constant Node_Id := Name (N);
Nam : Entity_Id;
I : Interp_Index;
It : Interp;
Norm_OK : Boolean;
Scop : Entity_Id;
begin
if Ekind (Etype (Subp)) = E_Subprogram_Type then
if not Is_Overloaded (Subp) then
Nam := Etype (Subp);
else
Get_First_Interp (Subp, I, It);
Nam := Empty;
while Present (It.Typ) loop
if Covers (Typ, Etype (It.Typ)) then
Nam := It.Typ;
exit;
end if;
Get_Next_Interp (I, It);
end loop;
if No (Nam) then
raise Program_Error;
end if;
end if;
if not Is_Entity_Name (Subp) then
Resolve (Subp, Nam);
end if;
elsif Nkind (Subp) = N_Selected_Component
or else Nkind (Subp) = N_Indexed_Component
or else (Is_Entity_Name (Subp)
and then Ekind (Entity (Subp)) = E_Entry)
then
Resolve_Entry_Call (N, Typ);
Check_Elab_Call (N);
return;
elsif not (Is_Type (Entity (Subp))) then
Nam := Entity (Subp);
Set_Entity_With_Style_Check (Subp, Nam);
Generate_Reference (Nam, Subp);
else
pragma Assert (Is_Overloaded (Subp));
Nam := Empty;
Get_First_Interp (Subp, I, It);
while Present (It.Typ) loop
if Covers (Typ, It.Typ) then
Nam := It.Nam;
Set_Entity_With_Style_Check (Subp, Nam);
Generate_Reference (Nam, Subp);
exit;
end if;
Get_Next_Interp (I, It);
end loop;
end if;
if Is_RTE (Nam, RE_Current_Task) then
declare
P : Node_Id;
begin
P := N;
loop
P := Parent (P);
exit when No (P);
if Nkind (P) = N_Entry_Body then
Error_Msg_NE
("& should not be used in entry body ('R'M C.7(17))",
N, Nam);
exit;
end if;
end loop;
end;
end if;
if Nkind (Parent (N)) = N_Entry_Call_Alternative
and then Nkind (N) /= N_Entry_Call_Statement
and then Entry_Call_Statement (Parent (N)) = N
then
Error_Msg_N ("entry call required in select statement", N);
end if;
if Is_Entity_Name (Subp) and then not In_Default_Expression then
Freeze_Expression (Subp);
end if;
if Is_Predefined_Op (Nam) then
if Etype (N) /= Universal_Fixed then
Set_Etype (N, Typ);
end if;
elsif Needs_No_Actuals (Nam)
and then
((Is_Array_Type (Etype (Nam))
and then Covers (Typ, Component_Type (Etype (Nam))))
or else (Is_Access_Type (Etype (Nam))
and then Is_Array_Type (Designated_Type (Etype (Nam)))
and then
Covers (Typ,
Component_Type (Designated_Type (Etype (Nam))))))
then
declare
Index_Node : Node_Id;
begin
if Component_Type (Etype (Nam)) /= Any_Type then
Index_Node :=
Make_Indexed_Component (Loc,
Prefix =>
Make_Function_Call (Loc,
Name => New_Occurrence_Of (Nam, Loc)),
Expressions => Parameter_Associations (N));
Replace (N, Index_Node);
Set_Etype (Prefix (N), Etype (Nam));
Set_Etype (N, Typ);
Resolve_Indexed_Component (N, Typ);
Check_Elab_Call (Prefix (N));
end if;
return;
end;
else
Set_Etype (N, Etype (Nam));
end if;
if Is_Overloaded (Subp) then
Normalize_Actuals (N, Nam, False, Norm_OK);
pragma Assert (Norm_OK);
end if;
Set_Is_Overloaded (Subp, False);
Set_Is_Overloaded (N, False);
Scop := Current_Scope;
if Nam = Scop
and then not Restrictions (No_Recursion)
and then Check_Infinite_Recursion (N)
then
null;
else
while Scop /= Standard_Standard loop
if Nam = Scop then
Check_Restriction (No_Recursion, N);
if No (First_Formal (Nam))
and then Etype (Nam) = Standard_Void_Type
and then not Error_Posted (N)
and then Nkind (Parent (N)) /= N_Exception_Handler
then
Set_Has_Recursive_Call (Nam);
Error_Msg_N ("possible infinite recursion?", N);
Error_Msg_N ("Storage_Error may be raised at run time?", N);
end if;
exit;
end if;
Scop := Scope (Scop);
end loop;
end if;
if Is_Predefined_Op (Nam) or else Ekind (Nam) = E_Operator then
Make_Call_Into_Operator (N, Typ, Entity (Name (N)));
return;
elsif Present (Alias (Nam))
and then Is_Predefined_Op (Alias (Nam))
then
Resolve_Actuals (N, Nam);
Make_Call_Into_Operator (N, Typ, Alias (Nam));
return;
end if;
if Expander_Active
and then Is_Type (Etype (Nam))
and then Requires_Transient_Scope (Etype (Nam))
and then Ekind (Nam) /= E_Enumeration_Literal
and then not Within_Init_Proc
and then not Is_Intrinsic_Subprogram (Nam)
then
Establish_Transient_Scope
(N, Sec_Stack => not Functions_Return_By_DSP_On_Target);
elsif Chars (Nam) = Name_uInit_Proc
and then not Within_Init_Proc
then
Check_Initialization_Call (N, Nam);
end if;
if Is_Protected_Type (Scope (Nam))
and then In_Open_Scopes (Scope (Nam))
and then not Has_Completion (Scope (Nam))
then
Error_Msg_NE
("& cannot be called before end of protected definition", N, Nam);
end if;
if Present (First_Formal (Nam)) then
Resolve_Actuals (N, Nam);
elsif Ekind (Nam) = E_Enumeration_Literal then
Copy_Node (Subp, N);
Resolve_Entity_Name (N, Typ);
return;
end if;
if Is_Overloadable (Nam)
and then Is_Dispatching_Operation (Nam)
then
Check_Dispatching_Call (N);
elsif Is_Abstract (Nam)
and then not In_Instance
then
Error_Msg_NE ("cannot call abstract subprogram &!", N, Nam);
end if;
if Is_Intrinsic_Subprogram (Nam) then
Check_Intrinsic_Call (N);
end if;
Check_Elab_Call (N);
end Resolve_Call;
procedure Resolve_Character_Literal (N : Node_Id; Typ : Entity_Id) is
B_Typ : constant Entity_Id := Base_Type (Typ);
C : Entity_Id;
begin
Set_Etype (N, B_Typ);
Eval_Character_Literal (N);
if Root_Type (B_Typ) = Standard_Wide_Character then
return;
elsif B_Typ = Any_Character then
return;
elsif Root_Type (B_Typ) = Standard_Character then
if In_Character_Range (Char_Literal_Value (N)) then
return;
end if;
elsif Present (Entity (N)) then
return;
else
C := Current_Entity (N);
while Present (C) loop
if Etype (C) = B_Typ then
Set_Entity_With_Style_Check (N, C);
Generate_Reference (C, N);
return;
end if;
C := Homonym (C);
end loop;
end if;
Error_Msg_NE
("character not defined for }", N, First_Subtype (B_Typ));
end Resolve_Character_Literal;
procedure Resolve_Comparison_Op (N : Node_Id; Typ : Entity_Id) is
L : constant Node_Id := Left_Opnd (N);
R : constant Node_Id := Right_Opnd (N);
T : Entity_Id;
begin
if Scope (Entity (N)) /= Standard_Standard then
T := Etype (First_Entity (Entity (N)));
else
T := Find_Unique_Type (L, R);
if T = Any_Fixed then
T := Unique_Fixed_Point_Type (L);
end if;
end if;
Set_Etype (N, Typ);
Generate_Reference (T, N, ' ');
if T /= Any_Type then
if T = Any_String
or else T = Any_Composite
or else T = Any_Character
then
if T = Any_Character then
Ambiguous_Character (L);
else
Error_Msg_N ("ambiguous operands for comparison", N);
end if;
Set_Etype (N, Any_Type);
return;
else
if Comes_From_Source (N)
and then Has_Unchecked_Union (T)
then
Error_Msg_N
("cannot compare Unchecked_Union values", N);
end if;
Resolve (L, T);
Resolve (R, T);
Check_Unset_Reference (L);
Check_Unset_Reference (R);
Generate_Operator_Reference (N);
Eval_Relational_Op (N);
end if;
end if;
end Resolve_Comparison_Op;
procedure Resolve_Conditional_Expression (N : Node_Id; Typ : Entity_Id) is
Condition : constant Node_Id := First (Expressions (N));
Then_Expr : constant Node_Id := Next (Condition);
Else_Expr : constant Node_Id := Next (Then_Expr);
begin
Resolve (Condition, Standard_Boolean);
Resolve (Then_Expr, Typ);
Resolve (Else_Expr, Typ);
Set_Etype (N, Typ);
Eval_Conditional_Expression (N);
end Resolve_Conditional_Expression;
procedure Resolve_Discrete_Subtype_Indication
(N : Node_Id;
Typ : Entity_Id)
is
R : Node_Id;
S : Entity_Id;
begin
Analyze (Subtype_Mark (N));
S := Entity (Subtype_Mark (N));
if Nkind (Constraint (N)) /= N_Range_Constraint then
Error_Msg_N ("expect range constraint for discrete type", N);
Set_Etype (N, Any_Type);
else
R := Range_Expression (Constraint (N));
if R = Error then
return;
end if;
Analyze (R);
if Base_Type (S) /= Base_Type (Typ) then
Error_Msg_NE
("expect subtype of }", N, First_Subtype (Typ));
Set_Etype (N, Typ);
Rewrite (Low_Bound (R),
Make_Attribute_Reference (Sloc (Low_Bound (R)),
Prefix => New_Occurrence_Of (Typ, Sloc (R)),
Attribute_Name => Name_First));
Rewrite (High_Bound (R),
Make_Attribute_Reference (Sloc (High_Bound (R)),
Prefix => New_Occurrence_Of (Typ, Sloc (R)),
Attribute_Name => Name_First));
else
Resolve (R, Typ);
Set_Etype (N, Etype (R));
Apply_Range_Check (R, S);
declare
L : Node_Id := Low_Bound (R);
H : Node_Id := High_Bound (R);
begin
if Nkind (L) = N_Raise_Constraint_Error then
Remove_Side_Effects (L);
end if;
if Nkind (H) = N_Raise_Constraint_Error then
Remove_Side_Effects (H);
end if;
end;
Check_Unset_Reference (Low_Bound (R));
Check_Unset_Reference (High_Bound (R));
end if;
end if;
end Resolve_Discrete_Subtype_Indication;
procedure Resolve_Entity_Name (N : Node_Id; Typ : Entity_Id) is
E : constant Entity_Id := Entity (N);
begin
if No (E) and then Total_Errors_Detected /= 0 then
Set_Etype (N, Any_Type);
return;
end if;
if Ekind (E) = E_Named_Integer then
Set_Etype (N, Typ);
Eval_Named_Integer (N);
elsif Ekind (E) = E_Named_Real then
Set_Etype (N, Typ);
Eval_Named_Real (N);
elsif Is_Type (E) then
if Is_Concurrent_Type (E)
and then In_Open_Scopes (E)
then
null;
else
Error_Msg_N
("Invalid use of subtype mark in expression or call", N);
end if;
elsif Ekind (E) = E_Discriminant
and then Scope (E) = Current_Scope
and then not Has_Completion (Current_Scope)
then
Check_Discriminant_Use (N);
elsif Ekind (E) = E_Generic_Function then
Error_Msg_N ("illegal use of generic function", N);
elsif Ekind (E) = E_Out_Parameter
and then Ada_83
and then (Nkind (Parent (N)) in N_Op
or else (Nkind (Parent (N)) = N_Assignment_Statement
and then N = Expression (Parent (N)))
or else Nkind (Parent (N)) = N_Explicit_Dereference)
then
Error_Msg_N ("(Ada 83) illegal reading of out parameter", N);
else
if Ekind (E) = E_Constant
and then Comes_From_Source (E)
and then No (Constant_Value (E))
and then Is_Frozen (Etype (E))
and then not In_Default_Expression
and then not Is_Imported (E)
then
if No_Initialization (Parent (E))
or else (Present (Full_View (E))
and then No_Initialization (Parent (Full_View (E))))
then
null;
else
Error_Msg_N (
"deferred constant is frozen before completion", N);
end if;
end if;
Eval_Entity_Name (N);
end if;
end Resolve_Entity_Name;
procedure Resolve_Entry (Entry_Name : Node_Id) is
Loc : constant Source_Ptr := Sloc (Entry_Name);
Nam : Entity_Id;
New_N : Node_Id;
S : Entity_Id;
Tsk : Entity_Id;
E_Name : Node_Id;
Index : Node_Id;
function Actual_Index_Type (E : Entity_Id) return Entity_Id;
function Actual_Index_Type (E : Entity_Id) return Entity_Id is
Typ : Entity_Id := Entry_Index_Type (E);
Tsk : Entity_Id := Scope (E);
Lo : Node_Id := Type_Low_Bound (Typ);
Hi : Node_Id := Type_High_Bound (Typ);
New_T : Entity_Id;
function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id;
function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id is
Typ : Entity_Id := Etype (Bound);
Ref : Node_Id;
begin
Remove_Side_Effects (Bound);
if not Is_Entity_Name (Bound)
or else Ekind (Entity (Bound)) /= E_Discriminant
then
return Bound;
elsif Is_Protected_Type (Tsk)
and then In_Open_Scopes (Tsk)
and then Nkind (Parent (Entry_Name)) = N_Requeue_Statement
then
return New_Occurrence_Of (Discriminal (Entity (Bound)), Loc);
else
Ref :=
Make_Selected_Component (Loc,
Prefix => New_Copy_Tree (Prefix (Prefix (Entry_Name))),
Selector_Name => New_Occurrence_Of (Entity (Bound), Loc));
Analyze (Ref);
Resolve (Ref, Typ);
return Ref;
end if;
end Actual_Discriminant_Ref;
begin
if not Has_Discriminants (Tsk)
or else (not Is_Entity_Name (Lo)
and then not Is_Entity_Name (Hi))
then
return Entry_Index_Type (E);
else
New_T := Create_Itype (Ekind (Typ), Parent (Entry_Name));
Set_Etype (New_T, Base_Type (Typ));
Set_Size_Info (New_T, Typ);
Set_RM_Size (New_T, RM_Size (Typ));
Set_Scalar_Range (New_T,
Make_Range (Sloc (Entry_Name),
Low_Bound => Actual_Discriminant_Ref (Lo),
High_Bound => Actual_Discriminant_Ref (Hi)));
return New_T;
end if;
end Actual_Index_Type;
begin
if Nkind (Entry_Name) = N_Indexed_Component then
E_Name := Prefix (Entry_Name);
else
E_Name := Entry_Name;
end if;
if Is_Entity_Name (E_Name) then
S := Scope (Entity (E_Name));
for J in reverse 0 .. Scope_Stack.Last loop
if Is_Task_Type (Scope_Stack.Table (J).Entity)
and then not Comes_From_Source (S)
then
Tsk := Next_Entity (S);
while Etype (Tsk) /= S loop
Next_Entity (Tsk);
end loop;
S := Tsk;
exit;
elsif S = Scope_Stack.Table (J).Entity then
exit;
end if;
end loop;
New_N :=
Make_Selected_Component (Loc,
Prefix => New_Occurrence_Of (S, Loc),
Selector_Name =>
New_Occurrence_Of (Entity (E_Name), Loc));
Rewrite (E_Name, New_N);
Analyze (E_Name);
elsif Nkind (Entry_Name) = N_Selected_Component
and then Is_Overloaded (Prefix (Entry_Name))
then
declare
Pref : Node_Id := Prefix (Entry_Name);
I : Interp_Index;
It : Interp;
Ent : Entity_Id := Entity (Selector_Name (Entry_Name));
begin
Get_First_Interp (Pref, I, It);
while Present (It.Typ) loop
if Scope (Ent) = It.Typ then
Set_Etype (Pref, It.Typ);
exit;
end if;
Get_Next_Interp (I, It);
end loop;
end;
end if;
if Nkind (Entry_Name) = N_Selected_Component then
Resolve (Prefix (Entry_Name), Etype (Prefix (Entry_Name)));
else pragma Assert (Nkind (Entry_Name) = N_Indexed_Component);
Nam := Entity (Selector_Name (Prefix (Entry_Name)));
Resolve (Prefix (Prefix (Entry_Name)),
Etype (Prefix (Prefix (Entry_Name))));
Index := First (Expressions (Entry_Name));
Resolve (Index, Entry_Index_Type (Nam));
if Nkind (Index) = N_Parameter_Association then
Error_Msg_N ("expect expression for entry index", Index);
else
Apply_Range_Check (Index, Actual_Index_Type (Nam));
end if;
end if;
end Resolve_Entry;
procedure Resolve_Entry_Call (N : Node_Id; Typ : Entity_Id) is
Entry_Name : constant Node_Id := Name (N);
Loc : constant Source_Ptr := Sloc (Entry_Name);
Actuals : List_Id;
First_Named : Node_Id;
Nam : Entity_Id;
Norm_OK : Boolean;
Obj : Node_Id;
Was_Over : Boolean;
begin
if Nkind (Entry_Name) = N_Selected_Component
and then Is_Overloaded (Selector_Name (Entry_Name))
and then Typ /= Standard_Void_Type
then
declare
I : Interp_Index;
It : Interp;
begin
Get_First_Interp (Selector_Name (Entry_Name), I, It);
while Present (It.Typ) loop
if Covers (Typ, It.Typ) then
Set_Entity (Selector_Name (Entry_Name), It.Nam);
Set_Etype (Entry_Name, It.Typ);
Generate_Reference (It.Typ, N, ' ');
end if;
Get_Next_Interp (I, It);
end loop;
end;
end if;
Resolve_Entry (Entry_Name);
if Nkind (Entry_Name) = N_Selected_Component then
Nam := Entity (Selector_Name (Entry_Name));
Obj := Prefix (Entry_Name);
Was_Over := Is_Overloaded (Selector_Name (Entry_Name));
else pragma Assert (Nkind (Entry_Name) = N_Indexed_Component);
Nam := Entity (Selector_Name (Prefix (Entry_Name)));
Obj := Prefix (Prefix (Entry_Name));
Was_Over := Is_Overloaded (Selector_Name (Prefix (Entry_Name)));
end if;
if Ekind (Nam) = E_Function
and then Needs_No_Actuals (Nam)
and then Present (Parameter_Associations (N))
and then
((Is_Array_Type (Etype (Nam))
and then Covers (Typ, Component_Type (Etype (Nam))))
or else (Is_Access_Type (Etype (Nam))
and then Is_Array_Type (Designated_Type (Etype (Nam)))
and then Covers (Typ,
Component_Type (Designated_Type (Etype (Nam))))))
then
declare
Index_Node : Node_Id;
begin
Index_Node :=
Make_Indexed_Component (Loc,
Prefix =>
Make_Function_Call (Loc,
Name => Relocate_Node (Entry_Name)),
Expressions => Parameter_Associations (N));
Replace (N, Index_Node);
Set_Etype (Prefix (N), Etype (Nam));
Set_Etype (N, Typ);
Resolve_Indexed_Component (N, Typ);
return;
end;
end if;
if Was_Over then
Normalize_Actuals (N, Nam, False, Norm_OK);
pragma Assert (Norm_OK);
end if;
Resolve_Actuals (N, Nam);
Generate_Reference (Nam, Entry_Name);
if Ekind (Nam) = E_Entry
or else Ekind (Nam) = E_Entry_Family
then
Check_Potentially_Blocking_Operation (N);
end if;
if Ekind (Nam) = E_Procedure then
if Nkind (Parent (N)) = N_Entry_Call_Alternative
and then N = Entry_Call_Statement (Parent (N))
then
Error_Msg_N ("entry call required in select statement", N);
elsif Nkind (Parent (N)) = N_Triggering_Alternative
and then N = Triggering_Statement (Parent (N))
then
Error_Msg_N ("triggering statement cannot be procedure call", N);
elsif Ekind (Scope (Nam)) = E_Task_Type
and then not In_Open_Scopes (Scope (Nam))
then
Error_Msg_N ("Task has no entry with this name", Entry_Name);
end if;
end if;
if Ekind (Nam) /= E_Function then
if Is_Protected_Type (Scope (Nam))
and then not Is_Variable (Obj)
and then (not Is_Entity_Name (Obj)
or else not Is_Type (Entity (Obj)))
then
Error_Msg_N
("prefix of protected procedure or entry call must be variable",
Entry_Name);
end if;
Actuals := Parameter_Associations (N);
First_Named := First_Named_Actual (N);
Rewrite (N,
Make_Entry_Call_Statement (Loc,
Name => Entry_Name,
Parameter_Associations => Actuals));
Set_First_Named_Actual (N, First_Named);
Set_Analyzed (N, True);
elsif Expander_Active
and then Requires_Transient_Scope (Etype (Nam))
then
Establish_Transient_Scope (N,
Sec_Stack => not Functions_Return_By_DSP_On_Target);
end if;
end Resolve_Entry_Call;
procedure Resolve_Equality_Op (N : Node_Id; Typ : Entity_Id) is
L : constant Node_Id := Left_Opnd (N);
R : constant Node_Id := Right_Opnd (N);
T : Entity_Id := Find_Unique_Type (L, R);
function Find_Unique_Access_Type return Entity_Id;
function Find_Unique_Access_Type return Entity_Id is
Acc : Entity_Id;
E : Entity_Id;
S : Entity_Id := Current_Scope;
begin
if Ekind (Etype (R)) = E_Allocator_Type then
Acc := Designated_Type (Etype (R));
elsif Ekind (Etype (L)) = E_Allocator_Type then
Acc := Designated_Type (Etype (L));
else
return Empty;
end if;
while S /= Standard_Standard loop
E := First_Entity (S);
while Present (E) loop
if Is_Type (E)
and then Is_Access_Type (E)
and then Ekind (E) /= E_Allocator_Type
and then Designated_Type (E) = Base_Type (Acc)
then
return E;
end if;
Next_Entity (E);
end loop;
S := Scope (S);
end loop;
return Empty;
end Find_Unique_Access_Type;
begin
Set_Etype (N, Base_Type (Typ));
Generate_Reference (T, N, ' ');
if T = Any_Fixed then
T := Unique_Fixed_Point_Type (L);
end if;
if T /= Any_Type then
if T = Any_String
or else T = Any_Composite
or else T = Any_Character
then
if T = Any_Character then
Ambiguous_Character (L);
else
Error_Msg_N ("ambiguous operands for equality", N);
end if;
Set_Etype (N, Any_Type);
return;
elsif T = Any_Access
or else Ekind (T) = E_Allocator_Type
then
T := Find_Unique_Access_Type;
if No (T) then
Error_Msg_N ("ambiguous operands for equality", N);
Set_Etype (N, Any_Type);
return;
end if;
end if;
if Comes_From_Source (N)
and then Has_Unchecked_Union (T)
then
Error_Msg_N
("cannot compare Unchecked_Union values", N);
end if;
Resolve (L, T);
Resolve (R, T);
Check_Unset_Reference (L);
Check_Unset_Reference (R);
Generate_Operator_Reference (N);
if Nkind (N) = N_Op_Eq
or else Comes_From_Source (Entity (N))
or else Ekind (Entity (N)) = E_Operator
or else Is_Intrinsic_Subprogram
(Corresponding_Equality (Entity (N)))
then
Eval_Relational_Op (N);
elsif Nkind (N) = N_Op_Ne
and then Is_Abstract (Entity (N))
then
Error_Msg_NE ("cannot call abstract subprogram &!", N, Entity (N));
end if;
end if;
end Resolve_Equality_Op;
procedure Resolve_Explicit_Dereference (N : Node_Id; Typ : Entity_Id) is
P : constant Node_Id := Prefix (N);
I : Interp_Index;
It : Interp;
begin
Check_Fully_Declared (Typ, N);
if Is_Overloaded (P) then
Get_First_Interp (P, I, It);
while Present (It.Typ) loop
exit when Is_Access_Type (It.Typ)
and then Covers (Typ, Designated_Type (It.Typ));
Get_Next_Interp (I, It);
end loop;
Resolve (P, It.Typ);
Set_Etype (N, Designated_Type (It.Typ));
else
Resolve (P, Etype (P));
end if;
if Is_Access_Type (Etype (P)) then
Apply_Access_Check (N);
end if;
if Is_Array_Type (Etype (N))
and then Is_Packed (Etype (N))
and then not Is_Constrained (Etype (N))
and then Nkind (Parent (N)) /= N_Attribute_Reference
and then Comes_From_Source (N)
then
Set_Etype (N, Get_Actual_Subtype (N));
end if;
end Resolve_Explicit_Dereference;
procedure Resolve_Indexed_Component (N : Node_Id; Typ : Entity_Id) is
Name : constant Node_Id := Prefix (N);
Expr : Node_Id;
Array_Type : Entity_Id := Empty; Index : Node_Id;
begin
if Is_Overloaded (Name) then
declare
I : Interp_Index;
It : Interp;
I1 : Interp_Index := 0;
P : constant Node_Id := Prefix (N);
Found : Boolean := False;
begin
Get_First_Interp (P, I, It);
while Present (It.Typ) loop
if (Is_Array_Type (It.Typ)
and then Covers (Typ, Component_Type (It.Typ)))
or else (Is_Access_Type (It.Typ)
and then Is_Array_Type (Designated_Type (It.Typ))
and then Covers
(Typ, Component_Type (Designated_Type (It.Typ))))
then
if Found then
It := Disambiguate (P, I1, I, Any_Type);
if It = No_Interp then
Error_Msg_N ("ambiguous prefix for indexing", N);
Set_Etype (N, Typ);
return;
else
Found := True;
Array_Type := It.Typ;
I1 := I;
end if;
else
Found := True;
Array_Type := It.Typ;
I1 := I;
end if;
end if;
Get_Next_Interp (I, It);
end loop;
end;
else
Array_Type := Etype (Name);
end if;
Resolve (Name, Array_Type);
Array_Type := Get_Actual_Subtype_If_Available (Name);
if Is_Access_Type (Array_Type) then
Array_Type := Designated_Type (Array_Type);
end if;
Set_Etype (N, Component_Type (Array_Type));
Index := First_Index (Array_Type);
Expr := First (Expressions (N));
if Ekind (Array_Type) = E_String_Literal_Subtype then
Resolve (Expr, Standard_Positive);
else
while Present (Index) and Present (Expr) loop
Resolve (Expr, Etype (Index));
Check_Unset_Reference (Expr);
if Is_Scalar_Type (Etype (Expr)) then
Apply_Scalar_Range_Check (Expr, Etype (Index));
else
Apply_Range_Check (Expr, Get_Actual_Subtype (Index));
end if;
Next_Index (Index);
Next (Expr);
end loop;
end if;
Eval_Indexed_Component (N);
end Resolve_Indexed_Component;
procedure Resolve_Integer_Literal (N : Node_Id; Typ : Entity_Id) is
begin
Set_Etype (N, Typ);
Eval_Integer_Literal (N);
end Resolve_Integer_Literal;
procedure Resolve_Intrinsic_Operator (N : Node_Id; Typ : Entity_Id) is
Op : Entity_Id;
Arg1 : Node_Id := Left_Opnd (N);
Arg2 : Node_Id := Right_Opnd (N);
begin
Op := Entity (N);
while Scope (Op) /= Standard_Standard loop
Op := Homonym (Op);
pragma Assert (Present (Op));
end loop;
Set_Entity (N, Op);
if Typ /= Etype (Arg1) or else Typ = Etype (Arg2) then
Rewrite (Left_Opnd (N), Convert_To (Typ, Arg1));
Rewrite (Right_Opnd (N), Convert_To (Typ, Arg2));
Analyze (Left_Opnd (N));
Analyze (Right_Opnd (N));
end if;
Resolve_Arithmetic_Op (N, Typ);
end Resolve_Intrinsic_Operator;
procedure Resolve_Logical_Op (N : Node_Id; Typ : Entity_Id) is
B_Typ : Entity_Id;
begin
if Is_Array_Type (Typ) then
B_Typ := Typ;
else
B_Typ := Base_Type (Typ);
end if;
if not Valid_Boolean_Arg (Typ) then
Error_Msg_N ("invalid context for logical operation", N);
Set_Etype (N, Any_Type);
return;
elsif Typ = Any_Modular then
Error_Msg_N
("no modular type available in this context", N);
Set_Etype (N, Any_Type);
return;
elsif Is_Modular_Integer_Type (Typ)
and then Etype (Left_Opnd (N)) = Universal_Integer
and then Etype (Right_Opnd (N)) = Universal_Integer
then
Check_For_Visible_Operator (N, B_Typ);
end if;
Resolve (Left_Opnd (N), B_Typ);
Resolve (Right_Opnd (N), B_Typ);
Check_Unset_Reference (Left_Opnd (N));
Check_Unset_Reference (Right_Opnd (N));
Set_Etype (N, B_Typ);
Generate_Operator_Reference (N);
Eval_Logical_Op (N);
end Resolve_Logical_Op;
procedure Resolve_Membership_Op (N : Node_Id; Typ : Entity_Id) is
pragma Warnings (Off, Typ);
L : constant Node_Id := Left_Opnd (N);
R : constant Node_Id := Right_Opnd (N);
T : Entity_Id;
begin
if L = Error or else R = Error then
return;
end if;
if not Is_Overloaded (R)
and then
(Etype (R) = Universal_Integer or else
Etype (R) = Universal_Real)
and then Is_Overloaded (L)
then
T := Etype (R);
else
T := Intersect_Types (L, R);
end if;
Resolve (L, T);
Check_Unset_Reference (L);
if Nkind (R) = N_Range
and then not Is_Scalar_Type (T)
then
Error_Msg_N ("scalar type required for range", R);
end if;
if Is_Entity_Name (R) then
Freeze_Expression (R);
else
Resolve (R, T);
Check_Unset_Reference (R);
end if;
Eval_Membership_Op (N);
end Resolve_Membership_Op;
procedure Resolve_Null (N : Node_Id; Typ : Entity_Id) is
begin
if not Debug_Flag_J
and then Ekind (Typ) = E_Anonymous_Access_Type
and then Comes_From_Source (N)
then
if Nkind (Parent (N)) = N_Procedure_Call_Statement
or else
Nkind (Parent (N)) = N_Function_Call
then
Error_Msg_N
("null is not allowed as argument for an access parameter", N);
else
Error_Msg_N
("null cannot be of an anonymous access type", N);
end if;
end if;
if (Ekind (Typ) = E_Record_Type
or else Is_Remote_Access_To_Subprogram_Type (Typ))
and then Remote_AST_Null_Value (N, Typ)
then
return;
end if;
Set_Etype (N, Typ);
end Resolve_Null;
procedure Resolve_Op_Concat (N : Node_Id; Typ : Entity_Id) is
Btyp : constant Entity_Id := Base_Type (Typ);
Op1 : constant Node_Id := Left_Opnd (N);
Op2 : constant Node_Id := Right_Opnd (N);
procedure Resolve_Concatenation_Arg (Arg : Node_Id; Is_Comp : Boolean);
procedure Resolve_Concatenation_Arg (Arg : Node_Id; Is_Comp : Boolean) is
begin
if In_Instance then
if Is_Comp
or else (not Is_Overloaded (Arg)
and then Etype (Arg) /= Any_Composite
and then Covers (Component_Type (Typ), Etype (Arg)))
then
Resolve (Arg, Component_Type (Typ));
else
Resolve (Arg, Btyp);
end if;
elsif Has_Compatible_Type (Arg, Component_Type (Typ)) then
if Nkind (Arg) = N_Aggregate
and then Is_Composite_Type (Component_Type (Typ))
then
if Is_Private_Type (Component_Type (Typ)) then
Resolve (Arg, Btyp);
else
Error_Msg_N ("ambiguous aggregate must be qualified", Arg);
Set_Etype (Arg, Any_Type);
end if;
else
if Is_Overloaded (Arg)
and then Has_Compatible_Type (Arg, Typ)
and then Etype (Arg) /= Any_Type
then
Error_Msg_N ("ambiguous operand for concatenation!", Arg);
declare
I : Interp_Index;
It : Interp;
begin
Get_First_Interp (Arg, I, It);
while Present (It.Nam) loop
if Base_Type (Etype (It.Nam)) = Base_Type (Typ)
or else Base_Type (Etype (It.Nam)) =
Base_Type (Component_Type (Typ))
then
Error_Msg_Sloc := Sloc (It.Nam);
Error_Msg_N ("\possible interpretation#", Arg);
end if;
Get_Next_Interp (I, It);
end loop;
end;
end if;
Resolve (Arg, Component_Type (Typ));
if Arg = Left_Opnd (N) then
Set_Is_Component_Left_Opnd (N);
else
Set_Is_Component_Right_Opnd (N);
end if;
end if;
else
Resolve (Arg, Btyp);
end if;
Check_Unset_Reference (Arg);
end Resolve_Concatenation_Arg;
begin
Set_Etype (N, Btyp);
if Is_Limited_Composite (Btyp) then
Error_Msg_N ("concatenation not available for limited array", N);
end if;
if Nkind (Op1) = N_Op_Concat
and then not Is_Array_Type (Component_Type (Typ))
and then Entity (Op1) = Entity (N)
then
Resolve_Op_Concat (Op1, Typ);
else
Resolve_Concatenation_Arg
(Op1, Is_Component_Left_Opnd (N));
end if;
if Nkind (Op2) = N_Op_Concat
and then not Is_Array_Type (Component_Type (Typ))
and then Entity (Op2) = Entity (N)
then
Resolve_Op_Concat (Op2, Typ);
else
Resolve_Concatenation_Arg
(Op2, Is_Component_Right_Opnd (N));
end if;
Generate_Operator_Reference (N);
if Is_String_Type (Typ) then
Eval_Concatenation (N);
end if;
if Nkind (N) /= N_String_Literal
and then Is_Character_Type (Component_Type (Typ))
then
Set_String_Literal_Subtype (Op1, Typ);
Set_String_Literal_Subtype (Op2, Typ);
end if;
end Resolve_Op_Concat;
procedure Resolve_Op_Expon (N : Node_Id; Typ : Entity_Id) is
B_Typ : constant Entity_Id := Base_Type (Typ);
begin
if Is_Fixed_Point_Type (Typ) and then Comes_From_Source (N) then
Error_Msg_N ("exponentiation not available for fixed point", N);
return;
end if;
if Etype (Left_Opnd (N)) = Universal_Integer
or else Etype (Left_Opnd (N)) = Universal_Real
then
Check_For_Visible_Operator (N, B_Typ);
end if;
Resolve (Left_Opnd (N), B_Typ);
Resolve (Right_Opnd (N), Standard_Integer);
Check_Unset_Reference (Left_Opnd (N));
Check_Unset_Reference (Right_Opnd (N));
Set_Etype (N, B_Typ);
Generate_Operator_Reference (N);
Eval_Op_Expon (N);
if Nkind (N) in N_Op then
if not Overflow_Checks_Suppressed (Etype (N)) then
Set_Do_Overflow_Check (N, True);
end if;
end if;
end Resolve_Op_Expon;
procedure Resolve_Op_Not (N : Node_Id; Typ : Entity_Id) is
B_Typ : Entity_Id;
function Parent_Is_Boolean return Boolean;
function Parent_Is_Boolean return Boolean is
begin
if Paren_Count (N) /= 0 then
return False;
else
case Nkind (Parent (N)) is
when N_Op_And |
N_Op_Eq |
N_Op_Ge |
N_Op_Gt |
N_Op_Le |
N_Op_Lt |
N_Op_Ne |
N_Op_Or |
N_Op_Xor |
N_In |
N_Not_In |
N_And_Then |
N_Or_Else =>
return Left_Opnd (Parent (N)) = N;
when others =>
return False;
end case;
end if;
end Parent_Is_Boolean;
begin
if Is_Array_Type (Typ) then
B_Typ := Typ;
else
B_Typ := Base_Type (Typ);
end if;
if not Valid_Boolean_Arg (Typ) then
Error_Msg_N ("invalid operand type for operator&", N);
Set_Etype (N, Any_Type);
return;
elsif (Typ = Universal_Integer
or else Typ = Any_Modular)
then
if Parent_Is_Boolean then
Error_Msg_N
("operand of not must be enclosed in parentheses",
Right_Opnd (N));
else
Error_Msg_N
("no modular type available in this context", N);
end if;
Set_Etype (N, Any_Type);
return;
else
if not Is_Boolean_Type (Typ)
and then Parent_Is_Boolean
then
Error_Msg_N ("?not expression should be parenthesized here", N);
end if;
Resolve (Right_Opnd (N), B_Typ);
Check_Unset_Reference (Right_Opnd (N));
Set_Etype (N, B_Typ);
Generate_Operator_Reference (N);
Eval_Op_Not (N);
end if;
end Resolve_Op_Not;
procedure Resolve_Operator_Symbol (N : Node_Id; Typ : Entity_Id) is
pragma Warnings (Off, N);
pragma Warnings (Off, Typ);
begin
null;
end Resolve_Operator_Symbol;
procedure Resolve_Qualified_Expression (N : Node_Id; Typ : Entity_Id) is
pragma Warnings (Off, Typ);
Target_Typ : constant Entity_Id := Entity (Subtype_Mark (N));
Expr : constant Node_Id := Expression (N);
begin
Resolve (Expr, Target_Typ);
if Is_Class_Wide_Type (Target_Typ)
and then Base_Type (Etype (Expr)) /= Base_Type (Target_Typ)
then
Wrong_Type (Expr, Target_Typ);
end if;
if Is_Composite_Type (Target_Typ)
and then not Is_Constrained (Target_Typ)
then
Set_Etype (N, Etype (Expr));
end if;
Eval_Qualified_Expression (N);
end Resolve_Qualified_Expression;
procedure Resolve_Range (N : Node_Id; Typ : Entity_Id) is
L : constant Node_Id := Low_Bound (N);
H : constant Node_Id := High_Bound (N);
begin
Set_Etype (N, Typ);
Resolve (L, Typ);
Resolve (H, Typ);
Check_Unset_Reference (L);
Check_Unset_Reference (H);
Check_Non_Static_Context (L);
Check_Non_Static_Context (H);
end Resolve_Range;
procedure Resolve_Real_Literal (N : Node_Id; Typ : Entity_Id) is
Actual_Typ : constant Entity_Id := Etype (N);
begin
if Is_Fixed_Point_Type (Typ)
and then Typ /= Universal_Fixed
and then Typ /= Any_Fixed
and then not Is_Generic_Type (Typ)
then
declare
Val : constant Ureal := Realval (N);
Cintr : constant Ureal := Val / Small_Value (Typ);
Cint : constant Uint := UR_Trunc (Cintr);
Den : constant Uint := Norm_Den (Cintr);
Stat : Boolean;
begin
if Den /= 1 then
if Is_Decimal_Fixed_Point_Type (Typ)
and then Actual_Typ = Universal_Real
and then Comes_From_Source (N)
then
Error_Msg_N ("value has extraneous low order digits", N);
end if;
Stat := Is_Static_Expression (N);
Rewrite (N,
Make_Real_Literal (Sloc (N),
Realval => Small_Value (Typ) * Cint));
Set_Is_Static_Expression (N, Stat);
end if;
Set_Corresponding_Integer_Value (N, Cint);
end;
end if;
Set_Etype (N, Typ);
Eval_Real_Literal (N);
end Resolve_Real_Literal;
procedure Resolve_Reference (N : Node_Id; Typ : Entity_Id) is
P : constant Node_Id := Prefix (N);
begin
if Ekind (Etype (N)) = E_Allocator_Type then
Set_Etype (N, Base_Type (Typ));
end if;
Resolve (P, Designated_Type (Etype (N)));
if Is_Entity_Name (P) and then Is_Volatile (Entity (P)) then
Note_Possible_Modification (P);
end if;
end Resolve_Reference;
procedure Resolve_Selected_Component (N : Node_Id; Typ : Entity_Id) is
Comp : Entity_Id;
Comp1 : Entity_Id := Empty; P : constant Node_Id := Prefix (N);
S : constant Node_Id := Selector_Name (N);
T : Entity_Id := Etype (P);
I : Interp_Index;
I1 : Interp_Index := 0; It : Interp;
It1 : Interp;
Found : Boolean;
function Init_Component return Boolean;
function Init_Component return Boolean is
begin
return Inside_Init_Proc
and then Nkind (Prefix (N)) = N_Identifier
and then Chars (Prefix (N)) = Name_uInit
and then Nkind (Parent (Parent (N))) = N_Case_Statement_Alternative;
end Init_Component;
begin
if Is_Overloaded (P) then
Found := False;
Get_First_Interp (P, I, It);
Search : while Present (It.Typ) loop
if Is_Access_Type (It.Typ) then
T := Designated_Type (It.Typ);
else
T := It.Typ;
end if;
if Is_Record_Type (T) then
Comp := First_Entity (T);
while Present (Comp) loop
if Chars (Comp) = Chars (S)
and then Covers (Etype (Comp), Typ)
then
if not Found then
Found := True;
I1 := I;
It1 := It;
Comp1 := Comp;
else
It := Disambiguate (P, I1, I, Any_Type);
if It = No_Interp then
Error_Msg_N
("ambiguous prefix for selected component", N);
Set_Etype (N, Typ);
return;
else
It1 := It;
if Scope (Comp1) /= It1.Typ then
Comp1 := First_Entity (It1.Typ);
while Present (Comp1)
and then Chars (Comp1) /= Chars (S)
loop
Comp1 := Next_Entity (Comp1);
end loop;
end if;
exit Search;
end if;
end if;
end if;
Comp := Next_Entity (Comp);
end loop;
end if;
Get_Next_Interp (I, It);
end loop Search;
Resolve (P, It1.Typ);
Set_Etype (N, Typ);
Set_Entity (S, Comp1);
else
Resolve (P, T);
end if;
if Is_Access_Type (Etype (P)) then
Apply_Access_Check (N);
T := Designated_Type (Etype (P));
else
T := Etype (P);
end if;
if Has_Discriminants (T)
and then Present (Original_Record_Component (Entity (S)))
and then Ekind (Original_Record_Component (Entity (S))) = E_Component
and then Present (Discriminant_Checking_Func
(Original_Record_Component (Entity (S))))
and then not Discriminant_Checks_Suppressed (T)
and then not Init_Component
then
Set_Do_Discriminant_Check (N);
end if;
if Ekind (Entity (S)) = E_Void then
Error_Msg_N ("premature use of component", S);
end if;
if Nkind (P) = N_Type_Conversion
and then Ekind (Entity (S)) = E_Discriminant
then
Set_Etype (N, Base_Type (Typ));
end if;
end Resolve_Selected_Component;
procedure Resolve_Shift (N : Node_Id; Typ : Entity_Id) is
B_Typ : constant Entity_Id := Base_Type (Typ);
L : constant Node_Id := Left_Opnd (N);
R : constant Node_Id := Right_Opnd (N);
begin
Resolve (L, B_Typ);
Resolve (R, Standard_Natural);
Check_Unset_Reference (L);
Check_Unset_Reference (R);
Set_Etype (N, B_Typ);
Generate_Operator_Reference (N);
Eval_Shift (N);
end Resolve_Shift;
procedure Resolve_Short_Circuit (N : Node_Id; Typ : Entity_Id) is
B_Typ : constant Entity_Id := Base_Type (Typ);
L : constant Node_Id := Left_Opnd (N);
R : constant Node_Id := Right_Opnd (N);
begin
Resolve (L, B_Typ);
Resolve (R, B_Typ);
Check_Unset_Reference (L);
Check_Unset_Reference (R);
Set_Etype (N, B_Typ);
Eval_Short_Circuit (N);
end Resolve_Short_Circuit;
procedure Resolve_Slice (N : Node_Id; Typ : Entity_Id) is
Name : constant Node_Id := Prefix (N);
Drange : constant Node_Id := Discrete_Range (N);
Array_Type : Entity_Id := Empty;
Index : Node_Id;
begin
if Is_Overloaded (Name) then
declare
I : Interp_Index;
I1 : Interp_Index := 0;
It : Interp;
P : constant Node_Id := Prefix (N);
Found : Boolean := False;
begin
Get_First_Interp (P, I, It);
while Present (It.Typ) loop
if (Is_Array_Type (It.Typ)
and then Covers (Typ, It.Typ))
or else (Is_Access_Type (It.Typ)
and then Is_Array_Type (Designated_Type (It.Typ))
and then Covers (Typ, Designated_Type (It.Typ)))
then
if Found then
It := Disambiguate (P, I1, I, Any_Type);
if It = No_Interp then
Error_Msg_N ("ambiguous prefix for slicing", N);
Set_Etype (N, Typ);
return;
else
Found := True;
Array_Type := It.Typ;
I1 := I;
end if;
else
Found := True;
Array_Type := It.Typ;
I1 := I;
end if;
end if;
Get_Next_Interp (I, It);
end loop;
end;
else
Array_Type := Etype (Name);
end if;
Resolve (Name, Array_Type);
if Is_Access_Type (Array_Type) then
Apply_Access_Check (N);
Array_Type := Designated_Type (Array_Type);
elsif Is_Entity_Name (Name)
or else (Nkind (Name) = N_Function_Call
and then not Is_Constrained (Etype (Name)))
then
Array_Type := Get_Actual_Subtype (Name);
end if;
Set_Etype (N, Array_Type);
if not Is_Entity_Name (Drange) then
Index := First_Index (Array_Type);
Resolve (Drange, Base_Type (Etype (Index)));
if Nkind (Drange) = N_Range then
Apply_Range_Check (Drange, Etype (Index));
end if;
end if;
Set_Slice_Subtype (N);
Eval_Slice (N);
end Resolve_Slice;
procedure Resolve_String_Literal (N : Node_Id; Typ : Entity_Id) is
C_Typ : constant Entity_Id := Component_Type (Typ);
R_Typ : constant Entity_Id := Root_Type (C_Typ);
Loc : constant Source_Ptr := Sloc (N);
Str : constant String_Id := Strval (N);
Strlen : constant Nat := String_Length (Str);
Subtype_Id : Entity_Id;
Need_Check : Boolean;
begin
Need_Check :=
(Strlen = 0 and then Typ /= Standard_String)
or else Nkind (Parent (N)) /= N_Op_Concat
or else (N /= Left_Opnd (Parent (N))
and then N /= Right_Opnd (Parent (N)))
or else (Typ = Standard_Wide_String
and then Nkind (Original_Node (N)) /= N_String_Literal);
if Ekind (Typ) = E_String_Literal_Subtype then
Subtype_Id := Typ;
elsif Nkind (Parent (N)) = N_Op_Concat
and then not Need_Check
and then Nkind (Original_Node (N)) /= N_Character_Literal
and then Nkind (Original_Node (N)) /= N_Attribute_Reference
and then Nkind (Original_Node (N)) /= N_Qualified_Expression
and then Nkind (Original_Node (N)) /= N_Type_Conversion
then
Subtype_Id := Typ;
else
Set_String_Literal_Subtype (N, Typ);
Subtype_Id := Etype (N);
end if;
if Nkind (Parent (N)) /= N_Op_Concat
or else Need_Check
then
Set_Etype (N, Subtype_Id);
Eval_String_Literal (N);
end if;
if Is_Limited_Composite (Typ)
or else Is_Private_Composite (Typ)
then
Error_Msg_N ("string literal not available for private array", N);
Set_Etype (N, Any_Type);
return;
end if;
if Strlen = 0 then
return;
elsif R_Typ = Any_Character then
return;
elsif Is_Bit_Packed_Array (Typ) then
null;
else
if R_Typ = Standard_Wide_Character then
null;
elsif R_Typ = Standard_Character
and then Nkind (Original_Node (N)) /= N_Op_Concat
then
for J in 1 .. Strlen loop
if not In_Character_Range (Get_String_Char (Str, J)) then
Error_Msg
("literal out of range of type Character",
Source_Ptr (Int (Loc) + J));
return;
end if;
end loop;
else
null;
end if;
if R_Typ = Standard_Wide_Character
or else R_Typ = Standard_Character
then
if Component_Type (Typ) = Base_Type (Component_Type (Typ)) then
return;
end if;
declare
Comp_Typ_Lo : constant Node_Id :=
Type_Low_Bound (Component_Type (Typ));
Comp_Typ_Hi : constant Node_Id :=
Type_High_Bound (Component_Type (Typ));
Char_Val : Uint;
begin
if Compile_Time_Known_Value (Comp_Typ_Lo)
and then Compile_Time_Known_Value (Comp_Typ_Hi)
then
for J in 1 .. Strlen loop
Char_Val := UI_From_Int (Int (Get_String_Char (Str, J)));
if Char_Val < Expr_Value (Comp_Typ_Lo)
or else Char_Val > Expr_Value (Comp_Typ_Hi)
then
Apply_Compile_Time_Constraint_Error
(N, "character out of range?", CE_Range_Check_Failed,
Loc => Source_Ptr (Int (Loc) + J));
end if;
end loop;
return;
end if;
end;
end if;
end if;
declare
Lits : List_Id := New_List;
P : Source_Ptr := Loc + 1;
C : Char_Code;
begin
for J in 1 .. Strlen loop
C := Get_String_Char (Str, J);
Set_Character_Literal_Name (C);
Append_To (Lits,
Make_Character_Literal (P, Name_Find, C));
if In_Character_Range (C) then
P := P + 1;
end if;
end loop;
Rewrite (N,
Make_Qualified_Expression (Loc,
Subtype_Mark => New_Reference_To (Typ, Loc),
Expression =>
Make_Aggregate (Loc, Expressions => Lits)));
Analyze_And_Resolve (N, Typ);
end;
end Resolve_String_Literal;
procedure Resolve_Subprogram_Info (N : Node_Id; Typ : Entity_Id) is
begin
Set_Etype (N, Typ);
end Resolve_Subprogram_Info;
procedure Resolve_Type_Conversion (N : Node_Id; Typ : Entity_Id) is
Target_Type : constant Entity_Id := Etype (N);
Conv_OK : constant Boolean := Conversion_OK (N);
Operand : Node_Id;
Opnd_Type : Entity_Id;
Rop : Node_Id;
begin
Operand := Expression (N);
if not Conv_OK
and then not Valid_Conversion (N, Target_Type, Operand)
then
return;
end if;
if Etype (Operand) = Any_Fixed then
if Is_Fixed_Point_Type (Typ) then
Set_Etype (Operand, Universal_Real);
elsif Is_Numeric_Type (Typ)
and then (Nkind (Operand) = N_Op_Multiply
or else Nkind (Operand) = N_Op_Divide)
and then (Etype (Right_Opnd (Operand)) = Universal_Real
or else Etype (Left_Opnd (Operand)) = Universal_Real)
then
if Unique_Fixed_Point_Type (N) = Any_Type then
return; else
Set_Etype (Operand, Standard_Duration);
end if;
if Etype (Right_Opnd (Operand)) = Universal_Real then
Rop := New_Copy_Tree (Right_Opnd (Operand));
else
Rop := New_Copy_Tree (Left_Opnd (Operand));
end if;
Resolve (Rop, Standard_Long_Long_Float);
if Realval (Rop) /= Ureal_0
and then abs (Realval (Rop)) < Delta_Value (Standard_Duration)
then
Error_Msg_N ("universal real operand can only be interpreted?",
Rop);
Error_Msg_N ("\as Duration, and will lose precision?", Rop);
end if;
else
Error_Msg_N ("invalid context for mixed mode operation", N);
Set_Etype (Operand, Any_Type);
return;
end if;
end if;
Opnd_Type := Etype (Operand);
Resolve (Operand, Opnd_Type);
Eval_Type_Conversion (N);
if Nkind (N) = N_Type_Conversion
and then not Is_Generic_Type (Root_Type (Target_Type))
and then Target_Type /= Universal_Fixed
and then Opnd_Type /= Universal_Fixed
then
Apply_Type_Conversion_Checks (N);
end if;
if Warn_On_Redundant_Constructs
and then Comes_From_Source (N)
and then Nkind (N) = N_Type_Conversion
and then Is_Entity_Name (Expression (N))
and then Etype (Entity (Expression (N))) = Target_Type
then
Error_Msg_NE
("?useless conversion, & has this type",
N, Entity (Expression (N)));
end if;
end Resolve_Type_Conversion;
procedure Resolve_Unary_Op (N : Node_Id; Typ : Entity_Id) is
B_Typ : Entity_Id := Base_Type (Typ);
R : constant Node_Id := Right_Opnd (N);
begin
if Paren_Count (N) = 0
and then Nkind (N) = N_Op_Minus
and then Nkind (Right_Opnd (N)) = N_Op_Mod
then
Error_Msg_N
("?unary minus expression should be parenthesized here", N);
end if;
if Etype (R) = Universal_Integer
or else Etype (R) = Universal_Real
then
Check_For_Visible_Operator (N, B_Typ);
end if;
Set_Etype (N, B_Typ);
Resolve (R, B_Typ);
Check_Unset_Reference (R);
Generate_Operator_Reference (N);
Eval_Unary_Op (N);
if Nkind (N) in N_Op then
if not Overflow_Checks_Suppressed (Etype (N)) then
Set_Do_Overflow_Check (N, True);
end if;
end if;
end Resolve_Unary_Op;
procedure Resolve_Unchecked_Expression
(N : Node_Id;
Typ : Entity_Id)
is
begin
Resolve (Expression (N), Typ, Suppress => All_Checks);
Set_Etype (N, Typ);
end Resolve_Unchecked_Expression;
procedure Resolve_Unchecked_Type_Conversion
(N : Node_Id;
Typ : Entity_Id)
is
pragma Warnings (Off, Typ);
Operand : constant Node_Id := Expression (N);
Opnd_Type : constant Entity_Id := Etype (Operand);
begin
Resolve (Operand, Opnd_Type);
Eval_Unchecked_Conversion (N);
end Resolve_Unchecked_Type_Conversion;
procedure Rewrite_Operator_As_Call (N : Node_Id; Nam : Entity_Id) is
Loc : Source_Ptr := Sloc (N);
Actuals : List_Id := New_List;
New_N : Node_Id;
begin
if Nkind (N) in N_Binary_Op then
Append (Left_Opnd (N), Actuals);
end if;
Append (Right_Opnd (N), Actuals);
New_N :=
Make_Function_Call (Sloc => Loc,
Name => New_Occurrence_Of (Nam, Loc),
Parameter_Associations => Actuals);
Preserve_Comes_From_Source (New_N, N);
Preserve_Comes_From_Source (Name (New_N), N);
Rewrite (N, New_N);
Set_Etype (N, Etype (Nam));
end Rewrite_Operator_As_Call;
procedure Rewrite_Renamed_Operator (N : Node_Id; Op : Entity_Id) is
Nam : constant Name_Id := Chars (Op);
Is_Binary : constant Boolean := Nkind (N) in N_Binary_Op;
Op_Node : Node_Id;
begin
if Chars (N) /= Nam then
Op_Node := New_Node (Operator_Kind (Nam, Is_Binary), Sloc (N));
Set_Chars (Op_Node, Nam);
Set_Etype (Op_Node, Etype (N));
Set_Entity (Op_Node, Op);
Set_Right_Opnd (Op_Node, Right_Opnd (N));
Generate_Reference (Op, N);
if Is_Binary then
Set_Left_Opnd (Op_Node, Left_Opnd (N));
end if;
Rewrite (N, Op_Node);
end if;
end Rewrite_Renamed_Operator;
procedure Set_Slice_Subtype (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Index : Node_Id;
Index_List : List_Id := New_List;
Index_Subtype : Entity_Id;
Index_Type : Entity_Id;
Slice_Subtype : Entity_Id;
Drange : constant Node_Id := Discrete_Range (N);
begin
if Is_Entity_Name (Drange) then
Index_Subtype := Entity (Drange);
else
if Nkind (Drange) = N_Range then
Force_Evaluation (Low_Bound (Drange));
Force_Evaluation (High_Bound (Drange));
end if;
Index_Type := Base_Type (Etype (Drange));
Index_Subtype := Create_Itype (Subtype_Kind (Ekind (Index_Type)), N);
Set_Scalar_Range (Index_Subtype, Drange);
Set_Etype (Index_Subtype, Index_Type);
Set_Size_Info (Index_Subtype, Index_Type);
Set_RM_Size (Index_Subtype, RM_Size (Index_Type));
end if;
Slice_Subtype := Create_Itype (E_Array_Subtype, N);
Index := New_Occurrence_Of (Index_Subtype, Loc);
Set_Etype (Index, Index_Subtype);
Append (Index, Index_List);
Set_First_Index (Slice_Subtype, Index);
Set_Etype (Slice_Subtype, Base_Type (Etype (N)));
Set_Is_Constrained (Slice_Subtype, True);
Init_Size_Align (Slice_Subtype);
Check_Compile_Time_Size (Slice_Subtype);
Set_Etype (N, Slice_Subtype);
if Is_Packed (Slice_Subtype) and not In_Default_Expression then
Freeze_Itype (Slice_Subtype, N);
end if;
end Set_Slice_Subtype;
procedure Set_String_Literal_Subtype (N : Node_Id; Typ : Entity_Id) is
Subtype_Id : Entity_Id;
begin
if Nkind (N) /= N_String_Literal then
return;
else
Subtype_Id := Create_Itype (E_String_Literal_Subtype, N);
end if;
Set_String_Literal_Length (Subtype_Id,
UI_From_Int (String_Length (Strval (N))));
Set_Etype (Subtype_Id, Base_Type (Typ));
Set_Is_Constrained (Subtype_Id);
Set_String_Literal_Low_Bound
(Subtype_Id, Type_Low_Bound (Etype (First_Index (Typ))));
Set_Etype (N, Subtype_Id);
end Set_String_Literal_Subtype;
function Unique_Fixed_Point_Type (N : Node_Id) return Entity_Id is
T1 : Entity_Id := Empty;
T2 : Entity_Id;
Item : Node_Id;
Scop : Entity_Id;
procedure Fixed_Point_Error;
procedure Fixed_Point_Error is
begin
Error_Msg_N ("ambiguous universal_fixed_expression", N);
Error_Msg_NE ("\possible interpretation as}", N, T1);
Error_Msg_NE ("\possible interpretation as}", N, T2);
end Fixed_Point_Error;
begin
T1 := Standard_Duration;
Scop := Current_Scope;
while Scop /= Standard_Standard loop
T2 := First_Entity (Scop);
while Present (T2) loop
if Is_Fixed_Point_Type (T2)
and then Current_Entity (T2) = T2
and then Scope (Base_Type (T2)) = Scop
then
if Present (T1) then
Fixed_Point_Error;
return Any_Type;
else
T1 := T2;
end if;
end if;
Next_Entity (T2);
end loop;
Scop := Scope (Scop);
end loop;
Item := First (Context_Items (Cunit (Current_Sem_Unit)));
while Present (Item) loop
if Nkind (Item) = N_With_Clause then
Scop := Entity (Name (Item));
T2 := First_Entity (Scop);
while Present (T2) loop
if Is_Fixed_Point_Type (T2)
and then Scope (Base_Type (T2)) = Scop
and then (Is_Potentially_Use_Visible (T2)
or else In_Use (T2))
then
if Present (T1) then
Fixed_Point_Error;
return Any_Type;
else
T1 := T2;
end if;
end if;
Next_Entity (T2);
end loop;
end if;
Next (Item);
end loop;
if Nkind (N) = N_Real_Literal then
Error_Msg_NE ("real literal interpreted as }?", N, T1);
else
Error_Msg_NE ("universal_fixed expression interpreted as }?", N, T1);
end if;
return T1;
end Unique_Fixed_Point_Type;
function Valid_Conversion
(N : Node_Id;
Target : Entity_Id;
Operand : Node_Id)
return Boolean
is
Target_Type : Entity_Id := Base_Type (Target);
Opnd_Type : Entity_Id := Etype (Operand);
function Conversion_Check
(Valid : Boolean;
Msg : String)
return Boolean;
function Valid_Tagged_Conversion
(Target_Type : Entity_Id;
Opnd_Type : Entity_Id)
return Boolean;
function Conversion_Check
(Valid : Boolean;
Msg : String)
return Boolean
is
begin
if not Valid then
Error_Msg_N (Msg, Operand);
end if;
return Valid;
end Conversion_Check;
function Valid_Tagged_Conversion
(Target_Type : Entity_Id;
Opnd_Type : Entity_Id)
return Boolean
is
begin
if Covers (Target_Type, Opnd_Type)
or else Is_Ancestor (Target_Type, Opnd_Type)
then
return True;
elsif Is_Class_Wide_Type (Opnd_Type)
and then Covers (Opnd_Type, Target_Type)
then
return True;
elsif Covers (Opnd_Type, Target_Type)
or else Is_Ancestor (Opnd_Type, Target_Type)
then
return
Conversion_Check (False,
"downward conversion of tagged objects not allowed");
else
Error_Msg_NE
("invalid tagged conversion, not compatible with}",
N, First_Subtype (Opnd_Type));
return False;
end if;
end Valid_Tagged_Conversion;
begin
Check_Parameterless_Call (Operand);
if Is_Overloaded (Operand) then
declare
I : Interp_Index;
I1 : Interp_Index;
It : Interp;
It1 : Interp;
N1 : Entity_Id;
begin
Get_First_Interp (Operand, I, It);
while Present (It.Typ) loop
if It.Typ = Standard_Void_Type then
Remove_Interp (I);
end if;
Get_Next_Interp (I, It);
end loop;
Get_First_Interp (Operand, I, It);
I1 := I;
It1 := It;
if No (It.Typ) then
Error_Msg_N ("illegal operand in conversion", Operand);
return False;
end if;
Get_Next_Interp (I, It);
if Present (It.Typ) then
N1 := It1.Nam;
It1 := Disambiguate (Operand, I1, I, Any_Type);
if It1 = No_Interp then
Error_Msg_N ("ambiguous operand in conversion", Operand);
Error_Msg_Sloc := Sloc (It.Nam);
Error_Msg_N ("possible interpretation#!", Operand);
Error_Msg_Sloc := Sloc (N1);
Error_Msg_N ("possible interpretation#!", Operand);
return False;
end if;
end if;
Set_Etype (Operand, It1.Typ);
Opnd_Type := It1.Typ;
end;
end if;
if Chars (Current_Scope) = Name_Unchecked_Conversion then
return True;
elsif Is_Numeric_Type (Target_Type) then
if Opnd_Type = Universal_Fixed then
return True;
else
return Conversion_Check (Is_Numeric_Type (Opnd_Type),
"illegal operand for numeric conversion");
end if;
elsif Is_Array_Type (Target_Type) then
if not Is_Array_Type (Opnd_Type)
or else Opnd_Type = Any_Composite
or else Opnd_Type = Any_String
then
Error_Msg_N
("illegal operand for array conversion", Operand);
return False;
elsif Number_Dimensions (Target_Type) /=
Number_Dimensions (Opnd_Type)
then
Error_Msg_N
("incompatible number of dimensions for conversion", Operand);
return False;
else
declare
Target_Index : Node_Id := First_Index (Target_Type);
Opnd_Index : Node_Id := First_Index (Opnd_Type);
Target_Index_Type : Entity_Id;
Opnd_Index_Type : Entity_Id;
Target_Comp_Type : Entity_Id := Component_Type (Target_Type);
Opnd_Comp_Type : Entity_Id := Component_Type (Opnd_Type);
begin
while Present (Target_Index) and then Present (Opnd_Index) loop
Target_Index_Type := Etype (Target_Index);
Opnd_Index_Type := Etype (Opnd_Index);
if not (Is_Integer_Type (Target_Index_Type)
and then Is_Integer_Type (Opnd_Index_Type))
and then (Root_Type (Target_Index_Type)
/= Root_Type (Opnd_Index_Type))
then
Error_Msg_N
("incompatible index types for array conversion",
Operand);
return False;
end if;
Next_Index (Target_Index);
Next_Index (Opnd_Index);
end loop;
if Base_Type (Target_Comp_Type) /=
Base_Type (Opnd_Comp_Type)
then
Error_Msg_N
("incompatible component types for array conversion",
Operand);
return False;
elsif
Is_Constrained (Target_Comp_Type)
/= Is_Constrained (Opnd_Comp_Type)
or else not Subtypes_Statically_Match
(Target_Comp_Type, Opnd_Comp_Type)
then
Error_Msg_N
("component subtypes must statically match", Operand);
return False;
end if;
end;
end if;
return True;
elsif (Ekind (Target_Type) = E_General_Access_Type
or else Ekind (Target_Type) = E_Anonymous_Access_Type)
and then
Conversion_Check
(Is_Access_Type (Opnd_Type)
and then Ekind (Opnd_Type) /=
E_Access_Subprogram_Type
and then Ekind (Opnd_Type) /=
E_Access_Protected_Subprogram_Type,
"must be an access-to-object type")
then
if Is_Access_Constant (Opnd_Type)
and then not Is_Access_Constant (Target_Type)
then
Error_Msg_N
("access-to-constant operand type not allowed", Operand);
return False;
end if;
if Ekind (Target_Type) /= E_Anonymous_Access_Type then
if Type_Access_Level (Opnd_Type)
> Type_Access_Level (Target_Type)
then
if In_Instance_Body then
Error_Msg_N
("?cannot convert local pointer to non-local access type",
Operand);
Error_Msg_N
("?Program_Error will be raised at run time", Operand);
else
Error_Msg_N
("cannot convert local pointer to non-local access type",
Operand);
return False;
end if;
elsif Ekind (Opnd_Type) = E_Anonymous_Access_Type then
if Nkind (Operand) = N_Selected_Component
and then Object_Access_Level (Operand)
> Type_Access_Level (Target_Type)
then
if In_Instance_Body then
Error_Msg_N
("?cannot convert access discriminant to non-local" &
" access type", Operand);
Error_Msg_N
("?Program_Error will be raised at run time", Operand);
else
Error_Msg_N
("cannot convert access discriminant to non-local" &
" access type", Operand);
return False;
end if;
end if;
if Is_Entity_Name (Operand)
and then (Ekind (Entity (Operand)) = E_In_Parameter
or else Ekind (Entity (Operand)) = E_Constant)
and then Present (Discriminal_Link (Entity (Operand)))
then
Error_Msg_N
("discriminant has deeper accessibility level than target",
Operand);
return False;
end if;
end if;
end if;
declare
Target : constant Entity_Id := Designated_Type (Target_Type);
Opnd : constant Entity_Id := Designated_Type (Opnd_Type);
begin
if Is_Tagged_Type (Target) then
return Valid_Tagged_Conversion (Target, Opnd);
else
if Base_Type (Target) /= Base_Type (Opnd) then
Error_Msg_NE
("target designated type not compatible with }",
N, Base_Type (Opnd));
return False;
elsif not Subtypes_Statically_Match (Target, Opnd)
and then (not Has_Discriminants (Target)
or else Is_Constrained (Target))
then
Error_Msg_NE
("target designated subtype not compatible with }",
N, Opnd);
return False;
else
return True;
end if;
end if;
end;
elsif Ekind (Target_Type) = E_Access_Subprogram_Type
and then Conversion_Check
(Ekind (Base_Type (Opnd_Type)) = E_Access_Subprogram_Type,
"illegal operand for access subprogram conversion")
then
if not Subtype_Conformant (Designated_Type (Opnd_Type),
Designated_Type (Target_Type))
then
Error_Msg_N
("operand type is not subtype conformant with target type",
Operand);
end if;
if Type_Access_Level (Opnd_Type) >
Type_Access_Level (Target_Type)
then
Error_Msg_N
("operand type has deeper accessibility level than target",
Operand);
elsif Present (Enclosing_Generic_Body (Opnd_Type)) then
declare
O_Gen : constant Node_Id :=
Enclosing_Generic_Body (Opnd_Type);
T_Gen : Node_Id :=
Enclosing_Generic_Body (Target_Type);
begin
while Present (T_Gen) and then T_Gen /= O_Gen loop
T_Gen := Enclosing_Generic_Body (T_Gen);
end loop;
if T_Gen /= O_Gen then
Error_Msg_N
("target type must be declared in same generic body"
& " as operand type", N);
end if;
end;
end if;
return True;
elsif Is_Remote_Access_To_Subprogram_Type (Target_Type)
and then Is_Remote_Access_To_Subprogram_Type (Opnd_Type)
then
Check_Subtype_Conformant
(New_Id =>
Designated_Type (Corresponding_Remote_Type (Target_Type)),
Old_Id =>
Designated_Type (Corresponding_Remote_Type (Opnd_Type)),
Err_Loc =>
N);
return True;
elsif Is_Tagged_Type (Target_Type) then
return Valid_Tagged_Conversion (Target_Type, Opnd_Type);
elsif Root_Type (Target_Type) = Root_Type (Opnd_Type) then
return True;
elsif In_Instance
and then Underlying_Type (Target_Type) = Underlying_Type (Opnd_Type)
then
return True;
elsif Ekind (Target_Type) = E_Access_Type
and then Is_Access_Type (Opnd_Type)
then
Error_Msg_N ("target type must be general access type!", N);
Error_Msg_NE ("add ALL to }!", N, Target_Type);
return False;
else
Error_Msg_NE ("invalid conversion, not compatible with }",
N, Opnd_Type);
return False;
end if;
end Valid_Conversion;
end Sem_Res;