Google Git
Sign in
gnu / gcc / 57ea00136418991e847e46a6946a81a1df70c9a4 / . / gcc / ada / sem_res.adb
blob: 5960a4d0cf83c213befcdc9fb9290b1ba0d1affb [file] [log] [blame]
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- S E M _ R E S --
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2004, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
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_Tss; use Exp_Tss;
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 Snames; use Snames;
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
-----------------------
-- Local Subprograms --
-----------------------
-- Second pass (top-down) type checking and overload resolution procedures
-- Typ is the type required by context. These procedures propagate the
-- type information recursively to the descendants of N. If the node
-- is not overloaded, its Etype is established in the first pass. If
-- overloaded, the Resolve routines set the correct type. For arith.
-- operators, the Etype is the base type of the context.
-- Note that Resolve_Attribute is separated off in Sem_Attr
procedure Ambiguous_Character (C : Node_Id);
-- Give list of candidate interpretations when a character literal cannot
-- be resolved.
procedure Check_Direct_Boolean_Op (N : Node_Id);
-- N is a binary operator node which may possibly operate on Boolean
-- operands. If the operator does have Boolean operands, then a call is
-- made to check the restriction No_Direct_Boolean_Operators.
procedure Check_Discriminant_Use (N : Node_Id);
-- Enforce the restrictions on the use of discriminants when constraining
-- a component of a discriminated type (record or concurrent type).
procedure Check_For_Visible_Operator (N : Node_Id; T : Entity_Id);
-- Given a node for an operator associated with type T, check that
-- the operator is visible. Operators all of whose operands are
-- universal must be checked for visibility during resolution
-- because their type is not determinable based on their operands.
function Check_Infinite_Recursion (N : Node_Id) return Boolean;
-- Given a call node, N, which is known to occur immediately within the
-- subprogram being called, determines whether it is a detectable case of
-- an infinite recursion, and if so, outputs appropriate messages. Returns
-- True if an infinite recursion is detected, and False otherwise.
procedure Check_Initialization_Call (N : Entity_Id; Nam : Entity_Id);
-- If the type of the object being initialized uses the secondary stack
-- directly or indirectly, create a transient scope for the call to the
-- init proc. This is because we do not create transient scopes for the
-- initialization of individual components within the init proc itself.
-- Could be optimized away perhaps?
function Is_Predefined_Op (Nam : Entity_Id) return Boolean;
-- Utility to check whether the name in the call is a predefined
-- operator, in which case the call is made into an operator node.
-- An instance of an intrinsic conversion operation may be given
-- an operator name, but is not treated like an operator.
procedure Replace_Actual_Discriminants (N : Node_Id; Default : Node_Id);
-- If a default expression in entry call N depends on the discriminants
-- of the task, it must be replaced with a reference to the discriminant
-- of the task being called.
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;
-- Utility to map the name of an operator into the corresponding Node. Used
-- by other node rewriting procedures.
procedure Resolve_Actuals (N : Node_Id; Nam : Entity_Id);
-- Resolve actuals of call, and add default expressions for missing ones.
procedure Resolve_Entry_Call (N : Node_Id; Typ : Entity_Id);
-- Called from Resolve_Call, when the prefix denotes an entry or element
-- of entry family. Actuals are resolved as for subprograms, and the node
-- is rebuilt as an entry call. Also called for protected operations. Typ
-- is the context type, which is used when the operation is a protected
-- function with no arguments, and the return value is indexed.
procedure Resolve_Intrinsic_Operator (N : Node_Id; Typ : Entity_Id);
-- A call to a user-defined intrinsic operator is rewritten as a call
-- to the corresponding predefined operator, with suitable conversions.
procedure Resolve_Intrinsic_Unary_Operator (N : Node_Id; Typ : Entity_Id);
-- Ditto, for unary operators (only arithmetic ones).
procedure Rewrite_Operator_As_Call (N : Node_Id; Nam : Entity_Id);
-- If an operator node resolves to a call to a user-defined operator,
-- rewrite the node as a function call.
procedure Make_Call_Into_Operator
(N : Node_Id;
Typ : Entity_Id;
Op_Id : Entity_Id);
-- Inverse transformation: if an operator is given in functional notation,
-- then after resolving the node, transform into an operator node, so
-- that operands are resolved properly. Recall that predefined operators
-- do not have a full signature and special resolution rules apply.
procedure Rewrite_Renamed_Operator (N : Node_Id; Op : Entity_Id);
-- An operator can rename another, e.g. in an instantiation. In that
-- case, the proper operator node must be constructed.
procedure Set_String_Literal_Subtype (N : Node_Id; Typ : Entity_Id);
-- The String_Literal_Subtype is built for all strings that are not
-- operands of a static concatenation operation. If the argument is
-- not a N_String_Literal node, then the call has no effect.
procedure Set_Slice_Subtype (N : Node_Id);
-- Build subtype of array type, with the range specified by the slice
function Unique_Fixed_Point_Type (N : Node_Id) return Entity_Id;
-- A universal_fixed expression in an universal context is unambiguous
-- if there is only one applicable fixed point type. Determining whether
-- there is only one requires a search over all visible entities, and
-- happens only in very pathological cases (see 6115-006).
function Valid_Conversion
(N : Node_Id;
Target : Entity_Id;
Operand : Node_Id)
return Boolean;
-- Verify legality rules given in 4.6 (8-23). Target is the target
-- type of the conversion, which may be an implicit conversion of
-- an actual parameter to an anonymous access type (in which case
-- N denotes the actual parameter and N = Operand).
-------------------------
-- Ambiguous_Character --
-------------------------
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;
-------------------------
-- Analyze_And_Resolve --
-------------------------
procedure Analyze_And_Resolve (N : Node_Id) is
begin
Analyze (N);
Resolve (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;
-- Version withs check(s) suppressed
procedure Analyze_And_Resolve
(N : Node_Id;
Typ : Entity_Id;
Suppress : Check_Id)
is
Scop : constant Entity_Id := Current_Scope;
begin
if Suppress = All_Checks then
declare
Svg : constant Suppress_Array := Scope_Suppress;
begin
Scope_Suppress := (others => True);
Analyze_And_Resolve (N, Typ);
Scope_Suppress := Svg;
end;
else
declare
Svg : constant Boolean := Scope_Suppress (Suppress);
begin
Scope_Suppress (Suppress) := True;
Analyze_And_Resolve (N, Typ);
Scope_Suppress (Suppress) := Svg;
end;
end if;
if Current_Scope /= Scop
and then Scope_Is_Transient
then
-- This can only happen if a transient scope was created
-- for an inner expression, which will be removed upon
-- completion of the analysis of an enclosing construct.
-- The transient scope must have the suppress status of
-- the enclosing environment, not of this Analyze call.
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 : constant Entity_Id := Current_Scope;
begin
if Suppress = All_Checks then
declare
Svg : constant Suppress_Array := Scope_Suppress;
begin
Scope_Suppress := (others => True);
Analyze_And_Resolve (N);
Scope_Suppress := Svg;
end;
else
declare
Svg : constant Boolean := Scope_Suppress (Suppress);
begin
Scope_Suppress (Suppress) := True;
Analyze_And_Resolve (N);
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;
-----------------------------
-- Check_Direct_Boolean_Op --
-----------------------------
procedure Check_Direct_Boolean_Op (N : Node_Id) is
begin
if Root_Type (Etype (Left_Opnd (N))) = Standard_Boolean then
Check_Restriction (No_Direct_Boolean_Operators, N);
end if;
end Check_Direct_Boolean_Op;
----------------------------
-- Check_Discriminant_Use --
----------------------------
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
-- Any use in a default expression is legal.
if In_Default_Expression then
null;
elsif Nkind (PN) = N_Range then
-- Discriminant cannot be used to constrain a scalar type.
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_Definition
then
Error_Msg_N ("discriminant cannot constrain scalar type", N);
elsif Nkind (P) = N_Index_Or_Discriminant_Constraint then
-- The following check catches the unusual case where
-- a discriminant appears within an index constraint
-- that is part of a larger expression within a constraint
-- on a component, e.g. "C : Int range 1 .. F (new A(1 .. D))".
-- For now we only check case of record components, and
-- note that a similar check should also apply in the
-- case of discriminant constraints below. ???
-- Note that the check for N_Subtype_Declaration below is to
-- detect the valid use of discriminants in the constraints of a
-- subtype declaration when this subtype declaration appears
-- inside the scope of a record type (which is syntactically
-- illegal, but which may be created as part of derived type
-- processing for records). See Sem_Ch3.Build_Derived_Record_Type
-- for more info.
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_Definition
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;
-- Detect a common beginner error:
-- type R (D : Positive := 100) is record
-- Name : String (1 .. D);
-- end record;
-- The default value causes an object of type R to be
-- allocated with room for Positive'Last characters.
declare
SI : Node_Id;
T : Entity_Id;
TB : Node_Id;
CB : Entity_Id;
function Large_Storage_Type (T : Entity_Id) return Boolean;
-- Return True if type T has a large enough range that
-- any array whose index type covered the whole range of
-- the type would likely raise Storage_Error.
------------------------
-- Large_Storage_Type --
------------------------
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
-- Check that the Disc has a large range
if not Large_Storage_Type (Etype (Disc)) then
goto No_Danger;
end if;
-- If the enclosing type is limited, we allocate only the
-- default value, not the maximum, and there is no need for
-- a warning.
if Is_Limited_Type (Scope (Disc)) then
goto No_Danger;
end if;
-- Check that it is the high bound
if N /= High_Bound (PN)
or else not Present (Discriminant_Default_Value (Disc))
then
goto No_Danger;
end if;
-- Check the array allows a large range at this bound.
-- First find the array
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;
-- Next, find the dimension
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;
-- Now, check the dimension has a large range
if not Large_Storage_Type (Etype (TB)) then
goto No_Danger;
end if;
-- Warn about the danger
Error_Msg_N
("creation of & object may raise Storage_Error?",
Scope (Disc));
<<No_Danger>>
null;
end;
end if;
-- Legal case is in index or discriminant constraint
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;
-- Otherwise, context is an expression. It should not be within
-- (i.e. a subexpression of) a constraint for a component.
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 the discriminant is used in an expression that is a bound
-- of a scalar type, an Itype is created and the bounds are attached
-- to its range, not to the original subtype indication. Such use
-- is of course a double fault.
if (Nkind (P) = N_Subtype_Indication
and then
(Nkind (Parent (P)) = N_Component_Definition
or else
Nkind (Parent (P)) = N_Derived_Type_Definition)
and then D = Constraint (P))
-- The constraint itself may be given by a subtype indication,
-- rather than by a more common discrete range.
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;
--------------------------------
-- Check_For_Visible_Operator --
--------------------------------
procedure Check_For_Visible_Operator (N : Node_Id; T : Entity_Id) is
begin
if Is_Invisible_Operator (N, T) 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;
------------------------------
-- Check_Infinite_Recursion --
------------------------------
function Check_Infinite_Recursion (N : Node_Id) return Boolean is
P : Node_Id;
C : Node_Id;
function Same_Argument_List return Boolean;
-- Check whether list of actuals is identical to list of formals
-- of called function (which is also the enclosing scope).
------------------------
-- Same_Argument_List --
------------------------
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;
-- Start of processing for Check_Infinite_Recursion
begin
-- Loop moving up tree, quitting if something tells us we are
-- definitely not in an infinite recursion situation.
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 the call is the expression of a return statement and
-- the actuals are identical to the formals, it's worth a
-- warning. However, we skip this if there is an immediately
-- preceding raise statement, since the call is never executed.
-- Furthermore, this corresponds to a common idiom:
-- function F (L : Thing) return Boolean is
-- begin
-- raise Program_Error;
-- return F (L);
-- end F;
-- for generating a stub function
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;
Error_Msg_N ("possible infinite recursion?", N);
Error_Msg_N ("\Storage_Error may be raised at run time?", N);
return True;
end Check_Infinite_Recursion;
-------------------------------
-- Check_Initialization_Call --
-------------------------------
procedure Check_Initialization_Call (N : Entity_Id; Nam : Entity_Id) is
Typ : constant Entity_Id := Etype (First_Formal (Nam));
function Uses_SS (T : Entity_Id) return Boolean;
-- Check whether the creation of an object of the type will involve
-- use of the secondary stack. If T is a record type, this is true
-- if the expression for some component uses the secondary stack, eg.
-- through a call to a function that returns an unconstrained value.
-- False if T is controlled, because cleanups occur elsewhere.
-------------
-- Uses_SS --
-------------
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));
-- The expression for a dynamic component may be
-- rewritten as a dereference. Retrieve original
-- call.
if Nkind (Original_Node (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;
-- Start of processing for Check_Initialization_Call
begin
-- Nothing to do if functions do not use the secondary stack for
-- returns (i.e. they use a depressed stack pointer instead).
if Functions_Return_By_DSP_On_Target then
return;
-- Otherwise establish a transient scope if the type needs it
elsif Uses_SS (Typ) then
Establish_Transient_Scope (First_Actual (N), Sec_Stack => True);
end if;
end Check_Initialization_Call;
------------------------------
-- Check_Parameterless_Call --
------------------------------
procedure Check_Parameterless_Call (N : Node_Id) is
Nam : Node_Id;
begin
-- Defend against junk stuff if errors already detected
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;
Require_Entity (N);
end if;
-- Rewrite as call if overloadable entity that is (or could be, in
-- the overloaded case) a function call. If we know for sure that
-- the entity is an enumeration literal, we do not rewrite it.
if (Is_Entity_Name (N)
and then Is_Overloadable (Entity (N))
and then (Ekind (Entity (N)) /= E_Enumeration_Literal
or else Is_Overloaded (N)))
-- Rewrite as call if it is an explicit deference of an expression of
-- a subprogram access type, and the suprogram type is not that of a
-- procedure or entry.
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)
-- Rewrite as call if it is a selected component which is a function,
-- this is the case of a call to a protected function (which may be
-- overloaded with other protected operations).
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)))))
-- If one of the above three conditions is met, rewrite as call.
-- Apply the rewriting only once.
then
if Nkind (Parent (N)) /= N_Function_Call
or else N /= Name (Parent (N))
then
Nam := New_Copy (N);
-- If overloaded, overload set belongs to new copy.
Save_Interps (N, Nam);
-- Change node to parameterless function call (note that the
-- Parameter_Associations associations field is left set to Empty,
-- its normal default value since there are no parameters)
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;
----------------------
-- Is_Predefined_Op --
----------------------
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;
-----------------------------
-- Make_Call_Into_Operator --
-----------------------------
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;
-- Determine whether E is an access type declared by an access decla-
-- ration, and not an (anonymous) allocator type.
function Operand_Type_In_Scope (S : Entity_Id) return Boolean;
-- If the operand is not universal, and the operator is given by a
-- expanded name, verify that the operand has an interpretation with
-- a type defined in the given scope of the operator.
function Type_In_P (Test : Kind_Test) return Entity_Id;
-- Find a type of the given class in the package Pack that contains
-- the operator.
-----------------------------
-- Is_Definite_Access_Type --
-----------------------------
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;
---------------------------
-- Operand_Type_In_Scope --
---------------------------
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;
---------------
-- Type_In_P --
---------------
function Type_In_P (Test : Kind_Test) return Entity_Id is
E : Entity_Id;
function In_Decl return Boolean;
-- Verify that node is not part of the type declaration for the
-- candidate type, which would otherwise be invisible.
-------------
-- In_Decl --
-------------
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;
-- Start of processing for Type_In_P
begin
-- If the context type is declared in the prefix package, this
-- is the desired base type.
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;
-- Start of processing for Make_Call_Into_Operator
begin
Op_Node := New_Node (Operator_Kind (Op_Name, Is_Binary), Sloc (N));
-- Binary operator
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);
-- Unary operator
else
Set_Right_Opnd (Op_Node, Relocate_Node (Act1));
Save_Interps (Act1, Right_Opnd (Op_Node));
Act1 := Right_Opnd (Op_Node);
end if;
-- If the operator is denoted by an expanded name, and the prefix is
-- not Standard, but the operator is a predefined one whose scope is
-- Standard, then this is an implicit_operator, inserted as an
-- interpretation by the procedure of the same name. This procedure
-- overestimates the presence of implicit operators, because it does
-- not examine the type of the operands. Verify now that the operand
-- type appears in the given scope. If right operand is universal,
-- check the other operand. In the case of concatenation, either
-- argument can be the component type, so check the type of the result.
-- If both arguments are literals, look for a type of the right kind
-- defined in the given scope. This elaborate nonsense is brought to
-- you courtesy of b33302a. The type itself must be frozen, so we must
-- find the type of the proper class in the given scope.
-- A final wrinkle is the multiplication operator for fixed point
-- types, which is defined in Standard only, and not in the scope of
-- the fixed_point type itself.
if Nkind (Name (N)) = N_Expanded_Name then
Pack := Entity (Prefix (Name (N)));
-- If the entity being called is defined in the given package,
-- it is a renaming of a predefined operator, and known to be
-- legal.
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
-- Verify that the scope contains a type that corresponds to
-- the given literal. Optimize the case where Pack is Standard.
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;
-- If the type is defined elsewhere, and the operator is not
-- defined in the given scope (by a renaming declaration, e.g.)
-- then this is an error as well. If an extension of System is
-- present, and the type may be defined there, Pack must be
-- System itself.
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);
if not Is_Private_Type (Etype (N)) then
Set_Etype (Op_Node, Base_Type (Etype (N)));
else
Set_Etype (Op_Node, Etype (N));
end if;
Set_Entity (Op_Node, Op_Id);
Generate_Reference (Op_Id, N, ' ');
Rewrite (N, Op_Node);
-- If this is an arithmetic operator and the result type is private,
-- the operands and the result must be wrapped in conversion to
-- expose the underlying numeric type and expand the proper checks,
-- e.g. on division.
if Is_Private_Type (Typ) then
case Nkind (N) is
when N_Op_Add | N_Op_Subtract | N_Op_Multiply | N_Op_Divide |
N_Op_Expon | N_Op_Mod | N_Op_Rem =>
Resolve_Intrinsic_Operator (N, Typ);
when N_Op_Plus | N_Op_Minus | N_Op_Abs =>
Resolve_Intrinsic_Unary_Operator (N, Typ);
when others =>
Resolve (N, Typ);
end case;
else
Resolve (N, Typ);
end if;
-- For predefined operators on literals, the operation freezes
-- their type.
if Present (Orig_Type) then
Set_Etype (Act1, Orig_Type);
Freeze_Expression (Act1);
end if;
end Make_Call_Into_Operator;
-------------------
-- Operator_Kind --
-------------------
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;
-- Unary operators
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;
-----------------------------
-- Pre_Analyze_And_Resolve --
-----------------------------
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);
-- We suppress all checks for this analysis, since the checks will
-- be applied properly, and in the right location, when the default
-- expression is reanalyzed and reexpanded later on.
Analyze_And_Resolve (N, T, Suppress => All_Checks);
Expander_Mode_Restore;
Full_Analysis := Save_Full_Analysis;
end Pre_Analyze_And_Resolve;
-- Version without context type.
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;
----------------------------------
-- Replace_Actual_Discriminants --
----------------------------------
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;
-------------------
-- Process_Discr --
-------------------
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);
-- Start of processing for Replace_Actual_Discriminants
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;
-------------
-- Resolve --
-------------
procedure Resolve (N : Node_Id; Typ : Entity_Id) is
I : Interp_Index;
I1 : Interp_Index := 0; -- prevent junk warning
It : Interp;
It1 : Interp;
Found : Boolean := False;
Seen : Entity_Id := Empty; -- prevent junk warning
Ctx_Type : Entity_Id := Typ;
Expr_Type : Entity_Id := Empty; -- prevent junk warning
Err_Type : Entity_Id := Empty;
Ambiguous : Boolean := False;
procedure Patch_Up_Value (N : Node_Id; Typ : Entity_Id);
-- Try and fix up a literal so that it matches its expected type. New
-- literals are manufactured if necessary to avoid cascaded errors.
procedure Resolution_Failed;
-- Called when attempt at resolving current expression fails
--------------------
-- Patch_Up_Value --
--------------------
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;
-----------------------
-- Resolution_Failed --
-----------------------
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);
-- The caller will return without calling the expander, so we need
-- to set the analyzed flag. Note that it is fine to set Analyzed
-- to True even if we are in the middle of a shallow analysis,
-- (see the spec of sem for more details) since this is an error
-- situation anyway, and there is no point in repeating the
-- analysis later (indeed it won't work to repeat it later, since
-- we haven't got a clear resolution of which entity is being
-- referenced.)
Set_Analyzed (N, True);
return;
end Resolution_Failed;
-- Start of processing for Resolve
begin
if N = Error then
return;
end if;
-- Access attribute on remote subprogram cannot be used for
-- a non-remote access-to-subprogram type.
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 the context is a Remote_Access_To_Subprogram, access attributes
-- must be resolved with the corresponding fat pointer. There is no need
-- to check for the attribute name since the return type of an
-- attribute is never a remote type.
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
-- Check that Typ is a fat pointer with a reference to a RAS as
-- original access type.
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
-- Prefix (N) must statically denote a remote subprogram
-- declared in a package specification.
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 we are generating code for a distributed program.
-- perform semantic checks against the corresponding
-- remote entities.
if (Attr = Attribute_Access
or else Attr = Attribute_Unchecked_Access
or else Attr = Attribute_Unrestricted_Access)
and then Expander_Active
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;
-- Return if already analyzed
if Analyzed (N) then
Debug_A_Exit ("resolving ", N, " (done, already analyzed)");
return;
-- Return if type = Any_Type (previous error encountered)
elsif Etype (N) = Any_Type then
Debug_A_Exit ("resolving ", N, " (done, Etype = Any_Type)");
return;
end if;
Check_Parameterless_Call (N);
-- If not overloaded, then we know the type, and all that needs doing
-- is to check that this type is compatible with the context.
if not Is_Overloaded (N) then
Found := Covers (Typ, Etype (N));
Expr_Type := Etype (N);
-- In the overloaded case, we must select the interpretation that
-- is compatible with the context (i.e. the type passed to Resolve)
else
Get_First_Interp (N, I, It);
-- Loop through possible interpretations
Interp_Loop : while Present (It.Typ) loop
-- We are only interested in interpretations that are compatible
-- with the expected type, any other interpretations are ignored
if not Covers (Typ, It.Typ) then
if Debug_Flag_V then
Write_Str (" interpretation incompatible with context");
Write_Eol;
end if;
else
-- First matching interpretation
if not Found then
Found := True;
I1 := I;
Seen := It.Nam;
Expr_Type := It.Typ;
-- Matching interpretation that is not the first, maybe an
-- error, but there are some cases where preference rules are
-- used to choose between the two possibilities. These and
-- some more obscure cases are handled in Disambiguate.
else
Error_Msg_Sloc := Sloc (Seen);
It1 := Disambiguate (N, I1, I, Typ);
-- Disambiguation has succeeded. Skip the remaining
-- interpretations.
if It1 /= No_Interp then
Seen := It1.Nam;
Expr_Type := It1.Typ;
while Present (It.Typ) loop
Get_Next_Interp (I, It);
end loop;
else
-- Before we issue an ambiguity complaint, check for
-- the case of a subprogram call where at least one
-- of the arguments is Any_Type, and if so, suppress
-- the message, since it is a cascaded error.
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;
-- Not that special case, so issue message using the
-- flag Ambiguous to control printing of the header
-- message only at the start of an ambiguous set.
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);
-- By default, the error message refers to the candidate
-- interpretation. But if it is a predefined operator,
-- it is implicitly declared at the declaration of
-- the type of the operand. Recover the sloc of that
-- declaration for the error message.
if Nkind (N) in N_Op
and then Scope (It.Nam) = Standard_Standard
and then not Is_Overloaded (Right_Opnd (N))
and then Scope (Base_Type (Etype (Right_Opnd (N))))
/= Standard_Standard
then
Err_Type := First_Subtype (Etype (Right_Opnd (N)));
if Comes_From_Source (Err_Type)
and then Present (Parent (Err_Type))
then
Error_Msg_Sloc := Sloc (Parent (Err_Type));
end if;
elsif Nkind (N) in N_Binary_Op
and then Scope (It.Nam) = Standard_Standard
and then not Is_Overloaded (Left_Opnd (N))
and then Scope (Base_Type (Etype (Left_Opnd (N))))
/= Standard_Standard
then
Err_Type := First_Subtype (Etype (Left_Opnd (N)));
if Comes_From_Source (Err_Type)
and then Present (Parent (Err_Type))
then
Error_Msg_Sloc := Sloc (Parent (Err_Type));
end if;
else
Err_Type := Empty;
end if;
if Nkind (N) in N_Op
and then Scope (It.Nam) = Standard_Standard
and then Present (Err_Type)
then
Error_Msg_N
("possible interpretation (predefined)#!", N);
else
Error_Msg_N ("possible interpretation#!", N);
end if;
end if;
end if;
-- We have a matching interpretation, Expr_Type is the
-- type from this interpretation, and Seen is the entity.
-- For an operator, just set the entity name. The type will
-- be set by the specific operator resolution routine.
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);
-- For an explicit dereference, attribute reference, range,
-- short-circuit form (which is not an operator node),
-- or a call with a name that is an explicit dereference,
-- there is nothing to be done at this point.
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;
-- For procedure or function calls, set the type of the
-- name, and also the entity pointer for the prefix
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)));
-- For all other cases, just set the type of the Name
else
Set_Etype (Name (N), Expr_Type);
end if;
end if;
-- Move to next interpretation
exit Interp_Loop when not Present (It.Typ);
Get_Next_Interp (I, It);
end loop Interp_Loop;
end if;
-- At this stage Found indicates whether or not an acceptable
-- interpretation exists. If not, then we have an error, except
-- that if the context is Any_Type as a result of some other error,
-- then we suppress the error report.
if not Found then
if Typ /= Any_Type then
-- If type we are looking for is Void, then this is the
-- procedure call case, and the error is simply that what
-- we gave is not a procedure name (we think of procedure
-- calls as expressions with types internally, but the user
-- doesn't think of them this way!)
if Typ = Standard_Void_Type then
-- Special case message if function used as a procedure
if Nkind (N) = N_Procedure_Call_Statement
and then Is_Entity_Name (Name (N))
and then Ekind (Entity (Name (N))) = E_Function
then
Error_Msg_NE
("cannot use function & in a procedure call",
Name (N), Entity (Name (N)));
-- Otherwise give general message (not clear what cases
-- this covers, but no harm in providing for them!)
else
Error_Msg_N ("expect procedure name in procedure call", N);
end if;
Found := True;
-- Otherwise we do have a subexpression with the wrong type
-- Check for the case of an allocator which uses an access
-- type instead of the designated type. This is a common
-- error and we specialize the message, posting an error
-- on the operand of the allocator, complaining that we
-- expected the designated type of the allocator.
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;
-- Check for view mismatch on Null in instances, for
-- which the view-swapping mechanism has no identifier.
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;
-- Check for an aggregate. Sometimes we can get bogus
-- aggregates from misuse of parentheses, and we are
-- about to complain about the aggregate without even
-- looking inside it.
-- Instead, if we have an aggregate of type Any_Composite,
-- then analyze and resolve the component fields, and then
-- only issue another message if we get no errors doing
-- this (otherwise assume that the errors in the aggregate
-- caused the problem).
elsif Nkind (N) = N_Aggregate
and then Etype (N) = Any_Composite
then
-- Disable expansion in any case. If there is a type mismatch
-- it may be fatal to try to expand the aggregate. The flag
-- would otherwise be set to false when the error is posted.
Expander_Active := False;
declare
procedure Check_Aggr (Aggr : Node_Id);
-- Check one aggregate, and set Found to True if we
-- have a definite error in any of its elements
procedure Check_Elmt (Aelmt : Node_Id);
-- Check one element of aggregate and set Found to
-- True if we definitely have an error in the element.
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;
----------------
-- Check_Elmt --
----------------
procedure Check_Elmt (Aelmt : Node_Id) is
begin
-- If we have a nested aggregate, go inside it (to
-- attempt a naked analyze-resolve of the aggregate
-- can cause undesirable cascaded errors). Do not
-- resolve expression if it needs a type from context,
-- as for integer * fixed expression.
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);
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 an error message was issued already, Found got reset
-- to True, so if it is still False, issue the standard
-- Wrong_Type message.
if not Found then
if Is_Overloaded (N)
and then Nkind (N) = N_Function_Call
then
declare
Subp_Name : Node_Id;
begin
if Is_Entity_Name (Name (N)) then
Subp_Name := Name (N);
elsif Nkind (Name (N)) = N_Selected_Component then
-- Protected operation: retrieve operation name.
Subp_Name := Selector_Name (Name (N));
else
raise Program_Error;
end if;
Error_Msg_Node_2 := Typ;
Error_Msg_NE ("no visible interpretation of&" &
" matches expected type&", N, Subp_Name);
end;
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;
-- Test if we have more than one interpretation for the context
elsif Ambiguous then
Resolution_Failed;
return;
-- Here we have an acceptable interpretation for the context
else
-- A user-defined operator is tranformed into a function call at
-- this point, so that further processing knows that operators are
-- really operators (i.e. are predefined operators). User-defined
-- operators that are intrinsic are just renamings of the predefined
-- ones, and need not be turned into calls either, but if they rename
-- a different operator, we must transform the node accordingly.
-- Instantiations of Unchecked_Conversion are intrinsic but are
-- treated as functions, even if given an operator designator.
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;
-- Propagate type information and normalize tree for various
-- predefined operations. If the context only imposes a class of
-- types, rather than a specific type, propagate the actual type
-- downward.
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;
-- Any_Fixed is legal in a real context only if a specific
-- fixed point type is imposed. If Norman Cohen can be
-- confused by this, it deserves a separate message.
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 the subexpression was replaced by a non-subexpression, then
-- all we do is to expand it. The only legitimate case we know of
-- is converting procedure call statement to entry call statements,
-- but there may be others, so we are making this test general.
if Nkind (N) not in N_Subexpr then
Debug_A_Exit ("resolving ", N, " (done)");
Expand (N);
return;
end if;
-- The expression is definitely NOT overloaded at this point, so
-- we reset the Is_Overloaded flag to avoid any confusion when
-- reanalyzing the node.
Set_Is_Overloaded (N, False);
-- Freeze expression type, entity if it is a name, and designated
-- type if it is an allocator (RM 13.14(10,11,13)).
-- Now that the resolution of the type of the node is complete,
-- and we did not detect an error, we can expand this node. We
-- skip the expand call if we are in a default expression, see
-- section "Handling of Default Expressions" in Sem spec.
Debug_A_Exit ("resolving ", N, " (done)");
-- We unconditionally freeze the expression, even if we are in
-- default expression mode (the Freeze_Expression routine tests
-- this flag and only freezes static types if it is set).
Freeze_Expression (N);
-- Now we can do the expansion
Expand (N);
end if;
end Resolve;
-------------
-- Resolve --
-------------
-- Version with check(s) suppressed
procedure Resolve (N : Node_Id; Typ : Entity_Id; Suppress : Check_Id) is
begin
if Suppress = All_Checks then
declare
Svg : constant Suppress_Array := Scope_Suppress;
begin
Scope_Suppress := (others => True);
Resolve (N, Typ);
Scope_Suppress := Svg;
end;
else
declare
Svg : constant Boolean := Scope_Suppress (Suppress);
begin
Scope_Suppress (Suppress) := True;
Resolve (N, Typ);
Scope_Suppress (Suppress) := Svg;
end;
end if;
end Resolve;
-------------
-- Resolve --
-------------
-- Version with implicit type
procedure Resolve (N : Node_Id) is
begin
Resolve (N, Etype (N));
end Resolve;
---------------------
-- Resolve_Actuals --
---------------------
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;
-- If the actual is missing in a call, insert in the actuals list
-- an instance of the default expression. The insertion is always
-- a named association.
function Same_Ancestor (T1, T2 : Entity_Id) return Boolean;
-- Check whether T1 and T2, or their full views, are derived from a
-- common type. Used to enforce the restrictions on array conversions
-- of AI95-00246.
--------------------
-- Insert_Default --
--------------------
procedure Insert_Default is
Actval : Node_Id;
Assoc : Node_Id;
begin
-- Missing argument in call, nothing to insert
if No (Default_Value (F)) then
return;
else
-- Note that we do a full New_Copy_Tree, so that any associated
-- Itypes are properly copied. This may not be needed any more,
-- but it does no harm as a safety measure! Defaults of a generic
-- formal may be out of bounds of the corresponding actual (see
-- cc1311b) and an additional check may be required.
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 default is a real literal, do not introduce a
-- conversion whose effect may depend on the run-time
-- size of universal real.
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);
-- Resolve aggregates with their base type, to avoid scope
-- anomalies: the subtype was first built in the suprogram
-- declaration, and the current call may be nested.
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;
else
Set_Parent (Actval, N);
-- See note above concerning aggregates.
if Nkind (Actval) = N_Aggregate
and then Has_Discriminants (Etype (Actval))
then
Analyze_And_Resolve (Actval, Base_Type (Etype (Actval)));
-- Resolve entities with their own type, which may differ
-- from the type of a reference in a generic context (the
-- view swapping mechanism did not anticipate the re-analysis
-- of default values in calls).
elsif Is_Entity_Name (Actval) then
Analyze_And_Resolve (Actval, Etype (Entity (Actval)));
else
Analyze_And_Resolve (Actval, Etype (Actval));
end if;
end if;
-- If default is a tag indeterminate function call, propagate
-- tag to obtain proper dispatching.
if Is_Controlling_Formal (F)
and then Nkind (Default_Value (F)) = N_Function_Call
then
Set_Is_Controlling_Actual (Actval);
end if;
end if;
-- If the default expression raises constraint error, then just
-- silently replace it with an N_Raise_Constraint_Error node,
-- since we already gave the warning on the subprogram spec.
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)));
-- Case of insertion is first named actual
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;
-- Case of insertion is not first named actual
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;
-------------------
-- Same_Ancestor --
-------------------
function Same_Ancestor (T1, T2 : Entity_Id) return Boolean is
FT1 : Entity_Id := T1;
FT2 : Entity_Id := T2;
begin
if Is_Private_Type (T1)
and then Present (Full_View (T1))
then
FT1 := Full_View (T1);
end if;
if Is_Private_Type (T2)
and then Present (Full_View (T2))
then
FT2 := Full_View (T2);
end if;
return Root_Type (Base_Type (FT1)) = Root_Type (Base_Type (FT2));
end Same_Ancestor;
-- Start of processing for Resolve_Actuals
begin
A := First_Actual (N);
F := First_Formal (Nam);
while Present (F) loop
if No (A) and then Needs_No_Actuals (Nam) then
null;
-- If we have an error in any actual or formal, indicated by
-- a type of Any_Type, then abandon resolution attempt, and
-- set result type to Any_Type.
elsif (Present (A) and then Etype (A) = Any_Type)
or else Etype (F) = Any_Type
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 the formal is Out or In_Out, do not resolve and expand the
-- conversion, because it is subsequently expanded into explicit
-- temporaries and assignments. However, the object of the
-- conversion can be resolved. An exception is the case of
-- a tagged type conversion with a class-wide actual. In that
-- case we want the tag check to occur and no temporary will
-- will be needed (no representation change can occur) and
-- the parameter is passed by reference, so we go ahead and
-- resolve the type conversion.
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))
then
if 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);
elsif not Same_Ancestor (Etype (F), Etype (Expression (A)))
and then
(Is_By_Reference_Type (Etype (F))
or else Is_By_Reference_Type (Etype (Expression (A))))
then
Error_Msg_N
("view conversion between unrelated by_reference "
& "array types not allowed (\A\I-00246)?", A);
end if;
end if;
if Conversion_OK (A)
or else Valid_Conversion (A, Etype (A), Expression (A))
then
Resolve (Expression (A));
end if;
else
if Nkind (A) = N_Type_Conversion
and then Is_Array_Type (Etype (F))
and then not Same_Ancestor (Etype (F), Etype (Expression (A)))
and then
(Is_Limited_Type (Etype (F))
or else Is_Limited_Type (Etype (Expression (A))))
then
Error_Msg_N
("Conversion between unrelated limited array types "
& "not allowed (\A\I-00246)?", A);
-- Disable explanation (which produces additional errors)
-- until AI is approved and warning becomes an error.
-- if Is_Limited_Type (Etype (F)) then
-- Explain_Limited_Type (Etype (F), A);
-- end if;
-- if Is_Limited_Type (Etype (Expression (A))) then
-- Explain_Limited_Type (Etype (Expression (A)), A);
-- end if;
end if;
Resolve (A, Etype (F));
end if;
A_Typ := Etype (A);
F_Typ := Etype (F);
-- Perform error checks for IN and IN OUT parameters
if Ekind (F) /= E_Out_Parameter then
-- Check unset reference. For scalar parameters, it is clearly
-- wrong to pass an uninitialized value as either an IN or
-- IN-OUT parameter. For composites, it is also clearly an
-- error to pass a completely uninitialized value as an IN
-- parameter, but the case of IN OUT is trickier. We prefer
-- not to give a warning here. For example, suppose there is
-- a routine that sets some component of a record to False.
-- It is perfectly reasonable to make this IN-OUT and allow
-- either initialized or uninitialized records to be passed
-- in this case.
-- For partially initialized composite values, we also avoid
-- warnings, since it is quite likely that we are passing a
-- partially initialized value and only the initialized fields
-- will in fact be read in the subprogram.
if Is_Scalar_Type (A_Typ)
or else (Ekind (F) = E_In_Parameter
and then not Is_Partially_Initialized_Type (A_Typ))
then
Check_Unset_Reference (A);
end if;
-- In Ada 83 we cannot pass an OUT parameter as an IN
-- or IN OUT actual to a nested call, since this is a
-- case of reading an out parameter, which is not allowed.
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
and then not Is_OK_Variable_For_Out_Formal (A)
then
Error_Msg_NE ("actual for& must be a variable", A, F);
if Is_Entity_Name (A) then
Kill_Checks (Entity (A));
else
Kill_All_Checks;
end if;
end if;
if Etype (A) = Any_Type then
Set_Etype (N, Any_Type);
return;
end if;
-- Apply appropriate range checks for in, out, and in-out
-- parameters. Out and in-out parameters also need a separate
-- check, if there is a type conversion, to make sure the return
-- value meets the constraints of the variable before the
-- conversion.
-- Gigi looks at the check flag and uses the appropriate types.
-- For now since one flag is used there is an optimization which
-- might not be done in the In Out case since Gigi does not do
-- any analysis. More thought required about this ???
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;
-- An actual associated with an access parameter is implicitly
-- converted to the anonymous access type of the formal and
-- must satisfy the legality checks for access conversions.
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;
-- Check bad case of atomic/volatile argument (RM C.6(12))
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;
-- Check that subprograms don't have improper controlling
-- arguments (RM 3.9.2 (9))
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 it is a named association, treat the selector_name as
-- a proper identifier, and mark the corresponding entity.
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;
if Ekind (F) /= E_Out_Parameter then
Check_Unset_Reference (A);
end if;
Next_Actual (A);
-- Case where actual is not present
else
Insert_Default;
end if;
Next_Formal (F);
end loop;
end Resolve_Actuals;
-----------------------
-- Resolve_Allocator --
-----------------------
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;
-- If the allocator is an actual in a call, it is allowed to be
-- class-wide when the context is not because it is a controlling
-- actual.
----------------------------
-- In_Dispatching_Context --
----------------------------
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;
-- Start of processing for Resolve_Allocator
begin
-- Replace general access with specific type
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;
-- For qualified expression, resolve the expression using the
-- given subtype (nothing to do for type mark, subtype indication)
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));
-- A qualified expression requires an exact match of the type,
-- class-wide matching is not allowed.
if (Is_Class_Wide_Type (Etype (Expression (E)))
or else Is_Class_Wide_Type (Etype (E)))
and then Base_Type (Etype (Expression (E))) /= Base_Type (Etype (E))
then
Wrong_Type (Expression (E), Etype (E));
end if;
-- For a subtype mark or subtype indication, freeze the subtype
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;
-- A special accessibility check is needed for allocators that
-- constrain access discriminants. The level of the type of the
-- expression used to contrain an access discriminant cannot be
-- deeper than the type of the allocator (in constrast to access
-- parameters, where the level of the actual can be arbitrary).
-- We can't use Valid_Conversion to perform this check because
-- in general the type of the allocator is unrelated to the type
-- of the access discriminant. Note that specialized checks are
-- needed for the cases of a constraint expression which is an
-- access attribute or an access discriminant.
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);
-- When the operand is an access discriminant the check
-- is against the level of the prefix object.
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;
-- Check for allocation from an empty storage pool
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;
---------------------------
-- Resolve_Arithmetic_Op --
---------------------------
-- Used for resolving all arithmetic operators except exponentiation
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);
TL : constant Entity_Id := Base_Type (Etype (L));
TR : constant Entity_Id := Base_Type (Etype (R));
T : Entity_Id;
Rop : Node_Id;
B_Typ : constant Entity_Id := Base_Type (Typ);
-- We do the resolution using the base type, because intermediate values
-- in expressions always are of the base type, not a subtype of it.
function Is_Integer_Or_Universal (N : Node_Id) return Boolean;
-- Return True iff given type is Integer or universal real/integer
procedure Set_Mixed_Mode_Operand (N : Node_Id; T : Entity_Id);
-- Choose type of integer literal in fixed-point operation to conform
-- to available fixed-point type. T is the type of the other operand,
-- which is needed to determine the expected type of N.
procedure Set_Operand_Type (N : Node_Id);
-- Set operand type to T if universal
-----------------------------
-- Is_Integer_Or_Universal --
-----------------------------
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;
----------------------------
-- Set_Mixed_Mode_Operand --
----------------------------
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
-- A universal integer literal is resolved as standard integer
-- except in the case of a fixed-point result, where we leave
-- it as universal (to be handled by Exp_Fixd later on)
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
-- A universal real can appear in a fixed-type context. We resolve
-- the literal with that context, even though this might raise an
-- exception prematurely (the other operand may be zero).
Resolve (N, B_Typ);
elsif Etype (N) = Base_Type (Standard_Integer)
and then T = Universal_Real
and then Is_Overloaded (N)
then
-- Integer arg in mixed-mode operation. Resolve with universal
-- type, in case preference rule must be applied.
Resolve (N, Universal_Integer);
elsif Etype (N) = T
and then B_Typ /= Universal_Fixed
then
-- Not a mixed-mode operation. Resolve with context.
Resolve (N, B_Typ);
elsif Etype (N) = Any_Fixed then
-- N may itself be a mixed-mode operation, so use context type.
Resolve (N, B_Typ);
elsif Is_Fixed_Point_Type (T)
and then B_Typ = Universal_Fixed
and then Is_Overloaded (N)
then
-- Must be (fixed * fixed) operation, operand must have one
-- compatible interpretation.
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
-- C * F(X) in a fixed context, where C is a real literal or a
-- fixed-point expression. F must have either a fixed type
-- interpretation or an integer interpretation, but not both.
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;
-- Reanalyze the literal with the fixed type of the context.
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);
end if;
end Set_Mixed_Mode_Operand;
----------------------
-- Set_Operand_Type --
----------------------
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;
-- Start of processing for Resolve_Arithmetic_Op
begin
if Comes_From_Source (N)
and then Ekind (Entity (N)) = E_Function
and then Is_Imported (Entity (N))
and then Is_Intrinsic_Subprogram (Entity (N))
then
Resolve_Intrinsic_Operator (N, Typ);
return;
-- Special-case for mixed-mode universal expressions or fixed point
-- type operation: each argument is resolved separately. The same
-- treatment is required if one of the operands of a fixed point
-- operation is universal real, since in this case we don't do a
-- conversion to a specific fixed-point type (instead the expander
-- takes care of the case).
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 context is a fixed type and one operand is integer, the
-- other is resolved with the type of the context.
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
-- If no previous errors, this is only possible if one operand
-- is overloaded and the context is universal. Resolve as such.
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 the context is Universal_Fixed and the operands are also
-- universal fixed, this is an error, unless there is only one
-- applicable fixed_point type (usually duration).
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;
-- If one of the arguments was resolved to a non-universal type.
-- label the result of the operation itself with the same type.
-- Do the same for the universal argument, if any.
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, Typ);
Eval_Arithmetic_Op (N);
-- Set overflow and division checking bit. Much cleverer code needed
-- here eventually and perhaps the Resolve routines should be separated
-- for the various arithmetic operations, since they will need
-- different processing. ???
if Nkind (N) in N_Op then
if not Overflow_Checks_Suppressed (Etype (N)) then
Enable_Overflow_Check (N);
end if;
-- Give warning if explicit division by zero
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
Rop := Right_Opnd (N);
if Compile_Time_Known_Value (Rop)
and then ((Is_Integer_Type (Etype (Rop))
and then Expr_Value (Rop) = Uint_0)
or else
(Is_Real_Type (Etype (Rop))
and then Expr_Value_R (Rop) = Ureal_0))
then
Apply_Compile_Time_Constraint_Error
(N, "division by zero?", CE_Divide_By_Zero,
Loc => Sloc (Right_Opnd (N)));
-- Otherwise just set the flag to check at run time
else
Set_Do_Division_Check (N);
end if;
end if;
end if;
Check_Unset_Reference (L);
Check_Unset_Reference (R);
end Resolve_Arithmetic_Op;
------------------
-- Resolve_Call --
------------------
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;
Decl : Node_Id;
begin
-- The context imposes a unique interpretation with type Typ on
-- a procedure or function call. Find the entity of the subprogram
-- that yields the expected type, and propagate the corresponding
-- formal constraints on the actuals. The caller has established
-- that an interpretation exists, and emitted an error if not unique.
-- First deal with the case of a call to an access-to-subprogram,
-- dereference made explicit in Analyze_Call.
if Ekind (Etype (Subp)) = E_Subprogram_Type then
if not Is_Overloaded (Subp) then
Nam := Etype (Subp);
else
-- Find the interpretation whose type (a subprogram type)
-- has a return type that is compatible with the context.
-- Analysis of the node has established that one exists.
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 the prefix is not an entity, then resolve it
if not Is_Entity_Name (Subp) then
Resolve (Subp, Nam);
end if;
-- For an indirect call, we always invalidate checks, since we
-- do not know whether the subprogram is local or global. Yes
-- we could do better here, e.g. by knowing that there are no
-- local subprograms, but it does not seem worth the effort.
-- Similarly, we kill al knowledge of current constant values.
Kill_Current_Values;
-- If this is a procedure call which is really an entry call, do
-- the conversion of the procedure call to an entry call. Protected
-- operations use the same circuitry because the name in the call
-- can be an arbitrary expression with special resolution rules.
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);
-- Kill checks and constant values, as above for indirect case
-- Who knows what happens when another task is activated?
Kill_Current_Values;
return;
-- Normal subprogram call with name established in Resolve
elsif not (Is_Type (Entity (Subp))) then
Nam := Entity (Subp);
Set_Entity_With_Style_Check (Subp, Nam);
Generate_Reference (Nam, Subp);
-- Otherwise we must have the case of an overloaded call
else
pragma Assert (Is_Overloaded (Subp));
Nam := Empty; -- We know that it will be assigned in loop below.
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;
-- Check that a call to Current_Task does not occur in an entry body
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;
-- Cannot call thread body directly
if Is_Thread_Body (Nam) then
Error_Msg_N ("cannot call thread body directly", N);
end if;
-- If the subprogram is not global, then kill all checks. This is
-- a bit conservative, since in many cases we could do better, but
-- it is not worth the effort. Similarly, we kill constant values.
-- However we do not need to do this for internal entities (unless
-- they are inherited user-defined subprograms), since they are not
-- in the business of molesting global values.
if not Is_Library_Level_Entity (Nam)
and then (Comes_From_Source (Nam)
or else (Present (Alias (Nam))
and then Comes_From_Source (Alias (Nam))))
then
Kill_Current_Values;
end if;
-- Check for call to obsolescent subprogram
if Warn_On_Obsolescent_Feature then
Decl := Parent (Parent (Nam));
if Nkind (Decl) = N_Subprogram_Declaration
and then Is_List_Member (Decl)
and then Nkind (Next (Decl)) = N_Pragma
then
declare
P : constant Node_Id := Next (Decl);
begin
if Chars (P) = Name_Obsolescent then
Error_Msg_NE ("call to obsolescent subprogram&?", N, Nam);
if Pragma_Argument_Associations (P) /= No_List then
Name_Buffer (1) := '|';
Name_Buffer (2) := '?';
Name_Len := 2;
Add_String_To_Name_Buffer
(Strval (Expression
(First (Pragma_Argument_Associations (P)))));
Error_Msg_N (Name_Buffer (1 .. Name_Len), N);
end if;
end if;
end;
end if;
end if;
-- Check that a procedure call does not occur in the context
-- of the entry call statement of a conditional or timed
-- entry call. Note that the case of a call to a subprogram
-- renaming of an entry will also be rejected. The test
-- for N not being an N_Entry_Call_Statement is defensive,
-- covering the possibility that the processing of entry
-- calls might reach this point due to later modifications
-- of the code above.
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;
-- Check that this is not a call to a protected procedure or
-- entry from within a protected function.
if Ekind (Current_Scope) = E_Function
and then Ekind (Scope (Current_Scope)) = E_Protected_Type
and then Ekind (Nam) /= E_Function
and then Scope (Nam) = Scope (Current_Scope)
then
Error_Msg_N ("within protected function, protected " &
"object is constant", N);
Error_Msg_N ("\cannot call operation that may modify it", N);
end if;
-- Freeze the subprogram name if not in default expression. Note
-- that we freeze procedure calls as well as function calls.
-- Procedure calls are not frozen according to the rules (RM
-- 13.14(14)) because it is impossible to have a procedure call to
-- a non-frozen procedure in pure Ada, but in the code that we
-- generate in the expander, this rule needs extending because we
-- can generate procedure calls that need freezing.
if Is_Entity_Name (Subp) and then not In_Default_Expression then
Freeze_Expression (Subp);
end if;
-- For a predefined operator, the type of the result is the type
-- imposed by context, except for a predefined operation on universal
-- fixed. Otherwise The type of the call is the type returned by the
-- subprogram being called.
if Is_Predefined_Op (Nam) then
if Etype (N) /= Universal_Fixed then
Set_Etype (N, Typ);
end if;
-- If the subprogram returns an array type, and the context
-- requires the component type of that array type, the node is
-- really an indexing of the parameterless call. Resolve as such.
-- A pathological case occurs when the type of the component is
-- an access to the array type. In this case the call is truly
-- ambiguous.
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;
New_Subp : Node_Id;
Ret_Type : constant Entity_Id := Etype (Nam);
begin
if Is_Access_Type (Ret_Type)
and then Ret_Type = Component_Type (Designated_Type (Ret_Type))
then
Error_Msg_N
("cannot disambiguate function call and indexing", N);
else
New_Subp := Relocate_Node (Subp);
Set_Entity (Subp, Nam);
if Component_Type (Ret_Type) /= Any_Type then
Index_Node :=
Make_Indexed_Component (Loc,
Prefix =>
Make_Function_Call (Loc,
Name => New_Subp),
Expressions => Parameter_Associations (N));
-- Since we are correcting a node classification error made
-- by the parser, we call Replace rather than Rewrite.
Replace (N, Index_Node);
Set_Etype (Prefix (N), Ret_Type);
Set_Etype (N, Typ);
Resolve_Indexed_Component (N, Typ);
Check_Elab_Call (Prefix (N));
end if;
end if;
return;
end;
else
Set_Etype (N, Etype (Nam));
end if;
-- In the case where the call is to an overloaded subprogram, Analyze
-- calls Normalize_Actuals once per overloaded subprogram. Therefore in
-- such a case Normalize_Actuals needs to be called once more to order
-- the actuals correctly. Otherwise the call will have the ordering
-- given by the last overloaded subprogram whether this is the correct
-- one being called or not.
if Is_Overloaded (Subp) then
Normalize_Actuals (N, Nam, False, Norm_OK);
pragma Assert (Norm_OK);
end if;
-- In any case, call is fully resolved now. Reset Overload flag, to
-- prevent subsequent overload resolution if node is analyzed again
Set_Is_Overloaded (Subp, False);
Set_Is_Overloaded (N, False);
-- If we are calling the current subprogram from immediately within
-- its body, then that is the case where we can sometimes detect
-- cases of infinite recursion statically. Do not try this in case
-- restriction No_Recursion is in effect anyway.
Scop := Current_Scope;
if Nam = Scop
and then not Restrictions (No_Recursion)
and then Check_Infinite_Recursion (N)
then
-- Here we detected and flagged an infinite recursion, so we do
-- not need to test the case below for further warnings.
null;
-- If call is to immediately containing subprogram, then check for
-- the case of a possible run-time detectable infinite recursion.
else
while Scop /= Standard_Standard loop
if Nam = Scop then
-- Although in general recursion is not statically checkable,
-- the case of calling an immediately containing subprogram
-- is easy to catch.
Check_Restriction (No_Recursion, N);
-- If the recursive call is to a parameterless procedure, then
-- even if we can't statically detect infinite recursion, this
-- is pretty suspicious, and we output a warning. Furthermore,
-- we will try later to detect some cases here at run time by
-- expanding checking code (see Detect_Infinite_Recursion in
-- package Exp_Ch6).
-- If the recursive call is within a handler we do not emit a
-- warning, because this is a common idiom: loop until input
-- is correct, catch illegal input in handler and restart.
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 subprogram name is a predefined operator, it was given in
-- functional notation. Replace call node with operator node, so
-- that actuals can be resolved appropriately.
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;
-- Create a transient scope if the resulting type requires it
-- There are 3 notable exceptions: in init procs, the transient scope
-- overhead is not needed and even incorrect due to the actual expansion
-- of adjust calls; the second case is enumeration literal pseudo calls,
-- the other case is intrinsic subprograms (Unchecked_Conversion and
-- source information functions) that do not use the secondary stack
-- even though the return type is unconstrained.
-- If this is an initialization call for a type whose initialization
-- uses the secondary stack, we also need to create a transient scope
-- for it, precisely because we will not do it within the init proc
-- itself.
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);
-- If the call appears within the bounds of a loop, it will
-- be rewritten and reanalyzed, nothing left to do here.
if Nkind (N) /= N_Function_Call then
return;
end if;
elsif Is_Init_Proc (Nam)
and then not Within_Init_Proc
then
Check_Initialization_Call (N, Nam);
end if;
-- A protected function cannot be called within the definition of the
-- enclosing protected type.
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;
-- Propagate interpretation to actuals, and add default expressions
-- where needed.
if Present (First_Formal (Nam)) then
Resolve_Actuals (N, Nam);
-- Overloaded literals are rewritten as function calls, for
-- purpose of resolution. After resolution, we can replace
-- the call with the literal itself.
elsif Ekind (Nam) = E_Enumeration_Literal then
Copy_Node (Subp, N);
Resolve_Entity_Name (N, Typ);
-- Avoid validation, since it is a static function call
return;
end if;
-- If the subprogram is a primitive operation, check whether or not
-- it is a correct dispatching call.
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;
-- If we fall through we definitely have a non-static call
Check_Elab_Call (N);
end Resolve_Call;
-------------------------------
-- Resolve_Character_Literal --
-------------------------------
procedure Resolve_Character_Literal (N : Node_Id; Typ : Entity_Id) is
B_Typ : constant Entity_Id := Base_Type (Typ);
C : Entity_Id;
begin
-- Verify that the character does belong to the type of the context
Set_Etype (N, B_Typ);
Eval_Character_Literal (N);
-- Wide_Character literals must always be defined, since the set of
-- wide character literals is complete, i.e. if a character literal
-- is accepted by the parser, then it is OK for wide character.
if Root_Type (B_Typ) = Standard_Wide_Character then
return;
-- Always accept character literal for type Any_Character, which
-- occurs in error situations and in comparisons of literals, both
-- of which should accept all literals.
elsif B_Typ = Any_Character then
return;
-- For Standard.Character or a type derived from it, check that
-- the literal is in range
elsif Root_Type (B_Typ) = Standard_Character then
if In_Character_Range (Char_Literal_Value (N)) then
return;
end if;
-- If the entity is already set, this has already been resolved in
-- a generic context, or comes from expansion. Nothing else to do.
elsif Present (Entity (N)) then
return;
-- Otherwise we have a user defined character type, and we can use
-- the standard visibility mechanisms to locate the referenced entity
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;
-- If we fall through, then the literal does not match any of the
-- entries of the enumeration type. This isn't just a constraint
-- error situation, it is an illegality (see RM 4.2).
Error_Msg_NE
("character not defined for }", N, First_Subtype (B_Typ));
end Resolve_Character_Literal;
---------------------------
-- Resolve_Comparison_Op --
---------------------------
-- Context requires a boolean type, and plays no role in resolution.
-- Processing identical to that for equality operators. The result
-- type is the base type, which matters when pathological subtypes of
-- booleans with limited ranges are used.
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
Check_Direct_Boolean_Op (N);
-- If this is an intrinsic operation which is not predefined, use
-- the types of its declared arguments to resolve the possibly
-- overloaded operands. Otherwise the operands are unambiguous and
-- specify the expected type.
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, Base_Type (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, T);
Eval_Relational_Op (N);
end if;
end if;
end Resolve_Comparison_Op;
------------------------------------
-- Resolve_Conditional_Expression --
------------------------------------
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;
-----------------------------------------
-- Resolve_Discrete_Subtype_Indication --
-----------------------------------------
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));
-- Rewrite the constraint as a range of Typ
-- to allow compilation to proceed further.
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));
-- Additionally, we must check that the bounds are compatible
-- with the given subtype, which might be different from the
-- type of the context.
Apply_Range_Check (R, S);
-- ??? If the above check statically detects a Constraint_Error
-- it replaces the offending bound(s) of the range R with a
-- Constraint_Error node. When the itype which uses these bounds
-- is frozen the resulting call to Duplicate_Subexpr generates
-- a new temporary for the bounds.
-- Unfortunately there are other itypes that are also made depend
-- on these bounds, so when Duplicate_Subexpr is called they get
-- a forward reference to the newly created temporaries and Gigi
-- aborts on such forward references. This is probably sign of a
-- more fundamental problem somewhere else in either the order of
-- itype freezing or the way certain itypes are constructed.
-- To get around this problem we call Remove_Side_Effects right
-- away if either bounds of R are a Constraint_Error.
declare
L : constant Node_Id := Low_Bound (R);
H : constant 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;
-------------------------
-- Resolve_Entity_Name --
-------------------------
-- Used to resolve identifiers and expanded names
procedure Resolve_Entity_Name (N : Node_Id; Typ : Entity_Id) is
E : constant Entity_Id := Entity (N);
begin
-- If garbage from errors, set to Any_Type and return
if No (E) and then Total_Errors_Detected /= 0 then
Set_Etype (N, Any_Type);
return;
end if;
-- Replace named numbers by corresponding literals. Note that this is
-- the one case where Resolve_Entity_Name must reset the Etype, since
-- it is currently marked as universal.
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);
-- Allow use of subtype only if it is a concurrent type where we are
-- currently inside the body. This will eventually be expanded
-- into a call to Self (for tasks) or _object (for protected
-- objects). Any other use of a subtype is invalid.
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;
-- Check discriminant use if entity is discriminant in current scope,
-- i.e. discriminant of record or concurrent type currently being
-- analyzed. Uses in corresponding body are unrestricted.
elsif Ekind (E) = E_Discriminant
and then Scope (E) = Current_Scope
and then not Has_Completion (Current_Scope)
then
Check_Discriminant_Use (N);
-- A parameterless generic function cannot appear in a context that
-- requires resolution.
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);
-- In all other cases, just do the possible static evaluation
else
-- A deferred constant that appears in an expression must have
-- a completion, unless it has been removed by in-place expansion
-- of an aggregate.
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;
-------------------
-- Resolve_Entry --
-------------------
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;
-- If the bounds of the entry family being called depend on task
-- discriminants, build a new index subtype where a discriminant is
-- replaced with the value of the discriminant of the target task.
-- The target task is the prefix of the entry name in the call.
-----------------------
-- Actual_Index_Type --
-----------------------
function Actual_Index_Type (E : Entity_Id) return Entity_Id is
Typ : constant Entity_Id := Entry_Index_Type (E);
Tsk : constant Entity_Id := Scope (E);
Lo : constant Node_Id := Type_Low_Bound (Typ);
Hi : constant Node_Id := Type_High_Bound (Typ);
New_T : Entity_Id;
function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id;
-- If the bound is given by a discriminant, replace with a reference
-- to the discriminant of the same name in the target task.
-- If the entry name is the target of a requeue statement and the
-- entry is in the current protected object, the bound to be used
-- is the discriminal of the object (see apply_range_checks for
-- details of the transformation).
-----------------------------
-- Actual_Discriminant_Ref --
-----------------------------
function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id is
Typ : constant 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;
-- Start of processing for Actual_Index_Type
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;
-- Start of processing of Resolve_Entry
begin
-- Find name of entry being called, and resolve prefix of name
-- with its own type. The prefix can be overloaded, and the name
-- and signature of the entry must be taken into account.
if Nkind (Entry_Name) = N_Indexed_Component then
-- Case of dealing with entry family within the current tasks
E_Name := Prefix (Entry_Name);
else
E_Name := Entry_Name;
end if;
if Is_Entity_Name (E_Name) then
-- Entry call to an entry (or entry family) in the current task.
-- This is legal even though the task will deadlock. Rewrite as
-- call to current task.
-- This can also be a call to an entry in an enclosing task.
-- If this is a single task, we have to retrieve its name,
-- because the scope of the entry is the task type, not the
-- object. If the enclosing task is a task type, the identity
-- of the task is given by its own self variable.
-- Finally this can be a requeue on an entry of the same task
-- or protected object.
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)