-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 2, or (at your option) any later ver- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING. If not, write --
--- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
--- Boston, MA 02110-1301, USA. --
+-- Public License distributed with GNAT; see file COPYING3. If not, go to --
+-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
with Debug; use Debug;
with Debug_A; use Debug_A;
with Einfo; use Einfo;
+with Elists; use Elists;
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 Fname; use Fname;
with Freeze; use Freeze;
with Itypes; use Itypes;
with Lib; use Lib;
with Rident; use Rident;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
+with Sem_Aux; use Sem_Aux;
with Sem_Aggr; use Sem_Aggr;
with Sem_Attr; use Sem_Attr;
with Sem_Cat; use Sem_Cat;
with Sem_Ch4; use Sem_Ch4;
with Sem_Ch6; use Sem_Ch6;
with Sem_Ch8; use Sem_Ch8;
+with Sem_Ch13; use Sem_Ch13;
with Sem_Disp; use Sem_Disp;
with Sem_Dist; use Sem_Dist;
+with Sem_Elim; use Sem_Elim;
with Sem_Elab; use Sem_Elab;
with Sem_Eval; use Sem_Eval;
with Sem_Intr; use Sem_Intr;
with Snames; use Snames;
with Stand; use Stand;
with Stringt; use Stringt;
+with Style; use Style;
with Tbuild; use Tbuild;
with Uintp; use Uintp;
with Urealp; use Urealp;
-- Note that Resolve_Attribute is separated off in Sem_Attr
- procedure Ambiguous_Character (C : Node_Id);
- -- Give list of candidate interpretations when a character literal cannot
- -- be resolved.
-
procedure Check_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).
-- initialization of individual components within the init proc itself.
-- Could be optimized away perhaps?
+ procedure Check_No_Direct_Boolean_Operators (N : Node_Id);
+ -- N is the node for a logical operator. If the operator is predefined, and
+ -- the root type of the operands is Standard.Boolean, then a check is made
+ -- for restriction No_Direct_Boolean_Operators. This procedure also handles
+ -- the style check for Style_Check_Boolean_And_Or.
+
+ function Is_Definite_Access_Type (E : Entity_Id) return Boolean;
+ -- Determine whether E is an access type declared by an access
+ -- declaration, and not an (anonymous) allocator type.
+
function Is_Predefined_Op (Nam : Entity_Id) return Boolean;
-- Utility to check whether the name in the call is a predefined
-- operator, in which case the call is made into an operator node.
-- of the task, it must be replaced with a reference to the discriminant
-- of the task being called.
+ procedure Resolve_Op_Concat_Arg
+ (N : Node_Id;
+ Arg : Node_Id;
+ Typ : Entity_Id;
+ Is_Comp : Boolean);
+ -- Internal procedure for Resolve_Op_Concat to resolve one operand of
+ -- concatenation operator. The operand is either of the array type or of
+ -- the component type. If the operand is an aggregate, and the component
+ -- type is composite, this is ambiguous if component type has aggregates.
+
+ procedure Resolve_Op_Concat_First (N : Node_Id; Typ : Entity_Id);
+ -- Does the first part of the work of Resolve_Op_Concat
+
+ procedure Resolve_Op_Concat_Rest (N : Node_Id; Typ : Entity_Id);
+ -- Does the "rest" of the work of Resolve_Op_Concat, after the left operand
+ -- has been resolved. See Resolve_Op_Concat for details.
+
procedure Resolve_Allocator (N : Node_Id; Typ : Entity_Id);
procedure Resolve_Arithmetic_Op (N : Node_Id; Typ : Entity_Id);
procedure Resolve_Call (N : Node_Id; Typ : Entity_Id);
begin
if Nkind (C) = N_Character_Literal then
Error_Msg_N ("ambiguous character literal", C);
+
+ -- First the ones in Standard
+
+ Error_Msg_N
+ ("\\possible interpretation: Character!", C);
Error_Msg_N
- ("\\possible interpretations: Character, Wide_Character!", C);
+ ("\\possible interpretation: Wide_Character!", C);
+
+ -- Include Wide_Wide_Character in Ada 2005 mode
+
+ if Ada_Version >= Ada_05 then
+ Error_Msg_N
+ ("\\possible interpretation: Wide_Wide_Character!", C);
+ end if;
+
+ -- Now any other types that match
E := Current_Entity (C);
while Present (E) loop
D : Node_Id;
begin
- -- Any use in a default expression is legal
+ -- Any use in a spec-expression is legal
- if In_Default_Expression then
+ if In_Spec_Expression then
null;
elsif Nkind (PN) = N_Range then
and then Scope (Disc) = Current_Scope
and then not
(Nkind (Parent (P)) = N_Subtype_Indication
- and then
- (Nkind (Parent (Parent (P))) = N_Component_Definition
- or else
- Nkind (Parent (Parent (P))) = N_Subtype_Declaration)
+ and then
+ Nkind_In (Parent (Parent (P)), N_Component_Definition,
+ N_Subtype_Declaration)
and then Paren_Count (N) = 0)
then
Error_Msg_N
return;
end if;
- -- Detect a common beginner error:
+ -- Detect a common error:
-- type R (D : Positive := 100) is record
-- Name : String (1 .. D);
-- end record;
- -- The default value causes an object of type R to be
- -- allocated with room for Positive'Last characters.
+ -- The default value causes an object of type R to be allocated
+ -- with room for Positive'Last characters. The RM does not mandate
+ -- the allocation of the maximum size, but that is what GNAT does
+ -- so we should warn the programmer that there is a problem.
- declare
+ Check_Large : declare
SI : Node_Id;
T : Entity_Id;
TB : Node_Id;
function Large_Storage_Type (T : Entity_Id) return Boolean is
begin
- return
- T = Standard_Integer
- or else
- T = Standard_Positive
- or else
- T = Standard_Natural;
+ -- The type is considered large if its bounds are known at
+ -- compile time and if it requires at least as many bits as
+ -- a Positive to store the possible values.
+
+ return Compile_Time_Known_Value (Type_Low_Bound (T))
+ and then Compile_Time_Known_Value (Type_High_Bound (T))
+ and then
+ Minimum_Size (T, Biased => True) >=
+ RM_Size (Standard_Positive);
end Large_Storage_Type;
+ -- Start of processing for Check_Large
+
begin
-- Check that the Disc has a large range
-- Warn about the danger
Error_Msg_N
- ("creation of & object may raise Storage_Error?",
+ ("?creation of & object may raise Storage_Error!",
Scope (Disc));
<<No_Danger>>
null;
- end;
+ end Check_Large;
end if;
-- Legal case is in index or discriminant constraint
- elsif Nkind (PN) = N_Index_Or_Discriminant_Constraint
- or else Nkind (PN) = N_Discriminant_Association
+ elsif Nkind_In (PN, N_Index_Or_Discriminant_Constraint,
+ N_Discriminant_Association)
then
if Paren_Count (N) > 0 then
Error_Msg_N
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
+ while not Nkind_In (P, N_Component_Declaration,
+ N_Subtype_Indication,
+ N_Entry_Declaration)
loop
D := P;
P := Parent (P);
-- is of course a double fault.
if (Nkind (P) = N_Subtype_Indication
- and then
- (Nkind (Parent (P)) = N_Component_Definition
- or else
- Nkind (Parent (P)) = N_Derived_Type_Definition)
+ and then Nkind_In (Parent (P), N_Component_Definition,
+ N_Derived_Type_Definition)
and then D = Constraint (P))
-- The constraint itself may be given by a subtype indication,
elsif Ada_Version >= Ada_05
and then Is_Entity_Name (Pref)
+ and then Is_Access_Type (Etype (Pref))
and then Ekind (Directly_Designated_Type (Etype (Pref))) =
E_Incomplete_Type
and then Is_Tagged_Type (Directly_Designated_Type (Etype (Pref)))
-- 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.
+ -- Special case, if this is a procedure call and is a call to the
+ -- current procedure with the same argument list, then this is for
+ -- sure an infinite recursion and we insert a call to raise SE.
+
+ if Is_List_Member (N)
+ and then List_Length (List_Containing (N)) = 1
+ and then Same_Argument_List
+ then
+ declare
+ P : constant Node_Id := Parent (N);
+ begin
+ if Nkind (P) = N_Handled_Sequence_Of_Statements
+ and then Nkind (Parent (P)) = N_Subprogram_Body
+ and then Is_Empty_List (Declarations (Parent (P)))
+ then
+ Error_Msg_N ("!?infinite recursion", N);
+ Error_Msg_N ("\!?Storage_Error will be raised at run time", N);
+ Insert_Action (N,
+ Make_Raise_Storage_Error (Sloc (N),
+ Reason => SE_Infinite_Recursion));
+ return True;
+ end if;
+ end;
+ end if;
+
+ -- If not that special case, search up tree, quitting if we reach a
+ -- construct (e.g. a conditional) that tells us that this is not a
+ -- case for an infinite recursion warning.
C := N;
loop
P := Parent (C);
+
+ -- If no parent, then we were not inside a subprogram, this can for
+ -- example happen when processing certain pragmas in a spec. Just
+ -- return False in this case.
+
+ if No (P) then
+ return False;
+ end if;
+
+ -- Done if we get to subprogram body, this is definitely an infinite
+ -- recursion case if we did not find anything to stop us.
+
exit when Nkind (P) = N_Subprogram_Body;
- if Nkind (P) = N_Or_Else or else
- Nkind (P) = N_And_Then or else
- Nkind (P) = N_If_Statement or else
- Nkind (P) = N_Case_Statement
+ -- If appearing in conditional, result is false
+
+ if Nkind_In (P, N_Or_Else,
+ N_And_Then,
+ N_If_Statement,
+ N_Case_Statement)
then
return False;
elsif Nkind (P) = N_Handled_Sequence_Of_Statements
and then C /= First (Statements (P))
then
- -- If the call is the expression of a return statement and
- -- the actuals are identical to the formals, it's worth a
- -- warning. However, we skip this if there is an immediately
- -- preceding raise statement, since the call is never executed.
+ -- 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:
-- for generating a stub function
- if Nkind (Parent (N)) = N_Return_Statement
+ if Nkind (Parent (N)) = N_Simple_Return_Statement
and then Same_Argument_List
then
exit when not Is_List_Member (Parent (N));
end if;
end loop;
- Error_Msg_N ("possible infinite recursion?", N);
- Error_Msg_N ("\Storage_Error may be raised at run time?", N);
+ Error_Msg_N ("!?possible infinite recursion", N);
+ Error_Msg_N ("\!?Storage_Error may be raised at run time", N);
return True;
end Check_Infinite_Recursion;
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.
+ -- if the expression for some component uses the secondary stack, e.g.
-- through a call to a function that returns an unconstrained value.
-- False if T is controlled, because cleanups occur elsewhere.
-------------
function Uses_SS (T : Entity_Id) return Boolean is
- Comp : Entity_Id;
- Expr : Node_Id;
+ Comp : Entity_Id;
+ Expr : Node_Id;
+ Full_Type : Entity_Id := Underlying_Type (T);
begin
- if Is_Controlled (T) then
+ -- Normally we want to use the underlying type, but if it's not set
+ -- then continue with T.
+
+ if not Present (Full_Type) then
+ Full_Type := T;
+ end if;
+
+ if Is_Controlled (Full_Type) then
return False;
- elsif Is_Array_Type (T) then
- return Uses_SS (Component_Type (T));
+ elsif Is_Array_Type (Full_Type) then
+ return Uses_SS (Component_Type (Full_Type));
- elsif Is_Record_Type (T) then
- Comp := First_Component (T);
+ elsif Is_Record_Type (Full_Type) then
+ Comp := First_Component (Full_Type);
while Present (Comp) loop
if Ekind (Comp) = E_Component
and then Nkind (Parent (Comp)) = N_Component_Declaration
then
- Expr := Expression (Parent (Comp));
+ -- The expression for a dynamic component may be rewritten
+ -- as a dereference, so retrieve original node.
+
+ Expr := Original_Node (Expression (Parent (Comp)));
- -- The expression for a dynamic component may be
- -- rewritten as a dereference. Retrieve original
- -- call.
+ -- Return True if the expression is a call to a function
+ -- (including an attribute function such as Image) with
+ -- a result that requires a transient scope.
- if Nkind (Original_Node (Expr)) = N_Function_Call
+ if (Nkind (Expr) = N_Function_Call
+ or else (Nkind (Expr) = N_Attribute_Reference
+ and then Present (Expressions (Expr))))
and then Requires_Transient_Scope (Etype (Expr))
then
return True;
end if;
end Check_Initialization_Call;
+ ---------------------------------------
+ -- Check_No_Direct_Boolean_Operators --
+ ---------------------------------------
+
+ procedure Check_No_Direct_Boolean_Operators (N : Node_Id) is
+ begin
+ if Scope (Entity (N)) = Standard_Standard
+ and then Root_Type (Etype (Left_Opnd (N))) = Standard_Boolean
+ then
+ -- Restriction only applies to original source code
+
+ if Comes_From_Source (N) then
+ Check_Restriction (No_Direct_Boolean_Operators, N);
+ end if;
+ end if;
+
+ if Style_Check then
+ Check_Boolean_Operator (N);
+ end if;
+ end Check_No_Direct_Boolean_Operators;
+
------------------------------
-- Check_Parameterless_Call --
------------------------------
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 the context expects a value, and the name is a procedure, this is
+ -- most likely a missing 'Access. Don't 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)
+ Nkind_In (Parent (N), N_Parameter_Association,
+ N_Function_Call,
+ N_Procedure_Call_Statement)
then
return;
end if;
- -- Rewrite as call if overloadable entity that is (or could be, in
- -- the overloaded case) a function call. If we know for sure that
- -- the entity is an enumeration literal, we do not rewrite it.
+ -- Rewrite as call if overloadable entity that is (or could be, in the
+ -- overloaded case) a function call. If we know for sure that the entity
+ -- is an enumeration literal, we do not rewrite it.
if (Is_Entity_Name (N)
and then Is_Overloadable (Entity (N))
and then (Ekind (Entity (N)) /= E_Enumeration_Literal
or else Is_Overloaded (N)))
- -- Rewrite as call if it is an explicit deference of an expression of
- -- a subprogram access type, and the suprogram type is not that of a
+ -- Rewrite as call if it is an explicit dereference of an expression of
+ -- a subprogram access type, and the subprogram type is not that of a
-- procedure or entry.
or else
end if;
end Check_Parameterless_Call;
+ -----------------------------
+ -- Is_Definite_Access_Type --
+ -----------------------------
+
+ function Is_Definite_Access_Type (E : Entity_Id) return Boolean is
+ Btyp : constant Entity_Id := Base_Type (E);
+ begin
+ return Ekind (Btyp) = E_Access_Type
+ or else (Ekind (Btyp) = E_Access_Subprogram_Type
+ and then Comes_From_Source (Btyp));
+ end Is_Definite_Access_Type;
+
----------------------
-- Is_Predefined_Op --
----------------------
type Kind_Test is access function (E : Entity_Id) return Boolean;
- function Is_Definite_Access_Type (E : Entity_Id) return Boolean;
- -- Determine whether E is an access type declared by an access decla-
- -- ration, and not an (anonymous) allocator type.
-
function Operand_Type_In_Scope (S : Entity_Id) return Boolean;
-- If the operand is not universal, and the operator is given by a
-- expanded name, verify that the operand has an interpretation with
-- Find a type of the given class in the package Pack that contains
-- the operator.
- -----------------------------
- -- Is_Definite_Access_Type --
- -----------------------------
-
- function Is_Definite_Access_Type (E : Entity_Id) return Boolean is
- Btyp : constant Entity_Id := Base_Type (E);
- begin
- return Ekind (Btyp) = E_Access_Type
- or else (Ekind (Btyp) = E_Access_Subprogram_Type
- and then Comes_From_Source (Btyp));
- end Is_Definite_Access_Type;
-
---------------------------
-- Operand_Type_In_Scope --
---------------------------
Set_Entity (Op_Node, Op_Id);
Generate_Reference (Op_Id, N, ' ');
- Rewrite (N, Op_Node);
+
+ -- Do rewrite setting Comes_From_Source on the result if the original
+ -- call came from source. Although it is not strictly the case that the
+ -- operator as such comes from the source, logically it corresponds
+ -- exactly to the function call in the source, so it should be marked
+ -- this way (e.g. to make sure that validity checks work fine).
+
+ declare
+ CS : constant Boolean := Comes_From_Source (N);
+ begin
+ Rewrite (N, Op_Node);
+ Set_Comes_From_Source (N, CS);
+ end;
-- If this is an arithmetic operator and the result type is private,
-- the operands and the result must be wrapped in conversion to
begin
if Is_Binary then
- if Op_Name = Name_Op_And then Kind := N_Op_And;
- elsif Op_Name = Name_Op_Or then Kind := N_Op_Or;
- elsif Op_Name = Name_Op_Xor then Kind := N_Op_Xor;
- elsif Op_Name = Name_Op_Eq then Kind := N_Op_Eq;
- elsif Op_Name = Name_Op_Ne then Kind := N_Op_Ne;
- elsif Op_Name = Name_Op_Lt then Kind := N_Op_Lt;
- elsif Op_Name = Name_Op_Le then Kind := N_Op_Le;
- elsif Op_Name = Name_Op_Gt then Kind := N_Op_Gt;
- elsif Op_Name = Name_Op_Ge then Kind := N_Op_Ge;
- elsif Op_Name = Name_Op_Add then Kind := N_Op_Add;
- elsif Op_Name = Name_Op_Subtract then Kind := N_Op_Subtract;
- elsif Op_Name = Name_Op_Concat then Kind := N_Op_Concat;
- elsif Op_Name = Name_Op_Multiply then Kind := N_Op_Multiply;
- elsif Op_Name = Name_Op_Divide then Kind := N_Op_Divide;
- elsif Op_Name = Name_Op_Mod then Kind := N_Op_Mod;
- elsif Op_Name = Name_Op_Rem then Kind := N_Op_Rem;
- elsif Op_Name = Name_Op_Expon then Kind := N_Op_Expon;
+ if Op_Name = Name_Op_And then
+ Kind := N_Op_And;
+ elsif Op_Name = Name_Op_Or then
+ Kind := N_Op_Or;
+ elsif Op_Name = Name_Op_Xor then
+ Kind := N_Op_Xor;
+ elsif Op_Name = Name_Op_Eq then
+ Kind := N_Op_Eq;
+ elsif Op_Name = Name_Op_Ne then
+ Kind := N_Op_Ne;
+ elsif Op_Name = Name_Op_Lt then
+ Kind := N_Op_Lt;
+ elsif Op_Name = Name_Op_Le then
+ Kind := N_Op_Le;
+ elsif Op_Name = Name_Op_Gt then
+ Kind := N_Op_Gt;
+ elsif Op_Name = Name_Op_Ge then
+ Kind := N_Op_Ge;
+ elsif Op_Name = Name_Op_Add then
+ Kind := N_Op_Add;
+ elsif Op_Name = Name_Op_Subtract then
+ Kind := N_Op_Subtract;
+ elsif Op_Name = Name_Op_Concat then
+ Kind := N_Op_Concat;
+ elsif Op_Name = Name_Op_Multiply then
+ Kind := N_Op_Multiply;
+ elsif Op_Name = Name_Op_Divide then
+ Kind := N_Op_Divide;
+ elsif Op_Name = Name_Op_Mod then
+ Kind := N_Op_Mod;
+ elsif Op_Name = Name_Op_Rem then
+ Kind := N_Op_Rem;
+ elsif Op_Name = Name_Op_Expon then
+ Kind := N_Op_Expon;
else
raise Program_Error;
end if;
-- Unary operators
else
- if Op_Name = Name_Op_Add then Kind := N_Op_Plus;
- elsif Op_Name = Name_Op_Subtract then Kind := N_Op_Minus;
- elsif Op_Name = Name_Op_Abs then Kind := N_Op_Abs;
- elsif Op_Name = Name_Op_Not then Kind := N_Op_Not;
+ if Op_Name = Name_Op_Add then
+ Kind := N_Op_Plus;
+ elsif Op_Name = Name_Op_Subtract then
+ Kind := N_Op_Minus;
+ elsif Op_Name = Name_Op_Abs then
+ Kind := N_Op_Abs;
+ elsif Op_Name = Name_Op_Not then
+ Kind := N_Op_Not;
else
raise Program_Error;
end if;
return Kind;
end Operator_Kind;
- -----------------------------
- -- Pre_Analyze_And_Resolve --
- -----------------------------
+ ----------------------------
+ -- Preanalyze_And_Resolve --
+ ----------------------------
- procedure Pre_Analyze_And_Resolve (N : Node_Id; T : Entity_Id) is
+ procedure Preanalyze_And_Resolve (N : Node_Id; T : Entity_Id) is
Save_Full_Analysis : constant Boolean := Full_Analysis;
begin
Expander_Mode_Restore;
Full_Analysis := Save_Full_Analysis;
- end Pre_Analyze_And_Resolve;
+ end Preanalyze_And_Resolve;
-- Version without context type
- procedure Pre_Analyze_And_Resolve (N : Node_Id) is
+ procedure Preanalyze_And_Resolve (N : Node_Id) is
Save_Full_Analysis : constant Boolean := Full_Analysis;
begin
Expander_Mode_Restore;
Full_Analysis := Save_Full_Analysis;
- end Pre_Analyze_And_Resolve;
+ end Preanalyze_And_Resolve;
----------------------------------
-- Replace_Actual_Discriminants --
-------------
procedure Resolve (N : Node_Id; Typ : Entity_Id) is
+ Ambiguous : Boolean := False;
+ Ctx_Type : Entity_Id := Typ;
+ Expr_Type : Entity_Id := Empty; -- prevent junk warning
+ Err_Type : Entity_Id := Empty;
+ Found : Boolean := False;
+ From_Lib : Boolean;
I : Interp_Index;
- I1 : Interp_Index := 0; -- prevent junk warning
+ I1 : Interp_Index := 0; -- prevent junk warning
It : Interp;
It1 : Interp;
- Found : Boolean := False;
Seen : Entity_Id := Empty; -- prevent junk warning
- Ctx_Type : Entity_Id := Typ;
- Expr_Type : Entity_Id := Empty; -- prevent junk warning
- Err_Type : Entity_Id := Empty;
- Ambiguous : Boolean := False;
+
+ function Comes_From_Predefined_Lib_Unit (Nod : Node_Id) return Boolean;
+ -- Determine whether a node comes from a predefined library unit or
+ -- Standard.
procedure Patch_Up_Value (N : Node_Id; Typ : Entity_Id);
-- Try and fix up a literal so that it matches its expected type. New
procedure Resolution_Failed;
-- Called when attempt at resolving current expression fails
+ ------------------------------------
+ -- Comes_From_Predefined_Lib_Unit --
+ -------------------------------------
+
+ function Comes_From_Predefined_Lib_Unit (Nod : Node_Id) return Boolean is
+ begin
+ return
+ Sloc (Nod) = Standard_Location
+ or else Is_Predefined_File_Name (Unit_File_Name (
+ Get_Source_Unit (Sloc (Nod))));
+ end Comes_From_Predefined_Lib_Unit;
+
--------------------
-- Patch_Up_Value --
--------------------
Intval => UR_To_Uint (Realval (N))));
Set_Etype (N, Universal_Integer);
Set_Is_Static_Expression (N);
+
elsif Nkind (N) = N_String_Literal
and then Is_Character_Type (Typ)
then
("prefix must statically denote a non-remote subprogram", N);
end if;
+ From_Lib := Comes_From_Predefined_Lib_Unit (N);
+
-- If the context is a Remote_Access_To_Subprogram, access attributes
-- must be resolved with the corresponding fat pointer. There is no need
-- to check for the attribute name since the return type of an
Old_Id => Designated_Type
(Corresponding_Remote_Type (Typ)),
Err_Loc => N);
+
if Is_Remote then
Process_Remote_AST_Attribute (N, Typ);
end if;
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
+ -- with the expected type, any other interpretations are ignored.
if not Covers (Typ, It.Typ) then
if Debug_Flag_V then
end if;
else
+ -- Skip the current interpretation if it is disabled by an
+ -- abstract operator. This action is performed only when the
+ -- type against which we are resolving is the same as the
+ -- type of the interpretation.
+
+ if Ada_Version >= Ada_05
+ and then It.Typ = Typ
+ and then Typ /= Universal_Integer
+ and then Typ /= Universal_Real
+ and then Present (It.Abstract_Op)
+ then
+ goto Continue;
+ end if;
+
-- First matching interpretation
if not Found then
-- some more obscure cases are handled in Disambiguate.
else
+ -- If the current statement is part of a predefined library
+ -- unit, then all interpretations which come from user level
+ -- packages should not be considered.
+
+ if From_Lib
+ and then not Comes_From_Predefined_Lib_Unit (It.Nam)
+ then
+ goto Continue;
+ end if;
+
Error_Msg_Sloc := Sloc (Seen);
It1 := Disambiguate (N, I1, I, Typ);
-- of the arguments is Any_Type, and if so, suppress
-- the message, since it is a cascaded error.
- if Nkind (N) = N_Function_Call
- or else Nkind (N) = N_Procedure_Call_Statement
+ if Nkind_In (N, N_Function_Call,
+ N_Procedure_Call_Statement)
then
declare
A : Node_Id;
end loop;
end;
- elsif Nkind (N) in N_Binary_Op
+ elsif Nkind (N) in N_Binary_Op
and then (Etype (Left_Opnd (N)) = Any_Type
or else Etype (Right_Opnd (N)) = Any_Type)
then
("ambiguous expression "
& "(cannot resolve indirect call)!", N);
else
- Error_Msg_NE
+ Error_Msg_NE -- CODEFIX
("ambiguous expression (cannot resolve&)!",
N, It.Nam);
end if;
Error_Msg_N
("\\possible interpretation (inherited)#!", N);
else
- Error_Msg_N ("\\possible interpretation#!", N);
+ Error_Msg_N -- CODEFIX
+ ("\\possible interpretation#!", N);
end if;
end if;
and then Scope (It.Nam) = Standard_Standard
and then Present (Err_Type)
then
- Error_Msg_N
- ("\\possible interpretation (predefined)#!", N);
+ -- Special-case the message for universal_fixed
+ -- operators, which are not declared with the type
+ -- of the operand, but appear forever in Standard.
+
+ if It.Typ = Universal_Fixed
+ and then Scope (It.Nam) = Standard_Standard
+ then
+ Error_Msg_N
+ ("\\possible interpretation as " &
+ "universal_fixed operation " &
+ "(RM 4.5.5 (19))", N);
+ else
+ Error_Msg_N
+ ("\\possible interpretation (predefined)#!", N);
+ end if;
elsif
Nkind (Parent (It.Nam)) = N_Full_Type_Declaration
Error_Msg_N
("\\possible interpretation (inherited)#!", N);
else
- Error_Msg_N ("\\possible interpretation#!", N);
+ Error_Msg_N -- CODEFIX
+ ("\\possible interpretation#!", N);
end if;
end if;
elsif Nkind (N) = N_Character_Literal then
Set_Etype (N, Expr_Type);
+ elsif Nkind (N) = N_Conditional_Expression then
+ Set_Etype (N, Expr_Type);
+
-- For an explicit dereference, attribute reference, range,
-- short-circuit form (which is not an operator node), or call
-- with a name that is an explicit dereference, there is
-- nothing to be done at this point.
- elsif Nkind (N) = N_Explicit_Dereference
- or else Nkind (N) = N_Attribute_Reference
- or else Nkind (N) = N_And_Then
- or else Nkind (N) = N_Indexed_Component
- or else Nkind (N) = N_Or_Else
- or else Nkind (N) = N_Range
- or else Nkind (N) = N_Selected_Component
- or else Nkind (N) = N_Slice
+ elsif Nkind_In (N, N_Explicit_Dereference,
+ N_Attribute_Reference,
+ N_And_Then,
+ N_Indexed_Component,
+ N_Or_Else,
+ N_Range,
+ N_Selected_Component,
+ N_Slice)
or else Nkind (Name (N)) = N_Explicit_Dereference
then
null;
-- For procedure or function calls, set the type of the name,
-- and also the entity pointer for the prefix
- elsif (Nkind (N) = N_Procedure_Call_Statement
- or else Nkind (N) = N_Function_Call)
+ elsif Nkind_In (N, N_Procedure_Call_Statement, N_Function_Call)
and then (Is_Entity_Name (Name (N))
or else Nkind (Name (N)) = N_Operator_Symbol)
then
end if;
+ <<Continue>>
+
-- Move to next interpretation
exit Interp_Loop when No (It.Typ);
Get_First_Interp (Name (N), Index, It);
while Present (It.Nam) loop
Error_Msg_Sloc := Sloc (It.Nam);
- Error_Msg_Node_2 := It.Typ;
- Error_Msg_NE ("\& declared#, type&", N, It.Nam);
+ Error_Msg_Node_2 := It.Nam;
+ Error_Msg_NE
+ ("\\ type& for & declared#", N, It.Typ);
Get_Next_Interp (Index, It);
end loop;
end;
+
else
Error_Msg_N ("\use -gnatf for details", N);
end if;
end if;
end if;
- -- A user-defined operator is tranformed into a function call at
+ -- A user-defined operator is transformed 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
elsif Present (Alias (Entity (N)))
and then
- Nkind (Parent (Parent (Entity (N))))
- = N_Subprogram_Renaming_Declaration
+ Nkind (Parent (Parent (Entity (N)))) =
+ N_Subprogram_Renaming_Declaration
then
Rewrite_Renamed_Operator (N, Alias (Entity (N)), Typ);
when N_Allocator => Resolve_Allocator (N, Ctx_Type);
- when N_And_Then | N_Or_Else
+ when N_Short_Circuit
=> Resolve_Short_Circuit (N, Ctx_Type);
when N_Attribute_Reference
A_Typ : Entity_Id;
F_Typ : Entity_Id;
Prev : Node_Id := Empty;
+ Orig_A : Node_Id;
+
+ procedure Check_Argument_Order;
+ -- Performs a check for the case where the actuals are all simple
+ -- identifiers that correspond to the formal names, but in the wrong
+ -- order, which is considered suspicious and cause for a warning.
+
+ procedure Check_Prefixed_Call;
+ -- If the original node is an overloaded call in prefix notation,
+ -- insert an 'Access or a dereference as needed over the first actual.
+ -- Try_Object_Operation has already verified that there is a valid
+ -- interpretation, but the form of the actual can only be determined
+ -- once the primitive operation is identified.
procedure Insert_Default;
-- If the actual is missing in a call, insert in the actuals list
-- common type. Used to enforce the restrictions on array conversions
-- of AI95-00246.
+ function Static_Concatenation (N : Node_Id) return Boolean;
+ -- Predicate to determine whether an actual that is a concatenation
+ -- will be evaluated statically and does not need a transient scope.
+ -- This must be determined before the actual is resolved and expanded
+ -- because if needed the transient scope must be introduced earlier.
+
+ --------------------------
+ -- Check_Argument_Order --
+ --------------------------
+
+ procedure Check_Argument_Order is
+ begin
+ -- Nothing to do if no parameters, or original node is neither a
+ -- function call nor a procedure call statement (happens in the
+ -- operator-transformed-to-function call case), or the call does
+ -- not come from source, or this warning is off.
+
+ if not Warn_On_Parameter_Order
+ or else
+ No (Parameter_Associations (N))
+ or else
+ not Nkind_In (Original_Node (N), N_Procedure_Call_Statement,
+ N_Function_Call)
+ or else
+ not Comes_From_Source (N)
+ then
+ return;
+ end if;
+
+ declare
+ Nargs : constant Nat := List_Length (Parameter_Associations (N));
+
+ begin
+ -- Nothing to do if only one parameter
+
+ if Nargs < 2 then
+ return;
+ end if;
+
+ -- Here if at least two arguments
+
+ declare
+ Actuals : array (1 .. Nargs) of Node_Id;
+ Actual : Node_Id;
+ Formal : Node_Id;
+
+ Wrong_Order : Boolean := False;
+ -- Set True if an out of order case is found
+
+ begin
+ -- Collect identifier names of actuals, fail if any actual is
+ -- not a simple identifier, and record max length of name.
+
+ Actual := First (Parameter_Associations (N));
+ for J in Actuals'Range loop
+ if Nkind (Actual) /= N_Identifier then
+ return;
+ else
+ Actuals (J) := Actual;
+ Next (Actual);
+ end if;
+ end loop;
+
+ -- If we got this far, all actuals are identifiers and the list
+ -- of their names is stored in the Actuals array.
+
+ Formal := First_Formal (Nam);
+ for J in Actuals'Range loop
+
+ -- If we ran out of formals, that's odd, probably an error
+ -- which will be detected elsewhere, but abandon the search.
+
+ if No (Formal) then
+ return;
+ end if;
+
+ -- If name matches and is in order OK
+
+ if Chars (Formal) = Chars (Actuals (J)) then
+ null;
+
+ else
+ -- If no match, see if it is elsewhere in list and if so
+ -- flag potential wrong order if type is compatible.
+
+ for K in Actuals'Range loop
+ if Chars (Formal) = Chars (Actuals (K))
+ and then
+ Has_Compatible_Type (Actuals (K), Etype (Formal))
+ then
+ Wrong_Order := True;
+ goto Continue;
+ end if;
+ end loop;
+
+ -- No match
+
+ return;
+ end if;
+
+ <<Continue>> Next_Formal (Formal);
+ end loop;
+
+ -- If Formals left over, also probably an error, skip warning
+
+ if Present (Formal) then
+ return;
+ end if;
+
+ -- Here we give the warning if something was out of order
+
+ if Wrong_Order then
+ Error_Msg_N
+ ("actuals for this call may be in wrong order?", N);
+ end if;
+ end;
+ end;
+ end Check_Argument_Order;
+
+ -------------------------
+ -- Check_Prefixed_Call --
+ -------------------------
+
+ procedure Check_Prefixed_Call is
+ Act : constant Node_Id := First_Actual (N);
+ A_Type : constant Entity_Id := Etype (Act);
+ F_Type : constant Entity_Id := Etype (First_Formal (Nam));
+ Orig : constant Node_Id := Original_Node (N);
+ New_A : Node_Id;
+
+ begin
+ -- Check whether the call is a prefixed call, with or without
+ -- additional actuals.
+
+ if Nkind (Orig) = N_Selected_Component
+ or else
+ (Nkind (Orig) = N_Indexed_Component
+ and then Nkind (Prefix (Orig)) = N_Selected_Component
+ and then Is_Entity_Name (Prefix (Prefix (Orig)))
+ and then Is_Entity_Name (Act)
+ and then Chars (Act) = Chars (Prefix (Prefix (Orig))))
+ then
+ if Is_Access_Type (A_Type)
+ and then not Is_Access_Type (F_Type)
+ then
+ -- Introduce dereference on object in prefix
+
+ New_A :=
+ Make_Explicit_Dereference (Sloc (Act),
+ Prefix => Relocate_Node (Act));
+ Rewrite (Act, New_A);
+ Analyze (Act);
+
+ elsif Is_Access_Type (F_Type)
+ and then not Is_Access_Type (A_Type)
+ then
+ -- Introduce an implicit 'Access in prefix
+
+ if not Is_Aliased_View (Act) then
+ Error_Msg_NE
+ ("object in prefixed call to& must be aliased"
+ & " (RM-2005 4.3.1 (13))",
+ Prefix (Act), Nam);
+ end if;
+
+ Rewrite (Act,
+ Make_Attribute_Reference (Loc,
+ Attribute_Name => Name_Access,
+ Prefix => Relocate_Node (Act)));
+ end if;
+
+ Analyze (Act);
+ end if;
+ end Check_Prefixed_Call;
+
--------------------
-- Insert_Default --
--------------------
-- 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);
+ Actval :=
+ New_Copy_Tree
+ (Default_Value (F),
+ New_Scope => Current_Scope,
+ New_Sloc => Loc);
if Is_Concurrent_Type (Scope (Nam))
and then Has_Discriminants (Scope (Nam))
Set_Parent (Actval, N);
-- Resolve aggregates with their base type, to avoid scope
- -- anomalies: the subtype was first built in the suprogram
+ -- anomalies: the subtype was first built in the subprogram
-- declaration, and the current call may be nested.
if Nkind (Actval) = N_Aggregate
return Root_Type (Base_Type (FT1)) = Root_Type (Base_Type (FT2));
end Same_Ancestor;
+ --------------------------
+ -- Static_Concatenation --
+ --------------------------
+
+ function Static_Concatenation (N : Node_Id) return Boolean is
+ begin
+ case Nkind (N) is
+ when N_String_Literal =>
+ return True;
+
+ when N_Op_Concat =>
+
+ -- Concatenation is static when both operands are static
+ -- and the concatenation operator is a predefined one.
+
+ return Scope (Entity (N)) = Standard_Standard
+ and then
+ Static_Concatenation (Left_Opnd (N))
+ and then
+ Static_Concatenation (Right_Opnd (N));
+
+ when others =>
+ if Is_Entity_Name (N) then
+ declare
+ Ent : constant Entity_Id := Entity (N);
+ begin
+ return Ekind (Ent) = E_Constant
+ and then Present (Constant_Value (Ent))
+ and then
+ Is_Static_Expression (Constant_Value (Ent));
+ end;
+
+ else
+ return False;
+ end if;
+ end case;
+ end Static_Concatenation;
+
-- Start of processing for Resolve_Actuals
begin
+ Check_Argument_Order;
+
+ if Present (First_Actual (N)) then
+ Check_Prefixed_Call;
+ end if;
+
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.
+ -- 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
return;
end if;
+ -- Case where actual is present
+
+ -- If the actual is an entity, generate a reference to it now. We
+ -- do this before the actual is resolved, because a formal of some
+ -- protected subprogram, or a task discriminant, will be rewritten
+ -- during expansion, and the reference to the source entity may
+ -- be lost.
+
+ if Present (A)
+ and then Is_Entity_Name (A)
+ and then Comes_From_Source (N)
+ then
+ Orig_A := Entity (A);
+
+ if Present (Orig_A) then
+ if Is_Formal (Orig_A)
+ and then Ekind (F) /= E_In_Parameter
+ then
+ Generate_Reference (Orig_A, A, 'm');
+ elsif not Is_Overloaded (A) then
+ Generate_Reference (Orig_A, A);
+ end if;
+ end if;
+ end if;
+
if Present (A)
and then (Nkind (Parent (A)) /= N_Parameter_Association
or else
Chars (Selector_Name (Parent (A))) = Chars (F))
then
+ -- If style checking mode on, check match of formal name
+
+ if Style_Check then
+ if Nkind (Parent (A)) = N_Parameter_Association then
+ Check_Identifier (Selector_Name (Parent (A)), F);
+ end if;
+ end if;
+
-- 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
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)
+ -- In a view conversion, the conversion must be legal in
+ -- both directions, and thus both component types must be
+ -- aliased, or neither (4.6 (8)).
+
+ -- The additional rule 4.6 (24.9.2) seems unduly
+ -- restrictive: the privacy requirement should not apply
+ -- to generic types, and should be checked in an
+ -- instance. ARG query is in order ???
+
+ Error_Msg_N
+ ("both component types in a view conversion must be"
+ & " aliased, or neither", A);
- elsif Has_Aliased_Components (Etype (F))
- and then
- not Has_Aliased_Components (Etype (Expression (A)))
+ elsif
+ not Same_Ancestor (Etype (F), Etype (Expression (A)))
+ then
+ if Is_By_Reference_Type (Etype (F))
+ or else Is_By_Reference_Type (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);
+ ("view conversion between unrelated by reference " &
+ "array types not allowed (\'A'I-00246)", A);
+ else
+ declare
+ Comp_Type : constant Entity_Id :=
+ Component_Type
+ (Etype (Expression (A)));
+ begin
+ if Comes_From_Source (A)
+ and then Ada_Version >= Ada_05
+ and then
+ ((Is_Private_Type (Comp_Type)
+ and then not Is_Generic_Type (Comp_Type))
+ or else Is_Tagged_Type (Comp_Type)
+ or else Is_Volatile (Comp_Type))
+ then
+ Error_Msg_N
+ ("component type of a view conversion cannot"
+ & " be private, tagged, or volatile"
+ & " (RM 4.6 (24))",
+ Expression (A));
+ end if;
+ end;
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;
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)))
+ -- If the actual is a function call that returns a limited
+ -- unconstrained object that needs finalization, create a
+ -- transient scope for it, so that it can receive the proper
+ -- finalization list.
+
+ elsif Nkind (A) = N_Function_Call
+ and then Is_Limited_Record (Etype (F))
+ and then not Is_Constrained (Etype (F))
+ and then Expander_Active
+ and then
+ (Is_Controlled (Etype (F)) or else Has_Task (Etype (F)))
+ then
+ Establish_Transient_Scope (A, False);
+
+ -- A small optimization: if one of the actuals is a concatenation
+ -- create a block around a procedure call to recover stack space.
+ -- This alleviates stack usage when several procedure calls in
+ -- the same statement list use concatenation. We do not perform
+ -- this wrapping for code statements, where the argument is a
+ -- static string, and we want to preserve warnings involving
+ -- sequences of such statements.
+
+ elsif Nkind (A) = N_Op_Concat
+ and then Nkind (N) = N_Procedure_Call_Statement
+ and then Expander_Active
+ and then
+ not (Is_Intrinsic_Subprogram (Nam)
+ and then Chars (Nam) = Name_Asm)
+ and then not Static_Concatenation (A)
+ then
+ Establish_Transient_Scope (A, False);
+ Resolve (A, Etype (F));
+
+ 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))))
declare
DDT : constant Entity_Id :=
Directly_Designated_Type (Base_Type (Etype (F)));
+
New_Itype : Entity_Id;
+
begin
if Is_Class_Wide_Type (DDT)
and then Is_Interface (DDT)
then
New_Itype := Create_Itype (E_Anonymous_Access_Type, A);
- Set_Etype (New_Itype, Etype (A));
- Init_Size_Align (New_Itype);
+ Set_Etype (New_Itype, Etype (A));
Set_Directly_Designated_Type (New_Itype,
Directly_Designated_Type (Etype (A)));
Set_Etype (A, New_Itype);
-- Ada 2005, AI-162:If the actual is an allocator, the
-- innermost enclosing statement is the master of the
- -- created object.
+ -- created object. This needs to be done with expansion
+ -- enabled only, otherwise the transient scope will not
+ -- be removed in the expansion of the wrapped construct.
- if Is_Controlled (DDT)
- or else Has_Task (DDT)
+ if (Is_Controlled (DDT) or else Has_Task (DDT))
+ and then Expander_Active
then
Establish_Transient_Scope (A, False);
end if;
end;
end if;
- Resolve (A, Etype (F));
+ -- (Ada 2005): The call may be to a primitive operation of
+ -- a tagged synchronized type, declared outside of the type.
+ -- In this case the controlling actual must be converted to
+ -- its corresponding record type, which is the formal type.
+ -- The actual may be a subtype, either because of a constraint
+ -- or because it is a generic actual, so use base type to
+ -- locate concurrent type.
+
+ A_Typ := Base_Type (Etype (A));
+ F_Typ := Base_Type (Etype (F));
+
+ declare
+ Full_A_Typ : Entity_Id;
+
+ begin
+ if Present (Full_View (A_Typ)) then
+ Full_A_Typ := Base_Type (Full_View (A_Typ));
+ else
+ Full_A_Typ := A_Typ;
+ end if;
+
+ -- Tagged synchronized type (case 1): the actual is a
+ -- concurrent type
+
+ if Is_Concurrent_Type (A_Typ)
+ and then Corresponding_Record_Type (A_Typ) = F_Typ
+ then
+ Rewrite (A,
+ Unchecked_Convert_To
+ (Corresponding_Record_Type (A_Typ), A));
+ Resolve (A, Etype (F));
+
+ -- Tagged synchronized type (case 2): the formal is a
+ -- concurrent type
+
+ elsif Ekind (Full_A_Typ) = E_Record_Type
+ and then Present
+ (Corresponding_Concurrent_Type (Full_A_Typ))
+ and then Is_Concurrent_Type (F_Typ)
+ and then Present (Corresponding_Record_Type (F_Typ))
+ and then Full_A_Typ = Corresponding_Record_Type (F_Typ)
+ then
+ Resolve (A, Corresponding_Record_Type (F_Typ));
+
+ -- Common case
+
+ else
+ Resolve (A, Etype (F));
+ end if;
+ end;
end if;
A_Typ := Etype (A);
F_Typ := Etype (F);
+ -- For mode IN, if actual is an entity, and the type of the formal
+ -- has warnings suppressed, then we reset Never_Set_In_Source for
+ -- the calling entity. The reason for this is to catch cases like
+ -- GNAT.Spitbol.Patterns.Vstring_Var where the called subprogram
+ -- uses trickery to modify an IN parameter.
+
+ if Ekind (F) = E_In_Parameter
+ and then Is_Entity_Name (A)
+ and then Present (Entity (A))
+ and then Ekind (Entity (A)) = E_Variable
+ and then Has_Warnings_Off (F_Typ)
+ then
+ Set_Never_Set_In_Source (Entity (A), False);
+ end if;
+
-- Perform error checks for IN and IN OUT parameters
if Ekind (F) /= 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);
+ -- Case of OUT or IN OUT parameter
+
+ if Ekind (F) /= E_In_Parameter then
+
+ -- For an Out parameter, check for useless assignment. Note
+ -- that we can't set Last_Assignment this early, because we may
+ -- kill current values in Resolve_Call, and that call would
+ -- clobber the Last_Assignment field.
+
+ -- Note: call Warn_On_Useless_Assignment before doing the check
+ -- below for Is_OK_Variable_For_Out_Formal so that the setting
+ -- of Referenced_As_LHS/Referenced_As_Out_Formal properly
+ -- reflects the last assignment, not this one!
+
+ if Ekind (F) = E_Out_Parameter then
+ if Warn_On_Modified_As_Out_Parameter (F)
+ and then Is_Entity_Name (A)
+ and then Present (Entity (A))
+ and then Comes_From_Source (N)
+ then
+ Warn_On_Useless_Assignment (Entity (A), A);
+ end if;
+ end if;
+
+ -- Validate the form of the actual. Note that the call to
+ -- Is_OK_Variable_For_Out_Formal generates the required
+ -- reference in this case.
+
+ if not Is_OK_Variable_For_Out_Formal (A) then
+ Error_Msg_NE ("actual for& must be a variable", A, F);
+ end if;
+
+ -- What's the following about???
if Is_Entity_Name (A) then
Kill_Checks (Entity (A));
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
+ and then Known_Null (A)
then
Apply_Compile_Time_Constraint_Error
(N => A,
- Msg => "(Ada 2005) NULL not allowed in "
+ Msg => "(Ada 2005) null not allowed in "
& "null-excluding formal?",
Reason => CE_Null_Not_Allowed);
end if;
end if;
-- An actual associated with an access parameter is implicitly
- -- converted to the anonymous access type of the formal and
- -- must satisfy the legality checks for access conversions.
+ -- converted to the anonymous access type of the formal and must
+ -- satisfy the legality checks for access conversions.
if Ekind (F_Typ) = E_Anonymous_Access_Type then
if not Valid_Conversion (A, F_Typ, A) then
end if;
-- Check that subprograms don't have improper controlling
- -- arguments (RM 3.9.2 (9))
+ -- arguments (RM 3.9.2 (9)).
-- A primitive operation may have an access parameter of an
-- incomplete tagged type, but a dispatching call is illegal
elsif Is_Access_Type (A_Typ)
and then Is_Access_Type (F_Typ)
and then Ekind (F_Typ) /= E_Access_Subprogram_Type
+ and then Ekind (F_Typ) /= E_Anonymous_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)))))
+ 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)
+
+ -- Disable these checks for call to imported C++ subprograms
+
+ and then not
+ (Is_Entity_Name (Name (N))
+ and then Is_Imported (Entity (Name (N)))
+ and then Convention (Entity (Name (N))) = Convention_CPP)
then
Error_Msg_N
("access to class-wide argument not allowed here!", A);
Subtyp : Entity_Id;
Discrim : Entity_Id;
Constr : Node_Id;
+ Aggr : Node_Id;
+ Assoc : Node_Id := Empty;
Disc_Exp : Node_Id;
+ procedure Check_Allocator_Discrim_Accessibility
+ (Disc_Exp : Node_Id;
+ Alloc_Typ : Entity_Id);
+ -- Check that accessibility level associated with an access discriminant
+ -- initialized in an allocator by the expression Disc_Exp is not deeper
+ -- than the level of the allocator type Alloc_Typ. An error message is
+ -- issued if this condition is violated. Specialized checks are done for
+ -- the cases of a constraint expression which is an access attribute or
+ -- an access discriminant.
+
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.
+ -- 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.
+
+ procedure Propagate_Coextensions (Root : Node_Id);
+ -- Propagate all nested coextensions which are located one nesting
+ -- level down the tree to the node Root. Example:
+ --
+ -- Top_Record
+ -- Level_1_Coextension
+ -- Level_2_Coextension
+ --
+ -- The algorithm is paired with delay actions done by the Expander. In
+ -- the above example, assume all coextensions are controlled types.
+ -- The cycle of analysis, resolution and expansion will yield:
+ --
+ -- 1) Analyze Top_Record
+ -- 2) Analyze Level_1_Coextension
+ -- 3) Analyze Level_2_Coextension
+ -- 4) Resolve Level_2_Coextension. The allocator is marked as a
+ -- coextension.
+ -- 5) Expand Level_2_Coextension. A temporary variable Temp_1 is
+ -- generated to capture the allocated object. Temp_1 is attached
+ -- to the coextension chain of Level_2_Coextension.
+ -- 6) Resolve Level_1_Coextension. The allocator is marked as a
+ -- coextension. A forward tree traversal is performed which finds
+ -- Level_2_Coextension's list and copies its contents into its
+ -- own list.
+ -- 7) Expand Level_1_Coextension. A temporary variable Temp_2 is
+ -- generated to capture the allocated object. Temp_2 is attached
+ -- to the coextension chain of Level_1_Coextension. Currently, the
+ -- contents of the list are [Temp_2, Temp_1].
+ -- 8) Resolve Top_Record. A forward tree traversal is performed which
+ -- finds Level_1_Coextension's list and copies its contents into
+ -- its own list.
+ -- 9) Expand Top_Record. Generate finalization calls for Temp_1 and
+ -- Temp_2 and attach them to Top_Record's finalization list.
+
+ -------------------------------------------
+ -- Check_Allocator_Discrim_Accessibility --
+ -------------------------------------------
+
+ procedure Check_Allocator_Discrim_Accessibility
+ (Disc_Exp : Node_Id;
+ Alloc_Typ : Entity_Id)
+ is
+ begin
+ if Type_Access_Level (Etype (Disc_Exp)) >
+ Type_Access_Level (Alloc_Typ)
+ then
+ Error_Msg_N
+ ("operand type has deeper level than allocator type", Disc_Exp);
+
+ -- When the expression is an Access attribute the level of the prefix
+ -- object must not be deeper than that of the allocator's type.
+
+ elsif Nkind (Disc_Exp) = N_Attribute_Reference
+ and then Get_Attribute_Id (Attribute_Name (Disc_Exp))
+ = Attribute_Access
+ and then Object_Access_Level (Prefix (Disc_Exp))
+ > Type_Access_Level (Alloc_Typ)
+ then
+ Error_Msg_N
+ ("prefix of attribute has deeper level than allocator type",
+ Disc_Exp);
+
+ -- When the expression is an access discriminant the check is against
+ -- the level of the prefix object.
+
+ elsif Ekind (Etype (Disc_Exp)) = E_Anonymous_Access_Type
+ and then Nkind (Disc_Exp) = N_Selected_Component
+ and then Object_Access_Level (Prefix (Disc_Exp))
+ > Type_Access_Level (Alloc_Typ)
+ then
+ Error_Msg_N
+ ("access discriminant has deeper level than allocator type",
+ Disc_Exp);
+
+ -- All other cases are legal
+
+ else
+ null;
+ end if;
+ end Check_Allocator_Discrim_Accessibility;
----------------------------
-- 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)
+ return Nkind_In (Par, N_Function_Call, N_Procedure_Call_Statement)
and then Is_Entity_Name (Name (Par))
and then Is_Dispatching_Operation (Entity (Name (Par)));
end In_Dispatching_Context;
+ ----------------------------
+ -- Propagate_Coextensions --
+ ----------------------------
+
+ procedure Propagate_Coextensions (Root : Node_Id) is
+
+ procedure Copy_List (From : Elist_Id; To : Elist_Id);
+ -- Copy the contents of list From into list To, preserving the
+ -- order of elements.
+
+ function Process_Allocator (Nod : Node_Id) return Traverse_Result;
+ -- Recognize an allocator or a rewritten allocator node and add it
+ -- along with its nested coextensions to the list of Root.
+
+ ---------------
+ -- Copy_List --
+ ---------------
+
+ procedure Copy_List (From : Elist_Id; To : Elist_Id) is
+ From_Elmt : Elmt_Id;
+ begin
+ From_Elmt := First_Elmt (From);
+ while Present (From_Elmt) loop
+ Append_Elmt (Node (From_Elmt), To);
+ Next_Elmt (From_Elmt);
+ end loop;
+ end Copy_List;
+
+ -----------------------
+ -- Process_Allocator --
+ -----------------------
+
+ function Process_Allocator (Nod : Node_Id) return Traverse_Result is
+ Orig_Nod : Node_Id := Nod;
+
+ begin
+ -- This is a possible rewritten subtype indication allocator. Any
+ -- nested coextensions will appear as discriminant constraints.
+
+ if Nkind (Nod) = N_Identifier
+ and then Present (Original_Node (Nod))
+ and then Nkind (Original_Node (Nod)) = N_Subtype_Indication
+ then
+ declare
+ Discr : Node_Id;
+ Discr_Elmt : Elmt_Id;
+
+ begin
+ if Is_Record_Type (Entity (Nod)) then
+ Discr_Elmt :=
+ First_Elmt (Discriminant_Constraint (Entity (Nod)));
+ while Present (Discr_Elmt) loop
+ Discr := Node (Discr_Elmt);
+
+ if Nkind (Discr) = N_Identifier
+ and then Present (Original_Node (Discr))
+ and then Nkind (Original_Node (Discr)) = N_Allocator
+ and then Present (Coextensions (
+ Original_Node (Discr)))
+ then
+ if No (Coextensions (Root)) then
+ Set_Coextensions (Root, New_Elmt_List);
+ end if;
+
+ Copy_List
+ (From => Coextensions (Original_Node (Discr)),
+ To => Coextensions (Root));
+ end if;
+
+ Next_Elmt (Discr_Elmt);
+ end loop;
+
+ -- There is no need to continue the traversal of this
+ -- subtree since all the information has already been
+ -- propagated.
+
+ return Skip;
+ end if;
+ end;
+
+ -- Case of either a stand alone allocator or a rewritten allocator
+ -- with an aggregate.
+
+ else
+ if Present (Original_Node (Nod)) then
+ Orig_Nod := Original_Node (Nod);
+ end if;
+
+ if Nkind (Orig_Nod) = N_Allocator then
+
+ -- Propagate the list of nested coextensions to the Root
+ -- allocator. This is done through list copy since a single
+ -- allocator may have multiple coextensions. Do not touch
+ -- coextensions roots.
+
+ if not Is_Coextension_Root (Orig_Nod)
+ and then Present (Coextensions (Orig_Nod))
+ then
+ if No (Coextensions (Root)) then
+ Set_Coextensions (Root, New_Elmt_List);
+ end if;
+
+ Copy_List
+ (From => Coextensions (Orig_Nod),
+ To => Coextensions (Root));
+ end if;
+
+ -- There is no need to continue the traversal of this
+ -- subtree since all the information has already been
+ -- propagated.
+
+ return Skip;
+ end if;
+ end if;
+
+ -- Keep on traversing, looking for the next allocator
+
+ return OK;
+ end Process_Allocator;
+
+ procedure Process_Allocators is
+ new Traverse_Proc (Process_Allocator);
+
+ -- Start of processing for Propagate_Coextensions
+
+ begin
+ Process_Allocators (Expression (Root));
+ end Propagate_Coextensions;
+
-- Start of processing for Resolve_Allocator
begin
-- class-wide matching is not allowed.
if (Is_Class_Wide_Type (Etype (Expression (E)))
- or else Is_Class_Wide_Type (Etype (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;
+ -- A special accessibility check is needed for allocators that
+ -- constrain access discriminants. The level of the type of the
+ -- expression used to constrain an access discriminant cannot be
+ -- deeper than the type of the allocator (in contrast to access
+ -- parameters, where the level of the actual can be arbitrary).
+
+ -- We can't use Valid_Conversion to perform this check because
+ -- in general the type of the allocator is unrelated to the type
+ -- of the access discriminant.
+
+ if Ekind (Typ) /= E_Anonymous_Access_Type
+ or else Is_Local_Anonymous_Access (Typ)
+ then
+ Subtyp := Entity (Subtype_Mark (E));
+
+ Aggr := Original_Node (Expression (E));
+
+ if Has_Discriminants (Subtyp)
+ and then Nkind_In (Aggr, N_Aggregate, N_Extension_Aggregate)
+ then
+ Discrim := First_Discriminant (Base_Type (Subtyp));
+
+ -- Get the first component expression of the aggregate
+
+ if Present (Expressions (Aggr)) then
+ Disc_Exp := First (Expressions (Aggr));
+
+ elsif Present (Component_Associations (Aggr)) then
+ Assoc := First (Component_Associations (Aggr));
+
+ if Present (Assoc) then
+ Disc_Exp := Expression (Assoc);
+ else
+ Disc_Exp := Empty;
+ end if;
+
+ else
+ Disc_Exp := Empty;
+ end if;
+
+ while Present (Discrim) and then Present (Disc_Exp) loop
+ if Ekind (Etype (Discrim)) = E_Anonymous_Access_Type then
+ Check_Allocator_Discrim_Accessibility (Disc_Exp, Typ);
+ end if;
+
+ Next_Discriminant (Discrim);
+
+ if Present (Discrim) then
+ if Present (Assoc) then
+ Next (Assoc);
+ Disc_Exp := Expression (Assoc);
+
+ elsif Present (Next (Disc_Exp)) then
+ Next (Disc_Exp);
+
+ else
+ Assoc := First (Component_Associations (Aggr));
+
+ if Present (Assoc) then
+ Disc_Exp := Expression (Assoc);
+ else
+ Disc_Exp := Empty;
+ end if;
+ end if;
+ end if;
+ end loop;
+ end if;
+ end if;
+
-- For a subtype mark or subtype indication, freeze the subtype
else
-- A special accessibility check is needed for allocators that
-- constrain access discriminants. The level of the type of the
- -- expression used to contrain an access discriminant cannot be
- -- deeper than the type of the allocator (in constrast to access
+ -- expression used to constrain an access discriminant cannot be
+ -- deeper than the type of the allocator (in contrast to access
-- parameters, where the level of the actual can be arbitrary).
-- We can't use Valid_Conversion to perform this check because
-- in general the type of the allocator is unrelated to the type
- -- of the access discriminant. Note that specialized checks are
- -- needed for the cases of a constraint expression which is an
- -- access attribute or an access discriminant.
+ -- of the access discriminant.
if Nkind (Original_Node (E)) = N_Subtype_Indication
- and then Ekind (Typ) /= E_Anonymous_Access_Type
+ and then (Ekind (Typ) /= E_Anonymous_Access_Type
+ or else Is_Local_Anonymous_Access (Typ))
then
Subtyp := Entity (Subtype_Mark (Original_Node (E)));
Disc_Exp := Original_Node (Constr);
end if;
- if Type_Access_Level (Etype (Disc_Exp))
- > Type_Access_Level (Typ)
- then
- Error_Msg_N
- ("operand type has deeper level than allocator type",
- Disc_Exp);
-
- elsif Nkind (Disc_Exp) = N_Attribute_Reference
- and then Get_Attribute_Id (Attribute_Name (Disc_Exp))
- = Attribute_Access
- and then Object_Access_Level (Prefix (Disc_Exp))
- > Type_Access_Level (Typ)
- then
- Error_Msg_N
- ("prefix of attribute has deeper level than"
- & " allocator type", Disc_Exp);
-
- -- When the operand is an access discriminant the check
- -- is against the level of the prefix object.
-
- elsif Ekind (Etype (Disc_Exp)) = E_Anonymous_Access_Type
- and then Nkind (Disc_Exp) = N_Selected_Component
- and then Object_Access_Level (Prefix (Disc_Exp))
- > Type_Access_Level (Typ)
- then
- Error_Msg_N
- ("access discriminant has deeper level than"
- & " allocator type", Disc_Exp);
- end if;
+ Check_Allocator_Discrim_Accessibility (Disc_Exp, Typ);
end if;
+
Next_Discriminant (Discrim);
Next (Constr);
end loop;
and then Is_Class_Wide_Type (Designated_Type (Typ))
then
declare
- Exp_Typ : Entity_Id;
+ Exp_Typ : Entity_Id;
begin
if Nkind (E) = N_Qualified_Expression 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);
+ Error_Msg_N ("?allocation from empty storage pool!", N);
+ Error_Msg_N ("\?Storage_Error will be raised at run time!", N);
Insert_Action (N,
Make_Raise_Storage_Error (Loc,
Reason => SE_Empty_Storage_Pool));
Set_Associated_Storage_Pool
(Typ, Associated_Storage_Pool (Etype (Parent (N))));
end if;
+
+ -- An erroneous allocator may be rewritten as a raise Program_Error
+ -- statement.
+
+ if Nkind (N) = N_Allocator then
+
+ -- An anonymous access discriminant is the definition of a
+ -- coextension.
+
+ if Ekind (Typ) = E_Anonymous_Access_Type
+ and then Nkind (Associated_Node_For_Itype (Typ)) =
+ N_Discriminant_Specification
+ then
+ -- Avoid marking an allocator as a dynamic coextension if it is
+ -- within a static construct.
+
+ if not Is_Static_Coextension (N) then
+ Set_Is_Dynamic_Coextension (N);
+ end if;
+
+ -- Cleanup for potential static coextensions
+
+ else
+ Set_Is_Dynamic_Coextension (N, False);
+ Set_Is_Static_Coextension (N, False);
+ end if;
+
+ -- There is no need to propagate any nested coextensions if they
+ -- are marked as static since they will be rewritten on the spot.
+
+ if not Is_Static_Coextension (N) then
+ Propagate_Coextensions (N);
+ end if;
+ end if;
end Resolve_Allocator;
---------------------------
-- N is the expression after "delta" in a fixed_point_definition;
-- see RM-3.5.9(6):
- return Nkind (Parent (N)) = N_Ordinary_Fixed_Point_Definition
- or else Nkind (Parent (N)) = N_Decimal_Fixed_Point_Definition
+ return Nkind_In (Parent (N), N_Ordinary_Fixed_Point_Definition,
+ N_Decimal_Fixed_Point_Definition,
-- N is one of the bounds in a real_range_specification;
-- see RM-3.5.7(5):
- or else Nkind (Parent (N)) = N_Real_Range_Specification
+ N_Real_Range_Specification,
-- N is the expression of a delta_constraint;
-- see RM-J.3(3):
- or else Nkind (Parent (N)) = N_Delta_Constraint;
+ N_Delta_Constraint);
end Expected_Type_Is_Any_Real;
-----------------------------
-- conversion to a specific fixed-point type (instead the expander
-- takes care of the case).
- elsif (B_Typ = Universal_Integer
- or else B_Typ = Universal_Real)
+ elsif (B_Typ = Universal_Integer or else B_Typ = Universal_Real)
and then Present (Universal_Interpretation (L))
and then Present (Universal_Interpretation (R))
then
Set_Etype (N, B_Typ);
elsif (B_Typ = Universal_Real
- or else Etype (N) = Universal_Fixed
- or else (Etype (N) = Any_Fixed
- and then Is_Fixed_Point_Type (B_Typ))
- or else (Is_Fixed_Point_Type (B_Typ)
- and then (Is_Integer_Or_Universal (L)
- or else
- Is_Integer_Or_Universal (R))))
- and then (Nkind (N) = N_Op_Multiply or else
- Nkind (N) = N_Op_Divide)
+ or else Etype (N) = Universal_Fixed
+ or else (Etype (N) = Any_Fixed
+ and then Is_Fixed_Point_Type (B_Typ))
+ or else (Is_Fixed_Point_Type (B_Typ)
+ and then (Is_Integer_Or_Universal (L)
+ or else
+ Is_Integer_Or_Universal (R))))
+ and then Nkind_In (N, N_Op_Multiply, N_Op_Divide)
then
if TL = Universal_Integer or else TR = Universal_Integer then
Check_For_Visible_Operator (N, B_Typ);
Set_Mixed_Mode_Operand (R, TL);
end if;
- -- Check the rule in RM05-4.5.5(19.1/2) disallowing the
- -- universal_fixed multiplying operators from being used when the
- -- expected type is also universal_fixed. Note that B_Typ will be
- -- Universal_Fixed in some cases where the expected type is actually
- -- Any_Real; Expected_Type_Is_Any_Real takes care of that case.
+ -- Check the rule in RM05-4.5.5(19.1/2) disallowing universal_fixed
+ -- multiplying operators from being used when the expected type is
+ -- also universal_fixed. Note that B_Typ will be Universal_Fixed in
+ -- some cases where the expected type is actually Any_Real;
+ -- Expected_Type_Is_Any_Real takes care of that case.
if Etype (N) = Universal_Fixed
or else Etype (N) = Any_Fixed
then
if B_Typ = Universal_Fixed
and then not Expected_Type_Is_Any_Real (N)
- and then Nkind (Parent (N)) /= N_Type_Conversion
- and then Nkind (Parent (N)) /= N_Unchecked_Type_Conversion
+ and then not Nkind_In (Parent (N), N_Type_Conversion,
+ N_Unchecked_Type_Conversion)
then
- Error_Msg_N
- ("type cannot be determined from context!", N);
- Error_Msg_N
- ("\explicit conversion to result type required", N);
+ Error_Msg_N ("type cannot be determined from context!", N);
+ Error_Msg_N ("\explicit conversion to result type required", N);
Set_Etype (L, Any_Type);
Set_Etype (R, Any_Type);
else
if Ada_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
+ and then Etype (N) = Universal_Fixed
+ and then not
+ Nkind_In (Parent (N), N_Type_Conversion,
+ N_Unchecked_Type_Conversion)
then
Error_Msg_N
- ("(Ada 83) fixed-point operation " &
- "needs explicit conversion",
- N);
+ ("(Ada 83) fixed-point operation "
+ & "needs explicit conversion", N);
end if;
-- The expected type is "any real type" in contexts like
and then (Is_Integer_Or_Universal (L)
or else Nkind (L) = N_Real_Literal
or else Nkind (R) = N_Real_Literal
- or else
- Is_Integer_Or_Universal (R))
+ or else Is_Integer_Or_Universal (R))
then
Set_Etype (N, B_Typ);
else
if (TL = Universal_Integer or else TL = Universal_Real)
- and then (TR = Universal_Integer or else TR = Universal_Real)
+ and then
+ (TR = Universal_Integer or else TR = Universal_Real)
then
Check_For_Visible_Operator (N, B_Typ);
end if;
-- universal fixed, this is an error, unless there is only one
-- applicable fixed_point type (usually duration).
- if B_Typ = Universal_Fixed
- and then Etype (L) = Universal_Fixed
- then
+ if B_Typ = Universal_Fixed and then Etype (L) = Universal_Fixed then
T := Unique_Fixed_Point_Type (N);
if T = Any_Type then
-- 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)
+ if Nkind_In (N, N_Op_Divide, N_Op_Rem, N_Op_Mod)
and then not Division_Checks_Suppressed (Etype (N))
then
Rop := Right_Opnd (N);
if Compile_Time_Known_Value (Rop)
and then ((Is_Integer_Type (Etype (Rop))
- and then Expr_Value (Rop) = Uint_0)
+ and then Expr_Value (Rop) = Uint_0)
or else
(Is_Real_Type (Etype (Rop))
- and then Expr_Value_R (Rop) = Ureal_0))
+ and then Expr_Value_R (Rop) = Ureal_0))
then
-- Specialize the warning message according to the operation
-- Otherwise just set the flag to check at run time
else
- Set_Do_Division_Check (N);
+ Activate_Division_Check (N);
end if;
end if;
+
+ -- If Restriction No_Implicit_Conditionals is active, then it is
+ -- violated if either operand can be negative for mod, or for rem
+ -- if both operands can be negative.
+
+ if Restrictions.Set (No_Implicit_Conditionals)
+ and then Nkind_In (N, N_Op_Rem, N_Op_Mod)
+ then
+ declare
+ Lo : Uint;
+ Hi : Uint;
+ OK : Boolean;
+
+ LNeg : Boolean;
+ RNeg : Boolean;
+ -- Set if corresponding operand might be negative
+
+ begin
+ Determine_Range
+ (Left_Opnd (N), OK, Lo, Hi, Assume_Valid => True);
+ LNeg := (not OK) or else Lo < 0;
+
+ Determine_Range
+ (Right_Opnd (N), OK, Lo, Hi, Assume_Valid => True);
+ RNeg := (not OK) or else Lo < 0;
+
+ -- Check if we will be generating conditionals. There are two
+ -- cases where that can happen, first for REM, the only case
+ -- is largest negative integer mod -1, where the division can
+ -- overflow, but we still have to give the right result. The
+ -- front end generates a test for this annoying case. Here we
+ -- just test if both operands can be negative (that's what the
+ -- expander does, so we match its logic here).
+
+ -- The second case is mod where either operand can be negative.
+ -- In this case, the back end has to generate additonal tests.
+
+ if (Nkind (N) = N_Op_Rem and then (LNeg and RNeg))
+ or else
+ (Nkind (N) = N_Op_Mod and then (LNeg or RNeg))
+ then
+ Check_Restriction (No_Implicit_Conditionals, N);
+ end if;
+ end;
+ end if;
end if;
Check_Unset_Reference (L);
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.
+ -- 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
+ elsif Nkind_In (Subp, N_Selected_Component, N_Indexed_Component)
or else (Is_Entity_Name (Subp)
and then Ekind (Entity (Subp)) = E_Entry)
then
elsif not (Is_Type (Entity (Subp))) then
Nam := Entity (Subp);
Set_Entity_With_Style_Check (Subp, Nam);
- Generate_Reference (Nam, Subp);
-- Otherwise we must have the case of an overloaded call
else
pragma Assert (Is_Overloaded (Subp));
- Nam := Empty; -- We know that it will be assigned in loop below
+
+ -- Initialize Nam to prevent warning (we know it will be assigned
+ -- in the loop below, but the compiler does not know that).
+
+ Nam := Empty;
Get_First_Interp (Subp, I, It);
while Present (It.Typ) loop
if Covers (Typ, It.Typ) then
Nam := It.Nam;
Set_Entity_With_Style_Check (Subp, Nam);
- Generate_Reference (Nam, Subp);
exit;
end if;
end loop;
end if;
+ if Is_Access_Subprogram_Type (Base_Type (Etype (Nam)))
+ and then not Is_Access_Subprogram_Type (Base_Type (Typ))
+ and then Nkind (Subp) /= N_Explicit_Dereference
+ and then Present (Parameter_Associations (N))
+ then
+ -- The prefix is a parameterless function call that returns an access
+ -- to subprogram. If parameters are present in the current call, add
+ -- add an explicit dereference. We use the base type here because
+ -- within an instance these may be subtypes.
+
+ -- The dereference is added either in Analyze_Call or here. Should
+ -- be consolidated ???
+
+ Set_Is_Overloaded (Subp, False);
+ Set_Etype (Subp, Etype (Nam));
+ Insert_Explicit_Dereference (Subp);
+ Nam := Designated_Type (Etype (Nam));
+ Resolve (Subp, Nam);
+ end if;
+
-- Check that a call to Current_Task does not occur in an entry body
if Is_RTE (Nam, RE_Current_Task) then
P := N;
loop
P := Parent (P);
- exit when No (P);
+
+ -- Exclude calls that occur within the default of a formal
+ -- parameter of the entry, since those are evaluated outside
+ -- of the body.
+
+ exit when No (P) or else Nkind (P) = N_Parameter_Specification;
if Nkind (P) = N_Entry_Body
or else (Nkind (P) = N_Subprogram_Body
- and then Is_Entry_Barrier_Function (P))
+ and then Is_Entry_Barrier_Function (P))
then
Rtype := Etype (N);
Error_Msg_NE
- ("& should not be used in entry body ('R'M C.7(17))?",
+ ("?& should not be used in entry body (RM C.7(17))",
N, Nam);
Error_Msg_NE
("\Program_Error will be raised at run time?", N, Nam);
Make_Raise_Program_Error (Loc,
Reason => PE_Current_Task_In_Entry_Body));
Set_Etype (N, Rtype);
- exit;
+ return;
end if;
end loop;
end;
end if;
- -- Cannot call thread body directly
-
- if Is_Thread_Body (Nam) then
- Error_Msg_N ("cannot call thread body directly", N);
- end if;
-
-- 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
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
+ -- for a procedure_or_entry_call, the procedure_name or
+ -- procedure_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.
end if;
end if;
- -- Check that this is not a call to a protected procedure or
- -- entry from within a protected function.
+ -- 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
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 the subprogram name if not in a spec-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
-- needs extending because we can generate procedure calls that need
-- freezing.
- if Is_Entity_Name (Subp) and then not In_Default_Expression then
+ if Is_Entity_Name (Subp) and then not In_Spec_Expression then
Freeze_Expression (Subp);
end if;
New_Subp := Relocate_Node (Subp);
Set_Entity (Subp, Nam);
- if Component_Type (Ret_Type) /= Any_Type then
+ if (Is_Array_Type (Ret_Type)
+ and then Component_Type (Ret_Type) /= Any_Type)
+ or else
+ (Is_Access_Type (Ret_Type)
+ and then
+ Component_Type (Designated_Type (Ret_Type)) /= Any_Type)
+ then
if Needs_No_Actuals (Nam) then
-- Indexed call to a parameterless function
-- 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.
+ -- No_Recursion is in effect anyway, and do it only for source calls.
- Scop := Current_Scope;
+ if Comes_From_Source (N) then
+ Scop := Current_Scope;
- if Nam = Scop
- 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
- -- not need to test the case below for further warnings.
+ -- Issue warning for possible infinite recursion in the absence
+ -- of the No_Recursion restriction.
- null;
+ if Nam = Scop
+ 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
+ -- not need to test the case below for further warnings. Also if
+ -- we now have a raise SE node, we are all done.
- -- If call is to immediately containing subprogram, then check for
- -- the case of a possible run-time detectable infinite recursion.
+ if Nkind (N) = N_Raise_Storage_Error then
+ return;
+ end if;
- else
- Scope_Loop : while Scop /= Standard_Standard loop
- if Nam = Scop then
-
- -- Although in general recursion is not statically checkable,
- -- the case of calling an immediately containing subprogram
- -- is easy to catch.
-
- Check_Restriction (No_Recursion, N);
-
- -- If the recursive call is to a parameterless subprogram, then
- -- even if we can't statically detect infinite recursion, this
- -- is pretty suspicious, and we output a warning. Furthermore,
- -- we will try later to detect some cases here at run time by
- -- expanding checking code (see Detect_Infinite_Recursion in
- -- package Exp_Ch6).
-
- -- If the recursive call is within a handler we do not emit a
- -- warning, because this is a common idiom: loop until input
- -- is correct, catch illegal input in handler and restart.
-
- if No (First_Formal (Nam))
- and then Etype (Nam) = Standard_Void_Type
- and then not Error_Posted (N)
- and then Nkind (Parent (N)) /= N_Exception_Handler
- then
- -- For the case of a procedure call. We give the message
- -- only if the call is the first statement in a sequence of
- -- statements, or if all previous statements are simple
- -- assignments. This is simply a heuristic to decrease false
- -- positives, without losing too many good warnings. The
- -- idea is that these previous statements may affect global
- -- variables the procedure depends on.
-
- if Nkind (N) = N_Procedure_Call_Statement
- and then Is_List_Member (N)
+ -- If call is to immediately containing subprogram, then check for
+ -- the case of a possible run-time detectable infinite recursion.
+
+ else
+ Scope_Loop : while Scop /= Standard_Standard loop
+ if Nam = Scop then
+
+ -- Although in general case, recursion is not statically
+ -- checkable, the case of calling an immediately containing
+ -- subprogram is easy to catch.
+
+ Check_Restriction (No_Recursion, N);
+
+ -- If the recursive call is to a parameterless subprogram,
+ -- then even if we can't statically detect infinite
+ -- recursion, this is pretty suspicious, and we output a
+ -- warning. Furthermore, we will try later to detect some
+ -- cases here at run time by expanding checking code (see
+ -- Detect_Infinite_Recursion in package Exp_Ch6).
+
+ -- If the recursive call is within a handler, do not emit a
+ -- warning, because this is a common idiom: loop until input
+ -- is correct, catch illegal input in handler and restart.
+
+ if No (First_Formal (Nam))
+ and then Etype (Nam) = Standard_Void_Type
+ and then not Error_Posted (N)
+ and then Nkind (Parent (N)) /= N_Exception_Handler
then
+ -- For the case of a procedure call. We give the message
+ -- only if the call is the first statement in a sequence
+ -- of statements, or if all previous statements are
+ -- simple assignments. This is simply a heuristic to
+ -- decrease false positives, without losing too many good
+ -- warnings. The idea is that these previous statements
+ -- may affect global variables the procedure depends on.
+
+ if Nkind (N) = N_Procedure_Call_Statement
+ and then Is_List_Member (N)
+ then
+ declare
+ P : Node_Id;
+ begin
+ P := Prev (N);
+ while Present (P) loop
+ if Nkind (P) /= N_Assignment_Statement then
+ exit Scope_Loop;
+ end if;
+
+ Prev (P);
+ end loop;
+ end;
+ end if;
+
+ -- Do not give warning if we are in a conditional context
+
declare
- P : Node_Id;
+ K : constant Node_Kind := Nkind (Parent (N));
begin
- P := Prev (N);
- while Present (P) loop
- if Nkind (P) /= N_Assignment_Statement then
- exit Scope_Loop;
- end if;
-
- Prev (P);
- end loop;
+ if (K = N_Loop_Statement
+ and then Present (Iteration_Scheme (Parent (N))))
+ or else K = N_If_Statement
+ or else K = N_Elsif_Part
+ or else K = N_Case_Statement_Alternative
+ then
+ exit Scope_Loop;
+ end if;
end;
- end if;
- -- Do not give warning if we are in a conditional context
+ -- Here warning is to be issued
- declare
- K : constant Node_Kind := Nkind (Parent (N));
- begin
- if (K = N_Loop_Statement
- and then Present (Iteration_Scheme (Parent (N))))
- or else K = N_If_Statement
- or else K = N_Elsif_Part
- or else K = N_Case_Statement_Alternative
- then
- exit Scope_Loop;
- end if;
- end;
-
- -- Here warning is to be issued
+ Set_Has_Recursive_Call (Nam);
+ Error_Msg_N
+ ("?possible infinite recursion!", N);
+ Error_Msg_N
+ ("\?Storage_Error may be raised at run time!", N);
+ end if;
- Set_Has_Recursive_Call (Nam);
- Error_Msg_N ("possible infinite recursion?", N);
- Error_Msg_N ("\Storage_Error may be raised at run time?", N);
+ exit Scope_Loop;
end if;
- exit Scope_Loop;
- end if;
-
- Scop := Scope (Scop);
- end loop Scope_Loop;
+ Scop := Scope (Scop);
+ end loop Scope_Loop;
+ end if;
end if;
-- If subprogram name is a predefined operator, it was given in
-- Create a transient scope if the resulting type requires it
- -- There are 4 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 third case is intrinsic subprograms (Unchecked_Conversion and
- -- source information functions) that do not use the secondary stack
- -- even though the return type is unconstrained; the fourth case is a
- -- call to a build-in-place function, since such functions may allocate
- -- their result directly in a target object, and cases where the result
- -- does get allocated in the secondary stack are checked for within the
- -- specialized Exp_Ch6 procedures for expanding build-in-place calls.
-
- -- If this is an initialization call for a type whose initialization
- -- uses the secondary stack, we also need to create a transient scope
- -- for it, precisely because we will not do it within the init proc
- -- itself.
-
- -- If the subprogram is marked Inlined_Always, then even if it returns
+ -- There are several notable exceptions:
+
+ -- a) In init procs, the transient scope overhead is not needed, and is
+ -- even incorrect when the call is a nested initialization call for a
+ -- component whose expansion may generate adjust calls. However, if the
+ -- call is some other procedure call within an initialization procedure
+ -- (for example a call to Create_Task in the init_proc of the task
+ -- run-time record) a transient scope must be created around this call.
+
+ -- b) Enumeration literal pseudo-calls need no transient scope
+
+ -- c) Intrinsic subprograms (Unchecked_Conversion and source info
+ -- functions) do not use the secondary stack even though the return
+ -- type may be unconstrained.
+
+ -- d) Calls to a build-in-place function, since such functions may
+ -- allocate their result directly in a target object, and cases where
+ -- the result does get allocated in the secondary stack are checked for
+ -- within the specialized Exp_Ch6 procedures for expanding those
+ -- build-in-place calls.
+
+ -- e) If the subprogram is marked Inline_Always, then even if it returns
-- an unconstrained type the call does not require use of the secondary
- -- stack.
+ -- stack. However, inlining will only take place if the body to inline
+ -- is already present. It may not be available if e.g. the subprogram is
+ -- declared in a child instance.
+
+ -- If this is an initialization call for a type whose construction
+ -- uses the secondary stack, and it is not a nested call to initialize
+ -- a component, we do need to create a transient scope for it. We
+ -- check for this by traversing the type in Check_Initialization_Call.
if Is_Inlined (Nam)
- and then Present (First_Rep_Item (Nam))
- and then Nkind (First_Rep_Item (Nam)) = N_Pragma
- and then Chars (First_Rep_Item (Nam)) = Name_Inline_Always
+ and then Has_Pragma_Inline_Always (Nam)
+ and then Nkind (Unit_Declaration_Node (Nam)) = N_Subprogram_Declaration
+ and then Present (Body_To_Inline (Unit_Declaration_Node (Nam)))
+ then
+ null;
+
+ elsif Ekind (Nam) = E_Enumeration_Literal
+ or else Is_Build_In_Place_Function (Nam)
+ or else Is_Intrinsic_Subprogram (Nam)
then
null;
elsif Expander_Active
and then Is_Type (Etype (Nam))
and then Requires_Transient_Scope (Etype (Nam))
- and then not Is_Build_In_Place_Function (Nam)
- and then Ekind (Nam) /= E_Enumeration_Literal
- and then not Within_Init_Proc
- and then not Is_Intrinsic_Subprogram (Nam)
+ and then
+ (not Within_Init_Proc
+ or else
+ (not Is_Init_Proc (Nam) and then Ekind (Nam) /= E_Function))
then
Establish_Transient_Scope (N, Sec_Stack => True);
if Present (First_Formal (Nam)) then
Resolve_Actuals (N, Nam);
- -- Overloaded literals are rewritten as function calls, for
- -- purpose of resolution. After resolution, we can replace
- -- the call with the literal itself.
+ -- Overloaded literals are rewritten as function calls, for purpose of
+ -- resolution. After resolution, we can replace the call with the
+ -- literal itself.
elsif Ekind (Nam) = E_Enumeration_Literal then
Copy_Node (Subp, N);
-- Avoid validation, since it is a static function call
+ Generate_Reference (Nam, Subp);
return;
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 the subprogram is not global, then kill all saved values and
+ -- 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 local values.
+
+ -- If the flag Suppress_Value_Tracking_On_Calls is set, then we also
+ -- kill all checks and values for calls to global subprograms. This
+ -- takes care of the case where an access to a local subprogram is
+ -- taken, and could be passed directly or indirectly and then called
+ -- from almost any context.
-- Note: we do not do this step till after resolving the actuals. That
-- way we still take advantage of the current value information while
-- scanning the actuals.
- if not Is_Library_Level_Entity (Nam)
+ -- We suppress killing values if we are processing the nodes associated
+ -- with N_Freeze_Entity nodes. Otherwise the declaration of a tagged
+ -- type kills all the values as part of analyzing the code that
+ -- initializes the dispatch tables.
+
+ if Inside_Freezing_Actions = 0
+ and then (not Is_Library_Level_Entity (Nam)
+ or else Suppress_Value_Tracking_On_Call
+ (Nearest_Dynamic_Scope (Current_Scope)))
and then (Comes_From_Source (Nam)
or else (Present (Alias (Nam))
and then Comes_From_Source (Alias (Nam))))
Kill_Current_Values;
end if;
+ -- If we are warning about unread OUT parameters, this is the place to
+ -- set Last_Assignment for OUT and IN OUT parameters. We have to do this
+ -- after the above call to Kill_Current_Values (since that call clears
+ -- the Last_Assignment field of all local variables).
+
+ if (Warn_On_Modified_Unread or Warn_On_All_Unread_Out_Parameters)
+ and then Comes_From_Source (N)
+ and then In_Extended_Main_Source_Unit (N)
+ then
+ declare
+ F : Entity_Id;
+ A : Node_Id;
+
+ begin
+ F := First_Formal (Nam);
+ A := First_Actual (N);
+ while Present (F) and then Present (A) loop
+ if (Ekind (F) = E_Out_Parameter
+ or else
+ Ekind (F) = E_In_Out_Parameter)
+ and then Warn_On_Modified_As_Out_Parameter (F)
+ and then Is_Entity_Name (A)
+ and then Present (Entity (A))
+ and then Comes_From_Source (N)
+ and then Safe_To_Capture_Value (N, Entity (A))
+ then
+ Set_Last_Assignment (Entity (A), A);
+ end if;
+
+ Next_Formal (F);
+ Next_Actual (A);
+ end loop;
+ end;
+ end if;
+
-- If the subprogram is a primitive operation, check whether or not
-- it is a correct dispatching call.
Error_Msg_NE ("cannot call abstract subprogram &!", N, Nam);
end if;
+ -- If this is a dispatching call, generate the appropriate reference,
+ -- for better source navigation in GPS.
+
+ if Is_Overloadable (Nam)
+ and then Present (Controlling_Argument (N))
+ then
+ Generate_Reference (Nam, Subp, 'R');
+
+ -- Normal case, not a dispatching call
+
+ else
+ Generate_Reference (Nam, Subp);
+ end if;
+
if Is_Intrinsic_Subprogram (Nam) then
Check_Intrinsic_Call (N);
end if;
+ -- Check for violation of restriction No_Specific_Termination_Handlers
+ -- and warn on a potentially blocking call to Abort_Task.
+
+ if Is_RTE (Nam, RE_Set_Specific_Handler)
+ or else
+ Is_RTE (Nam, RE_Specific_Handler)
+ then
+ Check_Restriction (No_Specific_Termination_Handlers, N);
+
+ elsif Is_RTE (Nam, RE_Abort_Task) then
+ Check_Potentially_Blocking_Operation (N);
+ end if;
+
+ -- Issue an error for a call to an eliminated subprogram
+
+ Check_For_Eliminated_Subprogram (Subp, Nam);
+
+ -- All done, evaluate call and deal with elaboration issues
+
Eval_Call (N);
Check_Elab_Call (N);
end Resolve_Call;
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.
+ -- If the entity is already set, this has already been resolved in a
+ -- generic context, or comes from expansion. Nothing else to do.
elsif Present (Entity (N)) then
return;
- -- Otherwise we have a user defined character type, and we can use
- -- the standard visibility mechanisms to locate the referenced entity
+ -- Otherwise we have a user defined character type, and we can use the
+ -- standard visibility mechanisms to locate the referenced entity.
else
C := Current_Entity (N);
T : Entity_Id;
begin
- -- If this is an intrinsic operation which is not predefined, use
- -- the types of its declared arguments to resolve the possibly
- -- overloaded operands. Otherwise the operands are unambiguous and
- -- specify the expected type.
+ -- If this is an intrinsic operation which is not predefined, use the
+ -- types of its declared arguments to resolve the possibly overloaded
+ -- operands. Otherwise the operands are unambiguous and specify the
+ -- expected type.
if Scope (Entity (N)) /= Standard_Standard then
T := Etype (First_Entity (Entity (N)));
Generate_Reference (T, N, ' ');
if T /= Any_Type then
- if T = Any_String
- or else T = Any_Composite
- or else T = Any_Character
+ if T = Any_String or else
+ T = Any_Composite or else
+ T = Any_Character
then
if T = Any_Character then
Ambiguous_Character (L);
Check_Unset_Reference (L);
Check_Unset_Reference (R);
Generate_Operator_Reference (N, T);
+ Check_Low_Bound_Tested (N);
Eval_Relational_Op (N);
end if;
end if;
procedure Resolve_Conditional_Expression (N : Node_Id; Typ : Entity_Id) is
Condition : constant Node_Id := First (Expressions (N));
Then_Expr : constant Node_Id := Next (Condition);
- Else_Expr : constant Node_Id := Next (Then_Expr);
+ Else_Expr : Node_Id := Next (Then_Expr);
begin
- Resolve (Condition, Standard_Boolean);
+ Resolve (Condition, Any_Boolean);
Resolve (Then_Expr, Typ);
- Resolve (Else_Expr, Typ);
+
+ -- If ELSE expression present, just resolve using the determined type
+
+ if Present (Else_Expr) then
+ Resolve (Else_Expr, Typ);
+
+ -- If no ELSE expression is present, root type must be Standard.Boolean
+ -- and we provide a Standard.True result converted to the appropriate
+ -- Boolean type (in case it is a derived boolean type).
+
+ elsif Root_Type (Typ) = Standard_Boolean then
+ Else_Expr :=
+ Convert_To (Typ, New_Occurrence_Of (Standard_True, Sloc (N)));
+ Analyze_And_Resolve (Else_Expr, Typ);
+ Append_To (Expressions (N), Else_Expr);
+
+ else
+ Error_Msg_N ("can only omit ELSE expression in Boolean case", N);
+ Append_To (Expressions (N), Error);
+ end if;
Set_Etype (N, Typ);
Eval_Conditional_Expression (N);
Eval_Named_Real (N);
-- Allow use of subtype only if it is a concurrent type where we are
- -- currently inside the body. This will eventually be expanded
- -- into a call to Self (for tasks) or _object (for protected
- -- objects). Any other use of a subtype is invalid.
+ -- currently inside the body. This will eventually be expanded into a
+ -- call to Self (for tasks) or _object (for protected objects). Any
+ -- other use of a subtype is invalid.
elsif Is_Type (E) then
if Is_Concurrent_Type (E)
-- In all other cases, just do the possible static evaluation
else
- -- A deferred constant that appears in an expression must have
- -- a completion, unless it has been removed by in-place expansion
- -- of an aggregate.
+ -- A deferred constant that appears in an expression must have a
+ -- completion, unless it has been removed by in-place expansion of
+ -- an aggregate.
if Ekind (E) = E_Constant
and then Comes_From_Source (E)
and then No (Constant_Value (E))
and then Is_Frozen (Etype (E))
- and then not In_Default_Expression
+ and then not In_Spec_Expression
and then not Is_Imported (E)
then
function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id;
-- If the bound is given by a discriminant, replace with a reference
- -- to the discriminant of the same name in the target task.
- -- If the entry name is the target of a requeue statement and the
- -- entry is in the current protected object, the bound to be used
- -- is the discriminal of the object (see apply_range_checks for
- -- details of the transformation).
+ -- to the discriminant of the same name in the target task. If the
+ -- entry name is the target of a requeue statement and the entry is
+ -- in the current protected object, the bound to be used is the
+ -- discriminal of the object (see apply_range_checks for details of
+ -- the transformation).
-----------------------------
-- Actual_Discriminant_Ref --
begin
if not Has_Discriminants (Tsk)
or else (not Is_Entity_Name (Lo)
- and then not Is_Entity_Name (Hi))
+ and then
+ not Is_Entity_Name (Hi))
then
return Entry_Index_Type (E);
end if;
if Is_Entity_Name (E_Name) then
- -- Entry call to an entry (or entry family) in the current task.
- -- This is legal even though the task will deadlock. Rewrite as
- -- call to current task.
- -- This can also be a call to an entry in an enclosing task.
- -- If this is a single task, we have to retrieve its name,
- -- because the scope of the entry is the task type, not the
- -- object. If the enclosing task is a task type, the identity
- -- of the task is given by its own self variable.
+ -- Entry call to an entry (or entry family) in the current task. This
+ -- is legal even though the task will deadlock. Rewrite as call to
+ -- current task.
+
+ -- This can also be a call to an entry in an enclosing task. If this
+ -- is a single task, we have to retrieve its name, because the scope
+ -- of the entry is the task type, not the object. If the enclosing
+ -- task is a task type, the identity of the task is given by its own
+ -- self variable.
- -- Finally this can be a requeue on an entry of the same task
- -- or protected object.
+ -- Finally this can be a requeue on an entry of the same task or
+ -- protected object.
S := Scope (Entity (E_Name));
for J in reverse 0 .. Scope_Stack.Last loop
-
if Is_Task_Type (Scope_Stack.Table (J).Entity)
and then not Comes_From_Source (S)
then
elsif Nkind (Entry_Name) = N_Selected_Component
and then Is_Overloaded (Prefix (Entry_Name))
then
- -- Use the entry name (which must be unique at this point) to
- -- find the prefix that returns the corresponding task type or
- -- protected type.
+ -- Use the entry name (which must be unique at this point) to find
+ -- the prefix that returns the corresponding task type or protected
+ -- type.
declare
Pref : constant Node_Id := Prefix (Entry_Name);
Index := First (Expressions (Entry_Name));
Resolve (Index, Entry_Index_Type (Nam));
- -- Up to this point the expression could have been the actual
- -- in a simple entry call, and be given by a named association.
+ -- Up to this point the expression could have been the actual in a
+ -- simple entry call, and be given by a named association.
if Nkind (Index) = N_Parameter_Association then
Error_Msg_N ("expect expression for entry index", Index);
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.
+ -- 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;
end if;
end if;
- -- After resolution, entry calls and protected procedure calls
- -- are changed into entry calls, for expansion. The structure
- -- of the node does not change, so it can safely be done in place.
- -- Protected function calls must keep their structure because they
- -- are subexpressions.
+ -- After resolution, entry calls and protected procedure calls are
+ -- changed into entry calls, for expansion. The structure of the node
+ -- does not change, so it can safely be done in place. Protected
+ -- function calls must keep their structure because they are
+ -- subexpressions.
if Ekind (Nam) /= E_Function then
-- A protected operation that is not a function may modify the
- -- corresponding object, and cannot apply to a constant.
- -- If this is an internal call, the prefix is the type itself.
+ -- corresponding object, and cannot apply to a constant. If this
+ -- is an internal call, the prefix is the type itself.
if Is_Protected_Type (Scope (Nam))
and then not Is_Variable (Obj)
-- Resolve_Equality_Op --
-------------------------
- -- Both arguments must have the same type, and the boolean context
- -- does not participate in the resolution. The first pass verifies
- -- that the interpretation is not ambiguous, and the type of the left
- -- argument is correctly set, or is Any_Type in case of ambiguity.
- -- If both arguments are strings or aggregates, allocators, or Null,
- -- they are ambiguous even though they carry a single (universal) type.
- -- Diagnose this case here.
+ -- Both arguments must have the same type, and the boolean context does
+ -- not participate in the resolution. The first pass verifies that the
+ -- interpretation is not ambiguous, and the type of the left argument is
+ -- correctly set, or is Any_Type in case of ambiguity. If both arguments
+ -- are strings or aggregates, allocators, or Null, they are ambiguous even
+ -- though they carry a single (universal) type. Diagnose this case here.
procedure Resolve_Equality_Op (N : Node_Id; Typ : Entity_Id) is
L : constant Node_Id := Left_Opnd (N);
begin
if Ekind (Etype (R)) = E_Allocator_Type then
Acc := Designated_Type (Etype (R));
-
elsif Ekind (Etype (L)) = E_Allocator_Type then
Acc := Designated_Type (Etype (L));
-
else
return Empty;
end if;
and then Entity (R) = Standard_True
and then Comes_From_Source (R)
then
- Error_Msg_N ("comparison with True is redundant?", R);
+ Error_Msg_N ("?comparison with True is redundant!", R);
end if;
Check_Unset_Reference (L);
Check_Unset_Reference (R);
Generate_Operator_Reference (N, T);
+ Check_Low_Bound_Tested (N);
-- If this is an inequality, it may be the implicit inequality
-- created for a user-defined operation, in which case the corres-
(Corresponding_Equality (Entity (N)))
then
Eval_Relational_Op (N);
+
elsif Nkind (N) = N_Op_Ne
and then Is_Abstract_Subprogram (Entity (N))
then
Error_Msg_NE ("cannot call abstract subprogram &!", N, Entity (N));
end if;
- -- Ada 2005: If one operand is an anonymous access type, convert
- -- the other operand to it, to ensure that the underlying types
- -- match in the back-end.
- -- We apply the same conversion in the case one of the operands is
- -- a private subtype of the type of the other.
+ -- Ada 2005: If one operand is an anonymous access type, convert the
+ -- other operand to it, to ensure that the underlying types match in
+ -- the back-end. Same for access_to_subprogram, and the conversion
+ -- verifies that the types are subtype conformant.
+
+ -- We apply the same conversion in the case one of the operands is a
+ -- private subtype of the type of the other.
+
+ -- Why the Expander_Active test here ???
if Expander_Active
- and then (Ekind (T) = E_Anonymous_Access_Type
- or else Is_Private_Type (T))
+ and then
+ (Ekind (T) = E_Anonymous_Access_Type
+ or else Ekind (T) = E_Anonymous_Access_Subprogram_Type
+ or else Is_Private_Type (T))
then
if Etype (L) /= T then
Rewrite (L,
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: No Eval processing is required for an explicit dereference,
+ -- because such a name can never be static.
end Resolve_Explicit_Dereference;
end if;
-- If name was overloaded, set component type correctly now
+ -- If a misplaced call to an entry family (which has no index types)
+ -- return. Error will be diagnosed from calling context.
- Set_Etype (N, Component_Type (Array_Type));
+ if Is_Array_Type (Array_Type) then
+ Set_Etype (N, Component_Type (Array_Type));
+ else
+ return;
+ end if;
Index := First_Index (Array_Type);
Expr := First (Expressions (N));
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.
+ -- 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));
procedure Resolve_Logical_Op (N : Node_Id; Typ : Entity_Id) is
B_Typ : Entity_Id;
- N_Opr : constant Node_Kind := Nkind (N);
begin
+ Check_No_Direct_Boolean_Operators (N);
+
-- 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).
Set_Etype (N, B_Typ);
Generate_Operator_Reference (N, B_Typ);
Eval_Logical_Op (N);
-
- -- Check for violation of restriction No_Direct_Boolean_Operators
- -- if the operator was not eliminated by the Eval_Logical_Op call.
-
- if Nkind (N) = N_Opr
- and then Root_Type (Etype (Left_Opnd (N))) = Standard_Boolean
- then
- Check_Restriction (No_Direct_Boolean_Operators, N);
- end if;
end Resolve_Logical_Op;
---------------------------
procedure Resolve_Membership_Op (N : Node_Id; Typ : Entity_Id) is
pragma Warnings (Off, Typ);
- L : constant Node_Id := Left_Opnd (N);
- R : constant Node_Id := Right_Opnd (N);
+ L : constant Node_Id := Left_Opnd (N);
+ R : constant Node_Id := Right_Opnd (N);
T : Entity_Id;
+ procedure Resolve_Set_Membership;
+ -- Analysis has determined a unique type for the left operand.
+ -- Use it to resolve the disjuncts.
+
+ ----------------------------
+ -- Resolve_Set_Membership --
+ ----------------------------
+
+ procedure Resolve_Set_Membership is
+ Alt : Node_Id;
+
+ begin
+ Resolve (L, Etype (L));
+
+ Alt := First (Alternatives (N));
+ while Present (Alt) loop
+
+ -- Alternative is an expression, a range
+ -- or a subtype mark.
+
+ if not Is_Entity_Name (Alt)
+ or else not Is_Type (Entity (Alt))
+ then
+ Resolve (Alt, Etype (L));
+ end if;
+
+ Next (Alt);
+ end loop;
+ end Resolve_Set_Membership;
+
+ -- Start of processing for Resolve_Membership_Op
+
begin
if L = Error or else R = Error then
return;
end if;
- if not Is_Overloaded (R)
+ if Present (Alternatives (N)) then
+ Resolve_Set_Membership;
+ return;
+
+ elsif not Is_Overloaded (R)
and then
(Etype (R) = Universal_Integer or else
Etype (R) = Universal_Real)
then
T := Etype (R);
- -- Ada 2005 (AI-251): Give support to the following case:
+ -- Ada 2005 (AI-251): Support the following case:
-- type I is interface;
-- type T is tagged ...
-- return O in T'Class.
-- end Test;
- -- In this case we have nothing else to do; the membership test will be
+ -- In this case we have nothing else to do. The membership test will be
-- done at run-time.
elsif Ada_Version >= Ada_05
------------------
procedure Resolve_Null (N : Node_Id; Typ : Entity_Id) is
+ Loc : constant Source_Ptr := Sloc (N);
+
begin
-- Handle restriction against anonymous null access values This
- -- restriction can be turned off using -gnatdh.
+ -- restriction can be turned off using -gnatdj.
-- Ada 2005 (AI-231): Remove restriction
and then Ekind (Typ) = E_Anonymous_Access_Type
and then Comes_From_Source (N)
then
- -- In the common case of a call which uses an explicitly null
- -- value for an access parameter, give specialized error msg
+ -- In the common case of a call which uses an explicitly null value
+ -- for an access parameter, give specialized error message.
- if Nkind (Parent (N)) = N_Procedure_Call_Statement
- or else
- Nkind (Parent (N)) = N_Function_Call
+ if Nkind_In (Parent (N), N_Procedure_Call_Statement,
+ N_Function_Call)
then
Error_Msg_N
("null is not allowed as argument for an access parameter", N);
end if;
end if;
- -- In a distributed context, null for a remote access to subprogram
- -- may need to be replaced with a special record aggregate. In this
- -- case, return after having done the transformation.
+ -- Ada 2005 (AI-231): Generate the null-excluding check in case of
+ -- assignment to a null-excluding object
+
+ if Ada_Version >= Ada_05
+ and then Can_Never_Be_Null (Typ)
+ and then Nkind (Parent (N)) = N_Assignment_Statement
+ then
+ if not Inside_Init_Proc then
+ Insert_Action
+ (Compile_Time_Constraint_Error (N,
+ "(Ada 2005) null not allowed in null-excluding objects?"),
+ Make_Raise_Constraint_Error (Loc,
+ Reason => CE_Access_Check_Failed));
+ else
+ Insert_Action (N,
+ Make_Raise_Constraint_Error (Loc,
+ Reason => CE_Access_Check_Failed));
+ end if;
+ end if;
+
+ -- In a distributed context, null for a remote access to subprogram may
+ -- need to be replaced with a special record aggregate. In this case,
+ -- return after having done the transformation.
+
+ if (Ekind (Typ) = E_Record_Type
+ or else Is_Remote_Access_To_Subprogram_Type (Typ))
+ and then Remote_AST_Null_Value (N, Typ)
+ then
+ return;
+ end if;
+
+ -- The null literal takes its type from the context
+
+ Set_Etype (N, Typ);
+ end Resolve_Null;
+
+ -----------------------
+ -- Resolve_Op_Concat --
+ -----------------------
+
+ procedure Resolve_Op_Concat (N : Node_Id; Typ : Entity_Id) is
+
+ -- We wish to avoid deep recursion, because concatenations are often
+ -- deeply nested, as in A&B&...&Z. Therefore, we walk down the left
+ -- operands nonrecursively until we find something that is not a simple
+ -- concatenation (A in this case). We resolve that, and then walk back
+ -- up the tree following Parent pointers, calling Resolve_Op_Concat_Rest
+ -- to do the rest of the work at each level. The Parent pointers allow
+ -- us to avoid recursion, and thus avoid running out of memory. See also
+ -- Sem_Ch4.Analyze_Concatenation, where a similar approach is used.
+
+ NN : Node_Id := N;
+ Op1 : Node_Id;
+
+ begin
+ -- The following code is equivalent to:
+
+ -- Resolve_Op_Concat_First (NN, Typ);
+ -- Resolve_Op_Concat_Arg (N, ...);
+ -- Resolve_Op_Concat_Rest (N, Typ);
+
+ -- where the Resolve_Op_Concat_Arg call recurses back here if the left
+ -- operand is a concatenation.
+
+ -- Walk down left operands
+
+ loop
+ Resolve_Op_Concat_First (NN, Typ);
+ Op1 := Left_Opnd (NN);
+ exit when not (Nkind (Op1) = N_Op_Concat
+ and then not Is_Array_Type (Component_Type (Typ))
+ and then Entity (Op1) = Entity (NN));
+ NN := Op1;
+ end loop;
+
+ -- Now (given the above example) NN is A&B and Op1 is A
- if (Ekind (Typ) = E_Record_Type
- or else Is_Remote_Access_To_Subprogram_Type (Typ))
- and then Remote_AST_Null_Value (N, Typ)
- then
- return;
- end if;
+ -- First resolve Op1 ...
- -- The null literal takes its type from the context
+ Resolve_Op_Concat_Arg (NN, Op1, Typ, Is_Component_Left_Opnd (NN));
- Set_Etype (N, Typ);
- end Resolve_Null;
+ -- ... then walk NN back up until we reach N (where we started), calling
+ -- Resolve_Op_Concat_Rest along the way.
- -----------------------
- -- Resolve_Op_Concat --
- -----------------------
+ loop
+ Resolve_Op_Concat_Rest (NN, Typ);
+ exit when NN = N;
+ NN := Parent (NN);
+ end loop;
+ end Resolve_Op_Concat;
- procedure Resolve_Op_Concat (N : Node_Id; Typ : Entity_Id) is
- Btyp : constant Entity_Id := Base_Type (Typ);
- Op1 : constant Node_Id := Left_Opnd (N);
- Op2 : constant Node_Id := Right_Opnd (N);
+ ---------------------------
+ -- Resolve_Op_Concat_Arg --
+ ---------------------------
- procedure Resolve_Concatenation_Arg (Arg : Node_Id; Is_Comp : Boolean);
- -- Internal procedure to resolve one operand of concatenation operator.
- -- The operand is either of the array type or of the component type.
- -- If the operand is an aggregate, and the component type is composite,
- -- this is ambiguous if component type has aggregates.
+ procedure Resolve_Op_Concat_Arg
+ (N : Node_Id;
+ Arg : Node_Id;
+ Typ : Entity_Id;
+ Is_Comp : Boolean)
+ is
+ Btyp : constant Entity_Id := Base_Type (Typ);
- -------------------------------
- -- Resolve_Concatenation_Arg --
- -------------------------------
+ begin
+ if In_Instance then
+ if Is_Comp
+ or else (not Is_Overloaded (Arg)
+ and then Etype (Arg) /= Any_Composite
+ and then Covers (Component_Type (Typ), Etype (Arg)))
+ then
+ Resolve (Arg, Component_Type (Typ));
+ else
+ Resolve (Arg, Btyp);
+ end if;
- procedure Resolve_Concatenation_Arg (Arg : Node_Id; Is_Comp : Boolean) is
- begin
- if In_Instance then
- if Is_Comp
- or else (not Is_Overloaded (Arg)
- and then Etype (Arg) /= Any_Composite
- and then Covers (Component_Type (Typ), Etype (Arg)))
- then
- Resolve (Arg, Component_Type (Typ));
- else
+ elsif Has_Compatible_Type (Arg, Component_Type (Typ)) then
+ if Nkind (Arg) = N_Aggregate
+ and then Is_Composite_Type (Component_Type (Typ))
+ then
+ if Is_Private_Type (Component_Type (Typ)) then
Resolve (Arg, Btyp);
+ else
+ Error_Msg_N ("ambiguous aggregate must be qualified", Arg);
+ Set_Etype (Arg, Any_Type);
end if;
- elsif Has_Compatible_Type (Arg, Component_Type (Typ)) then
-
- if Nkind (Arg) = N_Aggregate
- and then Is_Composite_Type (Component_Type (Typ))
+ else
+ if Is_Overloaded (Arg)
+ and then Has_Compatible_Type (Arg, Typ)
+ and then Etype (Arg) /= Any_Type
then
- if Is_Private_Type (Component_Type (Typ)) then
- Resolve (Arg, Btyp);
+ declare
+ I : Interp_Index;
+ It : Interp;
+ Func : Entity_Id;
- else
- Error_Msg_N ("ambiguous aggregate must be qualified", Arg);
- Set_Etype (Arg, Any_Type);
- end if;
+ begin
+ Get_First_Interp (Arg, I, It);
+ Func := It.Nam;
+ Get_Next_Interp (I, It);
- else
- if Is_Overloaded (Arg)
- and then Has_Compatible_Type (Arg, Typ)
- and then Etype (Arg) /= Any_Type
- then
+ -- Special-case the error message when the overloading is
+ -- caused by a function that yields an array and can be
+ -- called without parameters.
- declare
- I : Interp_Index;
- It : Interp;
- Func : Entity_Id;
+ if It.Nam = Func then
+ Error_Msg_Sloc := Sloc (Func);
+ Error_Msg_N ("ambiguous call to function#", Arg);
+ Error_Msg_NE
+ ("\\interpretation as call yields&", Arg, Typ);
+ Error_Msg_NE
+ ("\\interpretation as indexing of call yields&",
+ Arg, Component_Type (Typ));
- begin
+ else
+ Error_Msg_N
+ ("ambiguous operand for concatenation!", Arg);
Get_First_Interp (Arg, I, It);
- Func := It.Nam;
- Get_Next_Interp (I, It);
-
- -- Special-case the error message when the overloading
- -- is caused by a function that yields and array and
- -- can be called without parameters.
-
- if It.Nam = Func then
- Error_Msg_Sloc := Sloc (Func);
- Error_Msg_N ("\ambiguous call to function#", Arg);
- Error_Msg_NE
- ("\\interpretation as call yields&", Arg, Typ);
- Error_Msg_NE
- ("\\interpretation as indexing of call yields&",
- Arg, Component_Type (Typ));
-
- else
- Error_Msg_N
- ("ambiguous operand for concatenation!", Arg);
- Get_First_Interp (Arg, I, It);
- while Present (It.Nam) loop
- Error_Msg_Sloc := Sloc (It.Nam);
-
- if Base_Type (It.Typ) = Base_Type (Typ)
- or else Base_Type (It.Typ) =
- Base_Type (Component_Type (Typ))
- then
- Error_Msg_N ("\\possible interpretation#", Arg);
- end if;
+ while Present (It.Nam) loop
+ Error_Msg_Sloc := Sloc (It.Nam);
- Get_Next_Interp (I, It);
- end loop;
- end if;
- end;
- end if;
+ if Base_Type (It.Typ) = Base_Type (Typ)
+ or else Base_Type (It.Typ) =
+ Base_Type (Component_Type (Typ))
+ then
+ Error_Msg_N -- CODEFIX
+ ("\\possible interpretation#", Arg);
+ end if;
- Resolve (Arg, Component_Type (Typ));
+ Get_Next_Interp (I, It);
+ end loop;
+ end if;
+ end;
+ end if;
- if Nkind (Arg) = N_String_Literal then
- Set_Etype (Arg, Component_Type (Typ));
- end if;
+ Resolve (Arg, Component_Type (Typ));
- if Arg = Left_Opnd (N) then
- Set_Is_Component_Left_Opnd (N);
- else
- Set_Is_Component_Right_Opnd (N);
- end if;
+ if Nkind (Arg) = N_String_Literal then
+ Set_Etype (Arg, Component_Type (Typ));
end if;
- else
- Resolve (Arg, Btyp);
+ if Arg = Left_Opnd (N) then
+ Set_Is_Component_Left_Opnd (N);
+ else
+ Set_Is_Component_Right_Opnd (N);
+ end if;
end if;
- Check_Unset_Reference (Arg);
- end Resolve_Concatenation_Arg;
+ else
+ Resolve (Arg, Btyp);
+ end if;
+
+ Check_Unset_Reference (Arg);
+ end Resolve_Op_Concat_Arg;
+
+ -----------------------------
+ -- Resolve_Op_Concat_First --
+ -----------------------------
- -- Start of processing for Resolve_Op_Concat
+ procedure Resolve_Op_Concat_First (N : Node_Id; Typ : Entity_Id) is
+ Btyp : constant Entity_Id := Base_Type (Typ);
+ Op1 : constant Node_Id := Left_Opnd (N);
+ Op2 : constant Node_Id := Right_Opnd (N);
begin
+ -- The parser folds an enormous sequence of concatenations of string
+ -- literals into "" & "...", where the Is_Folded_In_Parser flag is set
+ -- in the right operand. If the expression resolves to a predefined "&"
+ -- operator, all is well. Otherwise, the parser's folding is wrong, so
+ -- we give an error. See P_Simple_Expression in Par.Ch4.
+
+ if Nkind (Op2) = N_String_Literal
+ and then Is_Folded_In_Parser (Op2)
+ and then Ekind (Entity (N)) = E_Function
+ then
+ pragma Assert (Nkind (Op1) = N_String_Literal -- should be ""
+ and then String_Length (Strval (Op1)) = 0);
+ Error_Msg_N ("too many user-defined concatenations", N);
+ return;
+ end if;
+
Set_Etype (N, Btyp);
if Is_Limited_Composite (Btyp) then
Error_Msg_N ("concatenation not available for limited array", N);
Explain_Limited_Type (Btyp, N);
end if;
+ end Resolve_Op_Concat_First;
- -- 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.
+ ----------------------------
+ -- Resolve_Op_Concat_Rest --
+ ----------------------------
- if Nkind (Op1) = N_Op_Concat
- and then not Is_Array_Type (Component_Type (Typ))
- and then Entity (Op1) = Entity (N)
- then
- Resolve_Op_Concat (Op1, Typ);
- else
- Resolve_Concatenation_Arg
- (Op1, Is_Component_Left_Opnd (N));
- end if;
+ procedure Resolve_Op_Concat_Rest (N : Node_Id; Typ : Entity_Id) is
+ Op1 : constant Node_Id := Left_Opnd (N);
+ Op2 : constant Node_Id := Right_Opnd (N);
- if Nkind (Op2) = N_Op_Concat
- and then not Is_Array_Type (Component_Type (Typ))
- and then Entity (Op2) = Entity (N)
- then
- Resolve_Op_Concat (Op2, Typ);
- else
- Resolve_Concatenation_Arg
- (Op2, Is_Component_Right_Opnd (N));
- end if;
+ begin
+ Resolve_Op_Concat_Arg (N, Op2, Typ, Is_Component_Right_Opnd (N));
Generate_Operator_Reference (N, Typ);
Eval_Concatenation (N);
end if;
- -- If this is not a static concatenation, but the result is a
- -- string type (and not an array of strings) insure that static
- -- string operands have their subtypes properly constructed.
+ -- If this is not a static concatenation, but the result is a string
+ -- type (and not an array of strings) ensure that static string operands
+ -- have their subtypes properly constructed.
if Nkind (N) /= N_String_Literal
and then Is_Character_Type (Component_Type (Typ))
Set_String_Literal_Subtype (Op1, Typ);
Set_String_Literal_Subtype (Op2, Typ);
end if;
- end Resolve_Op_Concat;
+ end Resolve_Op_Concat_Rest;
----------------------
-- Resolve_Op_Expon --
B_Typ : constant Entity_Id := Base_Type (Typ);
begin
- -- Catch attempts to do fixed-point exponentation with universal
+ -- Catch attempts to do fixed-point exponentiation with universal
-- operands, which is a case where the illegality is not caught during
-- normal operator analysis.
B_Typ := Base_Type (Typ);
end if;
- -- Straigtforward case of incorrect arguments
+ -- Straightforward case of incorrect arguments
if not Valid_Boolean_Arg (Typ) then
Error_Msg_N ("invalid operand type for operator&", N);
and then not Is_Boolean_Type (Typ)
and then Parent_Is_Boolean
then
- Error_Msg_N ("?not expression should be parenthesized here", N);
+ Error_Msg_N ("?not expression should be parenthesized here!", N);
+ end if;
+
+ -- Warn on double negation if checking redundant constructs
+
+ if Warn_On_Redundant_Constructs
+ and then Comes_From_Source (N)
+ and then Comes_From_Source (Right_Opnd (N))
+ and then Root_Type (Typ) = Standard_Boolean
+ and then Nkind (Right_Opnd (N)) = N_Op_Not
+ then
+ Error_Msg_N ("redundant double negation?", N);
end if;
+ -- Complete resolution and evaluation of NOT
+
Resolve (Right_Opnd (N), B_Typ);
Check_Unset_Reference (Right_Opnd (N));
Set_Etype (N, B_Typ);
Check_Non_Static_Context (L);
Check_Non_Static_Context (H);
+ -- Check for an ambiguous range over character literals. This will
+ -- happen with a membership test involving only literals.
+
+ if Typ = Any_Character then
+ Ambiguous_Character (L);
+ Set_Etype (N, Any_Type);
+ return;
+ end if;
+
-- 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
and then Warn_On_Bad_Fixed_Value
then
Error_Msg_N
- ("static fixed-point value is not a multiple of Small?",
+ ("?static fixed-point value is not a multiple of Small!",
N);
end if;
-- sequences that otherwise fail to notice the modification.
if Is_Entity_Name (P) and then Treat_As_Volatile (Entity (P)) then
- Note_Possible_Modification (P);
+ Note_Possible_Modification (P, Sure => False);
end if;
end Resolve_Reference;
end if;
if Is_Record_Type (T) then
+
+ -- The visible components of a class-wide type are those of
+ -- the root type.
+
+ if Is_Class_Wide_Type (T) then
+ T := Etype (T);
+ end if;
+
Comp := First_Entity (T);
while Present (Comp) loop
if Chars (Comp) = Chars (S)
-- Generate cross-reference. We needed to wait until full overloading
-- resolution was complete to do this, since otherwise we can't tell if
- -- we are an Lvalue of not.
+ -- we are an lvalue or not.
if May_Be_Lvalue (N) then
Generate_Reference (Entity (S), S, 'm');
Resolve (L, B_Typ);
Resolve (R, B_Typ);
+ -- Check for issuing warning for always False assert/check, this happens
+ -- when assertions are turned off, in which case the pragma Assert/Check
+ -- was transformed into:
+
+ -- if False and then <condition> then ...
+
+ -- and we detect this pattern
+
+ if Warn_On_Assertion_Failure
+ and then Is_Entity_Name (R)
+ and then Entity (R) = Standard_False
+ and then Nkind (Parent (N)) = N_If_Statement
+ and then Nkind (N) = N_And_Then
+ and then Is_Entity_Name (L)
+ and then Entity (L) = Standard_False
+ then
+ declare
+ Orig : constant Node_Id := Original_Node (Parent (N));
+
+ begin
+ if Nkind (Orig) = N_Pragma
+ and then Pragma_Name (Orig) = Name_Assert
+ then
+ -- Don't want to warn if original condition is explicit False
+
+ declare
+ Expr : constant Node_Id :=
+ Original_Node
+ (Expression
+ (First (Pragma_Argument_Associations (Orig))));
+ begin
+ if Is_Entity_Name (Expr)
+ and then Entity (Expr) = Standard_False
+ then
+ null;
+ else
+ -- Issue warning. Note that we don't want to make this
+ -- an unconditional warning, because if the assert is
+ -- within deleted code we do not want the warning. But
+ -- we do not want the deletion of the IF/AND-THEN to
+ -- take this message with it. We achieve this by making
+ -- sure that the expanded code points to the Sloc of
+ -- the expression, not the original pragma.
+
+ Error_Msg_N ("?assertion would fail at run-time", Orig);
+ end if;
+ end;
+
+ -- Similar processing for Check pragma
+
+ elsif Nkind (Orig) = N_Pragma
+ and then Pragma_Name (Orig) = Name_Check
+ then
+ -- Don't want to warn if original condition is explicit False
+
+ declare
+ Expr : constant Node_Id :=
+ Original_Node
+ (Expression
+ (Next (First
+ (Pragma_Argument_Associations (Orig)))));
+ begin
+ if Is_Entity_Name (Expr)
+ and then Entity (Expr) = Standard_False
+ then
+ null;
+ else
+ Error_Msg_N ("?check would fail at run-time", Orig);
+ end if;
+ end;
+ end if;
+ end;
+ end if;
+
+ -- Continue with processing of short circuit
+
Check_Unset_Reference (L);
Check_Unset_Reference (R);
begin
if Is_Overloaded (Name) then
- -- Use the context type to select the prefix that yields the
- -- correct array type.
+ -- Use the context type to select the prefix that yields the correct
+ -- array type.
declare
I : Interp_Index;
and then not Is_Constrained (Etype (Name)))
then
Array_Type := Get_Actual_Subtype (Name);
+
+ -- If the name is a selected component that depends on discriminants,
+ -- build an actual subtype for it. This can happen only when the name
+ -- itself is overloaded; otherwise the actual subtype is created when
+ -- the selected component is analyzed.
+
+ elsif Nkind (Name) = N_Selected_Component
+ and then Full_Analysis
+ and then Depends_On_Discriminant (First_Index (Array_Type))
+ then
+ declare
+ Act_Decl : constant Node_Id :=
+ Build_Actual_Subtype_Of_Component (Array_Type, Name);
+ begin
+ Insert_Action (N, Act_Decl);
+ Array_Type := Defining_Identifier (Act_Decl);
+ end;
+
+ -- Maybe this should just be "else", instead of checking for the
+ -- specific case of slice??? This is needed for the case where
+ -- the prefix is an Image attribute, which gets expanded to a
+ -- slice, and so has a constrained subtype which we want to use
+ -- for the slice range check applied below (the range check won't
+ -- get done if the unconstrained subtype of the 'Image is used).
+
+ elsif Nkind (Name) = N_Slice then
+ Array_Type := Etype (Name);
end if;
-- If name was overloaded, set slice type correctly now
-- if Ada.Tags is already loaded to void the addition of an
-- undesired dependence on such run-time unit.
- and then not
- (RTU_Loaded (Ada_Tags)
- and then Nkind (Prefix (N)) = N_Selected_Component
- and then Present (Entity (Selector_Name (Prefix (N))))
- and then Entity (Selector_Name (Prefix (N)))
- = RTE_Record_Component (RE_Prims_Ptr))
+ and then
+ (not Tagged_Type_Expansion
+ or else not
+ (RTU_Loaded (Ada_Tags)
+ and then Nkind (Prefix (N)) = N_Selected_Component
+ and then Present (Entity (Selector_Name (Prefix (N))))
+ and then Entity (Selector_Name (Prefix (N))) =
+ RTE_Record_Component (RE_Prims_Ptr)))
then
Apply_Range_Check (Drange, Etype (Index));
end if;
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
- -- can just reuse it, since there is no point in creating another.
+ -- If the resolving type is itself a string literal subtype, we can just
+ -- reuse it, since there is no point in creating another.
if Ekind (Typ) = E_String_Literal_Subtype then
Subtype_Id := Typ;
elsif Nkind (Parent (N)) = N_Op_Concat
and then not Need_Check
- and then Nkind (Original_Node (N)) /= N_Character_Literal
- and then Nkind (Original_Node (N)) /= N_Attribute_Reference
- and then Nkind (Original_Node (N)) /= N_Qualified_Expression
- and then Nkind (Original_Node (N)) /= N_Type_Conversion
+ and then not Nkind_In (Original_Node (N), N_Character_Literal,
+ N_Attribute_Reference,
+ N_Qualified_Expression,
+ N_Type_Conversion)
then
Subtype_Id := Typ;
-- Otherwise we must create a string literal subtype. Note that the
-- whole idea of string literal subtypes is simply to avoid the need
-- for building a full fledged array subtype for each literal.
+
else
Set_String_Literal_Subtype (N, Typ);
Subtype_Id := Etype (N);
return;
end if;
- -- The validity of a null string has been checked in the
- -- call to Eval_String_Literal.
+ -- The validity of a null string has been checked in the call to
+ -- Eval_String_Literal.
if Strlen = 0 then
return;
elsif R_Typ = Any_Character then
return;
- -- If the type is bit-packed, then we always tranform the string literal
- -- into a full fledged aggregate.
+ -- If the type is bit-packed, then we always transform the string
+ -- literal into a full fledged aggregate.
elsif Is_Bit_Packed_Array (Typ) then
null;
-- 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.
+ -- a token, right under the offending wide character. Not
+ -- quite clear if this is right wrt wide character encoding
+ -- sequences, but it's only an error message!
Error_Msg
("literal out of range of type Standard.Character",
-- corresponding character aggregate and let the aggregate
-- code do the checking.
- if R_Typ = Standard_Character
- or else R_Typ = Standard_Wide_Character
- or else R_Typ = Standard_Wide_Wide_Character
- then
+ if Is_Standard_Character_Type (R_Typ) then
+
-- Check for the case of full range, where we are definitely OK
if Component_Type (Typ) = Base_Type (Component_Type (Typ)) then
procedure Resolve_Type_Conversion (N : Node_Id; Typ : Entity_Id) is
Conv_OK : constant Boolean := Conversion_OK (N);
- Target_Type : Entity_Id := Etype (N);
- Operand : Node_Id;
- Opnd_Type : Entity_Id;
+ Operand : constant Node_Id := Expression (N);
+ Operand_Typ : constant Entity_Id := Etype (Operand);
+ Target_Typ : constant Entity_Id := Etype (N);
Rop : Node_Id;
Orig_N : Node_Id;
Orig_T : Node_Id;
begin
- Operand := Expression (N);
-
if not Conv_OK
- and then not Valid_Conversion (N, Target_Type, Operand)
+ and then not Valid_Conversion (N, Target_Typ, Operand)
then
return;
end if;
Set_Etype (Operand, Universal_Real);
elsif Is_Numeric_Type (Typ)
- and then (Nkind (Operand) = N_Op_Multiply
- or else Nkind (Operand) = N_Op_Divide)
+ and then Nkind_In (Operand, N_Op_Multiply, N_Op_Divide)
and then (Etype (Right_Opnd (Operand)) = Universal_Real
- or else Etype (Left_Opnd (Operand)) = Universal_Real)
+ or else
+ Etype (Left_Opnd (Operand)) = Universal_Real)
then
-- Return if expression is ambiguous
and then abs (Realval (Rop)) < Delta_Value (Standard_Duration)
then
Error_Msg_N
- ("universal real operand can only " &
- "be interpreted as Duration?",
+ ("?universal real operand can only " &
+ "be interpreted as Duration!",
Rop);
Error_Msg_N
- ("\precision will be lost in the conversion", Rop);
+ ("\?precision will be lost in the conversion!", Rop);
end if;
elsif Is_Numeric_Type (Typ)
end if;
end if;
- Opnd_Type := Etype (Operand);
Resolve (Operand);
-- Note: we do the Eval_Type_Conversion call before applying the
- -- required checks for a subtype conversion. This is important,
- -- since both are prepared under certain circumstances to change
- -- the type conversion to a constraint error node, but in the case
- -- of Eval_Type_Conversion this may reflect an illegality in the
- -- static case, and we would miss the illegality (getting only a
- -- warning message), if we applied the type conversion checks first.
+ -- required checks for a subtype conversion. This is important, since
+ -- both are prepared under certain circumstances to change the type
+ -- conversion to a constraint error node, but in the case of
+ -- Eval_Type_Conversion this may reflect an illegality in the static
+ -- case, and we would miss the illegality (getting only a warning
+ -- message), if we applied the type conversion checks first.
Eval_Type_Conversion (N);
- -- Even when evaluation is not possible, we may be able to simplify
- -- the conversion or its expression. This needs to be done before
- -- applying checks, since otherwise the checks may use the original
- -- expression and defeat the simplifications. The is specifically
- -- the case for elimination of the floating-point Truncation
- -- attribute in float-to-int conversions.
+ -- Even when evaluation is not possible, we may be able to simplify the
+ -- conversion or its expression. This needs to be done before applying
+ -- checks, since otherwise the checks may use the original expression
+ -- and defeat the simplifications. This is specifically the case for
+ -- elimination of the floating-point Truncation attribute in
+ -- float-to-int conversions.
Simplify_Type_Conversion (N);
- -- If after evaluation, we still have a type conversion, then we
- -- may need to apply checks required for a subtype conversion.
+ -- If after evaluation we still have a type conversion, then we may need
+ -- to apply checks required for a subtype conversion.
-- Skip these type conversion checks if universal fixed operands
-- operands involved, since range checks are handled separately for
-- these cases (in the appropriate Expand routines in unit Exp_Fixd).
if Nkind (N) = N_Type_Conversion
- and then not Is_Generic_Type (Root_Type (Target_Type))
- and then Target_Type /= Universal_Fixed
- and then Opnd_Type /= Universal_Fixed
+ and then not Is_Generic_Type (Root_Type (Target_Typ))
+ and then Target_Typ /= Universal_Fixed
+ and then Operand_Typ /= Universal_Fixed
then
Apply_Type_Conversion_Checks (N);
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.
+ -- 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);
and then not In_Instance
then
Orig_N := Original_Node (Expression (Orig_N));
- Orig_T := Target_Type;
+ Orig_T := Target_Typ;
-- 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
end if;
if Is_Entity_Name (Orig_N)
- and then Etype (Entity (Orig_N)) = Orig_T
+ and then
+ (Etype (Entity (Orig_N)) = Orig_T
+ or else
+ (Ekind (Entity (Orig_N)) = E_Loop_Parameter
+ and then Covers (Orig_T, Etype (Entity (Orig_N)))))
then
- Error_Msg_NE
- ("?useless conversion, & has this type", N, Entity (Orig_N));
+ Error_Msg_Node_2 := Orig_T;
+ Error_Msg_NE -- CODEFIX
+ ("?redundant conversion, & is of type &!", N, Entity (Orig_N));
end if;
end if;
- -- Ada 2005 (AI-251): Handle conversions to abstract interface types
+ -- Ada 2005 (AI-251): Handle class-wide interface type conversions.
-- No need to perform any interface conversion if the type of the
-- expression coincides with the target type.
if Ada_Version >= Ada_05
and then Expander_Active
- and then Opnd_Type /= Target_Type
+ and then Operand_Typ /= Target_Typ
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;
+ declare
+ Opnd : Entity_Id := Operand_Typ;
+ Target : Entity_Id := Target_Typ;
- if Is_Interface (Target_Type) then
- if Is_Access_Type (Opnd_Type) then
- Opnd_Type := Directly_Designated_Type (Opnd_Type);
+ begin
+ if Is_Access_Type (Opnd) then
+ Opnd := Directly_Designated_Type (Opnd);
end if;
- if Is_Class_Wide_Type (Opnd_Type) then
- Opnd_Type := Etype (Opnd_Type);
+ if Is_Access_Type (Target_Typ) then
+ Target := Directly_Designated_Type (Target);
end if;
- -- Handle subtypes
+ if Opnd = Target then
+ null;
- if Ekind (Opnd_Type) = E_Protected_Subtype
- or else Ekind (Opnd_Type) = E_Task_Subtype
- then
- Opnd_Type := Etype (Opnd_Type);
- end if;
+ -- Conversion from interface type
- if not Interface_Present_In_Ancestor
- (Typ => Opnd_Type,
- Iface => Target_Type)
- then
- -- The static analysis is not enough to know if the interface
- -- is implemented or not. Hence we must pass the work to the
- -- expander to generate the required code to evaluate the
- -- conversion at run-time.
+ elsif Is_Interface (Opnd) then
- Expand_Interface_Conversion (N, Is_Static => False);
+ -- Ada 2005 (AI-217): Handle entities from limited views
- else
- Expand_Interface_Conversion (N);
- end if;
+ if From_With_Type (Opnd) then
+ Error_Msg_Qual_Level := 99;
+ Error_Msg_NE ("missing WITH clause on package &", N,
+ Cunit_Entity (Get_Source_Unit (Base_Type (Opnd))));
+ Error_Msg_N
+ ("type conversions require visibility of the full view",
+ N);
+
+ elsif From_With_Type (Target)
+ and then not
+ (Is_Access_Type (Target_Typ)
+ and then Present (Non_Limited_View (Etype (Target))))
+ then
+ Error_Msg_Qual_Level := 99;
+ Error_Msg_NE ("missing WITH clause on package &", N,
+ Cunit_Entity (Get_Source_Unit (Base_Type (Target))));
+ Error_Msg_N
+ ("type conversions require visibility of the full view",
+ N);
- -- Ada 2005 (AI-251): Conversion from a class-wide interface to a
- -- tagged type
+ else
+ Expand_Interface_Conversion (N, Is_Static => False);
+ end if;
- elsif Is_Class_Wide_Type (Opnd_Type)
- and then Is_Interface (Opnd_Type)
- then
- Expand_Interface_Conversion (N, Is_Static => False);
- end if;
+ -- Conversion to interface type
+
+ elsif Is_Interface (Target) then
+
+ -- Handle subtypes
+
+ if Ekind (Opnd) = E_Protected_Subtype
+ or else Ekind (Opnd) = E_Task_Subtype
+ then
+ Opnd := Etype (Opnd);
+ end if;
+
+ if not Interface_Present_In_Ancestor
+ (Typ => Opnd,
+ Iface => Target)
+ then
+ if Is_Class_Wide_Type (Opnd) then
+
+ -- The static analysis is not enough to know if the
+ -- interface is implemented or not. Hence we must pass
+ -- the work to the expander to generate code to evaluate
+ -- the conversion at run-time.
+
+ Expand_Interface_Conversion (N, Is_Static => False);
+
+ else
+ Error_Msg_Name_1 := Chars (Etype (Target));
+ Error_Msg_Name_2 := Chars (Opnd);
+ Error_Msg_N
+ ("wrong interface conversion (% is not a progenitor " &
+ "of %)", N);
+ end if;
+
+ else
+ Expand_Interface_Conversion (N);
+ end if;
+ end if;
+ end;
end if;
end Resolve_Type_Conversion;
Hi : Uint;
begin
- -- Deal with intrincis unary operators
+ -- Deal with intrinsic unary operators
if Comes_From_Source (N)
and then Ekind (Entity (N)) = E_Function
end if;
end if;
- -- Generate warning for expressions like -5 mod 3 for integers. No
- -- need to worry in the floating-point case, since parens do not affect
- -- the result so there is no point in giving in a warning.
+ -- Generate warning for expressions like -5 mod 3 for integers. No need
+ -- to worry in the floating-point case, since parens do not affect the
+ -- result so there is no point in giving in a warning.
declare
Norig : constant Node_Id := Original_Node (N);
Rorig := Original_Node (Right_Opnd (Norig));
-- We are looking for cases where the right operand is not
- -- parenthesized, and is a bianry operator, multiply, divide, or
+ -- parenthesized, and is a binary operator, multiply, divide, or
-- mod. These are the cases where the grouping can affect results.
if Paren_Count (Rorig) = 0
- and then (Nkind (Rorig) = N_Op_Mod
- or else
- Nkind (Rorig) = N_Op_Multiply
- or else
- Nkind (Rorig) = N_Op_Divide)
+ and then Nkind_In (Rorig, N_Op_Mod, N_Op_Multiply, N_Op_Divide)
then
-- For mod, we always give the warning, since the value is
-- affected by the parenthesization (e.g. (-5) mod 315 /=
- -- (5 mod 315)). But for the other cases, the only concern is
+ -- -(5 mod 315)). But for the other cases, the only concern is
-- overflow, e.g. for the case of 8 big signed (-(2 * 64)
-- overflows, but (-2) * 64 does not). So we try to give the
-- message only when overflow is possible.
LB := Expr_Value (Type_Low_Bound (Base_Type (Typ)));
end if;
- -- Note that the test below is deliberately excluding
- -- the largest negative number, since that is a potentially
+ -- Note that the test below is deliberately excluding the
+ -- largest negative number, since that is a potentially
-- troublesome case (e.g. -2 * x, where the result is the
-- largest negative integer has an overflow with 2 * x).
-- overflow is impossible (divisor > 1) or we have a case of
-- division by zero in any case.
- if (Nkind (Rorig) = N_Op_Divide
- or else
- Nkind (Rorig) = N_Op_Rem)
+ if Nkind_In (Rorig, N_Op_Divide, N_Op_Rem)
and then Compile_Time_Known_Value (Right_Opnd (Rorig))
and then UI_Abs (Expr_Value (Right_Opnd (Rorig))) /= 1
then
-- If we fall through warning should be issued
Error_Msg_N
- ("?unary minus expression should be parenthesized here", N);
+ ("?unary minus expression should be parenthesized here!", N);
end if;
end if;
end;
Op_Node : Node_Id;
begin
- -- 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.
+ -- 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
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.
+ -- Indicate that both the original entity and its renaming are
+ -- referenced at this point.
Generate_Reference (Entity (N), N);
Generate_Reference (Op, N);
N_Op_Expon | N_Op_Mod | N_Op_Rem =>
Resolve_Intrinsic_Operator (N, Typ);
- when N_Op_Plus | N_Op_Minus | N_Op_Abs =>
+ when N_Op_Plus | N_Op_Minus | N_Op_Abs =>
Resolve_Intrinsic_Unary_Operator (N, Typ);
when others =>
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
+ -- the original operator in the node, which is the one that Gigi
-- knows about.
Set_Entity (N, Op);
-- Build an implicit subtype declaration to represent the type delivered
-- by the slice. This is an abbreviated version of an array subtype. We
- -- define an index subtype for the slice, using either the subtype name
+ -- define an index subtype for the slice, using either the subtype name
-- or the discrete range of the slice. To be consistent with index usage
-- elsewhere, we create a list header to hold the single index. This list
-- is not otherwise attached to the syntax tree.
Set_First_Index (Slice_Subtype, Index);
Set_Etype (Slice_Subtype, Base_Type (Etype (N)));
Set_Is_Constrained (Slice_Subtype, True);
- Init_Size_Align (Slice_Subtype);
Check_Compile_Time_Size (Slice_Subtype);
- -- The Etype of the existing Slice node is reset to this slice
- -- subtype. Its bounds are obtained from its first index.
+ -- The Etype of the existing Slice node is reset to this slice subtype.
+ -- Its bounds are obtained from its first index.
Set_Etype (N, Slice_Subtype);
-- call to Check_Compile_Time_Size could be eliminated, which would
-- be nice, because then that routine could be made private to Freeze.
- if Is_Packed (Slice_Subtype) and not In_Default_Expression then
+ -- Why the test for In_Spec_Expression here ???
+
+ if Is_Packed (Slice_Subtype) and not In_Spec_Expression then
Freeze_Itype (Slice_Subtype, N);
end if;
procedure Set_String_Literal_Subtype (N : Node_Id; Typ : Entity_Id) is
Loc : constant Source_Ptr := Sloc (N);
Low_Bound : constant Node_Id :=
- Type_Low_Bound (Etype (First_Index (Typ)));
+ Type_Low_Bound (Etype (First_Index (Typ)));
Subtype_Id : Entity_Id;
begin
(Subtype_Id, Make_Integer_Literal (Loc, 1));
Set_Etype (String_Literal_Low_Bound (Subtype_Id), Standard_Positive);
- -- Build bona fide subtypes for the string, and wrap it in an
- -- unchecked conversion, because the backend expects the
+ -- Build bona fide subtype for the string, and wrap it in an
+ -- unchecked conversion, because the backend expects the
-- String_Literal_Subtype to have a static lower bound.
declare
Set_Parent (Drange, N);
Analyze_And_Resolve (Drange, Index_Type);
- Set_Etype (Index_Subtype, Index_Type);
+ -- In the context, the Index_Type may already have a constraint,
+ -- so use common base type on string subtype. The base type may
+ -- be used when generating attributes of the string, for example
+ -- in the context of a slice assignment.
+
+ Set_Etype (Index_Subtype, Base_Type (Index_Type));
Set_Size_Info (Index_Subtype, Index_Type);
Set_RM_Size (Index_Subtype, RM_Size (Index_Type));
Set_First_Index (Array_Subtype, Index);
Set_Etype (Array_Subtype, Base_Type (Typ));
Set_Is_Constrained (Array_Subtype, True);
- Init_Size_Align (Array_Subtype);
Rewrite (N,
Make_Unchecked_Type_Conversion (Loc,
Scop : Entity_Id;
procedure Fixed_Point_Error;
- -- If true ambiguity, give details
+ -- Give error messages for true ambiguity. Messages are posted on node
+ -- N, and entities T1, T2 are the possible interpretations.
-----------------------
-- Fixed_Point_Error --
end loop;
if Nkind (N) = N_Real_Literal then
- Error_Msg_NE ("real literal interpreted as }?", N, T1);
-
+ Error_Msg_NE ("?real literal interpreted as }!", N, T1);
else
- Error_Msg_NE ("universal_fixed expression interpreted as }?", N, T1);
+ Error_Msg_NE ("?universal_fixed expression interpreted as }!", N, T1);
end if;
return T1;
return False;
end if;
- -- Check that component subtypes statically match
+ -- Check that component subtypes statically match. For numeric
+ -- types this means that both must be either constrained or
+ -- unconstrained. For enumeration types the bounds must match.
+ -- All of this is checked in Subtypes_Statically_Match.
- if Is_Constrained (Target_Comp_Type) /=
- Is_Constrained (Opnd_Comp_Type)
- or else not Subtypes_Statically_Match
+ if not Subtypes_Statically_Match
(Target_Comp_Type, Opnd_Comp_Type)
then
Error_Msg_N
-- (RM 4.6(23)).
elsif Is_Class_Wide_Type (Opnd_Type)
- and then Covers (Opnd_Type, Target_Type)
+ and then Covers (Opnd_Type, Target_Type)
then
return True;
elsif Is_Interface (Target_Type) or else Is_Interface (Opnd_Type) then
return True;
+ -- If the operand is a class-wide type obtained through a limited_
+ -- with clause, and the context includes the non-limited view, use
+ -- it to determine whether the conversion is legal.
+
+ elsif Is_Class_Wide_Type (Opnd_Type)
+ and then From_With_Type (Opnd_Type)
+ and then Present (Non_Limited_View (Etype (Opnd_Type)))
+ and then Is_Interface (Non_Limited_View (Etype (Opnd_Type)))
+ then
+ return True;
+
elsif Is_Access_Type (Opnd_Type)
and then Is_Interface (Directly_Designated_Type (Opnd_Type))
then
N1 : Entity_Id;
begin
- -- Remove procedure calls, which syntactically cannot appear
- -- in this context, but which cannot be removed by type checking,
+ -- Remove procedure calls, which syntactically cannot appear 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
Error_Msg_N ("ambiguous operand in conversion", Operand);
Error_Msg_Sloc := Sloc (It.Nam);
- Error_Msg_N ("\\possible interpretation#!", Operand);
+ Error_Msg_N -- CODEFIX
+ ("\\possible interpretation#!", Operand);
Error_Msg_Sloc := Sloc (N1);
- Error_Msg_N ("\\possible interpretation#!", Operand);
+ Error_Msg_N -- CODEFIX
+ ("\\possible interpretation#!", Operand);
return False;
end if;
-- Also no need to check when in an instance or inlined body, because
-- the legality has been established when the template was analyzed.
-- Furthermore, numeric conversions may occur where only a private
- -- view of the operand type is visible at the instanciation point.
+ -- view of the operand type is visible at the instantiation point.
-- This results in a spurious error if we check that the operand type
-- is a numeric type.
return Valid_Array_Conversion;
end if;
- -- Anonymous access types where target references an interface
+ -- Ada 2005 (AI-251): Anonymous access types where target references an
+ -- interface type.
elsif (Ekind (Target_Type) = E_General_Access_Type
or else
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.
+ -- 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) >
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.)
+ -- 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)
+ 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.
+ -- 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
-- 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)
+ -- discriminant is considered to be deeper than any (nameable)
-- access type.
if Is_Entity_Name (Operand)
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.
+ -- 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
("\?Program_Error will be raised at run time", Operand);
else
- Error_Msg_N
- ("cannot convert local pointer to non-local access type",
- Operand);
+ -- Avoid generation of spurious error message
+
+ if not Error_Posted (N) then
+ Error_Msg_N
+ ("cannot convert local pointer to non-local access type",
+ Operand);
+ end if;
+
return False;
end if;
-- 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.)
+ -- 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)
+ 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.
+ -- 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
-- 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)
+ -- discriminant is considered to be deeper than any (nameable)
-- access type.
if Is_Entity_Name (Operand)
end if;
end if;
- declare
+ -- In the presence of limited_with clauses we have to use non-limited
+ -- views, if available.
+
+ Check_Limited : declare
function Full_Designated_Type (T : Entity_Id) return Entity_Id;
-- Helper function to handle limited views
function Full_Designated_Type (T : Entity_Id) return Entity_Id is
Desig : constant Entity_Id := Designated_Type (T);
+
begin
- if From_With_Type (Desig)
- and then Is_Incomplete_Type (Desig)
+ -- Handle the limited view of a type
+
+ if Is_Incomplete_Type (Desig)
+ and then From_With_Type (Desig)
and then Present (Non_Limited_View (Desig))
then
- return Non_Limited_View (Desig);
+ return Available_View (Desig);
else
return Desig;
end if;
end Full_Designated_Type;
+ -- Local Declarations
+
Target : constant Entity_Id := Full_Designated_Type (Target_Type);
Opnd : constant Entity_Id := Full_Designated_Type (Opnd_Type);
Same_Base : constant Boolean :=
Base_Type (Target) = Base_Type (Opnd);
+ -- Start of processing for Check_Limited
+
begin
if Is_Tagged_Type (Target) then
return Valid_Tagged_Conversion (Target, Opnd);
(not Is_Constrained (Opnd)
or else not Is_Constrained (Target)))
then
- return True;
+ -- Special case, if Value_Size has been used to make the
+ -- sizes different, the conversion is not allowed even
+ -- though the subtypes statically match.
+
+ if Known_Static_RM_Size (Target)
+ and then Known_Static_RM_Size (Opnd)
+ and then RM_Size (Target) /= RM_Size (Opnd)
+ then
+ Error_Msg_NE
+ ("target designated subtype not compatible with }",
+ N, Opnd);
+ Error_Msg_NE
+ ("\because sizes of the two designated subtypes differ",
+ N, Opnd);
+ return False;
+
+ -- Normal case where conversion is allowed
+
+ else
+ return True;
+ end if;
else
Error_Msg_NE
return False;
end if;
end if;
- end;
+ end Check_Limited;
- -- Subprogram access types
+ -- Access to subprogram types. If the operand is an access parameter,
+ -- the type has a deeper accessibility that any master, and cannot
+ -- be assigned. We must make an exception if the conversion is part
+ -- of an assignment and the target is the return object of an extended
+ -- return statement, because in that case the accessibility check
+ -- takes place after the return.
- elsif (Ekind (Target_Type) = E_Access_Subprogram_Type
- or else
- Ekind (Target_Type) = E_Anonymous_Access_Subprogram_Type)
+ elsif Is_Access_Subprogram_Type (Target_Type)
and then No (Corresponding_Remote_Type (Opnd_Type))
then
- if
- Ekind (Base_Type (Opnd_Type)) = E_Anonymous_Access_Subprogram_Type
+ if Ekind (Base_Type (Opnd_Type)) = E_Anonymous_Access_Subprogram_Type
+ and then Is_Entity_Name (Operand)
+ and then Ekind (Entity (Operand)) = E_In_Parameter
+ and then
+ (Nkind (Parent (N)) /= N_Assignment_Statement
+ or else not Is_Entity_Name (Name (Parent (N)))
+ or else not Is_Return_Object (Entity (Name (Parent (N)))))
then
Error_Msg_N
("illegal attempt to store anonymous access to subprogram",
Operand);
Error_Msg_N
("\value has deeper accessibility than any master " &
- "('R'M 3.10.2 (13))",
+ "(RM 3.10.2 (13))",
Operand);
- if Is_Entity_Name (Operand)
- and then Ekind (Entity (Operand)) = E_In_Parameter
- then
- Error_Msg_NE
- ("\use named access type for& instead of access parameter",
- Operand, Entity (Operand));
- end if;
+ Error_Msg_NE
+ ("\use named access type for& instead of access parameter",
+ Operand, Entity (Operand));
end if;
-- Check that the designated types are subtype conformant
N);
return True;
- -- Tagged types
+ -- If both are tagged types, check legality of view conversions
- elsif Is_Tagged_Type (Target_Type) then
+ elsif Is_Tagged_Type (Target_Type)
+ and then Is_Tagged_Type (Opnd_Type)
+ then
return Valid_Tagged_Conversion (Target_Type, Opnd_Type);
-- Types derived from the same root type are convertible
elsif Root_Type (Target_Type) = Root_Type (Opnd_Type) then
return True;
- -- In an instance, there may be inconsistent views of the same
- -- type, or types derived from the same type.
+ -- In an instance or an inlined body, there may be inconsistent
+ -- views of the same type, or of types derived from a common root.
- elsif In_Instance
- and then Underlying_Type (Target_Type) = Underlying_Type (Opnd_Type)
+ elsif (In_Instance or In_Inlined_Body)
+ and then
+ Root_Type (Underlying_Type (Target_Type)) =
+ Root_Type (Underlying_Type (Opnd_Type))
then
return True;
then
Error_Msg_N ("target type must be general access type!", N);
Error_Msg_NE ("add ALL to }!", N, Target_Type);
-
return False;
else
Error_Msg_NE ("invalid conversion, not compatible with }",
N, Opnd_Type);
-
return False;
end if;
end Valid_Conversion;
OSDN Git Service
