-- --
-- B o d y --
-- --
--- $Revision$
--- --
--- Copyright (C) 1992-2001, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2005 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- --
-- 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. --
+-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
+-- Boston, MA 02110-1301, USA. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
--- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with Einfo; use Einfo;
with Errout; use Errout;
with Expander; use Expander;
+with Exp_Disp; use Exp_Disp;
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 Opt; use Opt;
with Output; use Output;
with Restrict; use Restrict;
+with Rident; use Rident;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
with Sem_Aggr; use Sem_Aggr;
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;
-- 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_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.
+ -- 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;
function Operator_Kind
(Op_Name : Name_Id;
- Is_Binary : Boolean)
- return Node_Kind;
+ 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.
+ -- N is the Node_Id for the subprogram call, and Nam is the entity of the
+ -- called subprogram.
procedure Resolve_Entry_Call (N : Node_Id; Typ : Entity_Id);
-- Called from Resolve_Call, when the prefix denotes an entry or element
-- 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.
-- 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);
+ procedure Rewrite_Renamed_Operator
+ (N : Node_Id;
+ Op : Entity_Id;
+ Typ : Entity_Id);
-- An operator can rename another, e.g. in an instantiation. In that
- -- case, the proper operator node must be constructed.
+ -- case, the proper operator node must be constructed and resolved.
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 String the function is a no-op.
+ -- 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.
+ -- 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
+ -- 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;
+ 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
("\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;
+ while Present (E) loop
+ Error_Msg_NE ("\possible interpretation:}!", C, Etype (E));
+ E := Homonym (E);
+ end loop;
end if;
end Ambiguous_Character;
procedure Analyze_And_Resolve (N : Node_Id) is
begin
Analyze (N);
- Resolve (N, Etype (N));
+ Resolve (N);
end Analyze_And_Resolve;
procedure Analyze_And_Resolve (N : Node_Id; Typ : Entity_Id) is
Typ : Entity_Id;
Suppress : Check_Id)
is
- Scop : Entity_Id := Current_Scope;
+ Scop : constant Entity_Id := Current_Scope;
begin
if Suppress = All_Checks then
declare
- Svg : constant Suppress_Record := Scope_Suppress;
+ Svg : constant Suppress_Array := Scope_Suppress;
begin
Scope_Suppress := (others => True);
else
declare
- Svg : constant Boolean := Get_Scope_Suppress (Suppress);
+ Svg : constant Boolean := Scope_Suppress (Suppress);
begin
- Set_Scope_Suppress (Suppress, True);
+ Scope_Suppress (Suppress) := True;
Analyze_And_Resolve (N, Typ);
- Set_Scope_Suppress (Suppress, Svg);
+ Scope_Suppress (Suppress) := Svg;
end;
end if;
(N : Node_Id;
Suppress : Check_Id)
is
- Scop : Entity_Id := Current_Scope;
+ Scop : constant Entity_Id := Current_Scope;
begin
if Suppress = All_Checks then
declare
- Svg : constant Suppress_Record := Scope_Suppress;
+ Svg : constant Suppress_Array := Scope_Suppress;
begin
Scope_Suppress := (others => True);
else
declare
- Svg : constant Boolean := Get_Scope_Suppress (Suppress);
+ Svg : constant Boolean := Scope_Suppress (Suppress);
begin
- Set_Scope_Suppress (Suppress, True);
+ Scope_Suppress (Suppress) := True;
Analyze_And_Resolve (N);
- Set_Scope_Suppress (Suppress, Svg);
+ Scope_Suppress (Suppress) := Svg;
end;
end if;
end if;
end Analyze_And_Resolve;
+ -----------------------------
+ -- Check_Direct_Boolean_Op --
+ -----------------------------
+
+ procedure Check_Direct_Boolean_Op (N : Node_Id) is
+ begin
+ if Nkind (N) in N_Op
+ and then 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 --
----------------------------
D : Node_Id;
begin
- -- Any use in a default expression is legal.
+ -- 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.
+ -- 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_Declaration
+ and then Nkind (Parent (Parent (P))) = N_Component_Definition
then
Error_Msg_N ("discriminant cannot constrain scalar type", N);
and then Scope (Disc) = Current_Scope
and then not
(Nkind (Parent (P)) = N_Subtype_Indication
- and then
- (Nkind (Parent (Parent (P))) = N_Component_Declaration
- or else Nkind (Parent (Parent (P))) = N_Subtype_Declaration)
+ and then
+ (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
end if;
-- Detect a common beginner error:
+
-- type R (D : Positive := 100) is record
- -- Name: String (1 .. D);
+ -- Name : String (1 .. D);
-- end record;
-- The default value causes an object of type R to be
-- 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
-- Warn about the danger
Error_Msg_N
- ("creation of object of this type may raise Storage_Error?",
- N);
+ ("creation of & object may raise Storage_Error?",
+ Scope (Disc));
<<No_Danger>>
null;
if Paren_Count (N) > 0 then
Error_Msg_N
("discriminant in constraint must appear alone", N);
+
+ elsif Nkind (N) = N_Expanded_Name
+ and then Comes_From_Source (N)
+ then
+ Error_Msg_N
+ ("discriminant must appear alone as a direct name", N);
end if;
return;
else
D := PN;
P := Parent (PN);
-
while Nkind (P) /= N_Component_Declaration
and then Nkind (P) /= N_Subtype_Indication
and then Nkind (P) /= N_Entry_Declaration
if (Nkind (P) = N_Subtype_Indication
and then
- (Nkind (Parent (P)) = N_Component_Declaration
- or else Nkind (Parent (P)) = N_Derived_Type_Definition)
+ (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)
-
+ 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
--------------------------------
procedure Check_For_Visible_Operator (N : Node_Id; T : Entity_Id) is
- Orig_Node : Node_Id := Original_Node (N);
-
begin
- if Comes_From_Source (Orig_Node)
- and then not In_Open_Scopes (Scope (T))
- and then not Is_Potentially_Use_Visible (T)
- and then not In_Use (T)
- and then not In_Use (Scope (T))
- and then (not Present (Entity (N))
- or else Ekind (Entity (N)) /= E_Function)
- and then (Nkind (Orig_Node) /= N_Function_Call
- or else Nkind (Name (Orig_Node)) /= N_Expanded_Name
- or else Entity (Prefix (Name (Orig_Node))) /= Scope (T))
- and then not In_Instance
- then
+ 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);
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.
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
end if;
end loop;
- Warn_On_Instance := True;
Error_Msg_N ("possible infinite recursion?", N);
Error_Msg_N ("\Storage_Error may be raised at run time?", N);
- Warn_On_Instance := False;
return True;
end Check_Infinite_Recursion;
-------------------------------
procedure Check_Initialization_Call (N : Entity_Id; Nam : Entity_Id) is
- Typ : Entity_Id := Etype (First_Formal (Nam));
+ 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)
- or else Has_Controlled_Component (T)
- or else Functions_Return_By_DSP_On_Target
- then
+ if Is_Controlled (T) then
return False;
elsif Is_Array_Type (T) then
elsif Is_Record_Type (T) then
Comp := First_Component (T);
-
while Present (Comp) loop
-
if Ekind (Comp) = E_Component
and then Nkind (Parent (Comp)) = N_Component_Declaration
then
Expr := Expression (Parent (Comp));
- if Nkind (Expr) = N_Function_Call
+ -- 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;
end if;
end Uses_SS;
+ -- Start of processing for Check_Initialization_Call
+
begin
- if Uses_SS (Typ) then
+ -- 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;
procedure Check_Parameterless_Call (N : Node_Id) is
Nam : Node_Id;
+ function Prefix_Is_Access_Subp return Boolean;
+ -- If the prefix is of an access_to_subprogram type, the node must be
+ -- rewritten as a call. Ditto if the prefix is overloaded and all its
+ -- interpretations are access to subprograms.
+
+ ---------------------------
+ -- Prefix_Is_Access_Subp --
+ ---------------------------
+
+ function Prefix_Is_Access_Subp return Boolean is
+ I : Interp_Index;
+ It : Interp;
+
+ begin
+ if not Is_Overloaded (N) then
+ return
+ Ekind (Etype (N)) = E_Subprogram_Type
+ and then Base_Type (Etype (Etype (N))) /= Standard_Void_Type;
+ else
+ Get_First_Interp (N, I, It);
+ while Present (It.Typ) loop
+ if Ekind (It.Typ) /= E_Subprogram_Type
+ or else Base_Type (Etype (It.Typ)) = Standard_Void_Type
+ then
+ return False;
+ end if;
+
+ Get_Next_Interp (I, It);
+ end loop;
+
+ return True;
+ end if;
+ end Prefix_Is_Access_Subp;
+
+ -- Start of processing for Check_Parameterless_Call
+
begin
- if Nkind (N) in N_Has_Etype and then Etype (N) = Any_Type then
+ -- 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;
+
+ -- If the context expects a value, and the name is a procedure,
+ -- this is most likely a missing 'Access. Do not try to resolve
+ -- the parameterless call, error will be caught when the outer
+ -- call is analyzed.
+
+ if Is_Entity_Name (N)
+ and then Ekind (Entity (N)) = E_Procedure
+ and then not Is_Overloaded (N)
+ and then
+ (Nkind (Parent (N)) = N_Parameter_Association
+ or else Nkind (Parent (N)) = N_Function_Call
+ or else Nkind (Parent (N)) = N_Procedure_Call_Statement)
+ then
return;
end if;
-- 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)
+ (Nkind (N) = N_Explicit_Dereference and then Prefix_Is_Access_Subp)
-- 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
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)))))
+ 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
Nam := New_Copy (N);
- -- If overloaded, overload set belongs to new copy.
+ -- If overloaded, overload set belongs to new copy
Save_Interps (N, Nam);
Act1 : Node_Id := First_Actual (N);
Act2 : Node_Id := Next_Actual (Act1);
Error : Boolean := False;
- Is_Binary : constant Boolean := Present (Act2);
+ Func : constant Entity_Id := Entity (Name (N));
+ Is_Binary : constant Boolean := Present (Act2);
Op_Node : Node_Id;
Opnd_Type : Entity_Id;
Orig_Type : Entity_Id := Empty;
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 acess type declared by an access decla-
+ -- 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;
else
Get_First_Interp (Nod, I, It);
-
while Present (It.Typ) loop
-
if Scope (Base_Type (It.Typ)) = S then
return True;
end if;
else
E := First_Entity (Pack);
-
while Present (E) loop
-
if Test (E)
and then not In_Decl
then
end if;
end Type_In_P;
- ---------------------------
- -- Operand_Type_In_Scope --
- ---------------------------
-
-- Start of processing for Make_Call_Into_Operator
begin
or else Scope (Opnd_Type) /= System_Aux_Id
or else Pack /= Scope (System_Aux_Id))
then
- Error := True;
+ if not Is_Overloaded (Right_Opnd (Op_Node)) then
+ Error := True;
+ else
+ Error := not Operand_Type_In_Scope (Pack);
+ end if;
elsif Pack = Standard_Standard
and then not Operand_Type_In_Scope (Standard_Standard)
end if;
Set_Chars (Op_Node, Op_Name);
- Set_Etype (Op_Node, Base_Type (Etype (N)));
+
+ 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;
+
+ -- If this is a call to a function that renames a predefined equality,
+ -- the renaming declaration provides a type that must be used to
+ -- resolve the operands. This must be done now because resolution of
+ -- the equality node will not resolve any remaining ambiguity, and it
+ -- assumes that the first operand is not overloaded.
+
+ if (Op_Name = Name_Op_Eq or else Op_Name = Name_Op_Ne)
+ and then Ekind (Func) = E_Function
+ and then Is_Overloaded (Act1)
+ then
+ Resolve (Act1, Base_Type (Etype (First_Formal (Func))));
+ Resolve (Act2, Base_Type (Etype (First_Formal (Func))));
+ end if;
+
Set_Entity (Op_Node, Op_Id);
Generate_Reference (Op_Id, N, ' ');
Rewrite (N, Op_Node);
- Resolve (N, Typ);
+
+ -- 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.
function Operator_Kind
(Op_Name : Name_Id;
- Is_Binary : Boolean)
- return Node_Kind
+ Is_Binary : Boolean) return Node_Kind
is
Kind : Node_Kind;
Full_Analysis := Save_Full_Analysis;
end Pre_Analyze_And_Resolve;
- -- Version without context type.
+ -- Version without context type
procedure Pre_Analyze_And_Resolve (N : Node_Id) is
Save_Full_Analysis : constant Boolean := Full_Analysis;
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);
Rewrite (N,
Make_Character_Literal (Sloc (N),
Chars => Name_Find,
- Char_Literal_Value => Char_Code (Character'Pos ('A'))));
+ Char_Literal_Value =>
+ UI_From_Int (Character'Pos ('A'))));
Set_Etype (N, Any_Character);
Set_Is_Static_Expression (N);
Is_Remote : Boolean := True;
begin
- -- Check that Typ is a fat pointer with a reference to a RAS as
- -- original access type.
+ -- Check that Typ is a remote access-to-subprogram 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
+ if Is_Remote_Access_To_Subprogram_Type (Typ) then
-- Prefix (N) must statically denote a remote subprogram
-- declared in a package specification.
end if;
end if;
- if Attr = Attribute_Access
- or else Attr = Attribute_Unchecked_Access
- or else Attr = Attribute_Unrestricted_Access
+ -- 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
+ and then Get_PCS_Name /= Name_No_DSA
then
Check_Subtype_Conformant
(New_Id => Entity (Prefix (N)),
Debug_A_Entry ("resolving ", N);
- if Is_Fixed_Point_Type (Typ) then
- Check_Restriction (No_Fixed_Point, 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);
+ 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
-- is compatible with the context (i.e. the type passed to Resolve)
else
- Get_First_Interp (N, I, It);
-
-- Loop through possible interpretations
+ Get_First_Interp (N, I, It);
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 Covers (Typ, It.Typ) then
+ 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
Seen := It.Nam;
Expr_Type := It.Typ;
- -- Matching intepretation that is not the first, maybe an
+ -- 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.
Error_Msg_Sloc := Sloc (Seen);
It1 := Disambiguate (N, I1, I, Typ);
- if It1 = No_Interp then
+ -- 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
or else Nkind (N) = N_Procedure_Call_Statement
then
declare
- A : Node_Id := First_Actual (N);
+ A : Node_Id;
E : Node_Id;
begin
+ A := First_Actual (N);
while Present (A) loop
E := A;
Error_Msg_NE
("ambiguous expression (cannot resolve&)!",
N, It.Nam);
+
Error_Msg_N
("possible interpretation#!", N);
Ambiguous := True;
end if;
Error_Msg_Sloc := Sloc (It.Nam);
- Error_Msg_N ("possible interpretation#!", N);
- -- Disambiguation has succeeded. Skip the remaining
- -- interpretations.
- else
- Seen := It1.Nam;
- Expr_Type := It1.Typ;
+ -- 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;
- while Present (It.Typ) loop
- Get_Next_Interp (I, It);
- end loop;
end if;
end if;
Set_Etype (Name (N), Expr_Type);
end if;
- -- Here if interpetation is incompatible with context type
-
- else
- if Debug_Flag_V then
- Write_Str (" intepretation incompatible with context");
- Write_Eol;
- end if;
end if;
-- Move to next interpretation
-- doesn't think of them this way!)
if Typ = Standard_Void_Type then
- Error_Msg_N ("expect procedure name in procedure call", N);
+
+ -- 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
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.
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
if not Is_Overloaded (Aelmt)
and then Etype (Aelmt) /= Any_Fixed
then
- Resolve (Aelmt, Etype (Aelmt));
+ Resolve (Aelmt);
end if;
if Etype (Aelmt) = Any_Type then
if Is_Overloaded (N)
and then Nkind (N) = N_Function_Call
then
- Error_Msg_Node_2 := Typ;
- Error_Msg_NE ("no visible interpretation of&" &
- " matches expected type&", N, Name (N));
+ 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
begin
Error_Msg_N ("\possible interpretations:", N);
- Get_First_Interp (Name (N), Index, It);
+ 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&",
-- 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
if Typ = Any_Real
and then Expr_Type = Any_Fixed
then
- Error_Msg_N ("Illegal context for mixed mode operation", N);
+ Error_Msg_N ("illegal context for mixed mode operation", N);
Set_Etype (N, Universal_Real);
Ctx_Type := Universal_Real;
end if;
end if;
+ -- 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)))
+ and then
+ Nkind (Parent (Parent (Entity (N))))
+ = N_Subprogram_Renaming_Declaration
+ then
+ Rewrite_Renamed_Operator (N, Alias (Entity (N)), Typ);
+
+ -- If the node is rewritten, it will be fully resolved in
+ -- Rewrite_Renamed_Operator.
+
+ if Analyzed (N) then
+ return;
+ end if;
+ end if;
+ end if;
+
case N_Subexpr'(Nkind (N)) is
when N_Aggregate => Resolve_Aggregate (N, Ctx_Type);
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(9,10)).
+ -- 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
Expand (N);
end if;
-
end Resolve;
- -- Version with check(s) suppressed
-
+ -------------
+ -- 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_Record := Scope_Suppress;
+ Svg : constant Suppress_Array := Scope_Suppress;
begin
Scope_Suppress := (others => True);
else
declare
- Svg : constant Boolean := Get_Scope_Suppress (Suppress);
+ Svg : constant Boolean := Scope_Suppress (Suppress);
begin
- Set_Scope_Suppress (Suppress, True);
+ Scope_Suppress (Suppress) := True;
Resolve (N, Typ);
- Set_Scope_Suppress (Suppress, Svg);
+ 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 --
---------------------
-- 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 --
--------------------
Assoc : Node_Id;
begin
- -- 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.
+ -- Missing argument in call, nothing to insert
- if Present (Default_Value (F)) then
+ 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);
end if;
Set_Parent (Actval, N);
- Analyze_And_Resolve (Actval, Etype (Actval));
- else
- Set_Parent (Actval, N);
-- Resolve aggregates with their base type, to avoid scope
-- anomalies: the subtype was first built in the suprogram
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
Set_Is_Controlling_Actual (Actval);
end if;
- else
- -- Missing argument in call, nothing to insert.
- return;
end if;
-- If the default expression raises constraint error, then just
if Raises_Constraint_Error (Actval) then
Rewrite (Actval,
- Make_Raise_Constraint_Error (Loc));
+ Make_Raise_Constraint_Error (Loc,
+ Reason => CE_Range_Check_Failed));
Set_Raises_Constraint_Error (Actval);
Set_Etype (Actval, Etype (F));
end if;
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
-- 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.
+ -- 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 be needed
+ -- (no representation change can occur) and the parameter is
+ -- passed by reference, so we go ahead and resolve the type
+ -- conversion. Another excpetion is the case of reference to a
+ -- component or subcomponent of a bit-packed array, in which case
+ -- we want to defer expansion to the point the in and out
+ -- assignments are performed.
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 Conversion_OK (A)
- or else Valid_Conversion (A, Etype (A), Expression (A))
+ if Ekind (F) = E_In_Out_Parameter
+ and then Is_Array_Type (Etype (F))
then
- Resolve (Expression (A), Etype (Expression (A)));
+ if Has_Aliased_Components (Etype (Expression (A)))
+ /= Has_Aliased_Components (Etype (F))
+ then
+ if Ada_Version < Ada_05 then
+ Error_Msg_N
+ ("both component types in a view conversion must be"
+ & " aliased, or neither", A);
+
+ -- Ada 2005: rule is relaxed (see AI-363)
+
+ elsif Has_Aliased_Components (Etype (F))
+ and then
+ not Has_Aliased_Components (Etype (Expression (A)))
+ then
+ Error_Msg_N
+ ("view conversion operand must have aliased " &
+ "components", N);
+ Error_Msg_N
+ ("\since target type has aliased components", N);
+ end if;
+
+ 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)))
+ and then not Is_Ref_To_Bit_Packed_Array (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);
+
+ 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);
- if Ekind (F) /= E_In_Parameter
- and then not Is_OK_Variable_For_Out_Formal (A)
- then
- -- Specialize error message for protected procedure call
- -- within function call of the same protected object.
-
- if Is_Entity_Name (A)
- and then Chars (Entity (A)) = Name_uObject
- and then Ekind (Current_Scope) = E_Function
- and then Convention (Current_Scope) = Convention_Protected
- and then Ekind (Nam) /= E_Function
+ -- 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
- Error_Msg_N ("within protected function, protected " &
- "object is constant", A);
- Error_Msg_N ("\cannot call operation that may modify it", A);
- else
- Error_Msg_NE ("actual for& must be a variable", A, F);
+ Check_Unset_Reference (A);
end if;
- end if;
- if Ekind (F) /= E_Out_Parameter then
- Check_Unset_Reference (A);
+ -- In Ada 83 we cannot pass an OUT parameter as an IN or IN OUT
+ -- actual to a nested call, since this is case of reading an
+ -- out parameter, which is not allowed.
- if Ada_83
+ if Ada_Version = Ada_83
and then Is_Entity_Name (A)
and then Ekind (Entity (A)) = E_Out_Parameter
then
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
else
Apply_Range_Check (A, F_Typ);
end if;
+
+ -- Ada 2005 (AI-231)
+
+ if Ada_Version >= Ada_05
+ and then Is_Access_Type (F_Typ)
+ and then Can_Never_Be_Null (F_Typ)
+ and then Nkind (A) = N_Null
+ then
+ Apply_Compile_Time_Constraint_Error
+ (N => A,
+ Msg => "(Ada 2005) NULL not allowed in "
+ & "null-excluding formal?",
+ Reason => CE_Null_Not_Allowed);
+ 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
and then not Is_Controlling_Formal (F)
then
Error_Msg_N ("class-wide argument not allowed here!", A);
- if Is_Subprogram (Nam) then
+
+ 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);
+ ("& is not a dispatching 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)))))
+ 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) then
+
+ 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);
+ ("& is not a dispatching operation of &!", A, Nam);
end if;
end if;
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;
-----------------------
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 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);
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
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
end if;
end if;
+ -- Ada 2005 (AI-344): A class-wide allocator requires an accessibility
+ -- check that the level of the type of the created object is not deeper
+ -- than the level of the allocator's access type, since extensions can
+ -- now occur at deeper levels than their ancestor types. This is a
+ -- static accessibility level check; a run-time check is also needed in
+ -- the case of an initialized allocator with a class-wide argument (see
+ -- Expand_Allocator_Expression).
+
+ if Ada_Version >= Ada_05
+ and then Is_Class_Wide_Type (Designated_Type (Typ))
+ then
+ declare
+ Exp_Typ : Entity_Id;
+
+ begin
+ if Nkind (E) = N_Qualified_Expression then
+ Exp_Typ := Etype (E);
+ elsif Nkind (E) = N_Subtype_Indication then
+ Exp_Typ := Entity (Subtype_Mark (Original_Node (E)));
+ else
+ Exp_Typ := Entity (E);
+ end if;
+
+ if Type_Access_Level (Exp_Typ) > Type_Access_Level (Typ) then
+ if In_Instance_Body then
+ Error_Msg_N ("?type in allocator has deeper level than" &
+ " designated class-wide type", E);
+ Error_Msg_N ("?Program_Error will be raised at run time", E);
+ Rewrite (N,
+ Make_Raise_Program_Error (Sloc (N),
+ Reason => PE_Accessibility_Check_Failed));
+ Set_Etype (N, Typ);
+ else
+ Error_Msg_N ("type in allocator has deeper level than" &
+ " designated class-wide type", E);
+ end if;
+ end if;
+ end;
+ 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));
+ Make_Raise_Storage_Error (Loc,
+ Reason => SE_Empty_Storage_Pool));
end;
+
+ -- If the context is an unchecked conversion, as may happen within
+ -- an inlined subprogram, the allocator is being resolved with its
+ -- own anonymous type. In that case, if the target type has a specific
+ -- storage pool, it must be inherited explicitly by the allocator type.
+
+ elsif Nkind (Parent (N)) = N_Unchecked_Type_Conversion
+ and then No (Associated_Storage_Pool (Typ))
+ then
+ Set_Associated_Storage_Pool
+ (Typ, Associated_Storage_Pool (Etype (Parent (N))));
end if;
end Resolve_Allocator;
-- 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);
- T : Entity_Id;
- TL : Entity_Id := Base_Type (Etype (L));
- TR : Entity_Id := Base_Type (Etype (R));
+ 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
procedure Set_Operand_Type (N : Node_Id);
-- Set operand type to T if universal
- function Universal_Interpretation (N : Node_Id) return Entity_Id;
- -- Find universal type of operand, if any.
-
-----------------------------
-- Is_Integer_Or_Universal --
-----------------------------
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
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)
+ -- 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);
elsif Etype (N) = T
and then B_Typ /= Universal_Fixed
then
- -- Not a mixed-mode operation. Resolve with context.
+ -- 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.
+ -- N may itself be a mixed-mode operation, so use context type
Resolve (N, B_Typ);
-- 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
Get_Next_Interp (Index, It);
end loop;
- -- Reanalyze the literal with the fixed type of the context.
+ -- Reanalyze the literal with the fixed type of the context. If
+ -- context is Universal_Fixed, we are within a conversion, leave
+ -- the literal as a universal real because there is no usable
+ -- fixed type, and the target of the conversion plays no role in
+ -- the resolution.
- if N = L then
- Set_Analyzed (R, False);
- Resolve (R, B_Typ);
- else
- Set_Analyzed (L, False);
- Resolve (L, B_Typ);
- end if;
+ declare
+ Op2 : Node_Id;
+ T2 : Entity_Id;
+
+ begin
+ if N = L then
+ Op2 := R;
+ else
+ Op2 := L;
+ end if;
+
+ if B_Typ = Universal_Fixed
+ and then Nkind (Op2) = N_Real_Literal
+ then
+ T2 := Universal_Real;
+ else
+ T2 := B_Typ;
+ end if;
+
+ Set_Analyzed (Op2, False);
+ Resolve (Op2, T2);
+ end;
else
- Resolve (N, Etype (N));
+ Resolve (N);
end if;
end Set_Mixed_Mode_Operand;
end if;
end Set_Operand_Type;
- ------------------------------
- -- Universal_Interpretation --
- ------------------------------
-
- function Universal_Interpretation (N : Node_Id) return Entity_Id is
- Index : Interp_Index;
- It : Interp;
-
- begin
- if not Is_Overloaded (N) then
-
- if Etype (N) = Universal_Integer
- or else Etype (N) = Universal_Real
- then
- return Etype (N);
- else
- return Empty;
- end if;
-
- else
- Get_First_Interp (N, Index, It);
-
- while Present (It.Typ) loop
-
- if It.Typ = Universal_Integer
- or else It.Typ = Universal_Real
- then
- return It.Typ;
- end if;
-
- Get_Next_Interp (Index, It);
- end loop;
-
- return Empty;
- end if;
- end Universal_Interpretation;
-
-- 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 Present (First_Rep_Item (Entity (N)))
+ and then Is_Intrinsic_Subprogram (Entity (N))
then
Resolve_Intrinsic_Operator (N, Typ);
return;
Set_Etype (R, Any_Type);
else
- if Ada_83
+ if Ada_Version = 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
Set_Operand_Type (R);
end if;
- Generate_Operator_Reference (N);
+ Generate_Operator_Reference (N, Typ);
Eval_Arithmetic_Op (N);
-- Set overflow and division checking bit. Much cleverer code needed
if Nkind (N) in N_Op then
if not Overflow_Checks_Suppressed (Etype (N)) then
- Set_Do_Overflow_Check (N);
+ 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
- Set_Do_Division_Check (N);
+ 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;
------------------
It : Interp;
Norm_OK : Boolean;
Scop : Entity_Id;
+ W : 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.
+ -- 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.
+ -- 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;
+ Get_First_Interp (Subp, I, It);
while Present (It.Typ) loop
-
if Covers (Typ, Etype (It.Typ)) then
Nam := It.Typ;
exit;
Resolve (Subp, Nam);
end if;
- -- 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.
+ -- 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
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
else
pragma Assert (Is_Overloaded (Subp));
- Nam := Empty; -- We know that it will be assigned in loop below.
+ 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;
end;
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.
+ -- 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;
+
+ -- Deal with call to obsolescent subprogram. Note that we always allow
+ -- such calls in the compiler itself and the run-time, since we assume
+ -- that we know what we are doing in such cases. For example, the calls
+ -- in Ada.Characters.Handling to its own obsolescent subprograms are
+ -- just fine.
+
+ if Is_Obsolescent (Nam) and then not GNAT_Mode then
+ Check_Restriction (No_Obsolescent_Features, N);
+
+ if Warn_On_Obsolescent_Feature then
+ Error_Msg_NE ("call to obsolescent subprogram&?", N, Nam);
+
+ -- Output additional warning if present
+
+ W := Obsolescent_Warning (Nam);
+
+ if Present (W) then
+ Name_Buffer (1) := '|';
+ Name_Buffer (2) := '?';
+ Name_Len := 2;
+
+ -- Add characters to message, and output message
+
+ for J in 1 .. String_Length (Strval (W)) loop
+ Add_Char_To_Name_Buffer (''');
+ Add_Char_To_Name_Buffer
+ (Get_Character (Get_String_Char (Strval (W), J)));
+ end loop;
+
+ Error_Msg_N (Name_Buffer (1 .. Name_Len), N);
+ end if;
+ 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);
+ if Ada_Version < Ada_05 then
+ Error_Msg_N ("entry call required in select statement", N);
+
+ -- Ada 2005 (AI-345): If a procedure_call_statement is used
+ -- for a procedure_or_entry_call, the procedure_name or pro-
+ -- cedure_prefix of the procedure_call_statement shall denote
+ -- an entry renamed by a procedure, or (a view of) a primitive
+ -- subprogram of a limited interface whose first parameter is
+ -- a controlling parameter.
+
+ elsif Nkind (N) = N_Procedure_Call_Statement
+ and then not Is_Renamed_Entry (Nam)
+ and then not Is_Controlling_Limited_Procedure (Nam)
+ then
+ Error_Msg_N
+ ("procedure or entry call required in select statement", N);
+ end if;
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.
+ -- 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.
+ -- 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.
+ -- 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
then
declare
Index_Node : Node_Id;
+ New_Subp : Node_Id;
+ Ret_Type : constant Entity_Id := Etype (Nam);
begin
- Check_Elab_Call (N);
-
- if Component_Type (Etype (Nam)) /= Any_Type then
- Index_Node :=
- Make_Indexed_Component (Loc,
- Prefix =>
- Make_Function_Call (Loc,
- Name => New_Occurrence_Of (Nam, Loc)),
- Expressions => Parameter_Associations (N));
-
- -- 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), Etype (Nam));
- Set_Etype (N, Typ);
- Resolve_Indexed_Component (N, Typ);
+ 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;
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.
+ -- 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 not Restriction_Active (No_Recursion)
and then Check_Infinite_Recursion (N)
then
-- Here we detected and flagged an infinite recursion, so we do
-- 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.
return;
end if;
- -- Create a transient scope if the resulting type requires it.
- -- There are 3 notable exceptions: in init_procs, the transient scope
+ -- 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
-- 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
+ -- for it, precisely because we will not do it within the init proc
-- itself.
if Expander_Active
Establish_Transient_Scope
(N, Sec_Stack => not Functions_Return_By_DSP_On_Target);
- elsif Chars (Nam) = Name_uInit_Proc
+ -- 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);
Copy_Node (Subp, N);
Resolve_Entity_Name (N, Typ);
- -- Avoid validation, since it is a static function call.
+ -- Avoid validation, since it is a static function call
return;
end if;
then
Check_Dispatching_Call (N);
- -- If the subprogram is abstract, check that the call has a
- -- controlling argument (i.e. is dispatching) or is disptaching on
- -- result
-
- if Is_Abstract (Nam)
- and then No (Controlling_Argument (N))
- and then not Is_Class_Wide_Type (Typ)
- and then not Is_Tag_Indeterminate (N)
- then
- Error_Msg_N ("call to abstract subprogram must be dispatching", N);
- end if;
-
elsif Is_Abstract (Nam)
and then not In_Instance
then
Check_Intrinsic_Call (N);
end if;
- -- If we fall through we definitely have a non-static call
-
+ Eval_Call (N);
Check_Elab_Call (N);
-
end Resolve_Call;
-------------------------------
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.
+ -- Wide_Wide_Character literals must always be defined, since the set
+ -- of wide wide character literals is complete, i.e. if a character
+ -- literal is accepted by the parser, then it is OK for wide wide
+ -- character (out of range character literals are rejected).
- if Root_Type (B_Typ) = Standard_Wide_Character then
+ if Root_Type (B_Typ) = Standard_Wide_Wide_Character then
return;
-- Always accept character literal for type Any_Character, which
-- the literal is in range
elsif Root_Type (B_Typ) = Standard_Character then
- if In_Character_Range (Char_Literal_Value (N)) then
+ if In_Character_Range (UI_To_CC (Char_Literal_Value (N))) then
return;
end if;
+ -- For Standard.Wide_Character or a type derived from it, check
+ -- that the literal is in range
+
+ elsif Root_Type (B_Typ) = Standard_Wide_Character then
+ if In_Wide_Character_Range (UI_To_CC (Char_Literal_Value (N))) then
+ return;
+ end if;
+
+ -- For Standard.Wide_Wide_Character or a type derived from it, we
+ -- know the literal is in range, since the parser checked!
+
+ elsif Root_Type (B_Typ) = Standard_Wide_Wide_Character then
+ return;
+
-- If the entity is already set, this has already been resolved in
-- a generic context, or comes from expansion. Nothing else to do.
else
C := Current_Entity (N);
-
while Present (C) loop
if Etype (C) = B_Typ then
Set_Entity_With_Style_Check (N, C);
Error_Msg_NE
("character not defined for }", N, First_Subtype (B_Typ));
-
end Resolve_Character_Literal;
---------------------------
---------------------------
-- Context requires a boolean type, and plays no role in resolution.
- -- Processing identical to that for equality operators.
+ -- 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);
if Scope (Entity (N)) /= Standard_Standard then
T := Etype (First_Entity (Entity (N)));
+
else
T := Find_Unique_Type (L, R);
end if;
end if;
- Set_Etype (N, Typ);
+ 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
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);
+ Generate_Operator_Reference (N, T);
Eval_Relational_Op (N);
+ Check_Direct_Boolean_Op (N);
end if;
end if;
-
end Resolve_Comparison_Op;
------------------------------------
-- away if either bounds of R are a Constraint_Error.
declare
- L : Node_Id := Low_Bound (R);
- H : Node_Id := High_Bound (R);
+ L : constant Node_Id := Low_Bound (R);
+ H : constant Node_Id := High_Bound (R);
begin
if Nkind (L) = N_Raise_Constraint_Error then
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.
null;
else
Error_Msg_N
- ("Invalid use of subtype mark in expression or call", N);
+ ("invalid use of subtype mark in expression or call", N);
end if;
-- Check discriminant use if entity is discriminant in current scope,
Error_Msg_N ("illegal use of generic function", N);
elsif Ekind (E) = E_Out_Parameter
- and then Ada_83
+ and then Ada_Version = Ada_83
and then (Nkind (Parent (N)) in N_Op
or else (Nkind (Parent (N)) = N_Assignment_Statement
and then N = Expression (Parent (N)))
-----------------------
function Actual_Index_Type (E : Entity_Id) return Entity_Id is
- Typ : Entity_Id := Entry_Index_Type (E);
- Tsk : Entity_Id := Scope (E);
- Lo : Node_Id := Type_Low_Bound (Typ);
- Hi : Node_Id := Type_High_Bound (Typ);
+ 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;
-----------------------------
function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id is
- Typ : Entity_Id := Etype (Bound);
+ Typ : constant Entity_Id := Etype (Bound);
Ref : Node_Id;
begin
-- the type in the same declarative part.
Tsk := Next_Entity (S);
-
while Etype (Tsk) /= S loop
Next_Entity (Tsk);
end loop;
-- protected type.
declare
- Pref : Node_Id := Prefix (Entry_Name);
+ Pref : constant Node_Id := Prefix (Entry_Name);
+ Ent : constant Entity_Id := Entity (Selector_Name (Entry_Name));
I : Interp_Index;
It : Interp;
- Ent : Entity_Id := Entity (Selector_Name (Entry_Name));
begin
Get_First_Interp (Pref, I, It);
-
while Present (It.Typ) loop
-
if Scope (Ent) = It.Typ then
Set_Etype (Pref, It.Typ);
exit;
end if;
if Nkind (Entry_Name) = N_Selected_Component then
- Resolve (Prefix (Entry_Name), Etype (Prefix (Entry_Name)));
+ Resolve (Prefix (Entry_Name));
else pragma Assert (Nkind (Entry_Name) = N_Indexed_Component);
Nam := Entity (Selector_Name (Prefix (Entry_Name)));
- Resolve (Prefix (Prefix (Entry_Name)),
- Etype (Prefix (Prefix (Entry_Name))));
-
+ Resolve (Prefix (Prefix (Entry_Name)));
Index := First (Expressions (Entry_Name));
Resolve (Index, Entry_Index_Type (Nam));
Apply_Range_Check (Index, Actual_Index_Type (Nam));
end if;
end if;
-
end Resolve_Entry;
------------------------
Was_Over : Boolean;
begin
+ -- We kill all checks here, because it does not seem worth the
+ -- effort to do anything better, an entry call is a big operation.
+
+ Kill_All_Checks;
+
-- Processing of the name is similar for entry calls and protected
-- operation calls. Once the entity is determined, we can complete
-- the resolution of the actuals.
begin
Get_First_Interp (Selector_Name (Entry_Name), I, It);
-
while Present (It.Typ) loop
-
if Covers (Typ, It.Typ) then
Set_Entity (Selector_Name (Entry_Name), It.Nam);
Set_Etype (Entry_Name, It.Typ);
if Nkind (Entry_Name) = N_Selected_Component then
- -- Simple entry call.
+ -- Simple entry call
Nam := Entity (Selector_Name (Entry_Name));
Obj := Prefix (Entry_Name);
else pragma Assert (Nkind (Entry_Name) = N_Indexed_Component);
- -- Call to member of entry family.
+ -- Call to member of entry family
Nam := Entity (Selector_Name (Prefix (Entry_Name)));
Obj := Prefix (Prefix (Entry_Name));
Was_Over := Is_Overloaded (Selector_Name (Prefix (Entry_Name)));
end if;
+ -- We cannot in general check the maximum depth of protected entry
+ -- calls at compile time. But we can tell that any protected entry
+ -- call at all violates a specified nesting depth of zero.
+
+ if Is_Protected_Type (Scope (Nam)) then
+ Check_Restriction (Max_Entry_Queue_Length, N);
+ end if;
+
-- Use context type to disambiguate a protected function that can be
-- called without actuals and that returns an array type, and where
-- the argument list may be an indexing of the returned value.
end if;
-- The operation name may have been overloaded. Order the actuals
- -- according to the formals of the resolved entity.
+ -- according to the formals of the resolved entity, and set the
+ -- return type to that of the operation.
if Was_Over then
Normalize_Actuals (N, Nam, False, Norm_OK);
pragma Assert (Norm_OK);
+ Set_Etype (N, Etype (Nam));
end if;
Resolve_Actuals (N, Nam);
-- call where an entry call is expected.
if Ekind (Nam) = E_Procedure then
-
if Nkind (Parent (N)) = N_Entry_Call_Alternative
and then N = Entry_Call_Statement (Parent (N))
then
elsif Ekind (Scope (Nam)) = E_Task_Type
and then not In_Open_Scopes (Scope (Nam))
then
- Error_Msg_N ("Task has no entry with this name", Entry_Name);
+ Error_Msg_N ("task has no entry with this name", Entry_Name);
end if;
end if;
Set_Analyzed (N, True);
-- Protected functions can return on the secondary stack, in which
- -- case we must trigger the transient scope mechanism
+ -- case we must trigger the transient scope mechanism.
elsif Expander_Active
and then Requires_Transient_Scope (Etype (Nam))
Establish_Transient_Scope (N,
Sec_Stack => not Functions_Return_By_DSP_On_Target);
end if;
-
end Resolve_Entry_Call;
-------------------------
function Find_Unique_Access_Type return Entity_Id is
Acc : Entity_Id;
E : Entity_Id;
- S : Entity_Id := Current_Scope;
+ S : Entity_Id;
begin
if Ekind (Etype (R)) = E_Allocator_Type then
return Empty;
end if;
+ S := Current_Scope;
while S /= Standard_Standard loop
E := First_Entity (S);
-
while Present (E) loop
-
if Is_Type (E)
and then Is_Access_Type (E)
and then Ekind (E) /= E_Allocator_Type
end if;
if T /= Any_Type then
-
if T = Any_String
or else T = Any_Composite
or else T = Any_Character
then
-
if T = Any_Character then
Ambiguous_Character (L);
else
end if;
end if;
- if Comes_From_Source (N)
- and then Has_Unchecked_Union (T)
+ Resolve (L, T);
+ Resolve (R, T);
+
+ if Warn_On_Redundant_Constructs
+ and then Comes_From_Source (N)
+ and then Is_Entity_Name (R)
+ and then Entity (R) = Standard_True
+ and then Comes_From_Source (R)
then
- Error_Msg_N
- ("cannot compare Unchecked_Union values", N);
+ Error_Msg_N ("comparison with True is redundant?", R);
end if;
- Resolve (L, T);
- Resolve (R, T);
Check_Unset_Reference (L);
Check_Unset_Reference (R);
- Generate_Operator_Reference (N);
+ Generate_Operator_Reference (N, T);
-- If this is an inequality, it may be the implicit inequality
-- created for a user-defined operation, in which case the corres-
then
Error_Msg_NE ("cannot call abstract subprogram &!", N, Entity (N));
end if;
+
+ Check_Direct_Boolean_Op (N);
end if;
end Resolve_Equality_Op;
----------------------------------
procedure Resolve_Explicit_Dereference (N : Node_Id; Typ : Entity_Id) is
- P : constant Node_Id := Prefix (N);
- I : Interp_Index;
- It : Interp;
+ Loc : constant Source_Ptr := Sloc (N);
+ New_N : Node_Id;
+ P : constant Node_Id := Prefix (N);
+ I : Interp_Index;
+ It : Interp;
begin
- -- Now that we know the type, check that this is not a
- -- dereference of an uncompleted type. Note that this
- -- is not entirely correct, because dereferences of
- -- private types are legal in default expressions.
- -- This consideration also applies to similar checks
- -- for allocators, qualified expressions, and type
- -- conversions. ???
+ -- Now that we know the type, check that this is not dereference of an
+ -- uncompleted type. Note that this is not entirely correct, because
+ -- dereferences of private types are legal in default expressions. This
+ -- exception is taken care of in Check_Fully_Declared.
+
+ -- This consideration also applies to similar checks for allocators,
+ -- qualified expressions, and type conversions.
+
+ -- An additional exception concerns other per-object expressions that
+ -- are not directly related to component declarations, in particular
+ -- representation pragmas for tasks. These will be per-object
+ -- expressions if they depend on discriminants or some global entity.
+ -- If the task has access discriminants, the designated type may be
+ -- incomplete at the point the expression is resolved. This resolution
+ -- takes place within the body of the initialization procedure, where
+ -- the discriminant is replaced by its discriminal.
+
+ if Is_Entity_Name (Prefix (N))
+ and then Ekind (Entity (Prefix (N))) = E_In_Parameter
+ then
+ null;
+
+ -- Ada 2005 (AI-326): Tagged incomplete types allowed. The wrong usages
+ -- are handled by Analyze_Access_Attribute, Analyze_Assignment, Analyze_
+ -- Object_Renaming, and Freeze_Entity.
- Check_Fully_Declared (Typ, N);
+ elsif Ada_Version >= Ada_05
+ and then Is_Entity_Name (Prefix (N))
+ and then Ekind (Directly_Designated_Type (Etype (Prefix (N))))
+ = E_Incomplete_Type
+ and then Is_Tagged_Type (Directly_Designated_Type (Etype (Prefix (N))))
+ then
+ null;
+ else
+ Check_Fully_Declared (Typ, N);
+ end if;
if Is_Overloaded (P) then
- -- Use the context type to select the prefix that has the
- -- correct designated type.
+ -- Use the context type to select the prefix that has the correct
+ -- designated type.
Get_First_Interp (P, I, It);
while Present (It.Typ) loop
exit when Is_Access_Type (It.Typ)
and then Covers (Typ, Designated_Type (It.Typ));
-
Get_Next_Interp (I, It);
end loop;
- Resolve (P, It.Typ);
+ if Present (It.Typ) then
+ Resolve (P, It.Typ);
+ else
+ -- If no interpretation covers the designated type of the prefix,
+ -- this is the pathological case where not all implementations of
+ -- the prefix allow the interpretation of the node as a call. Now
+ -- that the expected type is known, Remove other interpretations
+ -- from prefix, rewrite it as a call, and resolve again, so that
+ -- the proper call node is generated.
+
+ Get_First_Interp (P, I, It);
+ while Present (It.Typ) loop
+ if Ekind (It.Typ) /= E_Access_Subprogram_Type then
+ Remove_Interp (I);
+ end if;
+
+ Get_Next_Interp (I, It);
+ end loop;
+
+ New_N :=
+ Make_Function_Call (Loc,
+ Name =>
+ Make_Explicit_Dereference (Loc,
+ Prefix => P),
+ Parameter_Associations => New_List);
+
+ Save_Interps (N, New_N);
+ Rewrite (N, New_N);
+ Analyze_And_Resolve (N, Typ);
+ return;
+ end if;
+
Set_Etype (N, Designated_Type (It.Typ));
else
- Resolve (P, Etype (P));
+ Resolve (P);
end if;
if Is_Access_Type (Etype (P)) then
Apply_Access_Check (N);
end if;
- -- If the designated type is a packed unconstrained array type,
- -- and the explicit dereference is not in the context of an
- -- attribute reference, then we must compute and set the actual
- -- subtype, since it is needed by Gigi. The reason we exclude
- -- the attribute case is that this is handled fine by Gigi, and
- -- in fact we use such attributes to build the actual subtype.
- -- We also exclude generated code (which builds actual subtypes
- -- directly if they are needed).
+ -- If the designated type is a packed unconstrained array type, and the
+ -- explicit dereference is not in the context of an attribute reference,
+ -- then we must compute and set the actual subtype, since it is needed
+ -- by Gigi. The reason we exclude the attribute case is that this is
+ -- handled fine by Gigi, and in fact we use such attributes to build the
+ -- actual subtype. We also exclude generated code (which builds actual
+ -- subtypes directly if they are needed).
if Is_Array_Type (Etype (N))
and then Is_Packed (Etype (N))
Set_Etype (N, Get_Actual_Subtype (N));
end if;
- -- Note: there is no Eval processing required for an explicit
- -- deference, because the type is known to be an allocators, and
- -- allocator expressions can never be static.
+ -- Note: there is no Eval processing required for an explicit deference,
+ -- because the type is known to be an allocators, and allocator
+ -- expressions can never be static.
end Resolve_Explicit_Dereference;
begin
if Is_Overloaded (Name) then
- -- Use the context type to select the prefix that yields the
- -- correct component type.
+ -- Use the context type to select the prefix that yields the correct
+ -- component type.
declare
I : Interp_Index;
begin
Get_First_Interp (P, I, It);
-
while Present (It.Typ) loop
-
if (Is_Array_Type (It.Typ)
and then Covers (Typ, Component_Type (It.Typ)))
or else (Is_Access_Type (It.Typ)
Array_Type := Designated_Type (Array_Type);
end if;
- -- If name was overloaded, set component type correctly now.
+ -- If name was overloaded, set component type correctly now
Set_Etype (N, Component_Type (Array_Type));
Index := First_Index (Array_Type);
Expr := First (Expressions (N));
- -- The prefix may have resolved to a string literal, in which case
- -- its etype has a special representation. This is only possible
- -- currently if the prefix is a static concatenation, written in
- -- functional notation.
+ -- The prefix may have resolved to a string literal, in which case its
+ -- etype has a special representation. This is only possible currently
+ -- if the prefix is a static concatenation, written in functional
+ -- notation.
if Ekind (Array_Type) = E_String_Literal_Subtype then
Resolve (Expr, Standard_Positive);
end if;
Eval_Indexed_Component (N);
-
end Resolve_Indexed_Component;
-----------------------------
Eval_Integer_Literal (N);
end Resolve_Integer_Literal;
- ---------------------------------
- -- Resolve_Intrinsic_Operator --
- ---------------------------------
+ --------------------------------
+ -- Resolve_Intrinsic_Operator --
+ --------------------------------
procedure Resolve_Intrinsic_Operator (N : Node_Id; Typ : Entity_Id) is
- Op : Entity_Id;
- Arg1 : Node_Id := Left_Opnd (N);
- Arg2 : Node_Id := Right_Opnd (N);
+ Btyp : constant Entity_Id := Base_Type (Underlying_Type (Typ));
+ Op : Entity_Id;
+ Arg1 : Node_Id;
+ Arg2 : Node_Id;
begin
Op := Entity (N);
-
while Scope (Op) /= Standard_Standard loop
Op := Homonym (Op);
pragma Assert (Present (Op));
end loop;
Set_Entity (N, Op);
+ Set_Is_Overloaded (N, False);
- if Typ /= Etype (Arg1) or else Typ = Etype (Arg2) then
- Rewrite (Left_Opnd (N), Convert_To (Typ, Arg1));
- Rewrite (Right_Opnd (N), Convert_To (Typ, Arg2));
+ -- If the operand type is private, rewrite with suitable conversions on
+ -- the operands and the result, to expose the proper underlying numeric
+ -- type.
- Analyze (Left_Opnd (N));
- Analyze (Right_Opnd (N));
- end if;
+ if Is_Private_Type (Typ) then
+ Arg1 := Unchecked_Convert_To (Btyp, Left_Opnd (N));
- Resolve_Arithmetic_Op (N, Typ);
+ if Nkind (N) = N_Op_Expon then
+ Arg2 := Unchecked_Convert_To (Standard_Integer, Right_Opnd (N));
+ else
+ Arg2 := Unchecked_Convert_To (Btyp, Right_Opnd (N));
+ end if;
+
+ Save_Interps (Left_Opnd (N), Expression (Arg1));
+ Save_Interps (Right_Opnd (N), Expression (Arg2));
+
+ Set_Left_Opnd (N, Arg1);
+ Set_Right_Opnd (N, Arg2);
+
+ Set_Etype (N, Btyp);
+ Rewrite (N, Unchecked_Convert_To (Typ, N));
+ Resolve (N, Typ);
+
+ elsif Typ /= Etype (Left_Opnd (N))
+ or else Typ /= Etype (Right_Opnd (N))
+ then
+ -- Add explicit conversion where needed, and save interpretations
+ -- in case operands are overloaded.
+
+ Arg1 := Convert_To (Typ, Left_Opnd (N));
+ Arg2 := Convert_To (Typ, Right_Opnd (N));
+
+ if Nkind (Arg1) = N_Type_Conversion then
+ Save_Interps (Left_Opnd (N), Expression (Arg1));
+ else
+ Save_Interps (Left_Opnd (N), Arg1);
+ end if;
+
+ if Nkind (Arg2) = N_Type_Conversion then
+ Save_Interps (Right_Opnd (N), Expression (Arg2));
+ else
+ Save_Interps (Right_Opnd (N), Arg2);
+ end if;
+
+ Rewrite (Left_Opnd (N), Arg1);
+ Rewrite (Right_Opnd (N), Arg2);
+ Analyze (Arg1);
+ Analyze (Arg2);
+ Resolve_Arithmetic_Op (N, Typ);
+
+ else
+ Resolve_Arithmetic_Op (N, Typ);
+ end if;
end Resolve_Intrinsic_Operator;
+ --------------------------------------
+ -- Resolve_Intrinsic_Unary_Operator --
+ --------------------------------------
+
+ procedure Resolve_Intrinsic_Unary_Operator
+ (N : Node_Id;
+ Typ : Entity_Id)
+ is
+ Btyp : constant Entity_Id := Base_Type (Underlying_Type (Typ));
+ Op : Entity_Id;
+ Arg2 : Node_Id;
+
+ begin
+ Op := Entity (N);
+ while Scope (Op) /= Standard_Standard loop
+ Op := Homonym (Op);
+ pragma Assert (Present (Op));
+ end loop;
+
+ Set_Entity (N, Op);
+
+ if Is_Private_Type (Typ) then
+ Arg2 := Unchecked_Convert_To (Btyp, Right_Opnd (N));
+ Save_Interps (Right_Opnd (N), Expression (Arg2));
+
+ Set_Right_Opnd (N, Arg2);
+
+ Set_Etype (N, Btyp);
+ Rewrite (N, Unchecked_Convert_To (Typ, N));
+ Resolve (N, Typ);
+
+ else
+ Resolve_Unary_Op (N, Typ);
+ end if;
+ end Resolve_Intrinsic_Unary_Operator;
+
------------------------
-- Resolve_Logical_Op --
------------------------
B_Typ : Entity_Id;
begin
- -- Predefined operations on scalar types yield the base type. On
- -- the other hand, logical operations on arrays yield the type of
- -- the arguments (and the context).
+ -- Predefined operations on scalar types yield the base type. On the
+ -- other hand, logical operations on arrays yield the type of the
+ -- arguments (and the context).
if Is_Array_Type (Typ) then
B_Typ := Typ;
("no modular type available in this context", N);
Set_Etype (N, Any_Type);
return;
+ elsif Is_Modular_Integer_Type (Typ)
+ and then Etype (Left_Opnd (N)) = Universal_Integer
+ and then Etype (Right_Opnd (N)) = Universal_Integer
+ then
+ Check_For_Visible_Operator (N, B_Typ);
end if;
Resolve (Left_Opnd (N), B_Typ);
Check_Unset_Reference (Right_Opnd (N));
Set_Etype (N, B_Typ);
- Generate_Operator_Reference (N);
+ Generate_Operator_Reference (N, B_Typ);
Eval_Logical_Op (N);
+ Check_Direct_Boolean_Op (N);
end Resolve_Logical_Op;
---------------------------
-- rule for universal types applies.
procedure Resolve_Membership_Op (N : Node_Id; Typ : Entity_Id) is
+ pragma Warnings (Off, Typ);
+
L : constant Node_Id := Left_Opnd (N);
R : constant Node_Id := Right_Opnd (N);
T : Entity_Id;
and then Is_Overloaded (L)
then
T := Etype (R);
+
+ -- Ada 2005 (AI-251): Give support to the following case:
+
+ -- type I is interface;
+ -- type T is tagged ...
+
+ -- function Test (O : in I'Class) is
+ -- begin
+ -- return O in T'Class.
+ -- end Test;
+
+ -- In this case we have nothing else to do; the membership test will be
+ -- done at run-time.
+
+ elsif Ada_Version >= Ada_05
+ and then Is_Class_Wide_Type (Etype (L))
+ and then Is_Interface (Etype (L))
+ and then Is_Class_Wide_Type (Etype (R))
+ and then not Is_Interface (Etype (R))
+ then
+ return;
+
else
T := Intersect_Types (L, R);
end if;
procedure Resolve_Null (N : Node_Id; Typ : Entity_Id) is
begin
- -- For now allow circumvention of the restriction against
- -- anonymous null access values via a debug switch to allow
- -- for easier transition.
+ -- Handle restriction against anonymous null access values This
+ -- restriction can be turned off using -gnatdh.
+
+ -- Ada 2005 (AI-231): Remove restriction
- if not Debug_Flag_J
+ if Ada_Version < Ada_05
+ and then not Debug_Flag_J
and then Ekind (Typ) = E_Anonymous_Access_Type
and then Comes_From_Source (N)
then
return;
end if;
- -- The null literal takes its type from the context.
+ -- The null literal takes its type from the context
Set_Etype (N, Typ);
end Resolve_Null;
begin
Get_First_Interp (Arg, I, It);
-
while Present (It.Nam) loop
-
if Base_Type (Etype (It.Nam)) = Base_Type (Typ)
or else Base_Type (Etype (It.Nam)) =
Base_Type (Component_Type (Typ))
Resolve (Arg, Component_Type (Typ));
+ if Nkind (Arg) = N_String_Literal then
+ Set_Etype (Arg, Component_Type (Typ));
+ end if;
+
if Arg = Left_Opnd (N) then
Set_Is_Component_Left_Opnd (N);
else
if Is_Limited_Composite (Btyp) then
Error_Msg_N ("concatenation not available for limited array", N);
+ Explain_Limited_Type (Btyp, N);
end if;
- -- If the operands are themselves concatenations, resolve them as
- -- such directly. This removes several layers of recursion and allows
- -- GNAT to handle larger multiple concatenations.
+ -- If the operands are themselves concatenations, resolve them as such
+ -- directly. This removes several layers of recursion and allows GNAT to
+ -- handle larger multiple concatenations.
if Nkind (Op1) = N_Op_Concat
and then not Is_Array_Type (Component_Type (Typ))
(Op2, Is_Component_Right_Opnd (N));
end if;
- Generate_Operator_Reference (N);
+ Generate_Operator_Reference (N, Typ);
if Is_String_Type (Typ) then
Eval_Concatenation (N);
begin
-- Catch attempts to do fixed-point exponentation with universal
- -- operands, which is a case where the illegality is not caught
- -- during normal operator analysis.
+ -- operands, which is a case where the illegality is not caught during
+ -- normal operator analysis.
if Is_Fixed_Point_Type (Typ) and then Comes_From_Source (N) then
Error_Msg_N ("exponentiation not available for fixed point", N);
return;
end if;
+ if 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;
+ end if;
+
if Etype (Left_Opnd (N)) = Universal_Integer
or else Etype (Left_Opnd (N)) = Universal_Real
then
Check_Unset_Reference (Right_Opnd (N));
Set_Etype (N, B_Typ);
- Generate_Operator_Reference (N);
+ Generate_Operator_Reference (N, B_Typ);
Eval_Op_Expon (N);
-- Set overflow checking bit. Much cleverer code needed here eventually
if Nkind (N) in N_Op then
if not Overflow_Checks_Suppressed (Etype (N)) then
- Set_Do_Overflow_Check (N, True);
+ Enable_Overflow_Check (N);
end if;
end if;
-
end Resolve_Op_Expon;
--------------------
-- Start of processing for Resolve_Op_Not
begin
- -- Predefined operations on scalar types yield the base type. On
- -- the other hand, logical operations on arrays yield the type of
- -- the arguments (and the context).
+ -- Predefined operations on scalar types yield the base type. On the
+ -- other hand, logical operations on arrays yield the type of the
+ -- arguments (and the context).
if Is_Array_Type (Typ) then
B_Typ := Typ;
Set_Etype (N, Any_Type);
return;
- elsif (Typ = Universal_Integer
- or else Typ = Any_Modular)
- then
+ elsif Typ = Universal_Integer or else Typ = Any_Modular then
if Parent_Is_Boolean then
Error_Msg_N
("operand of not must be enclosed in parentheses",
Resolve (Right_Opnd (N), B_Typ);
Check_Unset_Reference (Right_Opnd (N));
Set_Etype (N, B_Typ);
- Generate_Operator_Reference (N);
+ Generate_Operator_Reference (N, B_Typ);
Eval_Op_Not (N);
end if;
end Resolve_Op_Not;
-- Nothing to be done, all resolved already
procedure Resolve_Operator_Symbol (N : Node_Id; Typ : Entity_Id) is
+ pragma Warnings (Off, N);
+ pragma Warnings (Off, Typ);
+
begin
null;
end Resolve_Operator_Symbol;
----------------------------------
procedure Resolve_Qualified_Expression (N : Node_Id; Typ : Entity_Id) is
+ pragma Warnings (Off, Typ);
+
Target_Typ : constant Entity_Id := Entity (Subtype_Mark (N));
Expr : constant Node_Id := Expression (N);
Resolve (Expr, Target_Typ);
-- A qualified expression requires an exact match of the type,
- -- class-wide matching is not allowed.
-
- if Is_Class_Wide_Type (Target_Typ)
+ -- class-wide matching is not allowed. However, if the qualifying
+ -- type is specific and the expression has a class-wide type, it
+ -- may still be okay, since it can be the result of the expansion
+ -- of a call to a dispatching function, so we also have to check
+ -- class-wideness of the type of the expression's original node.
+
+ if (Is_Class_Wide_Type (Target_Typ)
+ or else
+ (Is_Class_Wide_Type (Etype (Expr))
+ and then Is_Class_Wide_Type (Etype (Original_Node (Expr)))))
and then Base_Type (Etype (Expr)) /= Base_Type (Target_Typ)
then
Wrong_Type (Expr, Target_Typ);
Check_Unset_Reference (H);
-- We have to check the bounds for being within the base range as
- -- required for a non-static context. Normally this is automatic
- -- and done as part of evaluating expressions, but the N_Range
- -- node is an exception, since in GNAT we consider this node to
- -- be a subexpression, even though in Ada it is not. The circuit
- -- in Sem_Eval could check for this, but that would put the test
- -- on the main evaluation path for expressions.
+ -- required for a non-static context. Normally this is automatic and
+ -- done as part of evaluating expressions, but the N_Range node is an
+ -- exception, since in GNAT we consider this node to be a subexpression,
+ -- even though in Ada it is not. The circuit in Sem_Eval could check for
+ -- this, but that would put the test on the main evaluation path for
+ -- expressions.
Check_Non_Static_Context (L);
Check_Non_Static_Context (H);
+ -- If bounds are static, constant-fold them, so size computations
+ -- are identical between front-end and back-end. Do not perform this
+ -- transformation while analyzing generic units, as type information
+ -- would then be lost when reanalyzing the constant node in the
+ -- instance.
+
+ if Is_Discrete_Type (Typ) and then Expander_Active then
+ if Is_OK_Static_Expression (L) then
+ Fold_Uint (L, Expr_Value (L), Is_Static_Expression (L));
+ end if;
+
+ if Is_OK_Static_Expression (H) then
+ Fold_Uint (H, Expr_Value (H), Is_Static_Expression (H));
+ end if;
+ end if;
end Resolve_Range;
--------------------------
Error_Msg_N ("value has extraneous low order digits", N);
end if;
+ -- Generate a warning if literal from source
+
+ if Is_Static_Expression (N)
+ and then Warn_On_Bad_Fixed_Value
+ then
+ Error_Msg_N
+ ("static fixed-point value is not a multiple of Small?",
+ N);
+ end if;
+
-- Replace literal by a value that is the exact representation
-- of a value of the type, i.e. a multiple of the small value,
-- by truncation, since Machine_Rounds is false for all GNAT
-- If we are taking the reference of a volatile entity, then treat
-- it as a potential modification of this entity. This is much too
- -- conservative, but is neccessary because remove side effects can
+ -- conservative, but is necessary because remove side effects can
-- result in transformations of normal assignments into reference
-- sequences that otherwise fail to notice the modification.
- if Is_Entity_Name (P) and then Is_Volatile (Entity (P)) then
+ if Is_Entity_Name (P) and then Treat_As_Volatile (Entity (P)) then
Note_Possible_Modification (P);
end if;
end Resolve_Reference;
It1 : Interp;
Found : Boolean;
+ function Init_Component return Boolean;
+ -- Check whether this is the initialization of a component within an
+ -- init proc (by assignment or call to another init proc). If true,
+ -- there is no need for a discriminant check.
+
+ --------------------
+ -- Init_Component --
+ --------------------
+
+ function Init_Component return Boolean is
+ begin
+ return Inside_Init_Proc
+ and then Nkind (Prefix (N)) = N_Identifier
+ and then Chars (Prefix (N)) = Name_uInit
+ and then Nkind (Parent (Parent (N))) = N_Case_Statement_Alternative;
+ end Init_Component;
+
+ -- Start of processing for Resolve_Selected_Component
+
begin
if Is_Overloaded (P) then
if Is_Record_Type (T) then
Comp := First_Entity (T);
-
while Present (Comp) loop
-
if Chars (Comp) = Chars (S)
and then Covers (Etype (Comp), Typ)
then
-- Find the component with the right name.
Comp1 := First_Entity (It1.Typ);
-
while Present (Comp1)
and then Chars (Comp1) /= Chars (S)
loop
end if;
Get_Next_Interp (I, It);
-
end loop Search;
Resolve (P, It1.Typ);
Set_Entity (S, Comp1);
else
- -- Resolve prefix with its type.
+ -- Resolve prefix with its type
Resolve (P, T);
end if;
- -- Deal with access type case
+ -- If prefix is an access type, the node will be transformed into
+ -- an explicit dereference during expansion. The type of the node
+ -- is the designated type of that of the prefix.
if Is_Access_Type (Etype (P)) then
- Apply_Access_Check (N);
T := Designated_Type (Etype (P));
else
T := Etype (P);
end if;
if Has_Discriminants (T)
+ and then (Ekind (Entity (S)) = E_Component
+ or else
+ Ekind (Entity (S)) = E_Discriminant)
and then Present (Original_Record_Component (Entity (S)))
and then Ekind (Original_Record_Component (Entity (S))) = E_Component
and then Present (Discriminant_Checking_Func
(Original_Record_Component (Entity (S))))
and then not Discriminant_Checks_Suppressed (T)
+ and then not Init_Component
then
Set_Do_Discriminant_Check (N);
end if;
if Nkind (P) = N_Type_Conversion
and then Ekind (Entity (S)) = E_Discriminant
+ and then Is_Discrete_Type (Typ)
then
Set_Etype (N, Base_Type (Typ));
end if;
Check_Unset_Reference (R);
Set_Etype (N, B_Typ);
- Generate_Operator_Reference (N);
+ Generate_Operator_Reference (N, B_Typ);
Eval_Shift (N);
end Resolve_Shift;
begin
Get_First_Interp (P, I, It);
-
while Present (It.Typ) loop
-
if (Is_Array_Type (It.Typ)
and then Covers (Typ, It.Typ))
or else (Is_Access_Type (It.Typ)
Apply_Access_Check (N);
Array_Type := Designated_Type (Array_Type);
+ -- If the prefix is an access to an unconstrained array, we must
+ -- use the actual subtype of the object to perform the index checks.
+ -- The object denoted by the prefix is implicit in the node, so we
+ -- build an explicit representation for it in order to compute the
+ -- actual subtype.
+
+ if not Is_Constrained (Array_Type) then
+ Remove_Side_Effects (Prefix (N));
+
+ declare
+ Obj : constant Node_Id :=
+ Make_Explicit_Dereference (Sloc (N),
+ Prefix => New_Copy_Tree (Prefix (N)));
+ begin
+ Set_Etype (Obj, Array_Type);
+ Set_Parent (Obj, Parent (N));
+ Array_Type := Get_Actual_Subtype (Obj);
+ end;
+ end if;
+
elsif Is_Entity_Name (Name)
or else (Nkind (Name) = N_Function_Call
and then not Is_Constrained (Etype (Name)))
Set_Etype (N, Array_Type);
-- If the range is specified by a subtype mark, no resolution
- -- is necessary.
+ -- is necessary. Else resolve the bounds, and apply needed checks.
if not Is_Entity_Name (Drange) then
Index := First_Index (Array_Type);
Set_Slice_Subtype (N);
Eval_Slice (N);
-
end Resolve_Slice;
----------------------------
or else Nkind (Parent (N)) /= N_Op_Concat
or else (N /= Left_Opnd (Parent (N))
and then N /= Right_Opnd (Parent (N)))
- or else (Typ = Standard_Wide_String
+ or else ((Typ = Standard_Wide_String
+ or else Typ = Standard_Wide_Wide_String)
and then Nkind (Original_Node (N)) /= N_String_Literal);
-- If the resolving type is itself a string literal subtype, we
elsif Is_Bit_Packed_Array (Typ) then
null;
- -- Deal with cases of Wide_String and String
+ -- Deal with cases of Wide_Wide_String, Wide_String, and String
else
- -- For Standard.Wide_String, or any other type whose component
- -- type is Standard.Wide_Character, we know that all the
+ -- For Standard.Wide_Wide_String, or any other type whose component
+ -- type is Standard.Wide_Wide_Character, we know that all the
-- characters in the string must be acceptable, since the parser
-- accepted the characters as valid character literals.
- if R_Typ = Standard_Wide_Character then
+ if R_Typ = Standard_Wide_Wide_Character then
null;
-- For the case of Standard.String, or any other type whose
-- component type is Standard.Character, we must make sure that
-- there are no wide characters in the string, i.e. that it is
- -- entirely composed of characters in range of type String.
+ -- entirely composed of characters in range of type Character.
-- If the string literal is the result of a static concatenation,
-- the test has already been performed on the components, and need
-- a token, right under the offending wide character.
Error_Msg
- ("literal out of range of type Character",
+ ("literal out of range of type Standard.Character",
+ Source_Ptr (Int (Loc) + J));
+ return;
+ end if;
+ end loop;
+
+ -- For the case of Standard.Wide_String, or any other type whose
+ -- component type is Standard.Wide_Character, we must make sure that
+ -- there are no wide characters in the string, i.e. that it is
+ -- entirely composed of characters in range of type Wide_Character.
+
+ -- If the string literal is the result of a static concatenation,
+ -- the test has already been performed on the components, and need
+ -- not be repeated.
+
+ elsif R_Typ = Standard_Wide_Character
+ and then Nkind (Original_Node (N)) /= N_Op_Concat
+ then
+ for J in 1 .. Strlen loop
+ if not In_Wide_Character_Range (Get_String_Char (Str, J)) then
+
+ -- If we are out of range, post error. This is one of the
+ -- very few places that we place the flag in the middle of
+ -- a token, right under the offending wide character.
+
+ -- This is not quite right, because characters in general
+ -- will take more than one character position ???
+
+ Error_Msg
+ ("literal out of range of type Standard.Wide_Character",
Source_Ptr (Int (Loc) + J));
return;
end if;
-- If the root type is not a standard character, then we will convert
-- the string into an aggregate and will let the aggregate code do
- -- the checking.
+ -- the checking. Standard Wide_Wide_Character is also OK here.
else
null;
-
end if;
-- See if the component type of the array corresponding to the
-- the corresponding character aggregate and let the aggregate
-- code do the checking.
- if R_Typ = Standard_Wide_Character
- or else R_Typ = Standard_Character
+ if R_Typ = Standard_Character
+ or else R_Typ = Standard_Wide_Character
+ or else R_Typ = Standard_Wide_Wide_Character
then
-- Check for the case of full range, where we are definitely OK
or else Char_Val > Expr_Value (Comp_Typ_Hi)
then
Apply_Compile_Time_Constraint_Error
- (N, "character out of range?",
+ (N, "character out of range?", CE_Range_Check_Failed,
Loc => Source_Ptr (Int (Loc) + J));
end if;
end loop;
-- heavy artillery for this situation, but it is hard work to avoid.
declare
- Lits : List_Id := New_List;
+ Lits : constant List_Id := New_List;
P : Source_Ptr := Loc + 1;
C : Char_Code;
Set_Character_Literal_Name (C);
Append_To (Lits,
- Make_Character_Literal (P, Name_Find, C));
+ Make_Character_Literal (P,
+ Chars => Name_Find,
+ Char_Literal_Value => UI_From_CC (C)));
if In_Character_Range (C) then
P := P + 1;
-----------------------------
procedure Resolve_Type_Conversion (N : Node_Id; Typ : Entity_Id) is
- Target_Type : constant Entity_Id := Etype (N);
- Conv_OK : constant Boolean := Conversion_OK (N);
+ Conv_OK : constant Boolean := Conversion_OK (N);
+ Target_Type : Entity_Id := Etype (N);
Operand : Node_Id;
Opnd_Type : Entity_Id;
Rop : Node_Id;
+ Orig_N : Node_Id;
+ Orig_T : Node_Id;
begin
Operand := Expression (N);
and then (Etype (Right_Opnd (Operand)) = Universal_Real
or else Etype (Left_Opnd (Operand)) = Universal_Real)
then
+ -- Return if expression is ambiguous
+
if Unique_Fixed_Point_Type (N) = Any_Type then
- return; -- expression is ambiguous.
+ return;
+
+ -- If nothing else, the available fixed type is Duration
+
else
Set_Etype (Operand, Standard_Duration);
end if;
+ -- Resolve the real operand with largest available precision
if Etype (Right_Opnd (Operand)) = Universal_Real then
Rop := New_Copy_Tree (Right_Opnd (Operand));
else
Resolve (Rop, Standard_Long_Long_Float);
- if Realval (Rop) /= Ureal_0
+ -- If the operand is a literal (it could be a non-static and
+ -- illegal exponentiation) check whether the use of Duration
+ -- is potentially inaccurate.
+
+ if Nkind (Rop) = N_Real_Literal
+ and then Realval (Rop) /= Ureal_0
and then abs (Realval (Rop)) < Delta_Value (Standard_Duration)
then
Error_Msg_N ("universal real operand can only be interpreted?",
Error_Msg_N ("\as Duration, and will lose precision?", Rop);
end if;
+ elsif Is_Numeric_Type (Typ)
+ and then Nkind (Operand) in N_Op
+ and then Unique_Fixed_Point_Type (N) /= Any_Type
+ then
+ Set_Etype (Operand, Standard_Duration);
+
else
Error_Msg_N ("invalid context for mixed mode operation", N);
Set_Etype (Operand, Any_Type);
end if;
Opnd_Type := Etype (Operand);
- Resolve (Operand, Opnd_Type);
+ Resolve (Operand);
-- Note: we do the Eval_Type_Conversion call before applying the
-- required checks for a subtype conversion. This is important,
end if;
-- Issue warning for conversion of simple object to its own type
+ -- We have to test the original nodes, since they may have been
+ -- rewritten by various optimizations.
+
+ Orig_N := Original_Node (N);
if Warn_On_Redundant_Constructs
- and then Comes_From_Source (N)
- and then Nkind (N) = N_Type_Conversion
- and then Is_Entity_Name (Expression (N))
- and then Etype (Entity (Expression (N))) = Target_Type
+ and then Comes_From_Source (Orig_N)
+ and then Nkind (Orig_N) = N_Type_Conversion
+ and then not In_Instance
then
- Error_Msg_NE
- ("?useless conversion, & has this type",
- N, Entity (Expression (N)));
+ Orig_N := Original_Node (Expression (Orig_N));
+ Orig_T := Target_Type;
+
+ -- If the node is part of a larger expression, the Target_Type
+ -- may not be the original type of the node if the context is a
+ -- condition. Recover original type to see if conversion is needed.
+
+ if Is_Boolean_Type (Orig_T)
+ and then Nkind (Parent (N)) in N_Op
+ then
+ Orig_T := Etype (Parent (N));
+ end if;
+
+ if Is_Entity_Name (Orig_N)
+ and then Etype (Entity (Orig_N)) = Orig_T
+ then
+ Error_Msg_NE
+ ("?useless conversion, & has this type", N, Entity (Orig_N));
+ end if;
+ end if;
+
+ -- Ada 2005 (AI-251): Handle conversions to abstract interface types
+
+ if Ada_Version >= Ada_05 then
+ if Is_Access_Type (Target_Type) then
+ Target_Type := Directly_Designated_Type (Target_Type);
+ end if;
+
+ if Is_Class_Wide_Type (Target_Type) then
+ Target_Type := Etype (Target_Type);
+ end if;
+
+ if Is_Interface (Target_Type) then
+ if Is_Access_Type (Opnd_Type) then
+ Opnd_Type := Directly_Designated_Type (Opnd_Type);
+ end if;
+
+ if Is_Class_Wide_Type (Opnd_Type) then
+ Opnd_Type := Etype (Opnd_Type);
+ end if;
+
+ if not Interface_Present_In_Ancestor
+ (Typ => Opnd_Type,
+ Iface => Target_Type)
+ then
+ Error_Msg_NE
+ ("(Ada 2005) does not implement interface }",
+ Operand, Target_Type);
+
+ else
+ -- If a conversion to an interface type appears as an actual in
+ -- a source call, it will be expanded when the enclosing call
+ -- itself is examined in Expand_Interface_Formals. Otherwise,
+ -- generate the proper conversion code now, using the tag of
+ -- the interface.
+
+ if (Nkind (Parent (N)) = N_Procedure_Call_Statement
+ or else Nkind (Parent (N)) = N_Function_Call)
+ and then Comes_From_Source (N)
+ then
+ null;
+ else
+ Expand_Interface_Conversion (N);
+ end if;
+ end if;
+ end if;
end if;
end Resolve_Type_Conversion;
----------------------
procedure Resolve_Unary_Op (N : Node_Id; Typ : Entity_Id) is
- B_Typ : Entity_Id := Base_Type (Typ);
- R : constant Node_Id := Right_Opnd (N);
+ B_Typ : constant Entity_Id := Base_Type (Typ);
+ R : constant Node_Id := Right_Opnd (N);
+ OK : Boolean;
+ Lo : Uint;
+ Hi : Uint;
begin
+ -- Generate warning for expressions like abs (x mod 2)
+
+ if Warn_On_Redundant_Constructs
+ and then Nkind (N) = N_Op_Abs
+ then
+ Determine_Range (Right_Opnd (N), OK, Lo, Hi);
+
+ if OK and then Hi >= Lo and then Lo >= 0 then
+ Error_Msg_N
+ ("?abs applied to known non-negative value has no effect", N);
+ end if;
+ end if;
+
-- Generate warning for expressions like -5 mod 3
if Paren_Count (N) = 0
and then Nkind (N) = N_Op_Minus
and then Nkind (Right_Opnd (N)) = N_Op_Mod
+ and then Comes_From_Source (N)
then
Error_Msg_N
("?unary minus expression should be parenthesized here", N);
end if;
+ 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_Unary_Operator (N, Typ);
+ return;
+ end if;
+
if Etype (R) = Universal_Integer
- or else Etype (R) = Universal_Real
+ or else Etype (R) = Universal_Real
then
Check_For_Visible_Operator (N, B_Typ);
end if;
Set_Etype (N, B_Typ);
Resolve (R, B_Typ);
+
Check_Unset_Reference (R);
- Generate_Operator_Reference (N);
+ Generate_Operator_Reference (N, B_Typ);
Eval_Unary_Op (N);
-- Set overflow checking bit. Much cleverer code needed here eventually
if Nkind (N) in N_Op then
if not Overflow_Checks_Suppressed (Etype (N)) then
- Set_Do_Overflow_Check (N, True);
+ Enable_Overflow_Check (N);
end if;
end if;
-
end Resolve_Unary_Op;
----------------------------------
(N : Node_Id;
Typ : Entity_Id)
is
+ pragma Warnings (Off, Typ);
+
Operand : constant Node_Id := Expression (N);
Opnd_Type : constant Entity_Id := Etype (Operand);
begin
- -- Resolve operand using its own type.
+ -- Resolve operand using its own type
Resolve (Operand, Opnd_Type);
Eval_Unchecked_Conversion (N);
------------------------------
procedure Rewrite_Operator_As_Call (N : Node_Id; Nam : Entity_Id) is
- Loc : Source_Ptr := Sloc (N);
- Actuals : List_Id := New_List;
+ Loc : constant Source_Ptr := Sloc (N);
+ Actuals : constant List_Id := New_List;
New_N : Node_Id;
begin
-- Rewrite_Renamed_Operator --
------------------------------
- procedure Rewrite_Renamed_Operator (N : Node_Id; Op : Entity_Id) is
+ procedure Rewrite_Renamed_Operator
+ (N : Node_Id;
+ Op : Entity_Id;
+ Typ : Entity_Id)
+ is
Nam : constant Name_Id := Chars (Op);
Is_Binary : constant Boolean := Nkind (N) in N_Binary_Op;
Op_Node : Node_Id;
begin
- if Chars (N) /= Nam then
-
- -- Rewrite the operator node using the real operator, not its
- -- renaming.
+ -- Rewrite the operator node using the real operator, not its
+ -- renaming. Exclude user-defined intrinsic operations of the same
+ -- name, which are treated separately and rewritten as calls.
+ if Ekind (Op) /= E_Function
+ or else Chars (N) /= Nam
+ then
Op_Node := New_Node (Operator_Kind (Nam, Is_Binary), Sloc (N));
Set_Chars (Op_Node, Nam);
Set_Etype (Op_Node, Etype (N));
Set_Entity (Op_Node, Op);
Set_Right_Opnd (Op_Node, Right_Opnd (N));
+ -- Indicate that both the original entity and its renaming
+ -- are referenced at this point.
+
+ Generate_Reference (Entity (N), N);
Generate_Reference (Op, N);
if Is_Binary then
end if;
Rewrite (N, Op_Node);
+
+ -- If the context type is private, add the appropriate conversions
+ -- so that the operator is applied to the full view. This is done
+ -- in the routines that resolve intrinsic operators,
+
+ if Is_Intrinsic_Subprogram (Op)
+ and then 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;
+ end if;
+
+ elsif Ekind (Op) = E_Function
+ and then Is_Intrinsic_Subprogram (Op)
+ then
+ -- Operator renames a user-defined operator of the same name. Use
+ -- the original operator in the node, which is the one that gigi
+ -- knows about.
+
+ Set_Entity (N, Op);
+ Set_Is_Overloaded (N, False);
end if;
end Rewrite_Renamed_Operator;
procedure Set_Slice_Subtype (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
+ Index_List : constant List_Id := New_List;
Index : Node_Id;
- Index_List : List_Id := New_List;
Index_Subtype : Entity_Id;
Index_Type : Entity_Id;
Slice_Subtype : Entity_Id;
Set_Etype (Index, Index_Subtype);
Append (Index, Index_List);
- Set_Component_Type (Slice_Subtype, Component_Type (Etype (N)));
Set_First_Index (Slice_Subtype, Index);
Set_Etype (Slice_Subtype, Base_Type (Etype (N)));
Set_Is_Constrained (Slice_Subtype, True);
begin
if Nkind (N) /= N_String_Literal then
return;
-
else
Subtype_Id := Create_Itype (E_String_Literal_Subtype, N);
end if;
- Set_Component_Type (Subtype_Id, Component_Type (Typ));
- Set_String_Literal_Length (Subtype_Id,
- UI_From_Int (String_Length (Strval (N))));
- Set_Etype (Subtype_Id, Base_Type (Typ));
- Set_Is_Constrained (Subtype_Id);
+ Set_String_Literal_Length (Subtype_Id, UI_From_Int
+ (String_Length (Strval (N))));
+ Set_Etype (Subtype_Id, Base_Type (Typ));
+ Set_Is_Constrained (Subtype_Id);
-- The low bound is set from the low bound of the corresponding
-- index type. Note that we do not store the high bound in the
Scop : Entity_Id;
procedure Fixed_Point_Error;
- -- If true ambiguity, give details.
+ -- If true ambiguity, give details
+
+ -----------------------
+ -- Fixed_Point_Error --
+ -----------------------
procedure Fixed_Point_Error is
begin
Error_Msg_NE ("\possible interpretation as}", N, T2);
end Fixed_Point_Error;
+ -- Start of processing for Unique_Fixed_Point_Type
+
begin
-- The operations on Duration are visible, so Duration is always a
-- possible interpretation.
T1 := Standard_Duration;
- Scop := Current_Scope;
-
- -- Look for fixed-point types in enclosing scopes.
+ -- Look for fixed-point types in enclosing scopes
+ Scop := Current_Scope;
while Scop /= Standard_Standard loop
T2 := First_Entity (Scop);
-
while Present (T2) loop
if Is_Fixed_Point_Type (T2)
and then Current_Entity (T2) = T2
Scop := Scope (Scop);
end loop;
- -- Look for visible fixed type declarations in the context.
+ -- Look for visible fixed type declarations in the context
Item := First (Context_Items (Cunit (Current_Sem_Unit)));
-
while Present (Item) loop
-
if Nkind (Item) = N_With_Clause then
Scop := Entity (Name (Item));
T2 := First_Entity (Scop);
-
while Present (T2) loop
if Is_Fixed_Point_Type (T2)
and then Scope (Base_Type (T2)) = Scop
function Valid_Conversion
(N : Node_Id;
Target : Entity_Id;
- Operand : Node_Id)
- return Boolean
+ Operand : Node_Id) return Boolean
is
- Target_Type : Entity_Id := Base_Type (Target);
+ Target_Type : constant Entity_Id := Base_Type (Target);
Opnd_Type : Entity_Id := Etype (Operand);
function Conversion_Check
(Valid : Boolean;
- Msg : String)
- return Boolean;
+ Msg : String) return Boolean;
-- Little routine to post Msg if Valid is False, returns Valid value
function Valid_Tagged_Conversion
(Target_Type : Entity_Id;
- Opnd_Type : Entity_Id)
- return Boolean;
+ Opnd_Type : Entity_Id) return Boolean;
-- Specifically test for validity of tagged conversions
----------------------
function Conversion_Check
(Valid : Boolean;
- Msg : String)
- return Boolean
+ Msg : String) return Boolean
is
begin
if not Valid then
function Valid_Tagged_Conversion
(Target_Type : Entity_Id;
- Opnd_Type : Entity_Id)
- return Boolean
+ Opnd_Type : Entity_Id) return Boolean
is
begin
- -- Upward conversions are allowed (RM 4.6(22)).
+ -- Upward conversions are allowed (RM 4.6(22))
if Covers (Target_Type, Opnd_Type)
or else Is_Ancestor (Target_Type, Opnd_Type)
then
return True;
- -- Downward conversion are allowed if the operand is
- -- is class-wide (RM 4.6(23)).
+ -- Downward conversion are allowed if the operand is class-wide
+ -- (RM 4.6(23)).
elsif Is_Class_Wide_Type (Opnd_Type)
and then Covers (Opnd_Type, Target_Type)
return
Conversion_Check (False,
"downward conversion of tagged objects not allowed");
+
+ -- Ada 2005 (AI-251): The conversion of a tagged type to an
+ -- abstract interface type is always valid
+
+ elsif Is_Interface (Target_Type) then
+ return True;
+
else
Error_Msg_NE
("invalid tagged conversion, not compatible with}",
-- in this context, but which cannot be removed by type checking,
-- because the context does not impose a type.
+ -- When compiling for VMS, spurious ambiguities can be produced
+ -- when arithmetic operations have a literal operand and return
+ -- System.Address or a descendant of it. These ambiguities are
+ -- otherwise resolved by the context, but for conversions there
+ -- is no context type and the removal of the spurious operations
+ -- must be done explicitly here.
+
Get_First_Interp (Operand, I, It);
while Present (It.Typ) loop
-
if It.Typ = Standard_Void_Type then
Remove_Interp (I);
end if;
+ if Present (System_Aux_Id)
+ and then Is_Descendent_Of_Address (It.Typ)
+ then
+ Remove_Interp (I);
+ end if;
+
Get_Next_Interp (I, It);
end loop;
elsif Is_Numeric_Type (Target_Type) then
if Opnd_Type = Universal_Fixed then
return True;
+
+ elsif (In_Instance or else In_Inlined_Body)
+ and then not Comes_From_Source (N)
+ then
+ return True;
+
else
return Conversion_Check (Is_Numeric_Type (Opnd_Type),
"illegal operand for numeric conversion");
else
declare
- Target_Index : Node_Id := First_Index (Target_Type);
- Opnd_Index : Node_Id := First_Index (Opnd_Type);
+ Target_Index : Node_Id := First_Index (Target_Type);
+ Opnd_Index : Node_Id := First_Index (Opnd_Type);
Target_Index_Type : Entity_Id;
Opnd_Index_Type : Entity_Id;
- Target_Comp_Type : Entity_Id := Component_Type (Target_Type);
- Opnd_Comp_Type : Entity_Id := Component_Type (Opnd_Type);
+ Target_Comp_Type : constant Entity_Id :=
+ Component_Type (Target_Type);
+ Opnd_Comp_Type : constant Entity_Id :=
+ Component_Type (Opnd_Type);
begin
while Present (Target_Index) and then Present (Opnd_Index) loop
return True;
+ -- Ada 2005 (AI-251)
+
+ elsif (Ekind (Target_Type) = E_General_Access_Type
+ or else Ekind (Target_Type) = E_Anonymous_Access_Type)
+ and then Is_Interface (Directly_Designated_Type (Target_Type))
+ then
+ -- Check the static accessibility rule of 4.6(17). Note that the
+ -- check is not enforced when within an instance body, since the RM
+ -- requires such cases to be caught at run time.
+
+ if Ekind (Target_Type) /= E_Anonymous_Access_Type then
+ if Type_Access_Level (Opnd_Type) >
+ Type_Access_Level (Target_Type)
+ then
+ -- In an instance, this is a run-time check, but one we know
+ -- will fail, so generate an appropriate warning. The raise
+ -- will be generated by Expand_N_Type_Conversion.
+
+ if In_Instance_Body then
+ Error_Msg_N
+ ("?cannot convert local pointer to non-local access type",
+ Operand);
+ Error_Msg_N
+ ("?Program_Error will be raised at run time", Operand);
+
+ else
+ Error_Msg_N
+ ("cannot convert local pointer to non-local access type",
+ Operand);
+ return False;
+ end if;
+
+ -- Special accessibility checks are needed in the case of access
+ -- discriminants declared for a limited type.
+
+ elsif Ekind (Opnd_Type) = E_Anonymous_Access_Type
+ and then not Is_Local_Anonymous_Access (Opnd_Type)
+ then
+ -- When the operand is a selected access discriminant the check
+ -- needs to be made against the level of the object denoted by
+ -- the prefix of the selected name. (Object_Access_Level
+ -- handles checking the prefix of the operand for this case.)
+
+ if Nkind (Operand) = N_Selected_Component
+ and then Object_Access_Level (Operand)
+ > Type_Access_Level (Target_Type)
+ then
+ -- In an instance, this is a run-time check, but one we
+ -- know will fail, so generate an appropriate warning.
+ -- The raise will be generated by Expand_N_Type_Conversion.
+
+ if In_Instance_Body then
+ Error_Msg_N
+ ("?cannot convert access discriminant to non-local" &
+ " access type", Operand);
+ Error_Msg_N
+ ("?Program_Error will be raised at run time", Operand);
+
+ else
+ Error_Msg_N
+ ("cannot convert access discriminant to non-local" &
+ " access type", Operand);
+ return False;
+ end if;
+ end if;
+
+ -- The case of a reference to an access discriminant from
+ -- within a limited type declaration (which will appear as
+ -- a discriminal) is always illegal because the level of the
+ -- discriminant is considered to be deeper than any (namable)
+ -- access type.
+
+ if Is_Entity_Name (Operand)
+ and then not Is_Local_Anonymous_Access (Opnd_Type)
+ and then (Ekind (Entity (Operand)) = E_In_Parameter
+ or else Ekind (Entity (Operand)) = E_Constant)
+ and then Present (Discriminal_Link (Entity (Operand)))
+ then
+ Error_Msg_N
+ ("discriminant has deeper accessibility level than target",
+ Operand);
+ return False;
+ end if;
+ end if;
+ end if;
+
+ return True;
+
elsif (Ekind (Target_Type) = E_General_Access_Type
or else Ekind (Target_Type) = E_Anonymous_Access_Type)
and then
return False;
end if;
- -- Check the static accessibility rule of 4.6(17). Note that
- -- the check is not enforced when within an instance body, since
- -- the RM requires such cases to be caught at run time.
+ -- Check the static accessibility rule of 4.6(17). Note that the
+ -- check is not enforced when within an instance body, since the RM
+ -- requires such cases to be caught at run time.
- if Ekind (Target_Type) /= E_Anonymous_Access_Type then
+ if Ekind (Target_Type) /= E_Anonymous_Access_Type
+ or else Is_Local_Anonymous_Access (Target_Type)
+ then
if Type_Access_Level (Opnd_Type)
> Type_Access_Level (Target_Type)
then
return False;
end if;
- elsif Ekind (Opnd_Type) = E_Anonymous_Access_Type then
+ -- Special accessibility checks are needed in the case of access
+ -- discriminants declared for a limited type.
- -- When the operand is a selected access discriminant
- -- the check needs to be made against the level of the
- -- object denoted by the prefix of the selected name.
- -- (Object_Access_Level handles checking the prefix
- -- of the operand for this case.)
+ elsif Ekind (Opnd_Type) = E_Anonymous_Access_Type
+ and then not Is_Local_Anonymous_Access (Opnd_Type)
+ then
+
+ -- When the operand is a selected access discriminant the check
+ -- needs to be made against the level of the object denoted by
+ -- the prefix of the selected name. (Object_Access_Level
+ -- handles checking the prefix of the operand for this case.)
if Nkind (Operand) = N_Selected_Component
and then Object_Access_Level (Operand)
end if;
end if;
- -- The case of a reference to an access discriminant
- -- from within a type declaration (which will appear
- -- as a discriminal) is always illegal because the
- -- level of the discriminant is considered to be
- -- deeper than any (namable) access type.
+ -- The case of a reference to an access discriminant from
+ -- within a limited type declaration (which will appear as
+ -- a discriminal) is always illegal because the level of the
+ -- discriminant is considered to be deeper than any (namable)
+ -- access type.
if Is_Entity_Name (Operand)
and then (Ekind (Entity (Operand)) = E_In_Parameter
N, Base_Type (Opnd));
return False;
- elsif not Subtypes_Statically_Match (Target, Opnd)
- and then (not Has_Discriminants (Target)
- or else Is_Constrained (Target))
+ -- Ada 2005 AI-384: legality rule is symmetric in both
+ -- designated types. The conversion is legal (with possible
+ -- constraint check) if either designated type is
+ -- unconstrained.
+
+ elsif Subtypes_Statically_Match (Target, Opnd)
+ or else
+ (Has_Discriminants (Target)
+ and then
+ (not Is_Constrained (Opnd)
+ or else not Is_Constrained (Target)))
then
+ return True;
+
+ else
Error_Msg_NE
("target designated subtype not compatible with }",
N, Opnd);
return False;
-
- else
- return True;
end if;
end if;
end;
- elsif Ekind (Target_Type) = E_Access_Subprogram_Type
+ elsif (Ekind (Target_Type) = E_Access_Subprogram_Type
+ or else
+ Ekind (Target_Type) = E_Anonymous_Access_Subprogram_Type)
+ and then No (Corresponding_Remote_Type (Opnd_Type))
and then Conversion_Check
(Ekind (Base_Type (Opnd_Type)) = E_Access_Subprogram_Type,
"illegal operand for access subprogram conversion")
then
-- Check that the designated types are subtype conformant
- if not Subtype_Conformant (Designated_Type (Opnd_Type),
- Designated_Type (Target_Type))
- then
- Error_Msg_N
- ("operand type is not subtype conformant with target type",
- Operand);
- end if;
+ Check_Subtype_Conformant (New_Id => Designated_Type (Target_Type),
+ Old_Id => Designated_Type (Opnd_Type),
+ Err_Loc => N);
-- Check the static accessibility rule of 4.6(20)
O_Gen : constant Node_Id :=
Enclosing_Generic_Body (Opnd_Type);
- T_Gen : Node_Id :=
- Enclosing_Generic_Body (Target_Type);
+ T_Gen : Node_Id;
begin
+ T_Gen := Enclosing_Generic_Body (Target_Type);
while Present (T_Gen) and then T_Gen /= O_Gen loop
T_Gen := Enclosing_Generic_Body (T_Gen);
end loop;
elsif Is_Tagged_Type (Target_Type) then
return Valid_Tagged_Conversion (Target_Type, Opnd_Type);
- -- Types derived from the same root type are convertible.
+ -- Types derived from the same root type are convertible
elsif Root_Type (Target_Type) = Root_Type (Opnd_Type) then
return True;