-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2005 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_Ch6; use Exp_Ch6;
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 Targparm; use Targparm;
+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_Direct_Boolean_Op (N : Node_Id);
- -- N is a binary operator node which may possibly operate on Boolean
- -- operands. If the operator does have Boolean operands, then a call is
- -- made to check the restriction No_Direct_Boolean_Operators.
-
procedure Check_Discriminant_Use (N : Node_Id);
-- Enforce the restrictions on the use of discriminants when constraining
-- a component of a discriminated type (record or concurrent type).
-- universal must be checked for visibility during resolution
-- because their type is not determinable based on their operands.
+ procedure Check_Fully_Declared_Prefix
+ (Typ : Entity_Id;
+ Pref : Node_Id);
+ -- Check that the type of the prefix of a dereference is not incomplete
+
function Check_Infinite_Recursion (N : Node_Id) return Boolean;
-- Given a call node, N, which is known to occur immediately within the
-- subprogram being called, determines whether it is a detectable case of
-- 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);
procedure Set_Slice_Subtype (N : Node_Id);
-- Build subtype of array type, with the range specified by the slice
+ procedure Simplify_Type_Conversion (N : Node_Id);
+ -- Called after N has been resolved and evaluated, but before range checks
+ -- have been applied. Currently simplifies a combination of floating-point
+ -- to integer conversion and Truncation attribute.
+
function Unique_Fixed_Point_Type (N : Node_Id) return Entity_Id;
-- A universal_fixed expression in an universal context is unambiguous
-- if there is only one applicable fixed point type. Determining whether
begin
if Nkind (C) = N_Character_Literal then
Error_Msg_N ("ambiguous character literal", C);
- Error_Msg_N
- ("\possible interpretations: Character, Wide_Character!", C);
- E := Current_Entity (C);
+ -- First the ones in Standard
- if Present (E) then
+ Error_Msg_N
+ ("\\possible interpretation: Character!", C);
+ Error_Msg_N
+ ("\\possible interpretation: Wide_Character!", C);
- while Present (E) loop
- Error_Msg_NE ("\possible interpretation:}!", C, Etype (E));
- E := Homonym (E);
- end loop;
+ -- 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
+ Error_Msg_NE ("\\possible interpretation:}!", C, Etype (E));
+ E := Homonym (E);
+ end loop;
end if;
end Ambiguous_Character;
if Suppress = All_Checks then
declare
Svg : constant Suppress_Array := Scope_Suppress;
-
begin
Scope_Suppress := (others => True);
Analyze_And_Resolve (N, Typ);
if Suppress = All_Checks then
declare
Svg : constant Suppress_Array := Scope_Suppress;
-
begin
Scope_Suppress := (others => True);
Analyze_And_Resolve (N);
end if;
end Analyze_And_Resolve;
- -----------------------------
- -- Check_Direct_Boolean_Op --
- -----------------------------
-
- procedure Check_Direct_Boolean_Op (N : Node_Id) is
- begin
- if Nkind (N) in N_Op
- and then Root_Type (Etype (Left_Opnd (N))) = Standard_Boolean
- then
- Check_Restriction (No_Direct_Boolean_Operators, N);
- end if;
- end Check_Direct_Boolean_Op;
-
----------------------------
-- Check_Discriminant_Use --
----------------------------
D : Node_Id;
begin
- -- Any use in a default expression is legal
+ -- Any use in a 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
-- Check that it is the high bound
if N /= High_Bound (PN)
- or else not Present (Discriminant_Default_Value (Disc))
+ or else No (Discriminant_Default_Value (Disc))
then
goto No_Danger;
end if;
-- 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,
end if;
end Check_For_Visible_Operator;
+ ----------------------------------
+ -- Check_Fully_Declared_Prefix --
+ ----------------------------------
+
+ procedure Check_Fully_Declared_Prefix
+ (Typ : Entity_Id;
+ Pref : Node_Id)
+ is
+ begin
+ -- Check that the designated type of the prefix of a dereference is
+ -- not an incomplete type. This cannot be done unconditionally, because
+ -- dereferences of private types are legal in default expressions. This
+ -- case is taken care of in Check_Fully_Declared, called below. There
+ -- are also 2005 cases where it is legal for the prefix to be unfrozen.
+
+ -- This consideration also applies to similar checks for allocators,
+ -- qualified expressions, and type conversions.
+
+ -- An additional exception concerns other per-object expressions that
+ -- are not directly related to component declarations, in particular
+ -- representation pragmas for tasks. These will be per-object
+ -- expressions if they depend on discriminants or some global entity.
+ -- If the task has access discriminants, the designated type may be
+ -- incomplete at the point the expression is resolved. This resolution
+ -- takes place within the body of the initialization procedure, where
+ -- the discriminant is replaced by its discriminal.
+
+ if Is_Entity_Name (Pref)
+ and then Ekind (Entity (Pref)) = E_In_Parameter
+ then
+ null;
+
+ -- Ada 2005 (AI-326): Tagged incomplete types allowed. The wrong usages
+ -- are handled by Analyze_Access_Attribute, Analyze_Assignment,
+ -- Analyze_Object_Renaming, and Freeze_Entity.
+
+ 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)))
+ then
+ null;
+ else
+ Check_Fully_Declared (Typ, Parent (Pref));
+ end if;
+ end Check_Fully_Declared_Prefix;
+
------------------------------
-- Check_Infinite_Recursion --
------------------------------
-- 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))
- or else (Nkind (Prev (Parent (N))) /= N_Raise_Statement
- and then
- (Nkind (Prev (Parent (N))) not in N_Raise_xxx_Error
- or else
- Present (Condition (Prev (Parent (N))))));
+ exit when not Is_List_Member (Parent (N));
+
+ -- OK, return statement is in a statement list, look for raise
+
+ declare
+ Nod : Node_Id;
+
+ begin
+ -- Skip past N_Freeze_Entity nodes generated by expansion
+
+ Nod := Prev (Parent (N));
+ while Present (Nod)
+ and then Nkind (Nod) = N_Freeze_Entity
+ loop
+ Prev (Nod);
+ end loop;
+
+ -- If no raise statement, give warning
+
+ exit when Nkind (Nod) /= N_Raise_Statement
+ and then
+ (Nkind (Nod) not in N_Raise_xxx_Error
+ or else Present (Condition (Nod)));
+ end;
end if;
return False;
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
- return False;
+ -- Normally we want to use the underlying type, but if it's not set
+ -- then continue with T.
- elsif Is_Array_Type (T) then
- return Uses_SS (Component_Type (T));
+ if not Present (Full_Type) then
+ Full_Type := T;
+ end if;
+
+ if Is_Controlled (Full_Type) then
+ return False;
- elsif Is_Record_Type (T) then
- Comp := First_Component (T);
+ elsif Is_Array_Type (Full_Type) then
+ return Uses_SS (Component_Type (Full_Type));
+ 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.
- -- The expression for a dynamic component may be
- -- rewritten as a dereference. Retrieve original
- -- call.
+ Expr := Original_Node (Expression (Parent (Comp)));
- if Nkind (Original_Node (Expr)) = N_Function_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 (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;
-- Start of processing for Check_Initialization_Call
begin
- -- Nothing to do if functions do not use the secondary stack for
- -- returns (i.e. they use a depressed stack pointer instead).
-
- if Functions_Return_By_DSP_On_Target then
- return;
-
- -- Otherwise establish a transient scope if the type needs it
+ -- Establish a transient scope if the type needs it
- elsif Uses_SS (Typ) then
+ if Uses_SS (Typ) then
Establish_Transient_Scope (First_Actual (N), Sec_Stack => 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 --
---------------------------
else
Get_First_Interp (Nod, I, It);
-
while Present (It.Typ) loop
-
if Scope (Base_Type (It.Typ)) = S then
return True;
end if;
else
E := First_Entity (Pack);
-
while Present (E) loop
-
if Test (E)
and then not In_Decl
then
then
null;
+ -- Visibility does not need to be checked in an instance: if the
+ -- operator was not visible in the generic it has been diagnosed
+ -- already, else there is an implicit copy of it in the instance.
+
+ elsif In_Instance then
+ null;
+
elsif (Op_Name = Name_Op_Multiply
or else Op_Name = Name_Op_Divide)
and then Is_Fixed_Point_Type (Etype (Left_Opnd (Op_Node)))
Error := True;
end if;
+ -- Ada 2005, AI-420: Predefined equality on Universal_Access
+ -- is available.
+
+ elsif Ada_Version >= Ada_05
+ and then (Op_Name = Name_Op_Eq or else Op_Name = Name_Op_Ne)
+ and then Ekind (Etype (Act1)) = E_Anonymous_Access_Type
+ then
+ null;
+
else
Opnd_Type := Base_Type (Etype (Right_Opnd (Op_Node)));
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
if Nkind (N) = N_Attribute_Reference
and then (Attribute_Name (N) = Name_Access
- or else Attribute_Name (N) = Name_Unrestricted_Access
- or else Attribute_Name (N) = Name_Unchecked_Access)
+ or else Attribute_Name (N) = Name_Unrestricted_Access
+ or else Attribute_Name (N) = Name_Unchecked_Access)
and then Comes_From_Source (N)
and then Is_Entity_Name (Prefix (N))
and then Is_Subprogram (Entity (Prefix (N)))
("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;
-- is compatible with the context (i.e. the type passed to Resolve)
else
- Get_First_Interp (N, I, It);
-
-- Loop through possible interpretations
+ Get_First_Interp (N, I, It);
Interp_Loop : while Present (It.Typ) loop
-- We are only interested in interpretations that are compatible
- -- with the expected type, any other interpretations are ignored
+ -- 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 := First_Actual (N);
+ A : Node_Id;
E : Node_Id;
begin
+ A := First_Actual (N);
while Present (A) loop
E := A;
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
-- message only at the start of an ambiguous set.
if not Ambiguous then
- Error_Msg_NE
- ("ambiguous expression (cannot resolve&)!",
- N, It.Nam);
+ if Nkind (N) = N_Function_Call
+ and then Nkind (Name (N)) = N_Explicit_Dereference
+ then
+ Error_Msg_N
+ ("ambiguous expression "
+ & "(cannot resolve indirect call)!", N);
+ else
+ Error_Msg_NE -- CODEFIX
+ ("ambiguous expression (cannot resolve&)!",
+ N, It.Nam);
+ end if;
- Error_Msg_N
- ("possible interpretation#!", N);
Ambiguous := True;
+
+ if Nkind (Parent (Seen)) = N_Full_Type_Declaration then
+ Error_Msg_N
+ ("\\possible interpretation (inherited)#!", N);
+ else
+ Error_Msg_N -- CODEFIX
+ ("\\possible interpretation#!", N);
+ end if;
end if;
Error_Msg_Sloc := Sloc (It.Nam);
-- By default, the error message refers to the candidate
- -- interpretation. But if it is a predefined operator,
- -- it is implicitly declared at the declaration of
- -- the type of the operand. Recover the sloc of that
- -- declaration for the error message.
+ -- interpretation. But if it is a predefined operator, it
+ -- is implicitly declared at the declaration of the type
+ -- of the operand. Recover the sloc of that declaration
+ -- for the error message.
if Nkind (N) in N_Op
and then Scope (It.Nam) = Standard_Standard
and then not Is_Overloaded (Right_Opnd (N))
- and then Scope (Base_Type (Etype (Right_Opnd (N))))
- /= Standard_Standard
+ and then Scope (Base_Type (Etype (Right_Opnd (N)))) /=
+ Standard_Standard
then
Err_Type := First_Subtype (Etype (Right_Opnd (N)));
elsif Nkind (N) in N_Binary_Op
and then Scope (It.Nam) = Standard_Standard
and then not Is_Overloaded (Left_Opnd (N))
- and then Scope (Base_Type (Etype (Left_Opnd (N))))
- /= Standard_Standard
+ and then Scope (Base_Type (Etype (Left_Opnd (N)))) /=
+ Standard_Standard
then
Err_Type := First_Subtype (Etype (Left_Opnd (N)));
then
Error_Msg_Sloc := Sloc (Parent (Err_Type));
end if;
+
+ -- If this is an indirect call, use the subprogram_type
+ -- in the message, to have a meaningful location.
+ -- Indicate as well if this is an inherited operation,
+ -- created by a type declaration.
+
+ elsif Nkind (N) = N_Function_Call
+ and then Nkind (Name (N)) = N_Explicit_Dereference
+ and then Is_Type (It.Nam)
+ then
+ Err_Type := It.Nam;
+ Error_Msg_Sloc :=
+ Sloc (Associated_Node_For_Itype (Err_Type));
else
Err_Type := Empty;
end if;
and then Scope (It.Nam) = Standard_Standard
and then Present (Err_Type)
then
+ -- 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
+ then
Error_Msg_N
- ("possible interpretation (predefined)#!", N);
+ ("\\possible interpretation (inherited)#!", N);
else
- Error_Msg_N ("possible interpretation#!", N);
+ Error_Msg_N -- CODEFIX
+ ("\\possible interpretation#!", N);
end if;
end if;
end if;
- -- We have a matching interpretation, Expr_Type is the
- -- type from this interpretation, and Seen is the entity.
+ -- We have a matching interpretation, Expr_Type is the type
+ -- from this interpretation, and Seen is the entity.
- -- For an operator, just set the entity name. The type will
- -- be set by the specific operator resolution routine.
+ -- For an operator, just set the entity name. The type will be
+ -- set by the specific operator resolution routine.
if Nkind (N) in N_Op then
Set_Entity (N, Seen);
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 a call with a name that is an explicit dereference,
- -- there is nothing to be done at this point.
-
- elsif Nkind (N) = N_Explicit_Dereference
- or else Nkind (N) = N_Attribute_Reference
- or else Nkind (N) = N_And_Then
- or else Nkind (N) = N_Indexed_Component
- or else Nkind (N) = N_Or_Else
- or else Nkind (N) = N_Range
- or else Nkind (N) = N_Selected_Component
- or else Nkind (N) = N_Slice
+ -- 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_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
+ -- 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 not Present (It.Typ);
+ exit Interp_Loop when No (It.Typ);
Get_Next_Interp (I, It);
end loop Interp_Loop;
if not Found then
if Typ /= Any_Type then
- -- If type we are looking for is Void, then this is the
- -- procedure call case, and the error is simply that what
- -- we gave is not a procedure name (we think of procedure
- -- calls as expressions with types internally, but the user
- -- doesn't think of them this way!)
+ -- If type we are looking for is Void, then this is the procedure
+ -- call case, and the error is simply that what we gave is not a
+ -- procedure name (we think of procedure calls as expressions with
+ -- types internally, but the user doesn't think of them this way!)
if Typ = Standard_Void_Type then
("cannot use function & in a procedure call",
Name (N), Entity (Name (N)));
- -- Otherwise give general message (not clear what cases
- -- this covers, but no harm in providing for them!)
+ -- Otherwise give general message (not clear what cases this
+ -- covers, but no harm in providing for them!)
else
Error_Msg_N ("expect procedure name in procedure call", N);
-- Otherwise we do have a subexpression with the wrong type
- -- Check for the case of an allocator which uses an access
- -- type instead of the designated type. This is a common
- -- error and we specialize the message, posting an error
- -- on the operand of the allocator, complaining that we
- -- expected the designated type of the allocator.
+ -- Check for the case of an allocator which uses an access type
+ -- instead of the designated type. This is a common error and we
+ -- specialize the message, posting an error on the operand of the
+ -- allocator, complaining that we expected the designated type of
+ -- the allocator.
elsif Nkind (N) = N_Allocator
and then Ekind (Typ) in Access_Kind
Wrong_Type (Expression (N), Designated_Type (Typ));
Found := True;
- -- Check for view mismatch on Null in instances, for
- -- which the view-swapping mechanism has no identifier.
+ -- Check for view mismatch on Null in instances, for which the
+ -- view-swapping mechanism has no identifier.
elsif (In_Instance or else In_Inlined_Body)
and then (Nkind (N) = N_Null)
Set_Etype (N, Typ);
return;
- -- Check for an aggregate. Sometimes we can get bogus
- -- aggregates from misuse of parentheses, and we are
- -- about to complain about the aggregate without even
- -- looking inside it.
+ -- Check for an aggregate. Sometimes we can get bogus aggregates
+ -- from misuse of parentheses, and we are about to complain about
+ -- the aggregate without even looking inside it.
- -- Instead, if we have an aggregate of type Any_Composite,
- -- then analyze and resolve the component fields, and then
- -- only issue another message if we get no errors doing
- -- this (otherwise assume that the errors in the aggregate
- -- caused the problem).
+ -- Instead, if we have an aggregate of type Any_Composite, then
+ -- analyze and resolve the component fields, and then only issue
+ -- another message if we get no errors doing this (otherwise
+ -- assume that the errors in the aggregate caused the problem).
elsif Nkind (N) = N_Aggregate
and then Etype (N) = Any_Composite
declare
procedure Check_Aggr (Aggr : Node_Id);
- -- Check one aggregate, and set Found to True if we
- -- have a definite error in any of its elements
+ -- Check one aggregate, and set Found to True if we have a
+ -- definite error in any of its elements
procedure Check_Elmt (Aelmt : Node_Id);
- -- Check one element of aggregate and set Found to
- -- True if we definitely have an error in the element.
+ -- Check one element of aggregate and set Found to True if
+ -- we definitely have an error in the element.
+
+ ----------------
+ -- Check_Aggr --
+ ----------------
procedure Check_Aggr (Aggr : Node_Id) is
Elmt : Node_Id;
if Present (Component_Associations (Aggr)) then
Elmt := First (Component_Associations (Aggr));
while Present (Elmt) loop
- Check_Elmt (Expression (Elmt));
+
+ -- If this is a default-initialized component, then
+ -- there is nothing to check. The box will be
+ -- replaced by the appropriate call during late
+ -- expansion.
+
+ if not Box_Present (Elmt) then
+ Check_Elmt (Expression (Elmt));
+ end if;
+
Next (Elmt);
end loop;
end if;
It : Interp;
begin
- Error_Msg_N ("\possible interpretations:", N);
- Get_First_Interp (Name (N), Index, It);
+ Error_Msg_N ("\\possible interpretations:", N);
+ Get_First_Interp (Name (N), Index, It);
while Present (It.Nam) loop
-
- Error_Msg_Sloc := Sloc (It.Nam);
- Error_Msg_Node_2 := It.Typ;
- Error_Msg_NE ("\& declared#, type&",
- N, It.Nam);
-
+ Error_Msg_Sloc := Sloc (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
when N_Identifier
=> Resolve_Entity_Name (N, Ctx_Type);
- when N_In | N_Not_In
- => Resolve_Membership_Op (N, Ctx_Type);
-
when N_Indexed_Component
=> Resolve_Indexed_Component (N, Ctx_Type);
when N_Integer_Literal
=> Resolve_Integer_Literal (N, Ctx_Type);
+ when N_Membership_Test
+ => Resolve_Membership_Op (N, Ctx_Type);
+
when N_Null => Resolve_Null (N, Ctx_Type);
when N_Op_And | N_Op_Or | N_Op_Xor
if Suppress = All_Checks then
declare
Svg : constant Suppress_Array := Scope_Suppress;
-
begin
Scope_Suppress := (others => True);
Resolve (N, Typ);
else
declare
Svg : constant Boolean := Scope_Suppress (Suppress);
-
begin
Scope_Suppress (Suppress) := True;
Resolve (N, Typ);
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.
- --------------------
- -- Insert_Default --
- --------------------
+ 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.
- procedure Insert_Default is
- Actval : Node_Id;
- Assoc : Node_Id;
+ --------------------------
+ -- Check_Argument_Order --
+ --------------------------
+ procedure Check_Argument_Order is
begin
- -- Missing argument in call, nothing to insert
-
- if No (Default_Value (F)) then
+ -- 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;
- else
- -- Note that we do a full New_Copy_Tree, so that any associated
- -- Itypes are properly copied. This may not be needed any more,
- -- but it does no harm as a safety measure! Defaults of a generic
- -- formal may be out of bounds of the corresponding actual (see
- -- cc1311b) and an additional check may be required.
+ declare
+ Nargs : constant Nat := List_Length (Parameter_Associations (N));
- Actval := New_Copy_Tree (Default_Value (F),
- New_Scope => Current_Scope, New_Sloc => Loc);
+ begin
+ -- Nothing to do if only one parameter
- if Is_Concurrent_Type (Scope (Nam))
- and then Has_Discriminants (Scope (Nam))
- then
- Replace_Actual_Discriminants (N, Actval);
+ if Nargs < 2 then
+ return;
end if;
- if Is_Overloadable (Nam)
- and then Present (Alias (Nam))
- then
- if Base_Type (Etype (F)) /= Base_Type (Etype (Actval))
- and then not Is_Tagged_Type (Etype (F))
+ -- 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 --
+ --------------------
+
+ procedure Insert_Default is
+ Actval : Node_Id;
+ Assoc : Node_Id;
+
+ begin
+ -- Missing argument in call, nothing to insert
+
+ if No (Default_Value (F)) then
+ return;
+
+ else
+ -- Note that we do a full New_Copy_Tree, so that any associated
+ -- Itypes are properly copied. This may not be needed any more,
+ -- but it does no harm as a safety measure! Defaults of a generic
+ -- formal may be out of bounds of the corresponding actual (see
+ -- cc1311b) and an additional check may be required.
+
+ Actval :=
+ New_Copy_Tree
+ (Default_Value (F),
+ New_Scope => Current_Scope,
+ New_Sloc => Loc);
+
+ if Is_Concurrent_Type (Scope (Nam))
+ and then Has_Discriminants (Scope (Nam))
+ then
+ Replace_Actual_Discriminants (N, Actval);
+ end if;
+
+ if Is_Overloadable (Nam)
+ and then Present (Alias (Nam))
+ then
+ if Base_Type (Etype (F)) /= Base_Type (Etype (Actval))
+ and then not Is_Tagged_Type (Etype (F))
then
-- If default is a real literal, do not introduce a
-- conversion whose effect may depend on the run-time
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
- and then Has_Discriminants (Etype (Actval))
- then
- Analyze_And_Resolve (Actval, Base_Type (Etype (Actval)));
+ if Nkind (Actval) = N_Aggregate then
+ Analyze_And_Resolve (Actval, Etype (F));
else
Analyze_And_Resolve (Actval, Etype (Actval));
end if;
Set_First_Named_Actual (N, Actval);
if No (Prev) then
- if not Present (Parameter_Associations (N)) then
+ if No (Parameter_Associations (N)) then
Set_Parameter_Associations (N, New_List (Assoc));
else
Append (Assoc, Parameter_Associations (N));
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
- -- conversion can be resolved. An exception is the case of
- -- a tagged type conversion with a class-wide actual. In that
- -- case we want the tag check to occur and no temporary will
- -- will be needed (no representation change can occur) and
- -- the parameter is passed by reference, so we go ahead and
- -- resolve the type conversion.
+ -- conversion can be resolved. An exception is the case of tagged
+ -- type conversion with a class-wide actual. In that case we want
+ -- the tag check to occur and no temporary will be needed (no
+ -- representation change can occur) and the parameter is passed by
+ -- reference, so we go ahead and resolve the type conversion.
+ -- Another exception is the case of reference to component or
+ -- subcomponent of a bit-packed array, in which case we want to
+ -- defer expansion to the point the in and out assignments are
+ -- performed.
if Ekind (F) /= E_In_Parameter
and then Nkind (A) = N_Type_Conversion
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;
- if Conversion_OK (A)
- or else Valid_Conversion (A, Etype (A), Expression (A))
+ if (Conversion_OK (A)
+ or else Valid_Conversion (A, Etype (A), Expression (A)))
+ and then not Is_Ref_To_Bit_Packed_Array (Expression (A))
then
Resolve (Expression (A));
end if;
+ -- 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))
end if;
end if;
- Resolve (A, Etype (F));
+ -- (Ada 2005: AI-251): If the actual is an allocator whose
+ -- directly designated type is a class-wide interface, we build
+ -- an anonymous access type to use it as the type of the
+ -- allocator. Later, when the subprogram call is expanded, if
+ -- the interface has a secondary dispatch table the expander
+ -- will add a type conversion to force the correct displacement
+ -- of the pointer.
+
+ if Nkind (A) = N_Allocator then
+ 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));
+ Set_Directly_Designated_Type (New_Itype,
+ Directly_Designated_Type (Etype (A)));
+ Set_Etype (A, New_Itype);
+ end if;
+
+ -- Ada 2005, AI-162:If the actual is an allocator, the
+ -- innermost enclosing statement is the master of the
+ -- 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))
+ and then Expander_Active
+ then
+ Establish_Transient_Scope (A, False);
+ end if;
+ end;
+ end if;
+
+ -- (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)
- or else Can_Never_Be_Null (F_Typ))
+ and then Can_Never_Be_Null (F_Typ)
+ and then Known_Null (A)
then
- if Nkind (A) = N_Null then
- Apply_Compile_Time_Constraint_Error
- (N => A,
- Msg => "(Ada 2005) NULL not allowed in "
- & "null-excluding formal?",
- Reason => CE_Null_Not_Allowed);
- end if;
+ Apply_Compile_Time_Constraint_Error
+ (N => A,
+ Msg => "(Ada 2005) null not allowed in "
+ & "null-excluding formal?",
+ Reason => CE_Null_Not_Allowed);
end if;
end if;
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
+ -- if the type is still incomplete.
if Is_Controlling_Formal (F) then
Set_Is_Controlling_Actual (A);
+
+ if Ekind (Etype (F)) = E_Anonymous_Access_Type then
+ declare
+ Desig : constant Entity_Id := Designated_Type (Etype (F));
+ begin
+ if Ekind (Desig) = E_Incomplete_Type
+ and then No (Full_View (Desig))
+ and then No (Non_Limited_View (Desig))
+ then
+ Error_Msg_NE
+ ("premature use of incomplete type& " &
+ "in dispatching call", A, Desig);
+ end if;
+ end;
+ end if;
+
elsif Nkind (A) = N_Explicit_Dereference then
Validate_Remote_Access_To_Class_Wide_Type (A);
end if;
elsif Is_Access_Type (A_Typ)
and then Is_Access_Type (F_Typ)
and then Ekind (F_Typ) /= E_Access_Subprogram_Type
+ and then 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
Set_Etype (N, Base_Type (Typ));
end if;
- if Is_Abstract (Typ) then
+ if Is_Abstract_Type (Typ) then
Error_Msg_N ("type of allocator cannot be abstract", N);
end if;
-- 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)));
if Has_Discriminants (Subtyp) then
Discrim := First_Discriminant (Base_Type (Subtyp));
Constr := First (Constraints (Constraint (Original_Node (E))));
-
while Present (Discrim) and then Present (Constr) loop
if Ekind (Etype (Discrim)) = E_Anonymous_Access_Type then
if Nkind (Constr) = N_Discriminant_Association then
Disc_Exp := Original_Node (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
if In_Instance_Body then
Error_Msg_N ("?type in allocator has deeper level than" &
" designated class-wide type", E);
- Error_Msg_N ("?Program_Error will be raised at run time", E);
+ Error_Msg_N ("\?Program_Error will be raised at run time",
+ E);
Rewrite (N,
Make_Raise_Program_Error (Sloc (N),
Reason => PE_Accessibility_Check_Failed));
Set_Etype (N, Typ);
- else
+
+ -- Do not apply Ada 2005 accessibility checks on a class-wide
+ -- allocator if the type given in the allocator is a formal
+ -- type. A run-time check will be performed in the instance.
+
+ elsif not Is_Generic_Type (Exp_Typ) then
Error_Msg_N ("type in allocator has deeper level than" &
" designated class-wide type", E);
end if;
if No_Pool_Assigned (Typ) then
declare
Loc : constant Source_Ptr := Sloc (N);
-
begin
Error_Msg_N ("?allocation from empty storage pool!", N);
- Error_Msg_N ("?Storage_Error will be raised at run time!", N);
+ Error_Msg_N ("\?Storage_Error will be raised at run time!", N);
Insert_Action (N,
Make_Raise_Storage_Error (Loc,
Reason => SE_Empty_Storage_Pool));
end;
+
+ -- If the context is an unchecked conversion, as may happen within
+ -- an inlined subprogram, the allocator is being resolved with its
+ -- own anonymous type. In that case, if the target type has a specific
+ -- storage pool, it must be inherited explicitly by the allocator type.
+
+ elsif Nkind (Parent (N)) = N_Unchecked_Type_Conversion
+ and then No (Associated_Storage_Pool (Typ))
+ then
+ Set_Associated_Storage_Pool
+ (Typ, Associated_Storage_Pool (Etype (Parent (N))));
+ end if;
+
+ -- 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;
-- We do the resolution using the base type, because intermediate values
-- in expressions always are of the base type, not a subtype of it.
+ function Expected_Type_Is_Any_Real (N : Node_Id) return Boolean;
+ -- Returns True if N is in a context that expects "any real type"
+
function Is_Integer_Or_Universal (N : Node_Id) return Boolean;
-- Return True iff given type is Integer or universal real/integer
procedure Set_Operand_Type (N : Node_Id);
-- Set operand type to T if universal
+ -------------------------------
+ -- Expected_Type_Is_Any_Real --
+ -------------------------------
+
+ function Expected_Type_Is_Any_Real (N : Node_Id) return Boolean is
+ begin
+ -- N is the expression after "delta" in a fixed_point_definition;
+ -- see RM-3.5.9(6):
+
+ 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):
+
+ N_Real_Range_Specification,
+
+ -- N is the expression of a delta_constraint;
+ -- see RM-J.3(3):
+
+ N_Delta_Constraint);
+ end Expected_Type_Is_Any_Real;
+
-----------------------------
-- Is_Integer_Or_Universal --
-----------------------------
or else T = Universal_Real;
else
Get_First_Interp (N, Index, It);
-
while Present (It.Typ) loop
-
if Base_Type (It.Typ) = Base_Type (Standard_Integer)
or else It.Typ = Universal_Integer
or else It.Typ = Universal_Real
-- interpretation or an integer interpretation, but not both.
Get_First_Interp (N, Index, It);
-
while Present (It.Typ) loop
if Base_Type (It.Typ) = Base_Type (Standard_Integer) then
-- 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 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 Nkind (Parent (N)) /= N_Type_Conversion
- and then Nkind (Parent (N)) /= N_Unchecked_Type_Conversion
+ and then not Expected_Type_Is_Any_Real (N)
+ 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;
- Set_Etype (N, B_Typ);
+ -- The expected type is "any real type" in contexts like
+ -- type T is delta <universal_fixed-expression> ...
+ -- in which case we need to set the type to Universal_Real
+ -- so that static expression evaluation will work properly.
+
+ if Expected_Type_Is_Any_Real (N) then
+ Set_Etype (N, Universal_Real);
+ else
+ Set_Etype (N, B_Typ);
+ end if;
end if;
elsif Is_Fixed_Point_Type (B_Typ)
and then (Is_Integer_Or_Universal (L)
or else Nkind (L) = N_Real_Literal
or else Nkind (R) = N_Real_Literal
- or else
- Is_Integer_Or_Universal (R))
+ 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
- Apply_Compile_Time_Constraint_Error
- (N, "division by zero?", CE_Divide_By_Zero,
- Loc => Sloc (Right_Opnd (N)));
+ -- Specialize the warning message according to the operation
+
+ case Nkind (N) is
+ when N_Op_Divide =>
+ Apply_Compile_Time_Constraint_Error
+ (N, "division by zero?", CE_Divide_By_Zero,
+ Loc => Sloc (Right_Opnd (N)));
+
+ when N_Op_Rem =>
+ Apply_Compile_Time_Constraint_Error
+ (N, "rem with zero divisor?", CE_Divide_By_Zero,
+ Loc => Sloc (Right_Opnd (N)));
+
+ when N_Op_Mod =>
+ Apply_Compile_Time_Constraint_Error
+ (N, "mod with zero divisor?", CE_Divide_By_Zero,
+ Loc => Sloc (Right_Opnd (N)));
+
+ -- Division by zero can only happen with division, rem,
+ -- and mod operations.
+
+ when others =>
+ raise Program_Error;
+ end case;
-- 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);
It : Interp;
Norm_OK : Boolean;
Scop : Entity_Id;
- W : Node_Id;
+ Rtype : Entity_Id;
begin
-- The context imposes a unique interpretation with type Typ on a
-- return type that is compatible with the context. Analysis of
-- the node has established that one exists.
- Get_First_Interp (Subp, I, It);
Nam := Empty;
+ Get_First_Interp (Subp, I, It);
while Present (It.Typ) loop
if Covers (Typ, Etype (It.Typ)) then
Nam := It.Typ;
-- For an indirect call, we always invalidate checks, since we do not
-- know whether the subprogram is local or global. Yes we could do
-- better here, e.g. by knowing that there are no local subprograms,
- -- but it does not seem worth the effort. Similarly, we kill al
+ -- but it does not seem worth the effort. Similarly, we kill all
-- knowledge of current constant values.
Kill_Current_Values;
- -- If this is a procedure call which is really an entry call, do the
- -- conversion of the procedure call to an entry call. Protected
- -- operations use the same circuitry because the name in the call can be
- -- an arbitrary expression with special resolution rules.
+ -- 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.
- Get_First_Interp (Subp, I, It);
+ -- 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);
- if Nkind (P) = N_Entry_Body then
- Error_Msg_NE
- ("& should not be used in entry body ('R'M C.7(17))",
- N, Nam);
- exit;
- end if;
- end loop;
- end;
- end if;
+ -- Exclude calls that occur within the default of a formal
+ -- parameter of the entry, since those are evaluated outside
+ -- of the body.
- -- Cannot call thread body directly
+ exit when No (P) or else Nkind (P) = N_Parameter_Specification;
- if Is_Thread_Body (Nam) then
- Error_Msg_N ("cannot call thread body directly", N);
- end if;
-
- -- If the subprogram is not global, then kill all checks. This is a bit
- -- conservative, since in many cases we could do better, but it is not
- -- worth the effort. Similarly, we kill constant values. However we do
- -- not need to do this for internal entities (unless they are inherited
- -- user-defined subprograms), since they are not in the business of
- -- molesting global values.
-
- if not Is_Library_Level_Entity (Nam)
- and then (Comes_From_Source (Nam)
- or else (Present (Alias (Nam))
- and then Comes_From_Source (Alias (Nam))))
- then
- Kill_Current_Values;
- end if;
-
- -- Deal with call to obsolescent subprogram. Note that we always allow
- -- such calls in the compiler itself and the run-time, since we assume
- -- that we know what we are doing in such cases. For example, the calls
- -- in Ada.Characters.Handling to its own obsolescent subprograms are
- -- just fine.
-
- if Is_Obsolescent (Nam) and then not GNAT_Mode then
- Check_Restriction (No_Obsolescent_Features, N);
-
- if Warn_On_Obsolescent_Feature then
- Error_Msg_NE ("call to obsolescent subprogram&?", N, Nam);
-
- -- Output additional warning if present
-
- W := Obsolescent_Warning (Nam);
-
- if Present (W) then
- Name_Buffer (1) := '|';
- Name_Buffer (2) := '?';
- Name_Len := 2;
-
- -- Add characters to message, and output message
-
- for J in 1 .. String_Length (Strval (W)) loop
- Add_Char_To_Name_Buffer (''');
- Add_Char_To_Name_Buffer
- (Get_Character (Get_String_Char (Strval (W), J)));
- end loop;
-
- Error_Msg_N (Name_Buffer (1 .. Name_Len), N);
- end if;
- end if;
+ if Nkind (P) = N_Entry_Body
+ or else (Nkind (P) = N_Subprogram_Body
+ and then Is_Entry_Barrier_Function (P))
+ then
+ Rtype := Etype (N);
+ Error_Msg_NE
+ ("?& 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);
+ Rewrite (N,
+ Make_Raise_Program_Error (Loc,
+ Reason => PE_Current_Task_In_Entry_Body));
+ Set_Etype (N, Rtype);
+ return;
+ end if;
+ end loop;
+ end;
end if;
-- Check that a procedure call does not occur in the context of the
and then Nkind (N) /= N_Entry_Call_Statement
and then Entry_Call_Statement (Parent (N)) = N
then
- Error_Msg_N ("entry call required in select statement", N);
+ if Ada_Version < Ada_05 then
+ Error_Msg_N ("entry call required in select statement", N);
+
+ -- Ada 2005 (AI-345): If a procedure_call_statement is used
+ -- for a procedure_or_entry_call, the procedure_name or
+ -- 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.
+
+ elsif Nkind (N) = N_Procedure_Call_Statement
+ and then not Is_Renamed_Entry (Nam)
+ and then not Is_Controlling_Limited_Procedure (Nam)
+ then
+ Error_Msg_N
+ ("entry call or dispatching primitive of interface required", N);
+ 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;
-- when the type of the component is an access to the array type. In
-- this case the call is truly ambiguous.
- elsif Needs_No_Actuals (Nam)
+ elsif (Needs_No_Actuals (Nam) or else Needs_One_Actual (Nam))
and then
((Is_Array_Type (Etype (Nam))
and then Covers (Typ, Component_Type (Etype (Nam))))
New_Subp := Relocate_Node (Subp);
Set_Entity (Subp, Nam);
- if Component_Type (Ret_Type) /= Any_Type then
- Index_Node :=
- Make_Indexed_Component (Loc,
- Prefix =>
- Make_Function_Call (Loc,
- Name => New_Subp),
- Expressions => Parameter_Associations (N));
+ 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
+
+ Index_Node :=
+ Make_Indexed_Component (Loc,
+ Prefix =>
+ Make_Function_Call (Loc,
+ Name => New_Subp),
+ Expressions => Parameter_Associations (N));
+ else
+ -- An Ada 2005 prefixed call to a primitive operation
+ -- whose first parameter is the prefix. This prefix was
+ -- prepended to the parameter list, which is actually a
+ -- list of indices. Remove the prefix in order to build
+ -- the proper indexed component.
+
+ Index_Node :=
+ Make_Indexed_Component (Loc,
+ Prefix =>
+ Make_Function_Call (Loc,
+ Name => New_Subp,
+ Parameter_Associations =>
+ New_List
+ (Remove_Head (Parameter_Associations (N)))),
+ Expressions => Parameter_Associations (N));
+ end if;
-- Since we are correcting a node classification error made
-- by the parser, we call Replace rather than Rewrite.
-- 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
- while Scop /= Standard_Standard loop
- if Nam = Scop then
- -- Although in general recursion is not statically checkable,
- -- the case of calling an immediately containing subprogram
- -- is easy to catch.
-
- Check_Restriction (No_Recursion, N);
-
- -- If the recursive call is to a parameterless procedure, then
- -- even if we can't statically detect infinite recursion, this
- -- is pretty suspicious, and we output a warning. Furthermore,
- -- we will try later to detect some cases here at run time by
- -- expanding checking code (see Detect_Infinite_Recursion in
- -- package Exp_Ch6).
-
- -- If the recursive call is within a handler we do not emit a
- -- warning, because this is a common idiom: loop until input
- -- is correct, catch illegal input in handler and restart.
-
- if No (First_Formal (Nam))
- and then Etype (Nam) = Standard_Void_Type
- and then not Error_Posted (N)
- and then Nkind (Parent (N)) /= N_Exception_Handler
- then
- Set_Has_Recursive_Call (Nam);
- Error_Msg_N ("possible infinite recursion?", N);
- Error_Msg_N ("Storage_Error may be raised at run time?", N);
- end if;
+ -- If call is to immediately containing subprogram, then check for
+ -- the case of a possible run-time detectable infinite recursion.
- exit;
- end if;
+ 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;
- Scop := Scope (Scop);
- end loop;
+ Prev (P);
+ end loop;
+ end;
+ end if;
+
+ -- Do not give warning if we are in a conditional context
+
+ 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;
+
+ exit Scope_Loop;
+ end if;
+
+ 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 3 notable exceptions: in init procs, the transient scope
- -- overhead is not needed and even incorrect due to the actual expansion
- -- of adjust calls; the second case is enumeration literal pseudo calls,
- -- the other case is intrinsic subprograms (Unchecked_Conversion and
- -- source information functions) that do not use the secondary stack
- -- even though the return type is unconstrained.
+ -- 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. 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 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;
- -- 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.
+ elsif Ekind (Nam) = E_Enumeration_Literal
+ or else Is_Build_In_Place_Function (Nam)
+ or else Is_Intrinsic_Subprogram (Nam)
+ then
+ null;
- if Expander_Active
+ elsif Expander_Active
and then Is_Type (Etype (Nam))
and then Requires_Transient_Scope (Etype (Nam))
- and then Ekind (Nam) /= E_Enumeration_Literal
- and then not Within_Init_Proc
- and then not Is_Intrinsic_Subprogram (Nam)
+ 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 => not Functions_Return_By_DSP_On_Target);
+ Establish_Transient_Scope (N, Sec_Stack => True);
-- If the call appears within the bounds of a loop, it will
-- be rewritten and reanalyzed, nothing left to do here.
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 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.
+
+ -- 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))))
+ then
+ 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.
then
Check_Dispatching_Call (N);
- elsif Is_Abstract (Nam)
+ elsif Ekind (Nam) /= E_Subprogram_Type
+ and then Is_Abstract_Subprogram (Nam)
and then not In_Instance
then
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);
+ Warn_On_Overlapping_Actuals (Nam, 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);
-
while Present (C) loop
if Etype (C) = B_Typ then
Set_Entity_With_Style_Check (N, C);
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)));
+
else
T := Find_Unique_Type (L, R);
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);
- Check_Direct_Boolean_Op (N);
end if;
end if;
end Resolve_Comparison_Op;
procedure Resolve_Conditional_Expression (N : Node_Id; Typ : Entity_Id) is
Condition : constant Node_Id := First (Expressions (N));
Then_Expr : constant Node_Id := Next (Condition);
- Else_Expr : constant Node_Id := Next (Then_Expr);
+ 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
-- the type in the same declarative part.
Tsk := Next_Entity (S);
-
while Etype (Tsk) /= S loop
Next_Entity (Tsk);
end loop;
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);
begin
Get_First_Interp (Pref, I, It);
-
while Present (It.Typ) loop
-
if Scope (Ent) = It.Typ then
Set_Etype (Pref, It.Typ);
exit;
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;
begin
Get_First_Interp (Selector_Name (Entry_Name), I, It);
-
while Present (It.Typ) loop
-
if Covers (Typ, It.Typ) then
Set_Entity (Selector_Name (Entry_Name), It.Nam);
Set_Etype (Entry_Name, It.Typ);
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)
Set_Analyzed (N, True);
-- Protected functions can return on the secondary stack, in which
- -- case we must trigger the transient scope mechanism
+ -- case we must trigger the transient scope mechanism.
elsif Expander_Active
and then Requires_Transient_Scope (Etype (Nam))
then
- Establish_Transient_Scope (N,
- Sec_Stack => not Functions_Return_By_DSP_On_Target);
+ Establish_Transient_Scope (N, Sec_Stack => True);
end if;
end Resolve_Entry_Call;
-- 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);
function Find_Unique_Access_Type return Entity_Id is
Acc : Entity_Id;
E : Entity_Id;
- S : Entity_Id := Current_Scope;
+ S : Entity_Id;
begin
if Ekind (Etype (R)) = E_Allocator_Type then
Acc := Designated_Type (Etype (R));
-
elsif Ekind (Etype (L)) = E_Allocator_Type then
Acc := Designated_Type (Etype (L));
-
else
return Empty;
end if;
+ S := Current_Scope;
while S /= Standard_Standard loop
E := First_Entity (S);
-
while Present (E) loop
-
if Is_Type (E)
and then Is_Access_Type (E)
and then Ekind (E) /= E_Allocator_Type
end if;
if T /= Any_Type then
-
if T = Any_String
or else T = Any_Composite
or else T = Any_Character
then
-
if T = Any_Character then
Ambiguous_Character (L);
else
elsif T = Any_Access
or else Ekind (T) = E_Allocator_Type
+ or else Ekind (T) = E_Access_Attribute_Type
then
T := Find_Unique_Access_Type;
Resolve (L, T);
Resolve (R, T);
+ -- If the unique type is a class-wide type then it will be expanded
+ -- into a dispatching call to the predefined primitive. Therefore we
+ -- check here for potential violation of such restriction.
+
+ if Is_Class_Wide_Type (T) then
+ Check_Restriction (No_Dispatching_Calls, N);
+ end if;
+
if Warn_On_Redundant_Constructs
and then Comes_From_Source (N)
and then Is_Entity_Name (R)
and then Entity (R) = Standard_True
and then Comes_From_Source (R)
then
- Error_Msg_N ("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 (Entity (N))
+ and then Is_Abstract_Subprogram (Entity (N))
then
Error_Msg_NE ("cannot call abstract subprogram &!", N, Entity (N));
end if;
- Check_Direct_Boolean_Op (N);
+ -- 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 Ekind (T) = E_Anonymous_Access_Subprogram_Type
+ or else Is_Private_Type (T))
+ then
+ if Etype (L) /= T then
+ Rewrite (L,
+ Make_Unchecked_Type_Conversion (Sloc (L),
+ Subtype_Mark => New_Occurrence_Of (T, Sloc (L)),
+ Expression => Relocate_Node (L)));
+ Analyze_And_Resolve (L, T);
+ end if;
+
+ if (Etype (R)) /= T then
+ Rewrite (R,
+ Make_Unchecked_Type_Conversion (Sloc (R),
+ Subtype_Mark => New_Occurrence_Of (Etype (L), Sloc (R)),
+ Expression => Relocate_Node (R)));
+ Analyze_And_Resolve (R, T);
+ end if;
+ end if;
end if;
end Resolve_Equality_Op;
It : Interp;
begin
- -- Now that we know the type, check that this is not dereference of an
- -- uncompleted type. Note that this is not entirely correct, because
- -- dereferences of private types are legal in default expressions. This
- -- exception is taken care of in Check_Fully_Declared.
-
- -- This consideration also applies to similar checks for allocators,
- -- qualified expressions, and type conversions.
-
- -- An additional exception concerns other per-object expressions that
- -- are not directly related to component declarations, in particular
- -- representation pragmas for tasks. These will be per-object
- -- expressions if they depend on discriminants or some global entity.
- -- If the task has access discriminants, the designated type may be
- -- incomplete at the point the expression is resolved. This resolution
- -- takes place within the body of the initialization procedure, where
- -- the discriminant is replaced by its discriminal.
-
- if Is_Entity_Name (Prefix (N))
- and then Ekind (Entity (Prefix (N))) = E_In_Parameter
- then
- null;
- else
- Check_Fully_Declared (Typ, N);
- end if;
+ Check_Fully_Declared_Prefix (Typ, P);
if Is_Overloaded (P) then
while Present (It.Typ) loop
exit when Is_Access_Type (It.Typ)
and then Covers (Typ, Designated_Type (It.Typ));
-
Get_Next_Interp (I, It);
end loop;
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;
begin
Get_First_Interp (P, I, It);
-
- -- the task has access discriminants, the designated type may be
- -- incomplete at the point the expression is resolved. This resolution
- -- takes place within the body of the initialization proc
while Present (It.Typ) loop
-
if (Is_Array_Type (It.Typ)
and then Covers (Typ, Component_Type (It.Typ)))
or else (Is_Access_Type (It.Typ)
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));
end loop;
end if;
- Eval_Indexed_Component (N);
+ -- Do not generate the warning on suspicious index if we are analyzing
+ -- package Ada.Tags; otherwise we will report the warning with the
+ -- Prims_Ptr field of the dispatch table.
+
+ if Scope (Etype (Prefix (N))) = Standard_Standard
+ or else not
+ Is_RTU (Cunit_Entity (Get_Source_Unit (Etype (Prefix (N)))),
+ Ada_Tags)
+ then
+ Warn_On_Suspicious_Index (Name, First (Expressions (N)));
+ Eval_Indexed_Component (N);
+ end if;
end Resolve_Indexed_Component;
-----------------------------
begin
Op := Entity (N);
-
while Scope (Op) /= Standard_Standard loop
Op := Homonym (Op);
pragma Assert (Present (Op));
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));
begin
Op := Entity (N);
-
while Scope (Op) /= Standard_Standard loop
Op := Homonym (Op);
pragma Assert (Present (Op));
B_Typ : Entity_Id;
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_Direct_Boolean_Op (N);
end Resolve_Logical_Op;
---------------------------
procedure Resolve_Membership_Op (N : Node_Id; Typ : Entity_Id) is
pragma Warnings (Off, Typ);
- L : constant Node_Id := Left_Opnd (N);
- R : constant Node_Id := Right_Opnd (N);
+ 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)
and then Is_Overloaded (L)
then
T := Etype (R);
+
+ -- Ada 2005 (AI-251): Support the following case:
+
+ -- type I is interface;
+ -- type T is tagged ...
+
+ -- function Test (O : I'Class) is
+ -- begin
+ -- return O in T'Class.
+ -- end Test;
+
+ -- In this case we have nothing else to do. The membership test will be
+ -- done at run-time.
+
+ elsif Ada_Version >= Ada_05
+ and then Is_Class_Wide_Type (Etype (L))
+ and then Is_Interface (Etype (L))
+ and then Is_Class_Wide_Type (Etype (R))
+ and then not Is_Interface (Etype (R))
+ then
+ return;
+
else
T := Intersect_Types (L, R);
end if;
------------------
procedure Resolve_Null (N : Node_Id; Typ : Entity_Id) is
+ 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))
-----------------------
procedure Resolve_Op_Concat (N : Node_Id; Typ : Entity_Id) is
- Btyp : constant Entity_Id := Base_Type (Typ);
- Op1 : constant Node_Id := Left_Opnd (N);
- Op2 : constant Node_Id := Right_Opnd (N);
- procedure Resolve_Concatenation_Arg (Arg : Node_Id; Is_Comp : Boolean);
- -- 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.
+ -- 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.
- -------------------------------
- -- Resolve_Concatenation_Arg --
- -------------------------------
+ NN : Node_Id := N;
+ Op1 : Node_Id;
- procedure Resolve_Concatenation_Arg (Arg : Node_Id; Is_Comp : Boolean) is
- begin
- if In_Instance then
- if Is_Comp
- or else (not Is_Overloaded (Arg)
- and then Etype (Arg) /= Any_Composite
- and then Covers (Component_Type (Typ), Etype (Arg)))
- then
- Resolve (Arg, Component_Type (Typ));
- else
- Resolve (Arg, Btyp);
- end if;
+ begin
+ -- The following code is equivalent to:
- elsif Has_Compatible_Type (Arg, Component_Type (Typ)) then
+ -- Resolve_Op_Concat_First (NN, Typ);
+ -- Resolve_Op_Concat_Arg (N, ...);
+ -- Resolve_Op_Concat_Rest (N, Typ);
- 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);
+ -- where the Resolve_Op_Concat_Arg call recurses back here if the left
+ -- operand is a concatenation.
- else
- Error_Msg_N ("ambiguous aggregate must be qualified", Arg);
- Set_Etype (Arg, Any_Type);
- end if;
+ -- 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
+
+ -- First resolve Op1 ...
+
+ Resolve_Op_Concat_Arg (NN, Op1, Typ, Is_Component_Left_Opnd (NN));
+
+ -- ... then walk NN back up until we reach N (where we started), calling
+ -- Resolve_Op_Concat_Rest along the way.
+
+ loop
+ Resolve_Op_Concat_Rest (NN, Typ);
+ exit when NN = N;
+ NN := Parent (NN);
+ end loop;
+ end Resolve_Op_Concat;
+
+ ---------------------------
+ -- Resolve_Op_Concat_Arg --
+ ---------------------------
+
+ 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);
+
+ begin
+ if In_Instance then
+ if Is_Comp
+ or else (not Is_Overloaded (Arg)
+ and then Etype (Arg) /= Any_Composite
+ and then Covers (Component_Type (Typ), Etype (Arg)))
+ then
+ Resolve (Arg, Component_Type (Typ));
+ else
+ Resolve (Arg, Btyp);
+ end if;
+ elsif Has_Compatible_Type (Arg, Component_Type (Typ)) then
+ if Nkind (Arg) = N_Aggregate
+ and then Is_Composite_Type (Component_Type (Typ))
+ then
+ if Is_Private_Type (Component_Type (Typ)) then
+ Resolve (Arg, Btyp);
else
- if Is_Overloaded (Arg)
- and then Has_Compatible_Type (Arg, Typ)
- and then Etype (Arg) /= Any_Type
- then
- Error_Msg_N ("ambiguous operand for concatenation!", Arg);
+ Error_Msg_N ("ambiguous aggregate must be qualified", Arg);
+ Set_Etype (Arg, Any_Type);
+ end if;
+
+ else
+ if Is_Overloaded (Arg)
+ and then Has_Compatible_Type (Arg, Typ)
+ and then Etype (Arg) /= Any_Type
+ then
+ declare
+ I : Interp_Index;
+ It : Interp;
+ Func : Entity_Id;
- declare
- I : Interp_Index;
- It : Interp;
+ begin
+ 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 an 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));
- begin
+ 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 (Etype (It.Nam)) = Base_Type (Typ)
- or else Base_Type (Etype (It.Nam)) =
+ if Base_Type (It.Typ) = Base_Type (Typ)
+ or else Base_Type (It.Typ) =
Base_Type (Component_Type (Typ))
then
- Error_Msg_Sloc := Sloc (It.Nam);
- Error_Msg_N ("\possible interpretation#", Arg);
+ Error_Msg_N -- CODEFIX
+ ("\\possible interpretation#", Arg);
end if;
Get_Next_Interp (I, It);
end loop;
- end;
- end if;
-
- Resolve (Arg, Component_Type (Typ));
+ 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;
- -- Start of processing for Resolve_Op_Concat
+ -----------------------------
+ -- Resolve_Op_Concat_First --
+ -----------------------------
+
+ 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.
-- and the not in question is the left operand of this operation.
-- Note that if the not is in parens, then false is returned.
+ -----------------------
+ -- Parent_Is_Boolean --
+ -----------------------
+
function Parent_Is_Boolean return Boolean is
begin
if Paren_Count (N) /= 0 then
N_In |
N_Not_In |
N_And_Then |
- N_Or_Else =>
+ N_Or_Else =>
return Left_Opnd (Parent (N)) = N;
B_Typ := Base_Type (Typ);
end if;
+ -- Straightforward case of incorrect arguments
+
if not Valid_Boolean_Arg (Typ) then
Error_Msg_N ("invalid operand type for operator&", N);
Set_Etype (N, Any_Type);
return;
+ -- Special case of probable missing parens
+
elsif Typ = Universal_Integer or else Typ = Any_Modular then
if Parent_Is_Boolean then
Error_Msg_N
Set_Etype (N, Any_Type);
return;
+ -- OK resolution of not
+
else
- if not Is_Boolean_Type (Typ)
+ -- Warn if non-boolean types involved. This is a case like not a < b
+ -- where a and b are modular, where we will get (not a) < b and most
+ -- likely not (a < b) was intended.
+
+ if Warn_On_Questionable_Missing_Parens
+ 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);
Resolve (Expr, Target_Typ);
-- A qualified expression requires an exact match of the type,
- -- class-wide matching is not allowed.
-
- if Is_Class_Wide_Type (Target_Typ)
+ -- class-wide matching is not allowed. However, if the qualifying
+ -- type is specific and the expression has a class-wide type, it
+ -- may still be okay, since it can be the result of the expansion
+ -- of a call to a dispatching function, so we also have to check
+ -- class-wideness of the type of the expression's original node.
+
+ if (Is_Class_Wide_Type (Target_Typ)
+ or else
+ (Is_Class_Wide_Type (Etype (Expr))
+ and then Is_Class_Wide_Type (Etype (Original_Node (Expr)))))
and then Base_Type (Etype (Expr)) /= Base_Type (Target_Typ)
then
Wrong_Type (Expr, Target_Typ);
Check_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
- Comp := First_Entity (T);
- while Present (Comp) loop
+ -- 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)
and then Covers (Etype (Comp), Typ)
then
else
It1 := It;
- if Scope (Comp1) /= It1.Typ then
+ -- There may be an implicit dereference. Retrieve
+ -- designated record type.
+
+ if Is_Access_Type (It1.Typ) then
+ T := Designated_Type (It1.Typ);
+ else
+ T := It1.Typ;
+ end if;
+
+ if Scope (Comp1) /= T then
-- Resolution chooses the new interpretation.
-- Find the component with the right name.
- Comp1 := First_Entity (It1.Typ);
-
+ Comp1 := First_Entity (T);
while Present (Comp1)
and then Chars (Comp1) /= Chars (S)
loop
Resolve (P, It1.Typ);
Set_Etype (N, Typ);
- Set_Entity (S, Comp1);
+ Set_Entity_With_Style_Check (S, Comp1);
else
-- Resolve prefix with its type
Resolve (P, T);
end if;
- -- If prefix is an access type, the node will be transformed into
- -- an explicit dereference during expansion. The type of the node
- -- is the designated type of that of the prefix.
+ -- 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 or not.
+
+ if May_Be_Lvalue (N) then
+ Generate_Reference (Entity (S), S, 'm');
+ else
+ Generate_Reference (Entity (S), S, 'r');
+ end if;
+
+ -- If prefix is an access type, the node will be transformed into an
+ -- explicit dereference during expansion. The type of the node is the
+ -- designated type of that of the prefix.
if Is_Access_Type (Etype (P)) then
T := Designated_Type (Etype (P));
+ Check_Fully_Declared_Prefix (T, P);
else
T := Etype (P);
end if;
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;
begin
Get_First_Interp (P, I, It);
-
while Present (It.Typ) loop
-
if (Is_Array_Type (It.Typ)
and then Covers (Typ, It.Typ))
or else (Is_Access_Type (It.Typ)
Apply_Access_Check (N);
Array_Type := Designated_Type (Array_Type);
- -- If the prefix is an access to an unconstrained array, we must
- -- use the actual subtype of the object to perform the index checks.
- -- The object denoted by the prefix is implicit in the node, so we
- -- build an explicit representation for it in order to compute the
- -- actual subtype.
+ -- If the prefix is an access to an unconstrained array, we must use
+ -- the actual subtype of the object to perform the index checks. The
+ -- object denoted by the prefix is implicit in the node, so we build
+ -- an explicit representation for it in order to compute the actual
+ -- subtype.
if not Is_Constrained (Array_Type) then
Remove_Side_Effects (Prefix (N));
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
Set_Etype (N, Array_Type);
- -- If the range is specified by a subtype mark, no resolution
- -- is necessary. Else resolve the bounds, and apply needed checks.
+ -- If the range is specified by a subtype mark, no resolution is
+ -- necessary. Else resolve the bounds, and apply needed checks.
if not Is_Entity_Name (Drange) then
Index := First_Index (Array_Type);
Resolve (Drange, Base_Type (Etype (Index)));
- if Nkind (Drange) = N_Range then
+ if Nkind (Drange) = N_Range
+
+ -- Do not apply the range check to nodes associated with the
+ -- frontend expansion of the dispatch table. We first check
+ -- if Ada.Tags is already loaded to void the addition of an
+ -- undesired dependence on such run-time unit.
+
+ 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;
end if;
Set_Slice_Subtype (N);
+
+ if Nkind (Drange) = N_Range then
+ Warn_On_Suspicious_Index (Name, Low_Bound (Drange));
+ Warn_On_Suspicious_Index (Name, High_Bound (Drange));
+ end if;
+
Eval_Slice (N);
end Resolve_Slice;
begin
-- For a string appearing in a concatenation, defer creation of the
-- string_literal_subtype until the end of the resolution of the
- -- concatenation, because the literal may be constant-folded away.
- -- This is a useful optimization for long concatenation expressions.
+ -- concatenation, because the literal may be constant-folded away. This
+ -- is a useful optimization for long concatenation expressions.
- -- If the string is an aggregate built for a single character (which
+ -- If the string is an aggregate built for a single character (which
-- happens in a non-static context) or a is null string to which special
- -- checks may apply, we build the subtype. Wide strings must also get
- -- a string subtype if they come from a one character aggregate. Strings
+ -- checks may apply, we build the subtype. Wide strings must also get a
+ -- string subtype if they come from a one character aggregate. Strings
-- generated by attributes might be static, but it is often hard to
-- determine whether the enclosing context is static, so we generate
-- subtypes for them as well, thus losing some rarer optimizations ???
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;
- -- Always accept string literal with component type Any_Character,
- -- which occurs in error situations and in comparisons of literals,
- -- both of which should accept all literals.
+ -- Always accept string literal with component type Any_Character, which
+ -- occurs in error situations and in comparisons of literals, both of
+ -- which should accept all literals.
elsif R_Typ = Any_Character then
return;
- -- If the type is bit-packed, then we always tranform the string
+ -- 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
if R_Typ = Standard_Wide_Wide_Character then
null;
- -- For the case of Standard.String, or any other type whose
- -- component type is Standard.Character, we must make sure that
- -- there are no wide characters in the string, i.e. that it is
- -- entirely composed of characters in range of type Character.
+ -- For the case of Standard.String, or any other type whose component
+ -- type is Standard.Character, we must make sure that there are no
+ -- wide characters in the string, i.e. that it is entirely composed
+ -- of characters in range of type Character.
- -- If the string literal is the result of a static concatenation,
- -- the test has already been performed on the components, and need
- -- not be repeated.
+ -- If the string literal is the result of a static concatenation, the
+ -- test has already been performed on the components, and need not be
+ -- repeated.
elsif R_Typ = Standard_Character
and then Nkind (Original_Node (N)) /= N_Op_Concat
-- 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",
null;
end if;
- -- See if the component type of the array corresponding to the
- -- string has compile time known bounds. If yes we can directly
- -- check whether the evaluation of the string will raise constraint
- -- error. Otherwise we need to transform the string literal into
- -- the corresponding character aggregate and let the aggregate
+ -- See if the component type of the array corresponding to the string
+ -- has compile time known bounds. If yes we can directly check
+ -- whether the evaluation of the string will raise constraint error.
+ -- Otherwise we need to transform the string literal into the
+ -- 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
C : Char_Code;
begin
- -- Build the character literals, we give them source locations
- -- that correspond to the string positions, which is a bit tricky
- -- given the possible presence of wide character escape sequences.
+ -- Build the character literals, we give them source locations that
+ -- correspond to the string positions, which is a bit tricky given
+ -- the possible presence of wide character escape sequences.
for J in 1 .. Strlen loop
C := Get_String_Char (Str, J);
-----------------------------
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;
+ Conv_OK : constant Boolean := Conversion_OK (N);
+ 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
end if;
-- Resolve the real operand with largest available precision
+
if Etype (Right_Opnd (Operand)) = Universal_Real then
Rop := New_Copy_Tree (Right_Opnd (Operand));
else
Rop := New_Copy_Tree (Left_Opnd (Operand));
end if;
- Resolve (Rop, Standard_Long_Long_Float);
+ Resolve (Rop, Universal_Real);
-- If the operand is a literal (it could be a non-static and
-- illegal exponentiation) check whether the use of Duration
and then Realval (Rop) /= Ureal_0
and then abs (Realval (Rop)) < Delta_Value (Standard_Duration)
then
- Error_Msg_N ("universal real operand can only be interpreted?",
- Rop);
- Error_Msg_N ("\as Duration, and will lose precision?", Rop);
+ Error_Msg_N
+ ("?universal real operand can only " &
+ "be interpreted as Duration!",
+ Rop);
+ Error_Msg_N
+ ("\?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);
- -- If after evaluation, we still have a type conversion, then we
- -- may need to apply checks required for a subtype conversion.
+ -- 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.
-- 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));
+ -- One more check, do not give warning if the analyzed conversion
+ -- has an expression with non-static bounds, and the bounds of the
+ -- target are static. This avoids junk warnings in cases where the
+ -- conversion is necessary to establish staticness, for example in
+ -- a case statement.
+
+ if not Is_OK_Static_Subtype (Operand_Typ)
+ and then Is_OK_Static_Subtype (Target_Typ)
+ then
+ null;
+
+ -- Here we give the redundant conversion warning
+
+ else
+ Error_Msg_Node_2 := Orig_T;
+ Error_Msg_NE -- CODEFIX
+ ("?redundant conversion, & is of type &!",
+ N, Entity (Orig_N));
+ end if;
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 then
- if Is_Access_Type (Target_Type) then
- Target_Type := Directly_Designated_Type (Target_Type);
- end if;
+ if Ada_Version >= Ada_05
+ and then Expander_Active
+ and then Operand_Typ /= Target_Typ
+ then
+ declare
+ Opnd : Entity_Id := Operand_Typ;
+ Target : Entity_Id := Target_Typ;
- if Is_Class_Wide_Type (Target_Type) then
- Target_Type := Etype (Target_Type);
- end if;
+ begin
+ if Is_Access_Type (Opnd) then
+ Opnd := Directly_Designated_Type (Opnd);
+ end if;
- if Is_Interface (Target_Type) then
- 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;
- if not Interface_Present_In_Ancestor
- (Typ => Opnd_Type,
- Iface => Target_Type)
- then
- if Nkind (Operand) = N_Attribute_Reference then
- Error_Msg_Name_1 := Chars (Prefix (Operand));
+ if Opnd = Target then
+ null;
+
+ -- Conversion from interface type
+
+ elsif Is_Interface (Opnd) then
+
+ -- Ada 2005 (AI-217): Handle entities from limited views
+
+ 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);
+
else
- Error_Msg_Name_1 := Chars (Operand);
+ Expand_Interface_Conversion (N, Is_Static => False);
end if;
- Error_Msg_Name_2 := Chars (Target_Type);
- Error_Msg_NE
- ("(Ada 2005) % does not implement interface %",
- Operand, Target_Type);
+ -- Conversion to interface type
- else
- Expand_Interface_Conversion (N);
+ 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 if;
+ end;
end if;
end Resolve_Type_Conversion;
Hi : Uint;
begin
+ -- Deal with intrinsic unary operators
+
+ if Comes_From_Source (N)
+ and then Ekind (Entity (N)) = E_Function
+ and then Is_Imported (Entity (N))
+ and then Is_Intrinsic_Subprogram (Entity (N))
+ then
+ Resolve_Intrinsic_Unary_Operator (N, Typ);
+ return;
+ end if;
+
+ -- Deal with universal cases
+
+ if Etype (R) = Universal_Integer
+ or else
+ Etype (R) = Universal_Real
+ then
+ Check_For_Visible_Operator (N, B_Typ);
+ end if;
+
+ Set_Etype (N, B_Typ);
+ Resolve (R, B_Typ);
+
-- Generate warning for expressions like abs (x mod 2)
if Warn_On_Redundant_Constructs
end if;
end if;
- -- Generate warning for expressions like -5 mod 3
+ -- Deal with reference generation
- if Paren_Count (N) = 0
- and then Nkind (N) = N_Op_Minus
- and then Nkind (Right_Opnd (N)) = N_Op_Mod
- and then Comes_From_Source (N)
- then
- Error_Msg_N
- ("?unary minus expression should be parenthesized here", N);
+ Check_Unset_Reference (R);
+ Generate_Operator_Reference (N, B_Typ);
+ Eval_Unary_Op (N);
+
+ -- Set overflow checking bit. Much cleverer code needed here eventually
+ -- and perhaps the Resolve routines should be separated for the various
+ -- arithmetic operations, since they will need different processing ???
+
+ if Nkind (N) in N_Op then
+ if not Overflow_Checks_Suppressed (Etype (N)) then
+ Enable_Overflow_Check (N);
+ end if;
end if;
- if Comes_From_Source (N)
- and then Ekind (Entity (N)) = E_Function
- and then Is_Imported (Entity (N))
- and then Is_Intrinsic_Subprogram (Entity (N))
- then
- Resolve_Intrinsic_Unary_Operator (N, Typ);
- return;
- end if;
+ -- 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 : Node_Id;
+ Val : Uint;
+ HB : Uint;
+ LB : Uint;
+ Lval : Uint;
+ Opnd : Node_Id;
+
+ begin
+ if Warn_On_Questionable_Missing_Parens
+ and then Comes_From_Source (Norig)
+ and then Is_Integer_Type (Typ)
+ and then Nkind (Norig) = N_Op_Minus
+ then
+ Rorig := Original_Node (Right_Opnd (Norig));
+
+ -- We are looking for cases where the right operand is not
+ -- 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_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
+ -- 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.
+
+ if Nkind (Rorig) /= N_Op_Mod
+ and then Compile_Time_Known_Value (R)
+ then
+ Val := Expr_Value (R);
+
+ if Compile_Time_Known_Value (Type_High_Bound (Typ)) then
+ HB := Expr_Value (Type_High_Bound (Typ));
+ else
+ HB := Expr_Value (Type_High_Bound (Base_Type (Typ)));
+ end if;
+
+ if Compile_Time_Known_Value (Type_Low_Bound (Typ)) then
+ LB := Expr_Value (Type_Low_Bound (Typ));
+ else
+ 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
+ -- troublesome case (e.g. -2 * x, where the result is the
+ -- largest negative integer has an overflow with 2 * x).
+
+ if Val > LB and then Val <= HB then
+ return;
+ end if;
+ end if;
+
+ -- For the multiplication case, the only case we have to worry
+ -- about is when (-a)*b is exactly the largest negative number
+ -- so that -(a*b) can cause overflow. This can only happen if
+ -- a is a power of 2, and more generally if any operand is a
+ -- constant that is not a power of 2, then the parentheses
+ -- cannot affect whether overflow occurs. We only bother to
+ -- test the left most operand
+
+ -- Loop looking at left operands for one that has known value
+
+ Opnd := Rorig;
+ Opnd_Loop : while Nkind (Opnd) = N_Op_Multiply loop
+ if Compile_Time_Known_Value (Left_Opnd (Opnd)) then
+ Lval := UI_Abs (Expr_Value (Left_Opnd (Opnd)));
+
+ -- Operand value of 0 or 1 skips warning
+
+ if Lval <= 1 then
+ return;
+
+ -- Otherwise check power of 2, if power of 2, warn, if
+ -- anything else, skip warning.
+
+ else
+ while Lval /= 2 loop
+ if Lval mod 2 = 1 then
+ return;
+ else
+ Lval := Lval / 2;
+ end if;
+ end loop;
+
+ exit Opnd_Loop;
+ end if;
+ end if;
+
+ -- Keep looking at left operands
- if Etype (R) = Universal_Integer
- or else Etype (R) = Universal_Real
- then
- Check_For_Visible_Operator (N, B_Typ);
- end if;
+ Opnd := Left_Opnd (Opnd);
+ end loop Opnd_Loop;
- Set_Etype (N, B_Typ);
- Resolve (R, B_Typ);
+ -- For rem or "/" we can only have a problematic situation
+ -- if the divisor has a value of minus one or one. Otherwise
+ -- overflow is impossible (divisor > 1) or we have a case of
+ -- division by zero in any case.
- Check_Unset_Reference (R);
- Generate_Operator_Reference (N, B_Typ);
- Eval_Unary_Op (N);
+ 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
+ return;
+ end if;
- -- Set overflow checking bit. Much cleverer code needed here eventually
- -- and perhaps the Resolve routines should be separated for the various
- -- arithmetic operations, since they will need different processing ???
+ -- If we fall through warning should be issued
- if Nkind (N) in N_Op then
- if not Overflow_Checks_Suppressed (Etype (N)) then
- Enable_Overflow_Check (N);
+ Error_Msg_N
+ ("?unary minus expression should be parenthesized here!", N);
+ end if;
end if;
- end if;
+ end;
end Resolve_Unary_Op;
----------------------------------
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)));
Subtype_Id : Entity_Id;
begin
if Nkind (N) /= N_String_Literal then
return;
- else
- Subtype_Id := Create_Itype (E_String_Literal_Subtype, N);
end if;
+ Subtype_Id := Create_Itype (E_String_Literal_Subtype, N);
Set_String_Literal_Length (Subtype_Id, UI_From_Int
(String_Length (Strval (N))));
- Set_Etype (Subtype_Id, Base_Type (Typ));
- Set_Is_Constrained (Subtype_Id);
+ Set_Etype (Subtype_Id, Base_Type (Typ));
+ Set_Is_Constrained (Subtype_Id);
+ Set_Etype (N, Subtype_Id);
+
+ if Is_OK_Static_Expression (Low_Bound) then
-- The low bound is set from the low bound of the corresponding
-- index type. Note that we do not store the high bound in the
- -- string literal subtype, but it can be deduced if necssary
+ -- string literal subtype, but it can be deduced if necessary
-- from the length and the low bound.
- Set_String_Literal_Low_Bound
- (Subtype_Id, Type_Low_Bound (Etype (First_Index (Typ))));
+ Set_String_Literal_Low_Bound (Subtype_Id, Low_Bound);
+
+ else
+ Set_String_Literal_Low_Bound
+ (Subtype_Id, Make_Integer_Literal (Loc, 1));
+ Set_Etype (String_Literal_Low_Bound (Subtype_Id), Standard_Positive);
+
+ -- 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
+ Index_List : constant List_Id := New_List;
+ Index_Type : constant Entity_Id := Etype (First_Index (Typ));
+ High_Bound : constant Node_Id :=
+ Make_Op_Add (Loc,
+ Left_Opnd => New_Copy_Tree (Low_Bound),
+ Right_Opnd =>
+ Make_Integer_Literal (Loc,
+ String_Length (Strval (N)) - 1));
+ Array_Subtype : Entity_Id;
+ Index_Subtype : Entity_Id;
+ Drange : Node_Id;
+ Index : Node_Id;
+
+ begin
+ Index_Subtype :=
+ Create_Itype (Subtype_Kind (Ekind (Index_Type)), N);
+ Drange := Make_Range (Loc, New_Copy_Tree (Low_Bound), High_Bound);
+ Set_Scalar_Range (Index_Subtype, Drange);
+ Set_Parent (Drange, N);
+ Analyze_And_Resolve (Drange, 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_Etype (N, Subtype_Id);
+ Array_Subtype := Create_Itype (E_Array_Subtype, N);
+
+ Index := New_Occurrence_Of (Index_Subtype, Loc);
+ Set_Etype (Index, Index_Subtype);
+ Append (Index, Index_List);
+
+ Set_First_Index (Array_Subtype, Index);
+ Set_Etype (Array_Subtype, Base_Type (Typ));
+ Set_Is_Constrained (Array_Subtype, True);
+
+ Rewrite (N,
+ Make_Unchecked_Type_Conversion (Loc,
+ Subtype_Mark => New_Occurrence_Of (Array_Subtype, Loc),
+ Expression => Relocate_Node (N)));
+ Set_Etype (N, Array_Subtype);
+ end;
+ end if;
end Set_String_Literal_Subtype;
+ ------------------------------
+ -- Simplify_Type_Conversion --
+ ------------------------------
+
+ procedure Simplify_Type_Conversion (N : Node_Id) is
+ begin
+ if Nkind (N) = N_Type_Conversion then
+ declare
+ Operand : constant Node_Id := Expression (N);
+ Target_Typ : constant Entity_Id := Etype (N);
+ Opnd_Typ : constant Entity_Id := Etype (Operand);
+
+ begin
+ if Is_Floating_Point_Type (Opnd_Typ)
+ and then
+ (Is_Integer_Type (Target_Typ)
+ or else (Is_Fixed_Point_Type (Target_Typ)
+ and then Conversion_OK (N)))
+ and then Nkind (Operand) = N_Attribute_Reference
+ and then Attribute_Name (Operand) = Name_Truncation
+
+ -- Special processing required if the conversion is the expression
+ -- of a Truncation attribute reference. In this case we replace:
+
+ -- ityp (ftyp'Truncation (x))
+
+ -- by
+
+ -- ityp (x)
+
+ -- with the Float_Truncate flag set, which is more efficient
+
+ then
+ Rewrite (Operand,
+ Relocate_Node (First (Expressions (Operand))));
+ Set_Float_Truncate (N, True);
+ end if;
+ end;
+ end if;
+ end Simplify_Type_Conversion;
+
-----------------------------
-- Unique_Fixed_Point_Type --
-----------------------------
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 --
procedure Fixed_Point_Error is
begin
Error_Msg_N ("ambiguous universal_fixed_expression", N);
- Error_Msg_NE ("\possible interpretation as}", N, T1);
- Error_Msg_NE ("\possible interpretation as}", N, T2);
+ Error_Msg_NE ("\\possible interpretation as}", N, T1);
+ Error_Msg_NE ("\\possible interpretation as}", N, T2);
end Fixed_Point_Error;
-- Start of processing for Unique_Fixed_Point_Type
Scop := Current_Scope;
while Scop /= Standard_Standard loop
T2 := First_Entity (Scop);
-
while Present (T2) loop
if Is_Fixed_Point_Type (T2)
and then Current_Entity (T2) = T2
if Nkind (Item) = N_With_Clause then
Scop := Entity (Name (Item));
T2 := First_Entity (Scop);
-
while Present (T2) loop
if Is_Fixed_Point_Type (T2)
and then Scope (Base_Type (T2)) = Scop
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;
Opnd_Type : Entity_Id) return Boolean;
-- Specifically test for validity of tagged conversions
+ function Valid_Array_Conversion return Boolean;
+ -- Check index and component conformance, and accessibility levels
+ -- if the component types are anonymous access types (Ada 2005)
+
----------------------
-- Conversion_Check --
----------------------
return Valid;
end Conversion_Check;
+ ----------------------------
+ -- Valid_Array_Conversion --
+ ----------------------------
+
+ function Valid_Array_Conversion return Boolean
+ is
+ Opnd_Comp_Type : constant Entity_Id := Component_Type (Opnd_Type);
+ Opnd_Comp_Base : constant Entity_Id := Base_Type (Opnd_Comp_Type);
+
+ Opnd_Index : Node_Id;
+ Opnd_Index_Type : Entity_Id;
+
+ Target_Comp_Type : constant Entity_Id :=
+ Component_Type (Target_Type);
+ Target_Comp_Base : constant Entity_Id :=
+ Base_Type (Target_Comp_Type);
+
+ Target_Index : Node_Id;
+ Target_Index_Type : Entity_Id;
+
+ begin
+ -- Error if wrong number of dimensions
+
+ if
+ Number_Dimensions (Target_Type) /= Number_Dimensions (Opnd_Type)
+ then
+ Error_Msg_N
+ ("incompatible number of dimensions for conversion", Operand);
+ return False;
+
+ -- Number of dimensions matches
+
+ else
+ -- Loop through indexes of the two arrays
+
+ Target_Index := First_Index (Target_Type);
+ Opnd_Index := First_Index (Opnd_Type);
+ while Present (Target_Index) and then Present (Opnd_Index) loop
+ Target_Index_Type := Etype (Target_Index);
+ Opnd_Index_Type := Etype (Opnd_Index);
+
+ -- Error if index types are incompatible
+
+ if not (Is_Integer_Type (Target_Index_Type)
+ and then Is_Integer_Type (Opnd_Index_Type))
+ and then (Root_Type (Target_Index_Type)
+ /= Root_Type (Opnd_Index_Type))
+ then
+ Error_Msg_N
+ ("incompatible index types for array conversion",
+ Operand);
+ return False;
+ end if;
+
+ Next_Index (Target_Index);
+ Next_Index (Opnd_Index);
+ end loop;
+
+ -- If component types have same base type, all set
+
+ if Target_Comp_Base = Opnd_Comp_Base then
+ null;
+
+ -- Here if base types of components are not the same. The only
+ -- time this is allowed is if we have anonymous access types.
+
+ -- The conversion of arrays of anonymous access types can lead
+ -- to dangling pointers. AI-392 formalizes the accessibility
+ -- checks that must be applied to such conversions to prevent
+ -- out-of-scope references.
+
+ elsif
+ (Ekind (Target_Comp_Base) = E_Anonymous_Access_Type
+ or else
+ Ekind (Target_Comp_Base) = E_Anonymous_Access_Subprogram_Type)
+ and then Ekind (Opnd_Comp_Base) = Ekind (Target_Comp_Base)
+ and then
+ Subtypes_Statically_Match (Target_Comp_Type, Opnd_Comp_Type)
+ then
+ if Type_Access_Level (Target_Type) <
+ Type_Access_Level (Opnd_Type)
+ then
+ if In_Instance_Body then
+ Error_Msg_N ("?source array type " &
+ "has deeper accessibility level than target", Operand);
+ Error_Msg_N ("\?Program_Error will be raised at run time",
+ Operand);
+ Rewrite (N,
+ Make_Raise_Program_Error (Sloc (N),
+ Reason => PE_Accessibility_Check_Failed));
+ Set_Etype (N, Target_Type);
+ return False;
+
+ -- Conversion not allowed because of accessibility levels
+
+ else
+ Error_Msg_N ("source array type " &
+ "has deeper accessibility level than target", Operand);
+ return False;
+ end if;
+ else
+ null;
+ end if;
+
+ -- All other cases where component base types do not match
+
+ else
+ Error_Msg_N
+ ("incompatible component types for array conversion",
+ Operand);
+ return False;
+ end if;
+
+ -- 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 not Subtypes_Statically_Match
+ (Target_Comp_Type, Opnd_Comp_Type)
+ then
+ Error_Msg_N
+ ("component subtypes must statically match", Operand);
+ return False;
+ end if;
+ end if;
+
+ return True;
+ end Valid_Array_Conversion;
+
-----------------------------
-- Valid_Tagged_Conversion --
-----------------------------
-- (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;
Conversion_Check (False,
"downward conversion of tagged objects not allowed");
- -- Ada 2005 (AI-251): The conversion of a tagged type to an
- -- abstract interface type is always valid
+ -- Ada 2005 (AI-251): The conversion to/from interface types is
+ -- always valid
- elsif Is_Interface (Target_Type) then
+ 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
return True;
else
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
+ -- when arithmetic operations have a literal operand and return
+ -- System.Address or a descendant of it. These ambiguities are
+ -- otherwise resolved by the context, but for conversions there
+ -- is no context type and the removal of the spurious operations
+ -- must be done explicitly here.
+
+ -- The node may be labelled overloaded, but still contain only
+ -- one interpretation because others were discarded in previous
+ -- filters. If this is the case, retain the single interpretation
+ -- if legal.
+
Get_First_Interp (Operand, I, It);
+ Opnd_Type := It.Typ;
+ Get_Next_Interp (I, It);
- while Present (It.Typ) loop
+ if Present (It.Typ)
+ and then Opnd_Type /= Standard_Void_Type
+ then
+ -- More than one candidate interpretation is available
- if It.Typ = Standard_Void_Type then
- Remove_Interp (I);
- end if;
+ Get_First_Interp (Operand, I, It);
+ while Present (It.Typ) loop
+ if It.Typ = Standard_Void_Type then
+ Remove_Interp (I);
+ end if;
- Get_Next_Interp (I, It);
- end loop;
+ if Present (System_Aux_Id)
+ and then Is_Descendent_Of_Address (It.Typ)
+ then
+ Remove_Interp (I);
+ end if;
+
+ Get_Next_Interp (I, It);
+ end loop;
+ end if;
Get_First_Interp (Operand, I, It);
I1 := I;
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;
end;
end if;
- if Chars (Current_Scope) = Name_Unchecked_Conversion then
+ -- Numeric types
- -- This check is dubious, what if there were a user defined
- -- scope whose name was Unchecked_Conversion ???
+ if Is_Numeric_Type (Target_Type) then
- return True;
+ -- A universal fixed expression can be converted to any numeric type
- elsif Is_Numeric_Type (Target_Type) then
if Opnd_Type = Universal_Fixed then
return True;
- elsif (In_Instance or else In_Inlined_Body)
- and then not Comes_From_Source (N)
- then
- return True;
+ -- 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 instantiation point.
+ -- This results in a spurious error if we check that the operand type
+ -- is a numeric type.
+
+ -- Note: in a previous version of this unit, the following tests were
+ -- applied only for generated code (Comes_From_Source set to False),
+ -- but in fact the test is required for source code as well, since
+ -- this situation can arise in source code.
+
+ elsif In_Instance or else In_Inlined_Body then
+ return True;
+
+ -- Otherwise we need the conversion check
else
- return Conversion_Check (Is_Numeric_Type (Opnd_Type),
- "illegal operand for numeric conversion");
+ return Conversion_Check
+ (Is_Numeric_Type (Opnd_Type),
+ "illegal operand for numeric conversion");
end if;
+ -- Array types
+
elsif Is_Array_Type (Target_Type) then
if not Is_Array_Type (Opnd_Type)
or else Opnd_Type = Any_Composite
Error_Msg_N
("illegal operand for array conversion", Operand);
return False;
-
- elsif Number_Dimensions (Target_Type) /=
- Number_Dimensions (Opnd_Type)
- then
- Error_Msg_N
- ("incompatible number of dimensions for conversion", Operand);
- return False;
-
else
- declare
- Target_Index : Node_Id := First_Index (Target_Type);
- Opnd_Index : Node_Id := First_Index (Opnd_Type);
-
- Target_Index_Type : Entity_Id;
- Opnd_Index_Type : Entity_Id;
-
- Target_Comp_Type : constant Entity_Id :=
- Component_Type (Target_Type);
- Opnd_Comp_Type : constant Entity_Id :=
- Component_Type (Opnd_Type);
-
- begin
- while Present (Target_Index) and then Present (Opnd_Index) loop
- Target_Index_Type := Etype (Target_Index);
- Opnd_Index_Type := Etype (Opnd_Index);
-
- if not (Is_Integer_Type (Target_Index_Type)
- and then Is_Integer_Type (Opnd_Index_Type))
- and then (Root_Type (Target_Index_Type)
- /= Root_Type (Opnd_Index_Type))
- then
- Error_Msg_N
- ("incompatible index types for array conversion",
- Operand);
- return False;
- end if;
-
- Next_Index (Target_Index);
- Next_Index (Opnd_Index);
- end loop;
-
- if Base_Type (Target_Comp_Type) /=
- Base_Type (Opnd_Comp_Type)
- then
- Error_Msg_N
- ("incompatible component types for array conversion",
- Operand);
- return False;
-
- elsif
- Is_Constrained (Target_Comp_Type)
- /= Is_Constrained (Opnd_Comp_Type)
- or else not Subtypes_Statically_Match
- (Target_Comp_Type, Opnd_Comp_Type)
- then
- Error_Msg_N
- ("component subtypes must statically match", Operand);
- return False;
-
- end if;
- end;
+ return Valid_Array_Conversion;
end if;
- return True;
-
- -- Ada 2005 (AI-251)
+ -- Ada 2005 (AI-251): Anonymous access types where target references an
+ -- interface type.
elsif (Ekind (Target_Type) = E_General_Access_Type
- or else Ekind (Target_Type) = E_Anonymous_Access_Type)
+ or else
+ Ekind (Target_Type) = E_Anonymous_Access_Type)
and then Is_Interface (Directly_Designated_Type (Target_Type))
then
-- Check the static accessibility rule of 4.6(17). Note that the
- -- check is not enforced when within an instance body, since the RM
- -- requires such cases to be caught at run time.
+ -- 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) >
("?cannot convert local pointer to non-local access type",
Operand);
Error_Msg_N
- ("?Program_Error will be raised at run time", Operand);
-
+ ("\?Program_Error will be raised at run time", Operand);
else
Error_Msg_N
("cannot convert local pointer to non-local access 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)
+ 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
("?cannot convert access discriminant to non-local" &
" access type", Operand);
Error_Msg_N
- ("?Program_Error will be raised at run time", Operand);
-
+ ("\?Program_Error will be raised at run time", Operand);
else
Error_Msg_N
("cannot convert access discriminant to non-local" &
-- 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)
return True;
+ -- General and anonymous access types
+
elsif (Ekind (Target_Type) = E_General_Access_Type
or else Ekind (Target_Type) = E_Anonymous_Access_Type)
and then
if Type_Access_Level (Opnd_Type)
> Type_Access_Level (Target_Type)
then
- -- In an instance, this is a run-time check, but one we
- -- know will fail, so generate an appropriate warning.
- -- The raise will be generated by Expand_N_Type_Conversion.
+ -- In an instance, this is a run-time check, but one we know
+ -- will fail, so generate an appropriate warning. The raise
+ -- will be generated by Expand_N_Type_Conversion.
if In_Instance_Body then
Error_Msg_N
("?cannot convert local pointer to non-local access type",
Operand);
Error_Msg_N
- ("?Program_Error will be raised at run time", Operand);
+ ("\?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
("?cannot convert access discriminant to non-local" &
" access type", Operand);
Error_Msg_N
- ("?Program_Error will be raised at run time", Operand);
+ ("\?Program_Error will be raised at run time",
+ Operand);
else
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
- Target : constant Entity_Id := Designated_Type (Target_Type);
- Opnd : constant Entity_Id := Designated_Type (Opnd_Type);
+ -- 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
+
+ --------------------------
+ -- Full_Designated_Type --
+ --------------------------
+
+ function Full_Designated_Type (T : Entity_Id) return Entity_Id is
+ Desig : constant Entity_Id := Designated_Type (T);
+
+ begin
+ -- 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 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);
else
- if Base_Type (Target) /= Base_Type (Opnd) then
+ if not Same_Base then
Error_Msg_NE
("target designated type not compatible with }",
N, Base_Type (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;
- elsif (Ekind (Target_Type) = E_Access_Subprogram_Type
- or else
- Ekind (Target_Type) = E_Anonymous_Access_Subprogram_Type)
+ -- 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 Is_Access_Subprogram_Type (Target_Type)
and then No (Corresponding_Remote_Type (Opnd_Type))
- and then Conversion_Check
- (Ekind (Base_Type (Opnd_Type)) = E_Access_Subprogram_Type,
- "illegal operand for access subprogram conversion")
then
+ 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 " &
+ "(RM 3.10.2 (13))",
+ Operand);
+
+ 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
Check_Subtype_Conformant (New_Id => Designated_Type (Target_Type),
O_Gen : constant Node_Id :=
Enclosing_Generic_Body (Opnd_Type);
- T_Gen : Node_Id :=
- Enclosing_Generic_Body (Target_Type);
+ T_Gen : Node_Id;
begin
+ T_Gen := Enclosing_Generic_Body (Target_Type);
while Present (T_Gen) and then T_Gen /= O_Gen loop
T_Gen := Enclosing_Generic_Body (T_Gen);
end loop;
return True;
+ -- Remote subprogram access types
+
elsif Is_Remote_Access_To_Subprogram_Type (Target_Type)
and then Is_Remote_Access_To_Subprogram_Type (Opnd_Type)
then
N);
return True;
- elsif Is_Tagged_Type (Target_Type) then
+ -- If both are tagged types, check legality of view conversions
+
+ 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
