-- --
-- B o d y --
-- --
--- --
--- Copyright (C) 1992-2002, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
--- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
--- MA 02111-1307, USA. --
+-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
+-- Boston, MA 02110-1301, USA. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
with Einfo; use Einfo;
with Errout; use Errout;
with Expander; use Expander;
+with Exp_Disp; use Exp_Disp;
with Exp_Ch7; use Exp_Ch7;
+with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util;
with Freeze; use Freeze;
with Itypes; use Itypes;
with Opt; use Opt;
with Output; use Output;
with Restrict; use Restrict;
+with Rident; use Rident;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
with Sem_Aggr; use Sem_Aggr;
with Sem_Type; use Sem_Type;
with Sem_Warn; use Sem_Warn;
with Sinfo; use Sinfo;
+with Snames; use Snames;
with Stand; use Stand;
with Stringt; use Stringt;
with Targparm; use Targparm;
-- 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
procedure Check_Initialization_Call (N : Entity_Id; Nam : Entity_Id);
-- If the type of the object being initialized uses the secondary stack
-- directly or indirectly, create a transient scope for the call to the
- -- Init_Proc. This is because we do not create transient scopes for the
- -- initialization of individual components within the init_proc itself.
+ -- init proc. This is because we do not create transient scopes for the
+ -- initialization of individual components within the init proc itself.
-- Could be optimized away perhaps?
function Is_Predefined_Op (Nam : Entity_Id) return Boolean;
function Operator_Kind
(Op_Name : Name_Id;
- Is_Binary : Boolean)
- return Node_Kind;
+ Is_Binary : Boolean) return Node_Kind;
-- Utility to map the name of an operator into the corresponding Node. Used
-- by other node rewriting procedures.
procedure Resolve_Actuals (N : Node_Id; Nam : Entity_Id);
-- Resolve actuals of call, and add default expressions for missing ones.
+ -- N is the Node_Id for the subprogram call, and Nam is the entity of the
+ -- called subprogram.
procedure Resolve_Entry_Call (N : Node_Id; Typ : Entity_Id);
-- Called from Resolve_Call, when the prefix denotes an entry or element
-- A call to a user-defined intrinsic operator is rewritten as a call
-- to the corresponding predefined operator, with suitable conversions.
+ procedure Resolve_Intrinsic_Unary_Operator (N : Node_Id; Typ : Entity_Id);
+ -- Ditto, for unary operators (only arithmetic ones)
+
procedure Rewrite_Operator_As_Call (N : Node_Id; Nam : Entity_Id);
-- If an operator node resolves to a call to a user-defined operator,
-- rewrite the node as a function call.
-- that operands are resolved properly. Recall that predefined operators
-- do not have a full signature and special resolution rules apply.
- procedure Rewrite_Renamed_Operator (N : Node_Id; Op : Entity_Id);
+ procedure Rewrite_Renamed_Operator
+ (N : Node_Id;
+ Op : Entity_Id;
+ Typ : Entity_Id);
-- An operator can rename another, e.g. in an instantiation. In that
- -- case, the proper operator node must be constructed.
+ -- case, the proper operator node must be constructed and resolved.
procedure Set_String_Literal_Subtype (N : Node_Id; Typ : Entity_Id);
-- The String_Literal_Subtype is built for all strings that are not
-- not a N_String_Literal node, then the call has no effect.
procedure Set_Slice_Subtype (N : Node_Id);
- -- Build subtype of array type, with the range specified by the slice.
+ -- Build subtype of array type, with the range specified by the slice
function Unique_Fixed_Point_Type (N : Node_Id) return Entity_Id;
-- A universal_fixed expression in an universal context is unambiguous
function Valid_Conversion
(N : Node_Id;
Target : Entity_Id;
- Operand : Node_Id)
- return Boolean;
+ Operand : Node_Id) return Boolean;
-- Verify legality rules given in 4.6 (8-23). Target is the target
-- type of the conversion, which may be an implicit conversion of
-- an actual parameter to an anonymous access type (in which case
if Nkind (C) = N_Character_Literal then
Error_Msg_N ("ambiguous character literal", C);
Error_Msg_N
- ("\possible interpretations: Character, Wide_Character!", C);
+ ("\\possible interpretations: Character, Wide_Character!", C);
E := Current_Entity (C);
-
- if Present (E) then
-
- while Present (E) loop
- Error_Msg_NE ("\possible interpretation:}!", C, Etype (E));
- E := Homonym (E);
- end loop;
- end if;
+ while Present (E) loop
+ Error_Msg_NE ("\\possible interpretation:}!", C, Etype (E));
+ E := Homonym (E);
+ end loop;
end if;
end Ambiguous_Character;
procedure Analyze_And_Resolve (N : Node_Id) is
begin
Analyze (N);
- Resolve (N, Etype (N));
+ Resolve (N);
end Analyze_And_Resolve;
procedure Analyze_And_Resolve (N : Node_Id; Typ : Entity_Id) is
Typ : Entity_Id;
Suppress : Check_Id)
is
- Scop : Entity_Id := Current_Scope;
+ Scop : constant Entity_Id := Current_Scope;
begin
if Suppress = All_Checks then
declare
- Svg : constant Suppress_Record := Scope_Suppress;
-
+ Svg : constant Suppress_Array := Scope_Suppress;
begin
Scope_Suppress := (others => True);
Analyze_And_Resolve (N, Typ);
else
declare
- Svg : constant Boolean := Get_Scope_Suppress (Suppress);
+ Svg : constant Boolean := Scope_Suppress (Suppress);
begin
- Set_Scope_Suppress (Suppress, True);
+ Scope_Suppress (Suppress) := True;
Analyze_And_Resolve (N, Typ);
- Set_Scope_Suppress (Suppress, Svg);
+ Scope_Suppress (Suppress) := Svg;
end;
end if;
(N : Node_Id;
Suppress : Check_Id)
is
- Scop : Entity_Id := Current_Scope;
+ Scop : constant Entity_Id := Current_Scope;
begin
if Suppress = All_Checks then
declare
- Svg : constant Suppress_Record := Scope_Suppress;
-
+ Svg : constant Suppress_Array := Scope_Suppress;
begin
Scope_Suppress := (others => True);
Analyze_And_Resolve (N);
else
declare
- Svg : constant Boolean := Get_Scope_Suppress (Suppress);
+ Svg : constant Boolean := Scope_Suppress (Suppress);
begin
- Set_Scope_Suppress (Suppress, True);
+ Scope_Suppress (Suppress) := True;
Analyze_And_Resolve (N);
- Set_Scope_Suppress (Suppress, Svg);
+ Scope_Suppress (Suppress) := Svg;
end;
end if;
D : Node_Id;
begin
- -- Any use in a default expression is legal.
+ -- Any use in a default expression is legal
if In_Default_Expression then
null;
elsif Nkind (PN) = N_Range then
- -- Discriminant cannot be used to constrain a scalar type.
+ -- Discriminant cannot be used to constrain a scalar type
P := Parent (PN);
if Nkind (P) = N_Range_Constraint
and then Nkind (Parent (P)) = N_Subtype_Indication
- and then Nkind (Parent (Parent (P))) = N_Component_Declaration
+ and then Nkind (Parent (Parent (P))) = N_Component_Definition
then
Error_Msg_N ("discriminant cannot constrain scalar type", N);
and then Scope (Disc) = Current_Scope
and then not
(Nkind (Parent (P)) = N_Subtype_Indication
- and then
- (Nkind (Parent (Parent (P))) = N_Component_Declaration
- or else Nkind (Parent (Parent (P))) = N_Subtype_Declaration)
+ and then
+ (Nkind (Parent (Parent (P))) = N_Component_Definition
+ or else
+ Nkind (Parent (Parent (P))) = N_Subtype_Declaration)
and then Paren_Count (N) = 0)
then
Error_Msg_N
end if;
-- Detect a common beginner error:
+
-- type R (D : Positive := 100) is record
- -- Name: String (1 .. D);
+ -- Name : String (1 .. D);
-- end record;
-- The default value causes an object of type R to be
-- any array whose index type covered the whole range of
-- the type would likely raise Storage_Error.
+ ------------------------
+ -- Large_Storage_Type --
+ ------------------------
+
function Large_Storage_Type (T : Entity_Id) return Boolean is
begin
return
-- 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 of this type may raise Storage_Error?",
- N);
+ ("creation of & object may raise Storage_Error?",
+ Scope (Disc));
<<No_Danger>>
null;
if Paren_Count (N) > 0 then
Error_Msg_N
("discriminant in constraint must appear alone", N);
+
+ elsif Nkind (N) = N_Expanded_Name
+ and then Comes_From_Source (N)
+ then
+ Error_Msg_N
+ ("discriminant must appear alone as a direct name", N);
end if;
return;
else
D := PN;
P := Parent (PN);
-
while Nkind (P) /= N_Component_Declaration
and then Nkind (P) /= N_Subtype_Indication
and then Nkind (P) /= N_Entry_Declaration
if (Nkind (P) = N_Subtype_Indication
and then
- (Nkind (Parent (P)) = N_Component_Declaration
- or else Nkind (Parent (P)) = N_Derived_Type_Definition)
+ (Nkind (Parent (P)) = N_Component_Definition
+ or else
+ Nkind (Parent (P)) = N_Derived_Type_Definition)
and then D = Constraint (P))
-- The constraint itself may be given by a subtype indication,
-- rather than by a more common discrete range.
or else (Nkind (P) = N_Subtype_Indication
- and then Nkind (Parent (P)) = N_Index_Or_Discriminant_Constraint)
-
+ and then
+ Nkind (Parent (P)) = N_Index_Or_Discriminant_Constraint)
or else Nkind (P) = N_Entry_Declaration
or else Nkind (D) = N_Defining_Identifier
then
--------------------------------
procedure Check_For_Visible_Operator (N : Node_Id; T : Entity_Id) is
- Orig_Node : Node_Id := Original_Node (N);
-
begin
- if Comes_From_Source (Orig_Node)
- and then not In_Open_Scopes (Scope (T))
- and then not Is_Potentially_Use_Visible (T)
- and then not In_Use (T)
- and then not In_Use (Scope (T))
- and then (not Present (Entity (N))
- or else Ekind (Entity (N)) /= E_Function)
- and then (Nkind (Orig_Node) /= N_Function_Call
- or else Nkind (Name (Orig_Node)) /= N_Expanded_Name
- or else Entity (Prefix (Name (Orig_Node))) /= Scope (T))
- and then not In_Instance
- then
+ if Is_Invisible_Operator (N, T) then
Error_Msg_NE
("operator for} is not directly visible!", N, First_Subtype (T));
Error_Msg_N ("use clause would make operation legal!", N);
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 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 --
------------------------------
F := First_Formal (Subp);
A := First_Actual (N);
-
while Present (F) and then Present (A) loop
if not Is_Entity_Name (A)
or else Entity (A) /= F
if Nkind (Parent (N)) = N_Return_Statement
and then Same_Argument_List
then
- exit when not Is_List_Member (Parent (N))
- or else (Nkind (Prev (Parent (N))) /= N_Raise_Statement
- and then
- (Nkind (Prev (Parent (N))) not in N_Raise_xxx_Error
- or else
- Present (Condition (Prev (Parent (N))))));
+ 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;
- Warn_On_Instance := True;
Error_Msg_N ("possible infinite recursion?", N);
Error_Msg_N ("\Storage_Error may be raised at run time?", N);
- Warn_On_Instance := False;
return True;
end Check_Infinite_Recursion;
-------------------------------
procedure Check_Initialization_Call (N : Entity_Id; Nam : Entity_Id) is
- Typ : Entity_Id := Etype (First_Formal (Nam));
+ Typ : constant Entity_Id := Etype (First_Formal (Nam));
function Uses_SS (T : Entity_Id) return Boolean;
-- Check whether the creation of an object of the type will involve
elsif Is_Record_Type (T) then
Comp := First_Component (T);
-
while Present (Comp) loop
-
if Ekind (Comp) = E_Component
and then Nkind (Parent (Comp)) = N_Component_Declaration
then
Expr := Expression (Parent (Comp));
- if Nkind (Expr) = N_Function_Call
+ -- The expression for a dynamic component may be
+ -- rewritten as a dereference. Retrieve original
+ -- call.
+
+ if Nkind (Original_Node (Expr)) = N_Function_Call
and then Requires_Transient_Scope (Etype (Expr))
then
return True;
procedure Check_Parameterless_Call (N : Node_Id) is
Nam : Node_Id;
+ function Prefix_Is_Access_Subp return Boolean;
+ -- If the prefix is of an access_to_subprogram type, the node must be
+ -- rewritten as a call. Ditto if the prefix is overloaded and all its
+ -- interpretations are access to subprograms.
+
+ ---------------------------
+ -- Prefix_Is_Access_Subp --
+ ---------------------------
+
+ function Prefix_Is_Access_Subp return Boolean is
+ I : Interp_Index;
+ It : Interp;
+
+ begin
+ if not Is_Overloaded (N) then
+ return
+ Ekind (Etype (N)) = E_Subprogram_Type
+ and then Base_Type (Etype (Etype (N))) /= Standard_Void_Type;
+ else
+ Get_First_Interp (N, I, It);
+ while Present (It.Typ) loop
+ if Ekind (It.Typ) /= E_Subprogram_Type
+ or else Base_Type (Etype (It.Typ)) = Standard_Void_Type
+ then
+ return False;
+ end if;
+
+ Get_Next_Interp (I, It);
+ end loop;
+
+ return True;
+ end if;
+ end Prefix_Is_Access_Subp;
+
+ -- Start of processing for Check_Parameterless_Call
+
begin
-- Defend against junk stuff if errors already detected
then
return;
end if;
+
+ Require_Entity (N);
+ end if;
+
+ -- If the context expects a value, and the name is a procedure,
+ -- this is most likely a missing 'Access. Do not try to resolve
+ -- the parameterless call, error will be caught when the outer
+ -- call is analyzed.
+
+ if Is_Entity_Name (N)
+ and then Ekind (Entity (N)) = E_Procedure
+ and then not Is_Overloaded (N)
+ and then
+ (Nkind (Parent (N)) = N_Parameter_Association
+ or else Nkind (Parent (N)) = N_Function_Call
+ or else Nkind (Parent (N)) = N_Procedure_Call_Statement)
+ then
+ return;
end if;
-- Rewrite as call if overloadable entity that is (or could be, in
-- procedure or entry.
or else
- (Nkind (N) = N_Explicit_Dereference
- and then Ekind (Etype (N)) = E_Subprogram_Type
- and then Base_Type (Etype (Etype (N))) /= Standard_Void_Type)
+ (Nkind (N) = N_Explicit_Dereference and then Prefix_Is_Access_Subp)
-- Rewrite as call if it is a selected component which is a function,
-- this is the case of a call to a protected function (which may be
or else
(Nkind (N) = N_Selected_Component
and then (Ekind (Entity (Selector_Name (N))) = E_Function
- or else ((Ekind (Entity (Selector_Name (N))) = E_Entry
- or else
- Ekind (Entity (Selector_Name (N))) = E_Procedure)
- and then Is_Overloaded (Selector_Name (N)))))
+ or else
+ ((Ekind (Entity (Selector_Name (N))) = E_Entry
+ or else
+ Ekind (Entity (Selector_Name (N))) = E_Procedure)
+ and then Is_Overloaded (Selector_Name (N)))))
-- If one of the above three conditions is met, rewrite as call.
-- Apply the rewriting only once.
then
Nam := New_Copy (N);
- -- If overloaded, overload set belongs to new copy.
+ -- If overloaded, overload set belongs to new copy
Save_Interps (N, Nam);
Act1 : Node_Id := First_Actual (N);
Act2 : Node_Id := Next_Actual (Act1);
Error : Boolean := False;
- Is_Binary : constant Boolean := Present (Act2);
+ Func : constant Entity_Id := Entity (Name (N));
+ Is_Binary : constant Boolean := Present (Act2);
Op_Node : Node_Id;
Opnd_Type : Entity_Id;
Orig_Type : Entity_Id := Empty;
else
Get_First_Interp (Nod, I, It);
-
while Present (It.Typ) loop
-
if Scope (Base_Type (It.Typ)) = S then
return True;
end if;
else
E := First_Entity (Pack);
-
while Present (E) loop
-
if Test (E)
and then not In_Decl
then
end if;
end Type_In_P;
- ---------------------------
- -- Operand_Type_In_Scope --
- ---------------------------
-
-- Start of processing for Make_Call_Into_Operator
begin
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)));
or else Scope (Opnd_Type) /= System_Aux_Id
or else Pack /= Scope (System_Aux_Id))
then
- Error := True;
+ if not Is_Overloaded (Right_Opnd (Op_Node)) then
+ Error := True;
+ else
+ Error := not Operand_Type_In_Scope (Pack);
+ end if;
elsif Pack = Standard_Standard
and then not Operand_Type_In_Scope (Standard_Standard)
end if;
Set_Chars (Op_Node, Op_Name);
- Set_Etype (Op_Node, Base_Type (Etype (N)));
+
+ if not Is_Private_Type (Etype (N)) then
+ Set_Etype (Op_Node, Base_Type (Etype (N)));
+ else
+ Set_Etype (Op_Node, Etype (N));
+ end if;
+
+ -- If this is a call to a function that renames a predefined equality,
+ -- the renaming declaration provides a type that must be used to
+ -- resolve the operands. This must be done now because resolution of
+ -- the equality node will not resolve any remaining ambiguity, and it
+ -- assumes that the first operand is not overloaded.
+
+ if (Op_Name = Name_Op_Eq or else Op_Name = Name_Op_Ne)
+ and then Ekind (Func) = E_Function
+ and then Is_Overloaded (Act1)
+ then
+ Resolve (Act1, Base_Type (Etype (First_Formal (Func))));
+ Resolve (Act2, Base_Type (Etype (First_Formal (Func))));
+ end if;
+
Set_Entity (Op_Node, Op_Id);
Generate_Reference (Op_Id, N, ' ');
Rewrite (N, Op_Node);
- Resolve (N, Typ);
+
+ -- If this is an arithmetic operator and the result type is private,
+ -- the operands and the result must be wrapped in conversion to
+ -- expose the underlying numeric type and expand the proper checks,
+ -- e.g. on division.
+
+ if Is_Private_Type (Typ) then
+ case Nkind (N) is
+ when N_Op_Add | N_Op_Subtract | N_Op_Multiply | N_Op_Divide |
+ N_Op_Expon | N_Op_Mod | N_Op_Rem =>
+ Resolve_Intrinsic_Operator (N, Typ);
+
+ when N_Op_Plus | N_Op_Minus | N_Op_Abs =>
+ Resolve_Intrinsic_Unary_Operator (N, Typ);
+
+ when others =>
+ Resolve (N, Typ);
+ end case;
+ else
+ Resolve (N, Typ);
+ end if;
-- For predefined operators on literals, the operation freezes
-- their type.
function Operator_Kind
(Op_Name : Name_Id;
- Is_Binary : Boolean)
- return Node_Kind
+ Is_Binary : Boolean) return Node_Kind
is
Kind : Node_Kind;
Full_Analysis := Save_Full_Analysis;
end Pre_Analyze_And_Resolve;
- -- Version without context type.
+ -- Version without context type
procedure Pre_Analyze_And_Resolve (N : Node_Id) is
Save_Full_Analysis : constant Boolean := Full_Analysis;
Seen : Entity_Id := Empty; -- prevent junk warning
Ctx_Type : Entity_Id := Typ;
Expr_Type : Entity_Id := Empty; -- prevent junk warning
+ Err_Type : Entity_Id := Empty;
Ambiguous : Boolean := False;
procedure Patch_Up_Value (N : Node_Id; Typ : Entity_Id);
Rewrite (N,
Make_Character_Literal (Sloc (N),
Chars => Name_Find,
- Char_Literal_Value => Char_Code (Character'Pos ('A'))));
+ Char_Literal_Value =>
+ UI_From_Int (Character'Pos ('A'))));
Set_Etype (N, Any_Character);
Set_Is_Static_Expression (N);
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)))
Is_Remote : Boolean := True;
begin
- -- Check that Typ is a fat pointer with a reference to a RAS as
- -- original access type.
-
- if
- (Ekind (Typ) = E_Access_Subprogram_Type
- and then Present (Equivalent_Type (Typ)))
- or else
- (Ekind (Typ) = E_Record_Type
- and then Present (Corresponding_Remote_Type (Typ)))
+ -- Check that Typ is a remote access-to-subprogram type
- then
+ if Is_Remote_Access_To_Subprogram_Type (Typ) then
-- Prefix (N) must statically denote a remote subprogram
-- declared in a package specification.
end if;
end if;
- if Attr = Attribute_Access
- or else Attr = Attribute_Unchecked_Access
- or else Attr = Attribute_Unrestricted_Access
+ -- If we are generating code for a distributed program.
+ -- perform semantic checks against the corresponding
+ -- remote entities.
+
+ if (Attr = Attribute_Access
+ or else Attr = Attribute_Unchecked_Access
+ or else Attr = Attribute_Unrestricted_Access)
+ and then Expander_Active
+ and then Get_PCS_Name /= Name_No_DSA
then
Check_Subtype_Conformant
(New_Id => Entity (Prefix (N)),
-- is compatible with the context (i.e. the type passed to Resolve)
else
- Get_First_Interp (N, I, It);
-
-- Loop through possible interpretations
+ Get_First_Interp (N, I, It);
Interp_Loop : while Present (It.Typ) loop
-- We are only interested in interpretations that are compatible
-- with the expected type, any other interpretations are ignored
- if Covers (Typ, It.Typ) then
+ if not Covers (Typ, It.Typ) then
+ if Debug_Flag_V then
+ Write_Str (" interpretation incompatible with context");
+ Write_Eol;
+ end if;
+ else
-- First matching interpretation
if not Found then
Seen := It.Nam;
Expr_Type := It.Typ;
- -- Matching intepretation that is not the first, maybe an
+ -- Matching interpretation that is not the first, maybe an
-- error, but there are some cases where preference rules are
-- used to choose between the two possibilities. These and
-- some more obscure cases are handled in Disambiguate.
Error_Msg_Sloc := Sloc (Seen);
It1 := Disambiguate (N, I1, I, Typ);
- if It1 = No_Interp then
+ -- Disambiguation has succeeded. Skip the remaining
+ -- interpretations.
+
+ if It1 /= No_Interp then
+ Seen := It1.Nam;
+ Expr_Type := It1.Typ;
+
+ while Present (It.Typ) loop
+ Get_Next_Interp (I, It);
+ end loop;
+ else
-- Before we issue an ambiguity complaint, check for
-- the case of a subprogram call where at least one
-- of the arguments is Any_Type, and if so, suppress
or else Nkind (N) = N_Procedure_Call_Statement
then
declare
- A : Node_Id := First_Actual (N);
+ A : Node_Id;
E : Node_Id;
begin
+ A := First_Actual (N);
while Present (A) loop
E := A;
-- 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
+ ("ambiguous expression (cannot resolve&)!",
+ N, It.Nam);
+ end if;
+
Error_Msg_N
- ("possible interpretation#!", N);
+ ("\\possible interpretation#!", N);
Ambiguous := True;
end if;
Error_Msg_Sloc := Sloc (It.Nam);
- Error_Msg_N ("possible interpretation#!", N);
- -- Disambiguation has succeeded. Skip the remaining
- -- interpretations.
- else
- Seen := It1.Nam;
- Expr_Type := It1.Typ;
+ -- By default, the error message refers to the candidate
+ -- interpretation. But if it is a predefined operator,
+ -- it is implicitly declared at the declaration of
+ -- the type of the operand. Recover the sloc of that
+ -- declaration for the error message.
+
+ if Nkind (N) in N_Op
+ and then Scope (It.Nam) = Standard_Standard
+ and then not Is_Overloaded (Right_Opnd (N))
+ and then Scope (Base_Type (Etype (Right_Opnd (N))))
+ /= Standard_Standard
+ then
+ Err_Type := First_Subtype (Etype (Right_Opnd (N)));
+
+ if Comes_From_Source (Err_Type)
+ and then Present (Parent (Err_Type))
+ then
+ Error_Msg_Sloc := Sloc (Parent (Err_Type));
+ end if;
+
+ elsif Nkind (N) in N_Binary_Op
+ and then Scope (It.Nam) = Standard_Standard
+ and then not Is_Overloaded (Left_Opnd (N))
+ and then Scope (Base_Type (Etype (Left_Opnd (N))))
+ /= Standard_Standard
+ then
+ Err_Type := First_Subtype (Etype (Left_Opnd (N)));
+
+ if Comes_From_Source (Err_Type)
+ and then Present (Parent (Err_Type))
+ then
+ Error_Msg_Sloc := Sloc (Parent (Err_Type));
+ end if;
+
+ -- 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;
+
+ if Nkind (N) in N_Op
+ and then Scope (It.Nam) = Standard_Standard
+ and then Present (Err_Type)
+ then
+ Error_Msg_N
+ ("\\possible interpretation (predefined)#!", N);
+
+ elsif
+ Nkind (Parent (It.Nam)) = N_Full_Type_Declaration
+ then
+ Error_Msg_N
+ ("\\possible interpretation (inherited)#!", N);
+ else
+ Error_Msg_N ("\\possible interpretation#!", N);
+ end if;
- while Present (It.Typ) loop
- Get_Next_Interp (I, It);
- end loop;
end if;
end if;
Set_Etype (Name (N), Expr_Type);
end if;
- -- Here if interpetation is incompatible with context type
-
- else
- if Debug_Flag_V then
- Write_Str (" intepretation incompatible with context");
- Write_Eol;
- end if;
end if;
-- Move to next interpretation
- exit Interp_Loop when not Present (It.Typ);
+ exit Interp_Loop when No (It.Typ);
Get_Next_Interp (I, It);
end loop Interp_Loop;
-- doesn't think of them this way!)
if Typ = Standard_Void_Type then
- Error_Msg_N ("expect procedure name in procedure call", N);
+
+ -- Special case message if function used as a procedure
+
+ if Nkind (N) = N_Procedure_Call_Statement
+ and then Is_Entity_Name (Name (N))
+ and then Ekind (Entity (Name (N))) = E_Function
+ then
+ Error_Msg_NE
+ ("cannot use function & in a procedure call",
+ Name (N), Entity (Name (N)));
+
+ -- Otherwise give general message (not clear what cases
+ -- this covers, but no harm in providing for them!)
+
+ else
+ Error_Msg_N ("expect procedure name in procedure call", N);
+ end if;
+
Found := True;
-- Otherwise we do have a subexpression with the wrong type
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
then
-
-- Disable expansion in any case. If there is a type mismatch
-- it may be fatal to try to expand the aggregate. The flag
-- would otherwise be set to false when the error is posted.
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));
+
+ -- Nothing to check is this is a default-
+ -- initialized component. The box will be
+ -- 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;
end Check_Aggr;
+ ----------------
+ -- Check_Elmt --
+ ----------------
+
procedure Check_Elmt (Aelmt : Node_Id) is
begin
-- If we have a nested aggregate, go inside it (to
if not Is_Overloaded (Aelmt)
and then Etype (Aelmt) /= Any_Fixed
then
- Resolve (Aelmt, Etype (Aelmt));
+ Resolve (Aelmt);
end if;
if Etype (Aelmt) = Any_Type then
if Is_Overloaded (N)
and then Nkind (N) = N_Function_Call
then
- Error_Msg_Node_2 := Typ;
- Error_Msg_NE ("no visible interpretation of&" &
- " matches expected type&", N, Name (N));
+ declare
+ Subp_Name : Node_Id;
+ begin
+ if Is_Entity_Name (Name (N)) then
+ Subp_Name := Name (N);
+
+ elsif Nkind (Name (N)) = N_Selected_Component then
+
+ -- Protected operation: retrieve operation name
+
+ Subp_Name := Selector_Name (Name (N));
+ else
+ raise Program_Error;
+ end if;
+
+ Error_Msg_Node_2 := Typ;
+ Error_Msg_NE ("no visible interpretation of&" &
+ " matches expected type&", N, Subp_Name);
+ end;
if All_Errors_Mode then
declare
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.Typ;
+ Error_Msg_NE ("\& declared#, type&", N, It.Nam);
Get_Next_Interp (Index, It);
end loop;
end;
-- Here we have an acceptable interpretation for the context
else
- -- A user-defined operator is tranformed into a function call at
- -- this point, so that further processing knows that operators are
- -- really operators (i.e. are predefined operators). User-defined
- -- operators that are intrinsic are just renamings of the predefined
- -- ones, and need not be turned into calls either, but if they rename
- -- a different operator, we must transform the node accordingly.
- -- Instantiations of Unchecked_Conversion are intrinsic but are
- -- treated as functions, even if given an operator designator.
-
- if Nkind (N) in N_Op
- and then Present (Entity (N))
- and then Ekind (Entity (N)) /= E_Operator
- then
-
- if not Is_Predefined_Op (Entity (N)) then
- Rewrite_Operator_As_Call (N, Entity (N));
-
- elsif Present (Alias (Entity (N))) then
- Rewrite_Renamed_Operator (N, Alias (Entity (N)));
- end if;
- end if;
-
-- Propagate type information and normalize tree for various
-- predefined operations. If the context only imposes a class of
-- types, rather than a specific type, propagate the actual type
if Typ = Any_Real
and then Expr_Type = Any_Fixed
then
- Error_Msg_N ("Illegal context for mixed mode operation", N);
+ Error_Msg_N ("illegal context for mixed mode operation", N);
Set_Etype (N, Universal_Real);
Ctx_Type := Universal_Real;
end if;
end if;
- case N_Subexpr'(Nkind (N)) is
+ -- A user-defined operator is tranformed into a function call at
+ -- this point, so that further processing knows that operators are
+ -- really operators (i.e. are predefined operators). User-defined
+ -- operators that are intrinsic are just renamings of the predefined
+ -- ones, and need not be turned into calls either, but if they rename
+ -- a different operator, we must transform the node accordingly.
+ -- Instantiations of Unchecked_Conversion are intrinsic but are
+ -- treated as functions, even if given an operator designator.
- when N_Aggregate => Resolve_Aggregate (N, Ctx_Type);
+ if Nkind (N) in N_Op
+ and then Present (Entity (N))
+ and then Ekind (Entity (N)) /= E_Operator
+ then
- when N_Allocator => Resolve_Allocator (N, Ctx_Type);
+ if not Is_Predefined_Op (Entity (N)) then
+ Rewrite_Operator_As_Call (N, Entity (N));
- when N_And_Then | N_Or_Else
- => Resolve_Short_Circuit (N, Ctx_Type);
+ elsif Present (Alias (Entity (N)))
+ and then
+ Nkind (Parent (Parent (Entity (N))))
+ = N_Subprogram_Renaming_Declaration
+ then
+ Rewrite_Renamed_Operator (N, Alias (Entity (N)), Typ);
- when N_Attribute_Reference
- => Resolve_Attribute (N, Ctx_Type);
+ -- If the node is rewritten, it will be fully resolved in
+ -- Rewrite_Renamed_Operator.
+
+ if Analyzed (N) then
+ return;
+ end if;
+ end if;
+ end if;
+
+ case N_Subexpr'(Nkind (N)) is
+
+ when N_Aggregate => Resolve_Aggregate (N, Ctx_Type);
+
+ when N_Allocator => Resolve_Allocator (N, Ctx_Type);
+
+ when N_And_Then | N_Or_Else
+ => Resolve_Short_Circuit (N, Ctx_Type);
+
+ when N_Attribute_Reference
+ => Resolve_Attribute (N, Ctx_Type);
when N_Character_Literal
=> Resolve_Character_Literal (N, Ctx_Type);
when N_Identifier
=> Resolve_Entity_Name (N, Ctx_Type);
- when N_In | N_Not_In
+ when N_Membership_Test
=> Resolve_Membership_Op (N, Ctx_Type);
when N_Indexed_Component
Set_Is_Overloaded (N, False);
-- Freeze expression type, entity if it is a name, and designated
- -- type if it is an allocator (RM 13.14(9,10)).
+ -- type if it is an allocator (RM 13.14(10,11,13)).
-- Now that the resolution of the type of the node is complete,
-- and we did not detect an error, we can expand this node. We
Expand (N);
end if;
-
end Resolve;
+ -------------
+ -- Resolve --
+ -------------
+
-- Version with check(s) suppressed
procedure Resolve (N : Node_Id; Typ : Entity_Id; Suppress : Check_Id) is
begin
if Suppress = All_Checks then
declare
- Svg : constant Suppress_Record := Scope_Suppress;
-
+ Svg : constant Suppress_Array := Scope_Suppress;
begin
Scope_Suppress := (others => True);
Resolve (N, Typ);
else
declare
- Svg : constant Boolean := Get_Scope_Suppress (Suppress);
-
+ Svg : constant Boolean := Scope_Suppress (Suppress);
begin
- Set_Scope_Suppress (Suppress, True);
+ Scope_Suppress (Suppress) := True;
Resolve (N, Typ);
- Set_Scope_Suppress (Suppress, Svg);
+ Scope_Suppress (Suppress) := Svg;
end;
end if;
end Resolve;
+ -------------
+ -- Resolve --
+ -------------
+
+ -- Version with implicit type
+
+ procedure Resolve (N : Node_Id) is
+ begin
+ Resolve (N, Etype (N));
+ end Resolve;
+
---------------------
-- Resolve_Actuals --
---------------------
-- an instance of the default expression. The insertion is always
-- a named association.
+ function Same_Ancestor (T1, T2 : Entity_Id) return Boolean;
+ -- Check whether T1 and T2, or their full views, are derived from a
+ -- common type. Used to enforce the restrictions on array conversions
+ -- of AI95-00246.
+
--------------------
-- Insert_Default --
--------------------
Assoc : Node_Id;
begin
- -- Note that we do a full New_Copy_Tree, so that any associated
- -- Itypes are properly copied. This may not be needed any more,
- -- but it does no harm as a safety measure! Defaults of a generic
- -- formal may be out of bounds of the corresponding actual (see
- -- cc1311b) and an additional check may be required.
+ -- Missing argument in call, nothing to insert
+
+ if No (Default_Value (F)) then
+ return;
- if Present (Default_Value (F)) then
+ else
+ -- Note that we do a full New_Copy_Tree, so that any associated
+ -- Itypes are properly copied. This may not be needed any more,
+ -- but it does no harm as a safety measure! Defaults of a generic
+ -- formal may be out of bounds of the corresponding actual (see
+ -- cc1311b) and an additional check may be required.
Actval := New_Copy_Tree (Default_Value (F),
New_Scope => Current_Scope, New_Sloc => Loc);
end if;
Set_Parent (Actval, N);
- Analyze_And_Resolve (Actval, Etype (Actval));
- else
- Set_Parent (Actval, N);
-- Resolve aggregates with their base type, to avoid scope
-- anomalies: the subtype was first built in the suprogram
else
Analyze_And_Resolve (Actval, Etype (Actval));
end if;
+
+ else
+ Set_Parent (Actval, N);
+
+ -- See note above concerning aggregates
+
+ if Nkind (Actval) = N_Aggregate
+ and then Has_Discriminants (Etype (Actval))
+ then
+ Analyze_And_Resolve (Actval, Base_Type (Etype (Actval)));
+
+ -- Resolve entities with their own type, which may differ
+ -- from the type of a reference in a generic context (the
+ -- view swapping mechanism did not anticipate the re-analysis
+ -- of default values in calls).
+
+ elsif Is_Entity_Name (Actval) then
+ Analyze_And_Resolve (Actval, Etype (Entity (Actval)));
+
+ else
+ Analyze_And_Resolve (Actval, Etype (Actval));
+ end if;
end if;
-- If default is a tag indeterminate function call, propagate
Set_Is_Controlling_Actual (Actval);
end if;
- else
- -- Missing argument in call, nothing to insert.
- return;
end if;
-- If the default expression raises constraint error, then just
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));
Prev := Actval;
end Insert_Default;
+ -------------------
+ -- Same_Ancestor --
+ -------------------
+
+ function Same_Ancestor (T1, T2 : Entity_Id) return Boolean is
+ FT1 : Entity_Id := T1;
+ FT2 : Entity_Id := T2;
+
+ begin
+ if Is_Private_Type (T1)
+ and then Present (Full_View (T1))
+ then
+ FT1 := Full_View (T1);
+ end if;
+
+ if Is_Private_Type (T2)
+ and then Present (Full_View (T2))
+ then
+ FT2 := Full_View (T2);
+ end if;
+
+ return Root_Type (Base_Type (FT1)) = Root_Type (Base_Type (FT2));
+ end Same_Ancestor;
+
-- Start of processing for Resolve_Actuals
begin
A := First_Actual (N);
F := First_Formal (Nam);
-
while Present (F) loop
+ if No (A) and then Needs_No_Actuals (Nam) then
+ null;
-- If we have an error in any actual or formal, indicated by
-- a type of Any_Type, then abandon resolution attempt, and
-- set result type to Any_Type.
- if (No (A) or else Etype (A) = Any_Type or else Etype (F) = Any_Type)
- and then Total_Errors_Detected /= 0
+ elsif (Present (A) and then Etype (A) = Any_Type)
+ or else Etype (F) = Any_Type
then
Set_Etype (N, Any_Type);
return;
-- 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
then
if Ekind (F) = E_In_Out_Parameter
and then Is_Array_Type (Etype (F))
- and then Has_Aliased_Components (Etype (Expression (A)))
- /= Has_Aliased_Components (Etype (F))
then
- Error_Msg_N
- ("both component types in a view conversion must be"
- & " aliased, or neither", A);
+ if Has_Aliased_Components (Etype (Expression (A)))
+ /= Has_Aliased_Components (Etype (F))
+ then
+ if Ada_Version < Ada_05 then
+ Error_Msg_N
+ ("both component types in a view conversion must be"
+ & " aliased, or neither", A);
+
+ -- Ada 2005: rule is relaxed (see AI-363)
+
+ elsif Has_Aliased_Components (Etype (F))
+ and then
+ not Has_Aliased_Components (Etype (Expression (A)))
+ then
+ Error_Msg_N
+ ("view conversion operand must have aliased " &
+ "components", N);
+ Error_Msg_N
+ ("\since target type has aliased components", N);
+ end if;
+
+ elsif not Same_Ancestor (Etype (F), Etype (Expression (A)))
+ and then
+ (Is_By_Reference_Type (Etype (F))
+ or else Is_By_Reference_Type (Etype (Expression (A))))
+ then
+ Error_Msg_N
+ ("view conversion between unrelated by reference " &
+ "array types not allowed (\'A'I-00246)", A);
+ end if;
end if;
- if Conversion_OK (A)
- or else Valid_Conversion (A, Etype (A), Expression (A))
+ 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), Etype (Expression (A)));
+ Resolve (Expression (A));
end if;
else
+ if Nkind (A) = N_Type_Conversion
+ and then Is_Array_Type (Etype (F))
+ and then not Same_Ancestor (Etype (F), Etype (Expression (A)))
+ and then
+ (Is_Limited_Type (Etype (F))
+ or else Is_Limited_Type (Etype (Expression (A))))
+ then
+ Error_Msg_N
+ ("conversion between unrelated limited array types " &
+ "not allowed (\A\I-00246)", A);
+
+ if Is_Limited_Type (Etype (F)) then
+ Explain_Limited_Type (Etype (F), A);
+ end if;
+
+ if Is_Limited_Type (Etype (Expression (A))) then
+ Explain_Limited_Type (Etype (Expression (A)), A);
+ end if;
+ end if;
+
+ -- (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));
+ Init_Size_Align (New_Itype);
+ Set_Directly_Designated_Type (New_Itype,
+ Directly_Designated_Type (Etype (A)));
+ Set_Etype (A, New_Itype);
+ end if;
+ end;
+ end if;
+
Resolve (A, Etype (F));
end if;
A_Typ := Etype (A);
F_Typ := Etype (F);
+ -- Perform error checks for IN and IN OUT parameters
+
+ if Ekind (F) /= E_Out_Parameter then
+
+ -- Check unset reference. For scalar parameters, it is clearly
+ -- wrong to pass an uninitialized value as either an IN or
+ -- IN-OUT parameter. For composites, it is also clearly an
+ -- error to pass a completely uninitialized value as an IN
+ -- parameter, but the case of IN OUT is trickier. We prefer
+ -- not to give a warning here. For example, suppose there is
+ -- a routine that sets some component of a record to False.
+ -- It is perfectly reasonable to make this IN-OUT and allow
+ -- either initialized or uninitialized records to be passed
+ -- in this case.
+
+ -- For partially initialized composite values, we also avoid
+ -- warnings, since it is quite likely that we are passing a
+ -- partially initialized value and only the initialized fields
+ -- will in fact be read in the subprogram.
+
+ if Is_Scalar_Type (A_Typ)
+ or else (Ekind (F) = E_In_Parameter
+ and then not Is_Partially_Initialized_Type (A_Typ))
+ then
+ Check_Unset_Reference (A);
+ end if;
+
+ -- In Ada 83 we cannot pass an OUT parameter as an IN or IN OUT
+ -- actual to a nested call, since this is case of reading an
+ -- out parameter, which is not allowed.
+
+ if Ada_Version = Ada_83
+ and then Is_Entity_Name (A)
+ and then Ekind (Entity (A)) = E_Out_Parameter
+ then
+ Error_Msg_N ("(Ada 83) illegal reading of out parameter", A);
+ end if;
+ end if;
+
if Ekind (F) /= E_In_Parameter
and then not Is_OK_Variable_For_Out_Formal (A)
then
- -- Specialize error message for protected procedure call
- -- within function call of the same protected object.
-
- if Is_Entity_Name (A)
- and then Chars (Entity (A)) = Name_uObject
- and then Ekind (Current_Scope) = E_Function
- and then Convention (Current_Scope) = Convention_Protected
- and then Ekind (Nam) /= E_Function
- then
- Error_Msg_N ("within protected function, protected " &
- "object is constant", A);
- Error_Msg_N ("\cannot call operation that may modify it", A);
+ Error_Msg_NE ("actual for& must be a variable", A, F);
+
+ if Is_Entity_Name (A) then
+ Kill_Checks (Entity (A));
else
- Error_Msg_NE ("actual for& must be a variable", A, F);
+ Kill_All_Checks;
end if;
end if;
return;
end if;
- if Ekind (F) /= E_Out_Parameter then
- Check_Unset_Reference (A);
-
- if Ada_83
- and then Is_Entity_Name (A)
- and then Ekind (Entity (A)) = E_Out_Parameter
- then
- Error_Msg_N ("(Ada 83) illegal reading of out parameter", A);
- end if;
- end if;
-
-- Apply appropriate range checks for in, out, and in-out
-- parameters. Out and in-out parameters also need a separate
-- check, if there is a type conversion, to make sure the return
else
Apply_Range_Check (A, F_Typ);
end if;
+
+ -- Ada 2005 (AI-231)
+
+ if Ada_Version >= Ada_05
+ and then Is_Access_Type (F_Typ)
+ and then Can_Never_Be_Null (F_Typ)
+ and then Nkind (A) = N_Null
+ then
+ Apply_Compile_Time_Constraint_Error
+ (N => A,
+ Msg => "(Ada 2005) NULL not allowed in "
+ & "null-excluding formal?",
+ Reason => CE_Null_Not_Allowed);
+ end if;
end if;
if Ekind (F) = E_Out_Parameter
or else Ekind (F) = E_In_Out_Parameter
then
-
if Nkind (A) = N_Type_Conversion then
if Is_Scalar_Type (A_Typ) then
Apply_Scalar_Range_Check
then
Error_Msg_Node_2 := F_Typ;
Error_Msg_NE
- ("& is not a primitive operation of &!", A, Nam);
+ ("& is not a dispatching operation of &!", A, Nam);
end if;
elsif Is_Access_Type (A_Typ)
then
Error_Msg_Node_2 := Designated_Type (F_Typ);
Error_Msg_NE
- ("& is not a primitive operation of &!", A, Nam);
+ ("& is not a dispatching operation of &!", A, Nam);
end if;
end if;
end if;
Prev := A;
+
+ if Ekind (F) /= E_Out_Parameter then
+ Check_Unset_Reference (A);
+ end if;
+
Next_Actual (A);
+ -- Case where actual is not present
+
else
Insert_Default;
end if;
Next_Formal (F);
end loop;
-
end Resolve_Actuals;
-----------------------
Resolve (Expression (E), Etype (E));
Check_Unset_Reference (Expression (E));
+ -- A qualified expression requires an exact match of the type,
+ -- class-wide matching is not allowed.
+
+ if (Is_Class_Wide_Type (Etype (Expression (E)))
+ or else Is_Class_Wide_Type (Etype (E)))
+ and then Base_Type (Etype (Expression (E))) /= Base_Type (Etype (E))
+ then
+ Wrong_Type (Expression (E), Etype (E));
+ end if;
+
-- For a subtype mark or subtype indication, freeze the subtype
else
if Has_Discriminants (Subtyp) then
Discrim := First_Discriminant (Base_Type (Subtyp));
Constr := First (Constraints (Constraint (Original_Node (E))));
-
while Present (Discrim) and then Present (Constr) loop
if Ekind (Etype (Discrim)) = E_Anonymous_Access_Type then
if Nkind (Constr) = N_Discriminant_Association then
end if;
end if;
+ -- Ada 2005 (AI-344): A class-wide allocator requires an accessibility
+ -- check that the level of the type of the created object is not deeper
+ -- than the level of the allocator's access type, since extensions can
+ -- now occur at deeper levels than their ancestor types. This is a
+ -- static accessibility level check; a run-time check is also needed in
+ -- the case of an initialized allocator with a class-wide argument (see
+ -- Expand_Allocator_Expression).
+
+ if Ada_Version >= Ada_05
+ and then Is_Class_Wide_Type (Designated_Type (Typ))
+ then
+ declare
+ Exp_Typ : Entity_Id;
+
+ begin
+ if Nkind (E) = N_Qualified_Expression then
+ Exp_Typ := Etype (E);
+ elsif Nkind (E) = N_Subtype_Indication then
+ Exp_Typ := Entity (Subtype_Mark (Original_Node (E)));
+ else
+ Exp_Typ := Entity (E);
+ end if;
+
+ if Type_Access_Level (Exp_Typ) > Type_Access_Level (Typ) then
+ if In_Instance_Body then
+ Error_Msg_N ("?type in allocator has deeper level than" &
+ " designated class-wide type", E);
+ Error_Msg_N ("\?Program_Error will be raised at run time",
+ E);
+ Rewrite (N,
+ Make_Raise_Program_Error (Sloc (N),
+ Reason => PE_Accessibility_Check_Failed));
+ Set_Etype (N, Typ);
+
+ -- 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;
+ end if;
+ end;
+ end if;
+
-- Check for allocation from an empty storage pool
if No_Pool_Assigned (Typ) then
declare
Loc : constant Source_Ptr := Sloc (N);
-
begin
- Error_Msg_N ("?allocation from empty storage pool!", N);
- Error_Msg_N ("?Storage_Error will be raised at run time!", N);
+ Error_Msg_N ("?allocation from empty storage pool", N);
+ Error_Msg_N ("\?Storage_Error will be raised at run time", N);
Insert_Action (N,
Make_Raise_Storage_Error (Loc,
Reason => SE_Empty_Storage_Pool));
end;
+
+ -- If the context is an unchecked conversion, as may happen within
+ -- an inlined subprogram, the allocator is being resolved with its
+ -- own anonymous type. In that case, if the target type has a specific
+ -- storage pool, it must be inherited explicitly by the allocator type.
+
+ elsif Nkind (Parent (N)) = N_Unchecked_Type_Conversion
+ and then No (Associated_Storage_Pool (Typ))
+ then
+ Set_Associated_Storage_Pool
+ (Typ, Associated_Storage_Pool (Etype (Parent (N))));
end if;
end Resolve_Allocator;
-- Used for resolving all arithmetic operators except exponentiation
procedure Resolve_Arithmetic_Op (N : Node_Id; Typ : Entity_Id) is
- L : constant Node_Id := Left_Opnd (N);
- R : constant Node_Id := Right_Opnd (N);
- T : Entity_Id;
- TL : Entity_Id := Base_Type (Etype (L));
- TR : Entity_Id := Base_Type (Etype (R));
+ L : constant Node_Id := Left_Opnd (N);
+ R : constant Node_Id := Right_Opnd (N);
+ TL : constant Entity_Id := Base_Type (Etype (L));
+ TR : constant Entity_Id := Base_Type (Etype (R));
+ T : Entity_Id;
+ Rop : Node_Id;
B_Typ : constant Entity_Id := Base_Type (Typ);
-- We do the resolution using the base type, because intermediate values
-- 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
- function Universal_Interpretation (N : Node_Id) return Entity_Id;
- -- Find universal type of operand, if any.
+ -------------------------------
+ -- 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 (Parent (N)) = N_Ordinary_Fixed_Point_Definition
+ or else Nkind (Parent (N)) = N_Decimal_Fixed_Point_Definition
+
+ -- N is one of the bounds in a real_range_specification;
+ -- see RM-3.5.7(5):
+
+ or else Nkind (Parent (N)) = N_Real_Range_Specification
+
+ -- N is the expression of a delta_constraint;
+ -- see RM-J.3(3):
+
+ or else Nkind (Parent (N)) = 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
if Universal_Interpretation (N) = Universal_Integer then
-- A universal integer literal is resolved as standard integer
- -- except in the case of a fixed-point result, where we leave
- -- it as universal (to be handled by Exp_Fixd later on)
+ -- except in the case of a fixed-point result, where we leave it
+ -- as universal (to be handled by Exp_Fixd later on)
if Is_Fixed_Point_Type (T) then
Resolve (N, Universal_Integer);
elsif Etype (N) = T
and then B_Typ /= Universal_Fixed
then
- -- Not a mixed-mode operation. Resolve with context.
+ -- Not a mixed-mode operation, resolve with context
Resolve (N, B_Typ);
elsif Etype (N) = Any_Fixed then
- -- N may itself be a mixed-mode operation, so use context type.
+ -- N may itself be a mixed-mode operation, so use context type
Resolve (N, B_Typ);
-- interpretation or an integer interpretation, but not both.
Get_First_Interp (N, Index, It);
-
while Present (It.Typ) loop
-
if Base_Type (It.Typ) = Base_Type (Standard_Integer) then
if Analyzed (N) then
Get_Next_Interp (Index, It);
end loop;
- -- Reanalyze the literal with the fixed type of the context.
+ -- Reanalyze the literal with the fixed type of the context. If
+ -- context is Universal_Fixed, we are within a conversion, leave
+ -- the literal as a universal real because there is no usable
+ -- fixed type, and the target of the conversion plays no role in
+ -- the resolution.
- if N = L then
- Set_Analyzed (R, False);
- Resolve (R, B_Typ);
- else
- Set_Analyzed (L, False);
- Resolve (L, B_Typ);
- end if;
+ declare
+ Op2 : Node_Id;
+ T2 : Entity_Id;
+
+ begin
+ if N = L then
+ Op2 := R;
+ else
+ Op2 := L;
+ end if;
+
+ if B_Typ = Universal_Fixed
+ and then Nkind (Op2) = N_Real_Literal
+ then
+ T2 := Universal_Real;
+ else
+ T2 := B_Typ;
+ end if;
+
+ Set_Analyzed (Op2, False);
+ Resolve (Op2, T2);
+ end;
else
- Resolve (N, Etype (N));
+ Resolve (N);
end if;
end Set_Mixed_Mode_Operand;
end if;
end Set_Operand_Type;
- ------------------------------
- -- Universal_Interpretation --
- ------------------------------
-
- function Universal_Interpretation (N : Node_Id) return Entity_Id is
- Index : Interp_Index;
- It : Interp;
-
- begin
- if not Is_Overloaded (N) then
-
- if Etype (N) = Universal_Integer
- or else Etype (N) = Universal_Real
- then
- return Etype (N);
- else
- return Empty;
- end if;
-
- else
- Get_First_Interp (N, Index, It);
-
- while Present (It.Typ) loop
-
- if It.Typ = Universal_Integer
- or else It.Typ = Universal_Real
- then
- return It.Typ;
- end if;
-
- Get_Next_Interp (Index, It);
- end loop;
-
- return Empty;
- end if;
- end Universal_Interpretation;
-
-- Start of processing for Resolve_Arithmetic_Op
begin
if Comes_From_Source (N)
and then Ekind (Entity (N)) = E_Function
and then Is_Imported (Entity (N))
- and then Present (First_Rep_Item (Entity (N)))
+ and then Is_Intrinsic_Subprogram (Entity (N))
then
Resolve_Intrinsic_Operator (N, Typ);
return;
Set_Mixed_Mode_Operand (R, TL);
end if;
+ -- Check the rule in RM05-4.5.5(19.1/2) disallowing the
+ -- universal_fixed multiplying operators from being used when the
+ -- expected type is also universal_fixed. Note that B_Typ will be
+ -- Universal_Fixed in some cases where the expected type is actually
+ -- Any_Real; Expected_Type_Is_Any_Real takes care of that case.
+
if Etype (N) = Universal_Fixed
or else Etype (N) = Any_Fixed
then
if B_Typ = Universal_Fixed
+ and then not Expected_Type_Is_Any_Real (N)
and then Nkind (Parent (N)) /= N_Type_Conversion
and then Nkind (Parent (N)) /= N_Unchecked_Type_Conversion
then
Set_Etype (R, Any_Type);
else
- if Ada_83
+ if Ada_Version = Ada_83
and then Etype (N) = Universal_Fixed
and then Nkind (Parent (N)) /= N_Type_Conversion
and then Nkind (Parent (N)) /= N_Unchecked_Type_Conversion
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)
Set_Operand_Type (R);
end if;
- Generate_Operator_Reference (N);
+ Generate_Operator_Reference (N, Typ);
Eval_Arithmetic_Op (N);
-- Set overflow and division checking bit. Much cleverer code needed
if Nkind (N) in N_Op then
if not Overflow_Checks_Suppressed (Etype (N)) then
- Set_Do_Overflow_Check (N);
+ Enable_Overflow_Check (N);
end if;
+ -- Give warning if explicit division by zero
+
if (Nkind (N) = N_Op_Divide
or else Nkind (N) = N_Op_Rem
or else Nkind (N) = N_Op_Mod)
and then not Division_Checks_Suppressed (Etype (N))
then
- Set_Do_Division_Check (N);
+ Rop := Right_Opnd (N);
+
+ if Compile_Time_Known_Value (Rop)
+ and then ((Is_Integer_Type (Etype (Rop))
+ and then Expr_Value (Rop) = Uint_0)
+ or else
+ (Is_Real_Type (Etype (Rop))
+ and then Expr_Value_R (Rop) = Ureal_0))
+ then
+ -- 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);
+ end if;
end if;
end if;
Check_Unset_Reference (L);
Check_Unset_Reference (R);
-
end Resolve_Arithmetic_Op;
------------------
It : Interp;
Norm_OK : Boolean;
Scop : Entity_Id;
+ Rtype : Entity_Id;
begin
- -- The context imposes a unique interpretation with type Typ on
- -- a procedure or function call. Find the entity of the subprogram
- -- that yields the expected type, and propagate the corresponding
- -- formal constraints on the actuals. The caller has established
- -- that an interpretation exists, and emitted an error if not unique.
+ -- The context imposes a unique interpretation with type Typ on a
+ -- procedure or function call. Find the entity of the subprogram that
+ -- yields the expected type, and propagate the corresponding formal
+ -- constraints on the actuals. The caller has established that an
+ -- interpretation exists, and emitted an error if not unique.
-- First deal with the case of a call to an access-to-subprogram,
-- dereference made explicit in Analyze_Call.
if Ekind (Etype (Subp)) = E_Subprogram_Type then
-
if not Is_Overloaded (Subp) then
Nam := Etype (Subp);
else
- -- Find the interpretation whose type (a subprogram type)
- -- has a return type that is compatible with the context.
- -- Analysis of the node has established that one exists.
+ -- Find the interpretation whose type (a subprogram type) has a
+ -- return type that is compatible with the context. Analysis of
+ -- the node has established that one exists.
- Get_First_Interp (Subp, I, It);
Nam := Empty;
+ Get_First_Interp (Subp, I, It);
while Present (It.Typ) loop
-
if Covers (Typ, Etype (It.Typ)) then
Nam := It.Typ;
exit;
Resolve (Subp, Nam);
end if;
- -- If this is a procedure call which is really an entry call, do
- -- the conversion of the procedure call to an entry call. Protected
- -- operations use the same circuitry because the name in the call
- -- can be an arbitrary expression with special resolution rules.
+ -- For an indirect call, we always invalidate checks, since we do not
+ -- know whether the subprogram is local or global. Yes we could do
+ -- better here, e.g. by knowing that there are no local subprograms,
+ -- but it does not seem worth the effort. Similarly, we kill 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.
elsif Nkind (Subp) = N_Selected_Component
or else Nkind (Subp) = N_Indexed_Component
then
Resolve_Entry_Call (N, Typ);
Check_Elab_Call (N);
+
+ -- Kill checks and constant values, as above for indirect case
+ -- Who knows what happens when another task is activated?
+
+ Kill_Current_Values;
return;
-- Normal subprogram call with name established in Resolve
else
pragma Assert (Is_Overloaded (Subp));
- Nam := Empty; -- We know that it will be assigned in loop below.
+ Nam := Empty; -- We know that it will be assigned in loop below
Get_First_Interp (Subp, I, It);
-
while Present (It.Typ) loop
if Covers (Typ, It.Typ) then
Nam := It.Nam;
P := Parent (P);
exit when No (P);
- if Nkind (P) = N_Entry_Body then
+ 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 ('R'M C.7(17))",
+ ("& should not be used in entry body ('R'M 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);
exit;
end if;
end loop;
end;
end if;
- -- Check that a procedure call does not occur in the context
- -- of the entry call statement of a conditional or timed
- -- entry call. Note that the case of a call to a subprogram
- -- renaming of an entry will also be rejected. The test
- -- for N not being an N_Entry_Call_Statement is defensive,
- -- covering the possibility that the processing of entry
- -- calls might reach this point due to later modifications
- -- of the code above.
+ -- Cannot call thread body directly
+
+ if Is_Thread_Body (Nam) then
+ Error_Msg_N ("cannot call thread body directly", N);
+ end if;
+
+ -- Check that a procedure call does not occur in the context of the
+ -- entry call statement of a conditional or timed entry call. Note that
+ -- the case of a call to a subprogram renaming of an entry will also be
+ -- rejected. The test for N not being an N_Entry_Call_Statement is
+ -- defensive, covering the possibility that the processing of entry
+ -- calls might reach this point due to later modifications of the code
+ -- above.
if Nkind (Parent (N)) = N_Entry_Call_Alternative
and then Nkind (N) /= N_Entry_Call_Statement
and then Entry_Call_Statement (Parent (N)) = N
then
- Error_Msg_N ("entry call required in select statement", N);
+ if Ada_Version < Ada_05 then
+ Error_Msg_N ("entry call required in select statement", N);
+
+ -- Ada 2005 (AI-345): If a procedure_call_statement is used
+ -- for a procedure_or_entry_call, the procedure_name or pro-
+ -- cedure_prefix of the procedure_call_statement shall denote
+ -- an entry renamed by a procedure, or (a view of) a primitive
+ -- subprogram of a limited interface whose first parameter is
+ -- a controlling parameter.
+
+ elsif Nkind (N) = N_Procedure_Call_Statement
+ and then not Is_Renamed_Entry (Nam)
+ and then not Is_Controlling_Limited_Procedure (Nam)
+ then
+ Error_Msg_N
+ ("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.
+
+ if Ekind (Current_Scope) = E_Function
+ and then Ekind (Scope (Current_Scope)) = E_Protected_Type
+ and then Ekind (Nam) /= E_Function
+ and then Scope (Nam) = Scope (Current_Scope)
+ then
+ Error_Msg_N ("within protected function, protected " &
+ "object is constant", N);
+ Error_Msg_N ("\cannot call operation that may modify it", N);
end if;
- -- Freeze the subprogram name if not in default expression. Note
- -- that we freeze procedure calls as well as function calls.
- -- Procedure calls are not frozen according to the rules (RM
- -- 13.14(14)) because it is impossible to have a procedure call to
- -- a non-frozen procedure in pure Ada, but in the code that we
- -- generate in the expander, this rule needs extending because we
- -- can generate procedure calls that need freezing.
+ -- Freeze the subprogram name if not in default expression. Note that we
+ -- freeze procedure calls as well as function calls. Procedure calls are
+ -- not frozen according to the rules (RM 13.14(14)) because it is
+ -- impossible to have a procedure call to a non-frozen procedure in pure
+ -- Ada, but in the code that we generate in the expander, this rule
+ -- needs extending because we can generate procedure calls that need
+ -- freezing.
if Is_Entity_Name (Subp) and then not In_Default_Expression then
Freeze_Expression (Subp);
end if;
- -- For a predefined operator, the type of the result is the type
- -- imposed by context, except for a predefined operation on universal
- -- fixed. Otherwise The type of the call is the type returned by the
- -- subprogram being called.
+ -- For a predefined operator, the type of the result is the type imposed
+ -- by context, except for a predefined operation on universal fixed.
+ -- Otherwise The type of the call is the type returned by the subprogram
+ -- being called.
if Is_Predefined_Op (Nam) then
-
if Etype (N) /= Universal_Fixed then
Set_Etype (N, Typ);
end if;
- -- If the subprogram returns an array type, and the context
- -- requires the component type of that array type, the node is
- -- really an indexing of the parameterless call. Resolve as such.
+ -- If the subprogram returns an array type, and the context requires the
+ -- component type of that array type, the node is really an indexing of
+ -- the parameterless call. Resolve as such. A pathological case occurs
+ -- when the type of the component is an access to the array type. In
+ -- this case the call is truly ambiguous.
elsif Needs_No_Actuals (Nam)
and then
then
declare
Index_Node : Node_Id;
+ New_Subp : Node_Id;
+ Ret_Type : constant Entity_Id := Etype (Nam);
begin
-
- if Component_Type (Etype (Nam)) /= Any_Type then
- Index_Node :=
- Make_Indexed_Component (Loc,
- Prefix =>
- Make_Function_Call (Loc,
- Name => New_Occurrence_Of (Nam, Loc)),
- Expressions => Parameter_Associations (N));
-
- -- Since we are correcting a node classification error made by
- -- the parser, we call Replace rather than Rewrite.
-
- Replace (N, Index_Node);
- Set_Etype (Prefix (N), Etype (Nam));
- Set_Etype (N, Typ);
- Resolve_Indexed_Component (N, Typ);
- Check_Elab_Call (Prefix (N));
+ if Is_Access_Type (Ret_Type)
+ and then Ret_Type = Component_Type (Designated_Type (Ret_Type))
+ then
+ Error_Msg_N
+ ("cannot disambiguate function call and indexing", N);
+ else
+ New_Subp := Relocate_Node (Subp);
+ Set_Entity (Subp, Nam);
+
+ if Component_Type (Ret_Type) /= Any_Type then
+ Index_Node :=
+ Make_Indexed_Component (Loc,
+ Prefix =>
+ Make_Function_Call (Loc,
+ Name => New_Subp),
+ Expressions => Parameter_Associations (N));
+
+ -- Since we are correcting a node classification error made
+ -- by the parser, we call Replace rather than Rewrite.
+
+ Replace (N, Index_Node);
+ Set_Etype (Prefix (N), Ret_Type);
+ Set_Etype (N, Typ);
+ Resolve_Indexed_Component (N, Typ);
+ Check_Elab_Call (Prefix (N));
+ end if;
end if;
return;
Set_Is_Overloaded (Subp, False);
Set_Is_Overloaded (N, False);
- -- If we are calling the current subprogram from immediately within
- -- its body, then that is the case where we can sometimes detect
- -- cases of infinite recursion statically. Do not try this in case
- -- restriction No_Recursion is in effect anyway.
+ -- If we are calling the current subprogram from immediately within its
+ -- body, then that is the case where we can sometimes detect cases of
+ -- infinite recursion statically. Do not try this in case restriction
+ -- No_Recursion is in effect anyway.
Scop := Current_Scope;
if Nam = Scop
- and then not Restrictions (No_Recursion)
+ and then not Restriction_Active (No_Recursion)
and then Check_Infinite_Recursion (N)
then
-- Here we detected and flagged an infinite recursion, so we do
-- the case of a possible run-time detectable infinite recursion.
else
- while Scop /= Standard_Standard loop
+ Scope_Loop : while Scop /= Standard_Standard loop
if Nam = Scop then
+
-- Although in general recursion is not statically checkable,
-- the case of calling an immediately containing subprogram
-- is easy to catch.
Check_Restriction (No_Recursion, N);
- -- If the recursive call is to a parameterless procedure, then
+ -- If the recursive call is to a parameterless subprogram, then
-- even if we can't statically detect infinite recursion, this
-- is pretty suspicious, and we output a warning. Furthermore,
-- we will try later to detect some cases here at run time by
-- expanding checking code (see Detect_Infinite_Recursion in
-- package Exp_Ch6).
+
-- If the recursive call is within a handler we do not emit a
-- warning, because this is a common idiom: loop until input
-- is correct, catch illegal input in handler and restart.
and then not Error_Posted (N)
and then Nkind (Parent (N)) /= N_Exception_Handler
then
+ -- For the case of a procedure call. We give the message
+ -- only if the call is the first statement in a sequence of
+ -- statements, or if all previous statements are simple
+ -- assignments. This is simply a heuristic to decrease false
+ -- positives, without losing too many good warnings. The
+ -- idea is that these previous statements may affect global
+ -- variables the procedure depends on.
+
+ if Nkind (N) = N_Procedure_Call_Statement
+ and then Is_List_Member (N)
+ then
+ declare
+ P : Node_Id;
+ begin
+ P := Prev (N);
+ while Present (P) loop
+ if Nkind (P) /= N_Assignment_Statement then
+ exit Scope_Loop;
+ end if;
+
+ Prev (P);
+ end loop;
+ end;
+ end if;
+
+ -- Do not give warning if we are in a conditional context
+
+ declare
+ 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);
+ Error_Msg_N ("\Storage_Error may be raised at run time?", N);
end if;
- exit;
+ exit Scope_Loop;
end if;
Scop := Scope (Scop);
- end loop;
+ end loop Scope_Loop;
end if;
-- If subprogram name is a predefined operator, it was given in
return;
end if;
- -- Create a transient scope if the resulting type requires it.
- -- There are 3 notable exceptions: in init_procs, the transient scope
+ -- Create a transient scope if the resulting type requires it
+
+ -- There are 3 notable exceptions: in init procs, the transient scope
-- overhead is not needed and even incorrect due to the actual expansion
-- of adjust calls; the second case is enumeration literal pseudo calls,
-- the other case is intrinsic subprograms (Unchecked_Conversion and
-- If this is an initialization call for a type whose initialization
-- uses the secondary stack, we also need to create a transient scope
- -- for it, precisely because we will not do it within the init_proc
+ -- for it, precisely because we will not do it within the init proc
-- itself.
- if Expander_Active
+ -- If the subprogram is marked Inlined_Always, then even if it returns
+ -- an unconstrained type the call does not require use of the secondary
+ -- stack.
+
+ if Is_Inlined (Nam)
+ and then Present (First_Rep_Item (Nam))
+ and then Nkind (First_Rep_Item (Nam)) = N_Pragma
+ and then Chars (First_Rep_Item (Nam)) = Name_Inline_Always
+ then
+ null;
+
+ elsif Expander_Active
and then Is_Type (Etype (Nam))
and then Requires_Transient_Scope (Etype (Nam))
and then Ekind (Nam) /= E_Enumeration_Literal
Establish_Transient_Scope
(N, Sec_Stack => not Functions_Return_By_DSP_On_Target);
- elsif Chars (Nam) = Name_uInit_Proc
+ -- If the call appears within the bounds of a loop, it will
+ -- be rewritten and reanalyzed, nothing left to do here.
+
+ if Nkind (N) /= N_Function_Call then
+ return;
+ end if;
+
+ elsif Is_Init_Proc (Nam)
and then not Within_Init_Proc
then
Check_Initialization_Call (N, Nam);
Copy_Node (Subp, N);
Resolve_Entity_Name (N, Typ);
- -- Avoid validation, since it is a static function call.
+ -- Avoid validation, since it is a static function call
return;
end if;
+ -- 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.
+
+ -- Note: we do not do this step till after resolving the actuals. That
+ -- way we still take advantage of the current value information while
+ -- scanning the actuals.
+
+ if not Is_Library_Level_Entity (Nam)
+ 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 the subprogram is a primitive operation, check whether or not
-- it is a correct dispatching call.
Check_Intrinsic_Call (N);
end if;
- -- If we fall through we definitely have a non-static call
-
+ Eval_Call (N);
Check_Elab_Call (N);
-
end Resolve_Call;
-------------------------------
Set_Etype (N, B_Typ);
Eval_Character_Literal (N);
- -- Wide_Character literals must always be defined, since the set of
- -- wide character literals is complete, i.e. if a character literal
- -- is accepted by the parser, then it is OK for wide character.
+ -- Wide_Wide_Character literals must always be defined, since the set
+ -- of wide wide character literals is complete, i.e. if a character
+ -- literal is accepted by the parser, then it is OK for wide wide
+ -- character (out of range character literals are rejected).
- if Root_Type (B_Typ) = Standard_Wide_Character then
+ if Root_Type (B_Typ) = Standard_Wide_Wide_Character then
return;
-- Always accept character literal for type Any_Character, which
-- the literal is in range
elsif Root_Type (B_Typ) = Standard_Character then
- if In_Character_Range (Char_Literal_Value (N)) then
+ if In_Character_Range (UI_To_CC (Char_Literal_Value (N))) then
+ return;
+ end if;
+
+ -- For Standard.Wide_Character or a type derived from it, check
+ -- that the literal is in range
+
+ elsif Root_Type (B_Typ) = Standard_Wide_Character then
+ if In_Wide_Character_Range (UI_To_CC (Char_Literal_Value (N))) then
return;
end if;
+ -- For Standard.Wide_Wide_Character or a type derived from it, we
+ -- know the literal is in range, since the parser checked!
+
+ elsif Root_Type (B_Typ) = Standard_Wide_Wide_Character then
+ return;
+
-- If the entity is already set, this has already been resolved in
-- a generic context, or comes from expansion. Nothing else to do.
else
C := Current_Entity (N);
-
while Present (C) loop
if Etype (C) = B_Typ then
Set_Entity_With_Style_Check (N, C);
Error_Msg_NE
("character not defined for }", N, First_Subtype (B_Typ));
-
end Resolve_Character_Literal;
---------------------------
---------------------------
-- Context requires a boolean type, and plays no role in resolution.
- -- Processing identical to that for equality operators.
+ -- Processing identical to that for equality operators. The result
+ -- type is the base type, which matters when pathological subtypes of
+ -- booleans with limited ranges are used.
procedure Resolve_Comparison_Op (N : Node_Id; Typ : Entity_Id) is
L : constant Node_Id := Left_Opnd (N);
if Scope (Entity (N)) /= Standard_Standard then
T := Etype (First_Entity (Entity (N)));
+
else
T := Find_Unique_Type (L, R);
end if;
end if;
- Set_Etype (N, Typ);
+ Set_Etype (N, Base_Type (Typ));
Generate_Reference (T, N, ' ');
if T /= Any_Type then
-
if T = Any_String
or else T = Any_Composite
or else T = Any_Character
return;
else
- if Comes_From_Source (N)
- and then Has_Unchecked_Union (T)
- then
- Error_Msg_N
- ("cannot compare Unchecked_Union values", N);
- end if;
-
Resolve (L, T);
Resolve (R, T);
Check_Unset_Reference (L);
Check_Unset_Reference (R);
- Generate_Operator_Reference (N);
+ Generate_Operator_Reference (N, T);
Eval_Relational_Op (N);
end if;
end if;
-
end Resolve_Comparison_Op;
------------------------------------
-- away if either bounds of R are a Constraint_Error.
declare
- L : Node_Id := Low_Bound (R);
- H : Node_Id := High_Bound (R);
+ L : constant Node_Id := Low_Bound (R);
+ H : constant Node_Id := High_Bound (R);
begin
if Nkind (L) = N_Raise_Constraint_Error then
null;
else
Error_Msg_N
- ("Invalid use of subtype mark in expression or call", N);
+ ("invalid use of subtype mark in expression or call", N);
end if;
-- Check discriminant use if entity is discriminant in current scope,
Error_Msg_N ("illegal use of generic function", N);
elsif Ekind (E) = E_Out_Parameter
- and then Ada_83
+ and then Ada_Version = Ada_83
and then (Nkind (Parent (N)) in N_Op
or else (Nkind (Parent (N)) = N_Assignment_Statement
and then N = Expression (Parent (N)))
-----------------------
function Actual_Index_Type (E : Entity_Id) return Entity_Id is
- Typ : Entity_Id := Entry_Index_Type (E);
- Tsk : Entity_Id := Scope (E);
- Lo : Node_Id := Type_Low_Bound (Typ);
- Hi : Node_Id := Type_High_Bound (Typ);
+ Typ : constant Entity_Id := Entry_Index_Type (E);
+ Tsk : constant Entity_Id := Scope (E);
+ Lo : constant Node_Id := Type_Low_Bound (Typ);
+ Hi : constant Node_Id := Type_High_Bound (Typ);
New_T : Entity_Id;
function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id;
-----------------------------
function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id is
- Typ : Entity_Id := Etype (Bound);
+ Typ : constant Entity_Id := Etype (Bound);
Ref : Node_Id;
begin
-- the type in the same declarative part.
Tsk := Next_Entity (S);
-
while Etype (Tsk) /= S loop
Next_Entity (Tsk);
end loop;
-- protected type.
declare
- Pref : Node_Id := Prefix (Entry_Name);
+ Pref : constant Node_Id := Prefix (Entry_Name);
+ Ent : constant Entity_Id := Entity (Selector_Name (Entry_Name));
I : Interp_Index;
It : Interp;
- Ent : Entity_Id := Entity (Selector_Name (Entry_Name));
begin
Get_First_Interp (Pref, I, It);
-
while Present (It.Typ) loop
-
if Scope (Ent) = It.Typ then
Set_Etype (Pref, It.Typ);
exit;
end if;
if Nkind (Entry_Name) = N_Selected_Component then
- Resolve (Prefix (Entry_Name), Etype (Prefix (Entry_Name)));
+ Resolve (Prefix (Entry_Name));
else pragma Assert (Nkind (Entry_Name) = N_Indexed_Component);
Nam := Entity (Selector_Name (Prefix (Entry_Name)));
- Resolve (Prefix (Prefix (Entry_Name)),
- Etype (Prefix (Prefix (Entry_Name))));
-
+ Resolve (Prefix (Prefix (Entry_Name)));
Index := First (Expressions (Entry_Name));
Resolve (Index, Entry_Index_Type (Nam));
Apply_Range_Check (Index, Actual_Index_Type (Nam));
end if;
end if;
-
end Resolve_Entry;
------------------------
Was_Over : Boolean;
begin
+ -- We kill all checks here, because it does not seem worth the
+ -- effort to do anything better, an entry call is a big operation.
+
+ Kill_All_Checks;
+
-- Processing of the name is similar for entry calls and protected
-- operation calls. Once the entity is determined, we can complete
-- the resolution of the actuals.
begin
Get_First_Interp (Selector_Name (Entry_Name), I, It);
-
while Present (It.Typ) loop
-
if Covers (Typ, It.Typ) then
Set_Entity (Selector_Name (Entry_Name), It.Nam);
Set_Etype (Entry_Name, It.Typ);
if Nkind (Entry_Name) = N_Selected_Component then
- -- Simple entry call.
+ -- Simple entry call
Nam := Entity (Selector_Name (Entry_Name));
Obj := Prefix (Entry_Name);
else pragma Assert (Nkind (Entry_Name) = N_Indexed_Component);
- -- Call to member of entry family.
+ -- Call to member of entry family
Nam := Entity (Selector_Name (Prefix (Entry_Name)));
Obj := Prefix (Prefix (Entry_Name));
Was_Over := Is_Overloaded (Selector_Name (Prefix (Entry_Name)));
end if;
+ -- We cannot in general check the maximum depth of protected entry
+ -- calls at compile time. But we can tell that any protected entry
+ -- call at all violates a specified nesting depth of zero.
+
+ if Is_Protected_Type (Scope (Nam)) then
+ Check_Restriction (Max_Entry_Queue_Length, N);
+ end if;
+
-- Use context type to disambiguate a protected function that can be
-- called without actuals and that returns an array type, and where
-- the argument list may be an indexing of the returned value.
end if;
-- The operation name may have been overloaded. Order the actuals
- -- according to the formals of the resolved entity.
+ -- according to the formals of the resolved entity, and set the
+ -- return type to that of the operation.
if Was_Over then
Normalize_Actuals (N, Nam, False, Norm_OK);
pragma Assert (Norm_OK);
+ Set_Etype (N, Etype (Nam));
end if;
Resolve_Actuals (N, Nam);
-- call where an entry call is expected.
if Ekind (Nam) = E_Procedure then
-
if Nkind (Parent (N)) = N_Entry_Call_Alternative
and then N = Entry_Call_Statement (Parent (N))
then
elsif Ekind (Scope (Nam)) = E_Task_Type
and then not In_Open_Scopes (Scope (Nam))
then
- Error_Msg_N ("Task has no entry with this name", Entry_Name);
+ Error_Msg_N ("task has no entry with this name", Entry_Name);
end if;
end if;
Set_Analyzed (N, True);
-- Protected functions can return on the secondary stack, in which
- -- case we must trigger the transient scope mechanism
+ -- case we must trigger the transient scope mechanism.
elsif Expander_Active
and then Requires_Transient_Scope (Etype (Nam))
Establish_Transient_Scope (N,
Sec_Stack => not Functions_Return_By_DSP_On_Target);
end if;
-
end Resolve_Entry_Call;
-------------------------
function Find_Unique_Access_Type return Entity_Id is
Acc : Entity_Id;
E : Entity_Id;
- S : Entity_Id := Current_Scope;
+ S : Entity_Id;
begin
if Ekind (Etype (R)) = E_Allocator_Type then
return Empty;
end if;
+ S := Current_Scope;
while S /= Standard_Standard loop
E := First_Entity (S);
-
while Present (E) loop
-
if Is_Type (E)
and then Is_Access_Type (E)
and then Ekind (E) /= E_Allocator_Type
end if;
if T /= Any_Type then
-
if T = Any_String
or else T = Any_Composite
or else T = Any_Character
then
-
if T = Any_Character then
Ambiguous_Character (L);
else
end if;
end if;
- if Comes_From_Source (N)
- and then Has_Unchecked_Union (T)
+ Resolve (L, T);
+ Resolve (R, T);
+
+ if Warn_On_Redundant_Constructs
+ and then Comes_From_Source (N)
+ and then Is_Entity_Name (R)
+ and then Entity (R) = Standard_True
+ and then Comes_From_Source (R)
then
- Error_Msg_N
- ("cannot compare Unchecked_Union values", N);
+ Error_Msg_N ("comparison with True is redundant?", R);
end if;
- Resolve (L, T);
- Resolve (R, T);
Check_Unset_Reference (L);
Check_Unset_Reference (R);
- Generate_Operator_Reference (N);
+ Generate_Operator_Reference (N, T);
-- If this is an inequality, it may be the implicit inequality
-- created for a user-defined operation, in which case the corres-
then
Error_Msg_NE ("cannot call abstract subprogram &!", N, Entity (N));
end if;
+
+ -- Ada 2005: If one operand is an anonymous access type, convert
+ -- the other operand to it, to ensure that the underlying types
+ -- match in the back-end.
+ -- We apply the same conversion in the case one of the operands is
+ -- a private subtype of the type of the other.
+
+ if Expander_Active
+ and then (Ekind (T) = E_Anonymous_Access_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;
----------------------------------
procedure Resolve_Explicit_Dereference (N : Node_Id; Typ : Entity_Id) is
- P : constant Node_Id := Prefix (N);
- I : Interp_Index;
- It : Interp;
+ Loc : constant Source_Ptr := Sloc (N);
+ New_N : Node_Id;
+ P : constant Node_Id := Prefix (N);
+ I : Interp_Index;
+ It : Interp;
begin
- -- Now that we know the type, check that this is not a
- -- dereference of an uncompleted type. Note that this
- -- is not entirely correct, because dereferences of
- -- private types are legal in default expressions.
- -- This consideration also applies to similar checks
- -- for allocators, qualified expressions, and type
- -- conversions. ???
-
- Check_Fully_Declared (Typ, N);
+ Check_Fully_Declared_Prefix (Typ, P);
if Is_Overloaded (P) then
- -- Use the context type to select the prefix that has the
- -- correct designated type.
+ -- Use the context type to select the prefix that has the correct
+ -- designated type.
Get_First_Interp (P, I, It);
while Present (It.Typ) loop
exit when Is_Access_Type (It.Typ)
and then Covers (Typ, Designated_Type (It.Typ));
-
Get_Next_Interp (I, It);
end loop;
- Resolve (P, It.Typ);
+ if Present (It.Typ) then
+ Resolve (P, It.Typ);
+ else
+ -- If no interpretation covers the designated type of the prefix,
+ -- this is the pathological case where not all implementations of
+ -- the prefix allow the interpretation of the node as a call. Now
+ -- that the expected type is known, Remove other interpretations
+ -- from prefix, rewrite it as a call, and resolve again, so that
+ -- the proper call node is generated.
+
+ Get_First_Interp (P, I, It);
+ while Present (It.Typ) loop
+ if Ekind (It.Typ) /= E_Access_Subprogram_Type then
+ Remove_Interp (I);
+ end if;
+
+ Get_Next_Interp (I, It);
+ end loop;
+
+ New_N :=
+ Make_Function_Call (Loc,
+ Name =>
+ Make_Explicit_Dereference (Loc,
+ Prefix => P),
+ Parameter_Associations => New_List);
+
+ Save_Interps (N, New_N);
+ Rewrite (N, New_N);
+ Analyze_And_Resolve (N, Typ);
+ return;
+ end if;
+
Set_Etype (N, Designated_Type (It.Typ));
else
- Resolve (P, Etype (P));
+ Resolve (P);
end if;
if Is_Access_Type (Etype (P)) then
Apply_Access_Check (N);
end if;
- -- If the designated type is a packed unconstrained array type,
- -- and the explicit dereference is not in the context of an
- -- attribute reference, then we must compute and set the actual
- -- subtype, since it is needed by Gigi. The reason we exclude
- -- the attribute case is that this is handled fine by Gigi, and
- -- in fact we use such attributes to build the actual subtype.
- -- We also exclude generated code (which builds actual subtypes
- -- directly if they are needed).
+ -- If the designated type is a packed unconstrained array type, and the
+ -- explicit dereference is not in the context of an attribute reference,
+ -- then we must compute and set the actual subtype, since it is needed
+ -- by Gigi. The reason we exclude the attribute case is that this is
+ -- handled fine by Gigi, and in fact we use such attributes to build the
+ -- actual subtype. We also exclude generated code (which builds actual
+ -- subtypes directly if they are needed).
if Is_Array_Type (Etype (N))
and then Is_Packed (Etype (N))
Set_Etype (N, Get_Actual_Subtype (N));
end if;
- -- Note: there is no Eval processing required for an explicit
- -- deference, because the type is known to be an allocators, and
- -- allocator expressions can never be static.
+ -- Note: there is no Eval processing required for an explicit deference,
+ -- because the type is known to be an allocators, and allocator
+ -- expressions can never be static.
end Resolve_Explicit_Dereference;
begin
if Is_Overloaded (Name) then
- -- Use the context type to select the prefix that yields the
- -- correct component type.
+ -- Use the context type to select the prefix that yields the correct
+ -- component type.
declare
I : Interp_Index;
begin
Get_First_Interp (P, I, It);
-
while Present (It.Typ) loop
-
if (Is_Array_Type (It.Typ)
and then Covers (Typ, Component_Type (It.Typ)))
or else (Is_Access_Type (It.Typ)
Array_Type := Designated_Type (Array_Type);
end if;
- -- If name was overloaded, set component type correctly now.
+ -- If name was overloaded, set component type correctly now
Set_Etype (N, Component_Type (Array_Type));
Index := First_Index (Array_Type);
Expr := First (Expressions (N));
- -- The prefix may have resolved to a string literal, in which case
- -- its etype has a special representation. This is only possible
- -- currently if the prefix is a static concatenation, written in
- -- functional notation.
+ -- The prefix may have resolved to a string literal, in which case its
+ -- etype has a special representation. This is only possible currently
+ -- if the prefix is a static concatenation, written in functional
+ -- notation.
if Ekind (Array_Type) = E_String_Literal_Subtype then
Resolve (Expr, Standard_Positive);
end loop;
end if;
+ Warn_On_Suspicious_Index (Name, First (Expressions (N)));
Eval_Indexed_Component (N);
-
end Resolve_Indexed_Component;
-----------------------------
Eval_Integer_Literal (N);
end Resolve_Integer_Literal;
- ---------------------------------
- -- Resolve_Intrinsic_Operator --
- ---------------------------------
+ --------------------------------
+ -- Resolve_Intrinsic_Operator --
+ --------------------------------
procedure Resolve_Intrinsic_Operator (N : Node_Id; Typ : Entity_Id) is
- Op : Entity_Id;
- Arg1 : Node_Id := Left_Opnd (N);
- Arg2 : Node_Id := Right_Opnd (N);
+ Btyp : constant Entity_Id := Base_Type (Underlying_Type (Typ));
+ Op : Entity_Id;
+ Arg1 : Node_Id;
+ Arg2 : Node_Id;
begin
Op := Entity (N);
-
while Scope (Op) /= Standard_Standard loop
Op := Homonym (Op);
pragma Assert (Present (Op));
end loop;
Set_Entity (N, Op);
+ Set_Is_Overloaded (N, False);
- if Typ /= Etype (Arg1) or else Typ = Etype (Arg2) then
- Rewrite (Left_Opnd (N), Convert_To (Typ, Arg1));
- Rewrite (Right_Opnd (N), Convert_To (Typ, Arg2));
+ -- If the operand type is private, rewrite with suitable conversions on
+ -- the operands and the result, to expose the proper underlying numeric
+ -- type.
- Analyze (Left_Opnd (N));
- Analyze (Right_Opnd (N));
- end if;
+ if Is_Private_Type (Typ) then
+ Arg1 := Unchecked_Convert_To (Btyp, Left_Opnd (N));
+
+ if Nkind (N) = N_Op_Expon then
+ Arg2 := Unchecked_Convert_To (Standard_Integer, Right_Opnd (N));
+ else
+ Arg2 := Unchecked_Convert_To (Btyp, Right_Opnd (N));
+ end if;
+
+ Save_Interps (Left_Opnd (N), Expression (Arg1));
+ Save_Interps (Right_Opnd (N), Expression (Arg2));
+
+ Set_Left_Opnd (N, Arg1);
+ Set_Right_Opnd (N, Arg2);
+
+ Set_Etype (N, Btyp);
+ Rewrite (N, Unchecked_Convert_To (Typ, N));
+ Resolve (N, Typ);
+
+ elsif Typ /= Etype (Left_Opnd (N))
+ or else Typ /= Etype (Right_Opnd (N))
+ then
+ -- Add explicit conversion where needed, and save interpretations
+ -- in case operands are overloaded.
+
+ Arg1 := Convert_To (Typ, Left_Opnd (N));
+ Arg2 := Convert_To (Typ, Right_Opnd (N));
+
+ if Nkind (Arg1) = N_Type_Conversion then
+ Save_Interps (Left_Opnd (N), Expression (Arg1));
+ else
+ Save_Interps (Left_Opnd (N), Arg1);
+ end if;
+
+ if Nkind (Arg2) = N_Type_Conversion then
+ Save_Interps (Right_Opnd (N), Expression (Arg2));
+ else
+ Save_Interps (Right_Opnd (N), Arg2);
+ end if;
- Resolve_Arithmetic_Op (N, Typ);
+ Rewrite (Left_Opnd (N), Arg1);
+ Rewrite (Right_Opnd (N), Arg2);
+ Analyze (Arg1);
+ Analyze (Arg2);
+ Resolve_Arithmetic_Op (N, Typ);
+
+ else
+ Resolve_Arithmetic_Op (N, Typ);
+ end if;
end Resolve_Intrinsic_Operator;
+ --------------------------------------
+ -- Resolve_Intrinsic_Unary_Operator --
+ --------------------------------------
+
+ procedure Resolve_Intrinsic_Unary_Operator
+ (N : Node_Id;
+ Typ : Entity_Id)
+ is
+ Btyp : constant Entity_Id := Base_Type (Underlying_Type (Typ));
+ Op : Entity_Id;
+ Arg2 : Node_Id;
+
+ begin
+ Op := Entity (N);
+ while Scope (Op) /= Standard_Standard loop
+ Op := Homonym (Op);
+ pragma Assert (Present (Op));
+ end loop;
+
+ Set_Entity (N, Op);
+
+ if Is_Private_Type (Typ) then
+ Arg2 := Unchecked_Convert_To (Btyp, Right_Opnd (N));
+ Save_Interps (Right_Opnd (N), Expression (Arg2));
+
+ Set_Right_Opnd (N, Arg2);
+
+ Set_Etype (N, Btyp);
+ Rewrite (N, Unchecked_Convert_To (Typ, N));
+ Resolve (N, Typ);
+
+ else
+ Resolve_Unary_Op (N, Typ);
+ end if;
+ end Resolve_Intrinsic_Unary_Operator;
+
------------------------
-- Resolve_Logical_Op --
------------------------
procedure Resolve_Logical_Op (N : Node_Id; Typ : Entity_Id) is
B_Typ : Entity_Id;
+ N_Opr : constant Node_Kind := Nkind (N);
begin
- -- Predefined operations on scalar types yield the base type. On
- -- the other hand, logical operations on arrays yield the type of
- -- the arguments (and the context).
+ -- Predefined operations on scalar types yield the base type. On the
+ -- other hand, logical operations on arrays yield the type of the
+ -- arguments (and the context).
if Is_Array_Type (Typ) then
B_Typ := Typ;
Check_Unset_Reference (Right_Opnd (N));
Set_Etype (N, B_Typ);
- Generate_Operator_Reference (N);
+ Generate_Operator_Reference (N, B_Typ);
Eval_Logical_Op (N);
+
+ -- Check for violation of restriction No_Direct_Boolean_Operators
+ -- if the operator was not eliminated by the Eval_Logical_Op call.
+
+ if Nkind (N) = N_Opr
+ and then Root_Type (Etype (Left_Opnd (N))) = Standard_Boolean
+ then
+ Check_Restriction (No_Direct_Boolean_Operators, N);
+ end if;
end Resolve_Logical_Op;
---------------------------
and then Is_Overloaded (L)
then
T := Etype (R);
+
+ -- Ada 2005 (AI-251): Give support to the following case:
+
+ -- type I is interface;
+ -- type T is tagged ...
+
+ -- function Test (O : I'Class) is
+ -- begin
+ -- return O in T'Class.
+ -- end Test;
+
+ -- In this case we have nothing else to do; the membership test will be
+ -- done at run-time.
+
+ elsif Ada_Version >= Ada_05
+ and then Is_Class_Wide_Type (Etype (L))
+ and then Is_Interface (Etype (L))
+ and then Is_Class_Wide_Type (Etype (R))
+ and then not Is_Interface (Etype (R))
+ then
+ return;
+
else
T := Intersect_Types (L, R);
end if;
procedure Resolve_Null (N : Node_Id; Typ : Entity_Id) is
begin
- -- For now allow circumvention of the restriction against
- -- anonymous null access values via a debug switch to allow
- -- for easier transition.
+ -- Handle restriction against anonymous null access values This
+ -- restriction can be turned off using -gnatdh.
+
+ -- Ada 2005 (AI-231): Remove restriction
- if not Debug_Flag_J
+ if Ada_Version < Ada_05
+ and then not Debug_Flag_J
and then Ekind (Typ) = E_Anonymous_Access_Type
and then Comes_From_Source (N)
then
return;
end if;
- -- The null literal takes its type from the context.
+ -- The null literal takes its type from the context
Set_Etype (N, Typ);
end Resolve_Null;
and then Has_Compatible_Type (Arg, Typ)
and then Etype (Arg) /= Any_Type
then
- Error_Msg_N ("ambiguous operand for concatenation!", Arg);
declare
- I : Interp_Index;
- It : Interp;
+ I : Interp_Index;
+ It : Interp;
+ Func : Entity_Id;
begin
Get_First_Interp (Arg, I, It);
+ Func := It.Nam;
+ Get_Next_Interp (I, It);
- while Present (It.Nam) loop
+ -- Special-case the error message when the overloading
+ -- is caused by a function that yields and array and
+ -- can be called without parameters.
- if Base_Type (Etype (It.Nam)) = Base_Type (Typ)
- or else Base_Type (Etype (It.Nam)) =
- Base_Type (Component_Type (Typ))
- then
+ if It.Nam = Func then
+ Error_Msg_Sloc := Sloc (Func);
+ Error_Msg_N ("\ambiguous call to function#", Arg);
+ Error_Msg_NE
+ ("\\interpretation as call yields&", Arg, Typ);
+ Error_Msg_NE
+ ("\\interpretation as indexing of call yields&",
+ Arg, Component_Type (Typ));
+
+ else
+ Error_Msg_N
+ ("ambiguous operand for concatenation!", Arg);
+ Get_First_Interp (Arg, I, It);
+ while Present (It.Nam) loop
Error_Msg_Sloc := Sloc (It.Nam);
- Error_Msg_N ("\possible interpretation#", Arg);
- end if;
- Get_Next_Interp (I, It);
- end loop;
+ if Base_Type (It.Typ) = Base_Type (Typ)
+ or else Base_Type (It.Typ) =
+ Base_Type (Component_Type (Typ))
+ then
+ Error_Msg_N ("\\possible interpretation#", Arg);
+ end if;
+
+ Get_Next_Interp (I, It);
+ end loop;
+ end if;
end;
end if;
Resolve (Arg, Component_Type (Typ));
+ if Nkind (Arg) = N_String_Literal then
+ Set_Etype (Arg, Component_Type (Typ));
+ end if;
+
if Arg = Left_Opnd (N) then
Set_Is_Component_Left_Opnd (N);
else
if Is_Limited_Composite (Btyp) then
Error_Msg_N ("concatenation not available for limited array", N);
+ Explain_Limited_Type (Btyp, N);
end if;
- -- If the operands are themselves concatenations, resolve them as
- -- such directly. This removes several layers of recursion and allows
- -- GNAT to handle larger multiple concatenations.
+ -- If the operands are themselves concatenations, resolve them as such
+ -- directly. This removes several layers of recursion and allows GNAT to
+ -- handle larger multiple concatenations.
if Nkind (Op1) = N_Op_Concat
and then not Is_Array_Type (Component_Type (Typ))
(Op2, Is_Component_Right_Opnd (N));
end if;
- Generate_Operator_Reference (N);
+ Generate_Operator_Reference (N, Typ);
if Is_String_Type (Typ) then
Eval_Concatenation (N);
begin
-- Catch attempts to do fixed-point exponentation with universal
- -- operands, which is a case where the illegality is not caught
- -- during normal operator analysis.
+ -- operands, which is a case where the illegality is not caught during
+ -- normal operator analysis.
if Is_Fixed_Point_Type (Typ) and then Comes_From_Source (N) then
Error_Msg_N ("exponentiation not available for fixed point", N);
return;
end if;
+ if Comes_From_Source (N)
+ and then Ekind (Entity (N)) = E_Function
+ and then Is_Imported (Entity (N))
+ and then Is_Intrinsic_Subprogram (Entity (N))
+ then
+ Resolve_Intrinsic_Operator (N, Typ);
+ return;
+ end if;
+
if Etype (Left_Opnd (N)) = Universal_Integer
or else Etype (Left_Opnd (N)) = Universal_Real
then
Check_Unset_Reference (Right_Opnd (N));
Set_Etype (N, B_Typ);
- Generate_Operator_Reference (N);
+ Generate_Operator_Reference (N, B_Typ);
Eval_Op_Expon (N);
-- Set overflow checking bit. Much cleverer code needed here eventually
if Nkind (N) in N_Op then
if not Overflow_Checks_Suppressed (Etype (N)) then
- Set_Do_Overflow_Check (N, True);
+ Enable_Overflow_Check (N);
end if;
end if;
-
end Resolve_Op_Expon;
--------------------
-- 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;
-- Start of processing for Resolve_Op_Not
begin
- -- Predefined operations on scalar types yield the base type. On
- -- the other hand, logical operations on arrays yield the type of
- -- the arguments (and the context).
+ -- Predefined operations on scalar types yield the base type. On the
+ -- other hand, logical operations on arrays yield the type of the
+ -- arguments (and the context).
if Is_Array_Type (Typ) then
B_Typ := Typ;
B_Typ := Base_Type (Typ);
end if;
+ -- Straigtforward 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;
- elsif (Typ = Universal_Integer
- or else Typ = Any_Modular)
- then
+ -- Special case of probable missing parens
+
+ elsif Typ = Universal_Integer or else Typ = Any_Modular then
if Parent_Is_Boolean then
Error_Msg_N
("operand of not must be enclosed in parentheses",
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);
Resolve (Right_Opnd (N), B_Typ);
Check_Unset_Reference (Right_Opnd (N));
Set_Etype (N, B_Typ);
- Generate_Operator_Reference (N);
+ Generate_Operator_Reference (N, B_Typ);
Eval_Op_Not (N);
end if;
end Resolve_Op_Not;
Resolve (Expr, Target_Typ);
-- A qualified expression requires an exact match of the type,
- -- class-wide matching is not allowed.
-
- if Is_Class_Wide_Type (Target_Typ)
+ -- class-wide matching is not allowed. However, if the qualifying
+ -- type is specific and the expression has a class-wide type, it
+ -- may still be okay, since it can be the result of the expansion
+ -- of a call to a dispatching function, so we also have to check
+ -- class-wideness of the type of the expression's original node.
+
+ if (Is_Class_Wide_Type (Target_Typ)
+ or else
+ (Is_Class_Wide_Type (Etype (Expr))
+ and then Is_Class_Wide_Type (Etype (Original_Node (Expr)))))
and then Base_Type (Etype (Expr)) /= Base_Type (Target_Typ)
then
Wrong_Type (Expr, Target_Typ);
Check_Unset_Reference (H);
-- We have to check the bounds for being within the base range as
- -- required for a non-static context. Normally this is automatic
- -- and done as part of evaluating expressions, but the N_Range
- -- node is an exception, since in GNAT we consider this node to
- -- be a subexpression, even though in Ada it is not. The circuit
- -- in Sem_Eval could check for this, but that would put the test
- -- on the main evaluation path for expressions.
+ -- required for a non-static context. Normally this is automatic and
+ -- done as part of evaluating expressions, but the N_Range node is an
+ -- exception, since in GNAT we consider this node to be a subexpression,
+ -- even though in Ada it is not. The circuit in Sem_Eval could check for
+ -- this, but that would put the test on the main evaluation path for
+ -- expressions.
Check_Non_Static_Context (L);
Check_Non_Static_Context (H);
+ -- If bounds are static, constant-fold them, so size computations
+ -- are identical between front-end and back-end. Do not perform this
+ -- transformation while analyzing generic units, as type information
+ -- would then be lost when reanalyzing the constant node in the
+ -- instance.
+
+ if Is_Discrete_Type (Typ) and then Expander_Active then
+ if Is_OK_Static_Expression (L) then
+ Fold_Uint (L, Expr_Value (L), Is_Static_Expression (L));
+ end if;
+
+ if Is_OK_Static_Expression (H) then
+ Fold_Uint (H, Expr_Value (H), Is_Static_Expression (H));
+ end if;
+ end if;
end Resolve_Range;
--------------------------
Error_Msg_N ("value has extraneous low order digits", N);
end if;
+ -- Generate a warning if literal from source
+
+ if Is_Static_Expression (N)
+ and then Warn_On_Bad_Fixed_Value
+ then
+ Error_Msg_N
+ ("static fixed-point value is not a multiple of Small?",
+ N);
+ end if;
+
-- Replace literal by a value that is the exact representation
-- of a value of the type, i.e. a multiple of the small value,
-- by truncation, since Machine_Rounds is false for all GNAT
-- result in transformations of normal assignments into reference
-- sequences that otherwise fail to notice the modification.
- if Is_Entity_Name (P) and then Is_Volatile (Entity (P)) then
+ if Is_Entity_Name (P) and then Treat_As_Volatile (Entity (P)) then
Note_Possible_Modification (P);
end if;
end Resolve_Reference;
function Init_Component return Boolean;
-- Check whether this is the initialization of a component within an
- -- init_proc (by assignment or call to another init_proc). If true,
+ -- init proc (by assignment or call to another init proc). If true,
-- there is no need for a discriminant check.
--------------------
if Is_Record_Type (T) then
Comp := First_Entity (T);
-
while Present (Comp) loop
-
if Chars (Comp) = Chars (S)
and then Covers (Etype (Comp), Typ)
then
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
end if;
Get_Next_Interp (I, It);
-
end loop Search;
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 prefix with its type
Resolve (P, T);
end if;
- -- Deal with access type case
+ -- Generate cross-reference. We needed to wait until full overloading
+ -- resolution was complete to do this, since otherwise we can't tell if
+ -- we are an Lvalue of not.
+
+ 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
- Apply_Access_Check (N);
T := Designated_Type (Etype (P));
+ Check_Fully_Declared_Prefix (T, P);
else
T := Etype (P);
end if;
if Has_Discriminants (T)
+ and then (Ekind (Entity (S)) = E_Component
+ or else
+ Ekind (Entity (S)) = E_Discriminant)
and then Present (Original_Record_Component (Entity (S)))
and then Ekind (Original_Record_Component (Entity (S))) = E_Component
and then Present (Discriminant_Checking_Func
if Nkind (P) = N_Type_Conversion
and then Ekind (Entity (S)) = E_Discriminant
+ and then Is_Discrete_Type (Typ)
then
Set_Etype (N, Base_Type (Typ));
end if;
Check_Unset_Reference (R);
Set_Etype (N, B_Typ);
- Generate_Operator_Reference (N);
+ Generate_Operator_Reference (N, B_Typ);
Eval_Shift (N);
end Resolve_Shift;
begin
Get_First_Interp (P, I, It);
-
while Present (It.Typ) loop
-
if (Is_Array_Type (It.Typ)
and then Covers (Typ, It.Typ))
or else (Is_Access_Type (It.Typ)
Apply_Access_Check (N);
Array_Type := Designated_Type (Array_Type);
+ -- If the prefix is an access to an unconstrained array, we must use
+ -- the actual subtype of the object to perform the index checks. The
+ -- object denoted by the prefix is implicit in the node, so we build
+ -- an explicit representation for it in order to compute the actual
+ -- subtype.
+
+ if not Is_Constrained (Array_Type) then
+ Remove_Side_Effects (Prefix (N));
+
+ declare
+ Obj : constant Node_Id :=
+ Make_Explicit_Dereference (Sloc (N),
+ Prefix => New_Copy_Tree (Prefix (N)));
+ begin
+ Set_Etype (Obj, Array_Type);
+ Set_Parent (Obj, Parent (N));
+ Array_Type := Get_Actual_Subtype (Obj);
+ end;
+ end if;
+
elsif Is_Entity_Name (Name)
or else (Nkind (Name) = N_Function_Call
and then not Is_Constrained (Etype (Name)))
Set_Etype (N, Array_Type);
- -- If the range is specified by a subtype mark, no resolution
- -- is necessary.
+ -- 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);
end if;
Set_Slice_Subtype (N);
- Eval_Slice (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 Nkind (Parent (N)) /= N_Op_Concat
or else (N /= Left_Opnd (Parent (N))
and then N /= Right_Opnd (Parent (N)))
- or else (Typ = Standard_Wide_String
+ or else ((Typ = Standard_Wide_String
+ or else Typ = Standard_Wide_Wide_String)
and then Nkind (Original_Node (N)) /= N_String_Literal);
-- If the resolving type is itself a string literal subtype, we
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
- -- literal into a full fledged aggregate.
+ -- If the type is bit-packed, then we always tranform the string literal
+ -- into a full fledged aggregate.
elsif Is_Bit_Packed_Array (Typ) then
null;
- -- Deal with cases of Wide_String and String
+ -- Deal with cases of Wide_Wide_String, Wide_String, and String
else
- -- For Standard.Wide_String, or any other type whose component
- -- type is Standard.Wide_Character, we know that all the
+ -- For Standard.Wide_Wide_String, or any other type whose component
+ -- type is Standard.Wide_Wide_Character, we know that all the
-- characters in the string must be acceptable, since the parser
-- accepted the characters as valid character literals.
- if R_Typ = Standard_Wide_Character then
+ if R_Typ = Standard_Wide_Wide_Character then
null;
- -- For the case of Standard.String, or any other type whose
- -- component type is Standard.Character, we must make sure that
- -- there are no wide characters in the string, i.e. that it is
- -- entirely composed of characters in range of type String.
+ -- 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
-- a token, right under the offending wide character.
Error_Msg
- ("literal out of range of type Character",
+ ("literal out of range of type Standard.Character",
Source_Ptr (Int (Loc) + J));
return;
end if;
end loop;
- -- If the root type is not a standard character, then we will convert
- -- the string into an aggregate and will let the aggregate code do
- -- the checking.
-
- else
- null;
+ -- For the case of Standard.Wide_String, or any other type whose
+ -- component type is Standard.Wide_Character, we must make sure that
+ -- there are no wide characters in the string, i.e. that it is
+ -- entirely composed of characters in range of type Wide_Character.
- end if;
+ -- 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.
- -- 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
+ elsif R_Typ = Standard_Wide_Character
+ and then Nkind (Original_Node (N)) /= N_Op_Concat
+ then
+ for J in 1 .. Strlen loop
+ if not In_Wide_Character_Range (Get_String_Char (Str, J)) then
+
+ -- If we are out of range, post error. This is one of the
+ -- very few places that we place the flag in the middle of
+ -- a token, right under the offending wide character.
+
+ -- This is not quite right, because characters in general
+ -- will take more than one character position ???
+
+ Error_Msg
+ ("literal out of range of type Standard.Wide_Character",
+ Source_Ptr (Int (Loc) + J));
+ return;
+ end if;
+ end loop;
+
+ -- If the root type is not a standard character, then we will convert
+ -- the string into an aggregate and will let the aggregate code do
+ -- the checking. Standard Wide_Wide_Character is also OK here.
+
+ else
+ 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
-- code do the checking.
- if R_Typ = Standard_Wide_Character
- or else R_Typ = Standard_Character
+ if R_Typ = Standard_Character
+ or else R_Typ = Standard_Wide_Character
+ or else R_Typ = Standard_Wide_Wide_Character
then
-- Check for the case of full range, where we are definitely OK
-- heavy artillery for this situation, but it is hard work to avoid.
declare
- Lits : List_Id := New_List;
+ Lits : constant List_Id := New_List;
P : Source_Ptr := Loc + 1;
C : Char_Code;
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);
Set_Character_Literal_Name (C);
Append_To (Lits,
- Make_Character_Literal (P, Name_Find, C));
+ Make_Character_Literal (P,
+ Chars => Name_Find,
+ Char_Literal_Value => UI_From_CC (C)));
if In_Character_Range (C) then
P := P + 1;
-----------------------------
procedure Resolve_Type_Conversion (N : Node_Id; Typ : Entity_Id) is
- Target_Type : constant Entity_Id := Etype (N);
- Conv_OK : constant Boolean := Conversion_OK (N);
+ Conv_OK : constant Boolean := Conversion_OK (N);
+ Target_Type : Entity_Id := Etype (N);
Operand : Node_Id;
Opnd_Type : Entity_Id;
Rop : Node_Id;
+ Orig_N : Node_Id;
+ Orig_T : Node_Id;
begin
Operand := Expression (N);
and then (Etype (Right_Opnd (Operand)) = Universal_Real
or else Etype (Left_Opnd (Operand)) = Universal_Real)
then
+ -- Return if expression is ambiguous
+
if Unique_Fixed_Point_Type (N) = Any_Type then
- return; -- expression is ambiguous.
+ return;
+
+ -- If nothing else, the available fixed type is Duration
+
else
Set_Etype (Operand, Standard_Duration);
end if;
+ -- Resolve the real operand with largest available precision
+
if Etype (Right_Opnd (Operand)) = Universal_Real then
Rop := New_Copy_Tree (Right_Opnd (Operand));
else
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
+ -- is potentially inaccurate.
- if Realval (Rop) /= Ureal_0
+ if Nkind (Rop) = N_Real_Literal
+ and then Realval (Rop) /= Ureal_0
and then abs (Realval (Rop)) < Delta_Value (Standard_Duration)
then
- Error_Msg_N ("universal real operand can only be interpreted?",
- 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)
+ and then Nkind (Operand) in N_Op
+ and then Unique_Fixed_Point_Type (N) /= Any_Type
+ then
+ Set_Etype (Operand, Standard_Duration);
+
else
Error_Msg_N ("invalid context for mixed mode operation", N);
Set_Etype (Operand, Any_Type);
end if;
Opnd_Type := Etype (Operand);
- Resolve (Operand, Opnd_Type);
+ Resolve (Operand);
-- Note: we do the Eval_Type_Conversion call before applying the
-- required checks for a subtype conversion. This is important,
end if;
-- Issue warning for conversion of simple object to its own type
+ -- We have to test the original nodes, since they may have been
+ -- rewritten by various optimizations.
+
+ Orig_N := Original_Node (N);
if Warn_On_Redundant_Constructs
- and then Comes_From_Source (N)
- and then Nkind (N) = N_Type_Conversion
- and then Is_Entity_Name (Expression (N))
- and then Etype (Entity (Expression (N))) = Target_Type
+ and then Comes_From_Source (Orig_N)
+ and then Nkind (Orig_N) = N_Type_Conversion
+ and then not In_Instance
then
- Error_Msg_NE
- ("?useless conversion, & has this type",
- N, Entity (Expression (N)));
+ Orig_N := Original_Node (Expression (Orig_N));
+ Orig_T := Target_Type;
+
+ -- If the node is part of a larger expression, the Target_Type
+ -- may not be the original type of the node if the context is a
+ -- condition. Recover original type to see if conversion is needed.
+
+ if Is_Boolean_Type (Orig_T)
+ and then Nkind (Parent (N)) in N_Op
+ then
+ Orig_T := Etype (Parent (N));
+ end if;
+
+ if Is_Entity_Name (Orig_N)
+ and then Etype (Entity (Orig_N)) = Orig_T
+ then
+ Error_Msg_NE
+ ("?useless conversion, & has this type", N, Entity (Orig_N));
+ end if;
+ end if;
+
+ -- Ada 2005 (AI-251): Handle conversions to abstract interface types
+
+ if Ada_Version >= Ada_05 and then Expander_Active then
+ if Is_Access_Type (Target_Type) then
+ Target_Type := Directly_Designated_Type (Target_Type);
+ end if;
+
+ if Is_Class_Wide_Type (Target_Type) then
+ Target_Type := Etype (Target_Type);
+ end if;
+
+ if Is_Interface (Target_Type) then
+ if Is_Access_Type (Opnd_Type) then
+ Opnd_Type := Directly_Designated_Type (Opnd_Type);
+ end if;
+
+ if Is_Class_Wide_Type (Opnd_Type) then
+ Opnd_Type := Etype (Opnd_Type);
+ end if;
+
+ -- Handle subtypes
+
+ if Ekind (Opnd_Type) = E_Protected_Subtype
+ or else Ekind (Opnd_Type) = E_Task_Subtype
+ then
+ Opnd_Type := Etype (Opnd_Type);
+ end if;
+
+ if not Interface_Present_In_Ancestor
+ (Typ => Opnd_Type,
+ Iface => Target_Type)
+ then
+ -- The static analysis is not enough to know if the interface
+ -- is implemented or not. Hence we must pass the work to the
+ -- expander to generate the required code to evaluate the
+ -- conversion at run-time.
+
+ Expand_Interface_Conversion (N, Is_Static => False);
+
+ else
+ Expand_Interface_Conversion (N);
+ end if;
+
+ -- Ada 2005 (AI-251): Conversion from a class-wide interface to a
+ -- tagged type
+
+ elsif Is_Class_Wide_Type (Opnd_Type)
+ and then Is_Interface (Opnd_Type)
+ then
+ Expand_Interface_Conversion (N, Is_Static => False);
+ end if;
end if;
end Resolve_Type_Conversion;
----------------------
procedure Resolve_Unary_Op (N : Node_Id; Typ : Entity_Id) is
- B_Typ : Entity_Id := Base_Type (Typ);
- R : constant Node_Id := Right_Opnd (N);
+ B_Typ : constant Entity_Id := Base_Type (Typ);
+ R : constant Node_Id := Right_Opnd (N);
+ OK : Boolean;
+ Lo : Uint;
+ Hi : Uint;
begin
-- Generate warning for expressions like -5 mod 3
- if Paren_Count (N) = 0
- and then Nkind (N) = N_Op_Minus
- and then Nkind (Right_Opnd (N)) = N_Op_Mod
+ if Warn_On_Questionable_Missing_Parens
+ and then Paren_Count (N) = 0
+ and then (Nkind (N) = N_Op_Minus or else Nkind (N) = N_Op_Plus)
+ and then Paren_Count (Right_Opnd (N)) = 0
+ and then Nkind (Right_Opnd (N)) in N_Multiplying_Operator
+ and then Comes_From_Source (N)
then
Error_Msg_N
("?unary minus expression should be parenthesized here", N);
end if;
+ if Comes_From_Source (N)
+ and then Ekind (Entity (N)) = E_Function
+ and then Is_Imported (Entity (N))
+ and then Is_Intrinsic_Subprogram (Entity (N))
+ then
+ Resolve_Intrinsic_Unary_Operator (N, Typ);
+ return;
+ end if;
+
if Etype (R) = Universal_Integer
- or else Etype (R) = Universal_Real
+ or else Etype (R) = Universal_Real
then
Check_For_Visible_Operator (N, B_Typ);
end if;
Set_Etype (N, B_Typ);
Resolve (R, B_Typ);
+
+ -- Generate warning for expressions like abs (x mod 2)
+
+ if Warn_On_Redundant_Constructs
+ and then Nkind (N) = N_Op_Abs
+ then
+ Determine_Range (Right_Opnd (N), OK, Lo, Hi);
+
+ if OK and then Hi >= Lo and then Lo >= 0 then
+ Error_Msg_N
+ ("?abs applied to known non-negative value has no effect", N);
+ end if;
+ end if;
+
Check_Unset_Reference (R);
- Generate_Operator_Reference (N);
+ Generate_Operator_Reference (N, B_Typ);
Eval_Unary_Op (N);
-- Set overflow checking bit. Much cleverer code needed here eventually
if Nkind (N) in N_Op then
if not Overflow_Checks_Suppressed (Etype (N)) then
- Set_Do_Overflow_Check (N, True);
+ Enable_Overflow_Check (N);
end if;
end if;
-
end Resolve_Unary_Op;
----------------------------------
Opnd_Type : constant Entity_Id := Etype (Operand);
begin
- -- Resolve operand using its own type.
+ -- Resolve operand using its own type
Resolve (Operand, Opnd_Type);
Eval_Unchecked_Conversion (N);
------------------------------
procedure Rewrite_Operator_As_Call (N : Node_Id; Nam : Entity_Id) is
- Loc : Source_Ptr := Sloc (N);
- Actuals : List_Id := New_List;
+ Loc : constant Source_Ptr := Sloc (N);
+ Actuals : constant List_Id := New_List;
New_N : Node_Id;
begin
-- Rewrite_Renamed_Operator --
------------------------------
- procedure Rewrite_Renamed_Operator (N : Node_Id; Op : Entity_Id) is
+ procedure Rewrite_Renamed_Operator
+ (N : Node_Id;
+ Op : Entity_Id;
+ Typ : Entity_Id)
+ is
Nam : constant Name_Id := Chars (Op);
Is_Binary : constant Boolean := Nkind (N) in N_Binary_Op;
Op_Node : Node_Id;
begin
- if Chars (N) /= Nam then
-
- -- Rewrite the operator node using the real operator, not its
- -- renaming.
+ -- Rewrite the operator node using the real operator, not its
+ -- renaming. Exclude user-defined intrinsic operations of the same
+ -- name, which are treated separately and rewritten as calls.
+ if Ekind (Op) /= E_Function
+ or else Chars (N) /= Nam
+ then
Op_Node := New_Node (Operator_Kind (Nam, Is_Binary), Sloc (N));
Set_Chars (Op_Node, Nam);
Set_Etype (Op_Node, Etype (N));
Set_Entity (Op_Node, Op);
Set_Right_Opnd (Op_Node, Right_Opnd (N));
+ -- Indicate that both the original entity and its renaming
+ -- are referenced at this point.
+
+ Generate_Reference (Entity (N), N);
Generate_Reference (Op, N);
if Is_Binary then
end if;
Rewrite (N, Op_Node);
+
+ -- If the context type is private, add the appropriate conversions
+ -- so that the operator is applied to the full view. This is done
+ -- in the routines that resolve intrinsic operators,
+
+ if Is_Intrinsic_Subprogram (Op)
+ and then Is_Private_Type (Typ)
+ then
+ case Nkind (N) is
+ when N_Op_Add | N_Op_Subtract | N_Op_Multiply | N_Op_Divide |
+ N_Op_Expon | N_Op_Mod | N_Op_Rem =>
+ Resolve_Intrinsic_Operator (N, Typ);
+
+ when N_Op_Plus | N_Op_Minus | N_Op_Abs =>
+ Resolve_Intrinsic_Unary_Operator (N, Typ);
+
+ when others =>
+ Resolve (N, Typ);
+ end case;
+ end if;
+
+ elsif Ekind (Op) = E_Function
+ and then Is_Intrinsic_Subprogram (Op)
+ then
+ -- Operator renames a user-defined operator of the same name. Use
+ -- the original operator in the node, which is the one that gigi
+ -- knows about.
+
+ Set_Entity (N, Op);
+ Set_Is_Overloaded (N, False);
end if;
end Rewrite_Renamed_Operator;
procedure Set_Slice_Subtype (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
+ Index_List : constant List_Id := New_List;
Index : Node_Id;
- Index_List : List_Id := New_List;
Index_Subtype : Entity_Id;
Index_Type : Entity_Id;
Slice_Subtype : Entity_Id;
--------------------------------
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;
- 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);
+ 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 (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 subtypes for the string, and wrap it in an
+ -- unchecked conversion, because the backend expects the
+ -- String_Literal_Subtype to have a static lower bound.
- Set_Etype (N, Subtype_Id);
+ 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, Low_Bound, High_Bound);
+ Set_Scalar_Range (Index_Subtype, Drange);
+ Set_Parent (Drange, N);
+ Analyze_And_Resolve (Drange, Index_Type);
+
+ Set_Etype (Index_Subtype, Index_Type);
+ Set_Size_Info (Index_Subtype, Index_Type);
+ Set_RM_Size (Index_Subtype, RM_Size (Index_Type));
+
+ 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);
+ Init_Size_Align (Array_Subtype);
+
+ 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;
-----------------------------
Scop : Entity_Id;
procedure Fixed_Point_Error;
- -- If true ambiguity, give details.
+ -- If true ambiguity, give details
+
+ -----------------------
+ -- Fixed_Point_Error --
+ -----------------------
procedure Fixed_Point_Error is
begin
Error_Msg_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
+
begin
-- The operations on Duration are visible, so Duration is always a
-- possible interpretation.
T1 := Standard_Duration;
- Scop := Current_Scope;
-
- -- Look for fixed-point types in enclosing scopes.
+ -- Look for fixed-point types in enclosing scopes
+ Scop := Current_Scope;
while Scop /= Standard_Standard loop
T2 := First_Entity (Scop);
-
while Present (T2) loop
if Is_Fixed_Point_Type (T2)
and then Current_Entity (T2) = T2
Scop := Scope (Scop);
end loop;
- -- Look for visible fixed type declarations in the context.
+ -- Look for visible fixed type declarations in the context
Item := First (Context_Items (Cunit (Current_Sem_Unit)));
-
while Present (Item) loop
-
if Nkind (Item) = N_With_Clause then
Scop := Entity (Name (Item));
T2 := First_Entity (Scop);
-
while Present (T2) loop
if Is_Fixed_Point_Type (T2)
and then Scope (Base_Type (T2)) = Scop
function Valid_Conversion
(N : Node_Id;
Target : Entity_Id;
- Operand : Node_Id)
- return Boolean
+ Operand : Node_Id) return Boolean
is
- Target_Type : Entity_Id := Base_Type (Target);
+ Target_Type : constant Entity_Id := Base_Type (Target);
Opnd_Type : Entity_Id := Etype (Operand);
function Conversion_Check
(Valid : Boolean;
- Msg : String)
- return Boolean;
+ Msg : String) return Boolean;
-- Little routine to post Msg if Valid is False, returns Valid value
function Valid_Tagged_Conversion
(Target_Type : Entity_Id;
- Opnd_Type : Entity_Id)
- return Boolean;
+ Opnd_Type : Entity_Id) return Boolean;
-- Specifically test for validity of tagged conversions
+ function 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 --
----------------------
function Conversion_Check
(Valid : Boolean;
- Msg : String)
- return Boolean
+ Msg : String) return Boolean
is
begin
if not Valid then
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
+
+ if 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 if;
+
+ return True;
+ end Valid_Array_Conversion;
+
-----------------------------
-- Valid_Tagged_Conversion --
-----------------------------
function Valid_Tagged_Conversion
(Target_Type : Entity_Id;
- Opnd_Type : Entity_Id)
- return Boolean
+ Opnd_Type : Entity_Id) return Boolean
is
begin
- -- Upward conversions are allowed (RM 4.6(22)).
+ -- Upward conversions are allowed (RM 4.6(22))
if Covers (Target_Type, Opnd_Type)
or else Is_Ancestor (Target_Type, Opnd_Type)
then
return True;
- -- Downward conversion are allowed if the operand is
- -- is class-wide (RM 4.6(23)).
+ -- Downward conversion are allowed if the operand is class-wide
+ -- (RM 4.6(23)).
elsif Is_Class_Wide_Type (Opnd_Type)
and then Covers (Opnd_Type, Target_Type)
return
Conversion_Check (False,
"downward conversion of tagged objects not allowed");
+
+ -- Ada 2005 (AI-251): The conversion of a tagged type to an
+ -- abstract interface type is always valid
+
+ elsif Is_Interface (Target_Type) then
+ return True;
+
+ elsif Is_Access_Type (Opnd_Type)
+ and then Is_Interface (Directly_Designated_Type (Opnd_Type))
+ then
+ return True;
+
else
Error_Msg_NE
("invalid tagged conversion, not compatible with}",
-- in this context, but which cannot be removed by type checking,
-- because the context does not impose a type.
+ -- When compiling for VMS, spurious ambiguities can be produced
+ -- when arithmetic operations have a literal operand and return
+ -- System.Address or a descendant of it. These ambiguities are
+ -- otherwise resolved by the context, but for conversions there
+ -- is no context type and the removal of the spurious operations
+ -- must be done explicitly here.
+
+ -- 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 ("\\possible interpretation#!", Operand);
Error_Msg_Sloc := Sloc (N1);
- Error_Msg_N ("possible interpretation#!", Operand);
+ Error_Msg_N ("\\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;
+
+ -- Also no need to check when in an instance or inlined body, because
+ -- the legality has been established when the template was analyzed.
+ -- Furthermore, numeric conversions may occur where only a private
+ -- view of the operand type is visible at the instanciation point.
+ -- 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;
+ else
+ return Valid_Array_Conversion;
+ end if;
- elsif Number_Dimensions (Target_Type) /=
- Number_Dimensions (Opnd_Type)
- then
- Error_Msg_N
- ("incompatible number of dimensions for conversion", Operand);
- return False;
+ -- Anonymous access types where target references an interface
- else
- declare
- Target_Index : Node_Id := First_Index (Target_Type);
- Opnd_Index : Node_Id := First_Index (Opnd_Type);
+ elsif (Ekind (Target_Type) = E_General_Access_Type
+ or else
+ Ekind (Target_Type) = E_Anonymous_Access_Type)
+ and then Is_Interface (Directly_Designated_Type (Target_Type))
+ then
+ -- Check the static accessibility rule of 4.6(17). Note that the
+ -- check is not enforced when within an instance body, since the RM
+ -- requires such cases to be caught at run time.
- Target_Index_Type : Entity_Id;
- Opnd_Index_Type : Entity_Id;
+ if Ekind (Target_Type) /= E_Anonymous_Access_Type then
+ if Type_Access_Level (Opnd_Type) >
+ Type_Access_Level (Target_Type)
+ then
+ -- In an instance, this is a run-time check, but one we know
+ -- will fail, so generate an appropriate warning. The raise
+ -- will be generated by Expand_N_Type_Conversion.
- Target_Comp_Type : Entity_Id := Component_Type (Target_Type);
- Opnd_Comp_Type : Entity_Id := Component_Type (Opnd_Type);
+ if In_Instance_Body then
+ Error_Msg_N
+ ("?cannot convert local pointer to non-local access type",
+ Operand);
+ Error_Msg_N
+ ("\?Program_Error will be raised at run time", Operand);
+ else
+ Error_Msg_N
+ ("cannot convert local pointer to non-local access type",
+ Operand);
+ return False;
+ end if;
- 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
+ -- Special accessibility checks are needed in the case of access
+ -- discriminants declared for a limited type.
+
+ elsif Ekind (Opnd_Type) = E_Anonymous_Access_Type
+ and then not Is_Local_Anonymous_Access (Opnd_Type)
+ then
+ -- When the operand is a selected access discriminant the check
+ -- needs to be made against the level of the object denoted by
+ -- the prefix of the selected name. (Object_Access_Level
+ -- handles checking the prefix of the operand for this case.)
+
+ if Nkind (Operand) = N_Selected_Component
+ and then Object_Access_Level (Operand) >
+ Type_Access_Level (Target_Type)
+ then
+ -- In an instance, this is a run-time check, but one we
+ -- know will fail, so generate an appropriate warning.
+ -- The raise will be generated by Expand_N_Type_Conversion.
+
+ if In_Instance_Body then
Error_Msg_N
- ("incompatible index types for array conversion",
- Operand);
+ ("?cannot convert access discriminant to non-local" &
+ " access type", Operand);
+ Error_Msg_N
+ ("\?Program_Error will be raised at run time", Operand);
+ else
+ Error_Msg_N
+ ("cannot convert access discriminant to non-local" &
+ " access type", Operand);
return False;
end if;
+ end if;
- Next_Index (Target_Index);
- Next_Index (Opnd_Index);
- end loop;
+ -- The case of a reference to an access discriminant from
+ -- within a limited type declaration (which will appear as
+ -- a discriminal) is always illegal because the level of the
+ -- discriminant is considered to be deeper than any (namable)
+ -- access type.
- if Base_Type (Target_Comp_Type) /=
- Base_Type (Opnd_Comp_Type)
+ if Is_Entity_Name (Operand)
+ and then not Is_Local_Anonymous_Access (Opnd_Type)
+ and then (Ekind (Entity (Operand)) = E_In_Parameter
+ or else Ekind (Entity (Operand)) = E_Constant)
+ and then Present (Discriminal_Link (Entity (Operand)))
then
Error_Msg_N
- ("incompatible component types for array conversion",
+ ("discriminant has deeper accessibility level than target",
Operand);
return False;
-
- elsif
- Is_Constrained (Target_Comp_Type)
- /= Is_Constrained (Opnd_Comp_Type)
- or else not Subtypes_Statically_Match
- (Target_Comp_Type, Opnd_Comp_Type)
- then
- Error_Msg_N
- ("component subtypes must statically match", Operand);
- return False;
-
end if;
- end;
+ end if;
end if;
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
return False;
end if;
- -- Check the static accessibility rule of 4.6(17). Note that
- -- the check is not enforced when within an instance body, since
- -- the RM requires such cases to be caught at run time.
+ -- Check the static accessibility rule of 4.6(17). Note that the
+ -- check is not enforced when within an instance body, since the RM
+ -- requires such cases to be caught at run time.
- if Ekind (Target_Type) /= E_Anonymous_Access_Type then
+ if Ekind (Target_Type) /= E_Anonymous_Access_Type
+ or else Is_Local_Anonymous_Access (Target_Type)
+ then
if Type_Access_Level (Opnd_Type)
> Type_Access_Level (Target_Type)
then
("?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
return False;
end if;
- elsif Ekind (Opnd_Type) = E_Anonymous_Access_Type then
+ -- Special accessibility checks are needed in the case of access
+ -- discriminants declared for a limited type.
+
+ elsif Ekind (Opnd_Type) = E_Anonymous_Access_Type
+ and then not Is_Local_Anonymous_Access (Opnd_Type)
+ then
- -- When the operand is a selected access discriminant
- -- the check needs to be made against the level of the
- -- object denoted by the prefix of the selected name.
- -- (Object_Access_Level handles checking the prefix
- -- of the operand for this case.)
+ -- When the operand is a selected access discriminant the check
+ -- needs to be made against the level of the object denoted by
+ -- the prefix of the selected name. (Object_Access_Level
+ -- handles checking the prefix of the operand for this case.)
if Nkind (Operand) = N_Selected_Component
and then Object_Access_Level (Operand)
("?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
end if;
end if;
- -- The case of a reference to an access discriminant
- -- from within a type declaration (which will appear
- -- as a discriminal) is always illegal because the
- -- level of the discriminant is considered to be
- -- deeper than any (namable) access type.
+ -- The case of a reference to an access discriminant from
+ -- within a limited type declaration (which will appear as
+ -- a discriminal) is always illegal because the level of the
+ -- discriminant is considered to be deeper than any (namable)
+ -- access type.
if Is_Entity_Name (Operand)
and then (Ekind (Entity (Operand)) = E_In_Parameter
N, Base_Type (Opnd));
return False;
- elsif not Subtypes_Statically_Match (Target, Opnd)
- and then (not Has_Discriminants (Target)
- or else Is_Constrained (Target))
+ -- Ada 2005 AI-384: legality rule is symmetric in both
+ -- designated types. The conversion is legal (with possible
+ -- constraint check) if either designated type is
+ -- unconstrained.
+
+ elsif Subtypes_Statically_Match (Target, Opnd)
+ or else
+ (Has_Discriminants (Target)
+ and then
+ (not Is_Constrained (Opnd)
+ or else not Is_Constrained (Target)))
then
+ return True;
+
+ else
Error_Msg_NE
("target designated subtype not compatible with }",
N, Opnd);
return False;
-
- else
- return True;
end if;
end if;
end;
- elsif Ekind (Target_Type) = E_Access_Subprogram_Type
+ -- Subprogram access types
+
+ elsif (Ekind (Target_Type) = E_Access_Subprogram_Type
+ or else
+ Ekind (Target_Type) = E_Anonymous_Access_Subprogram_Type)
+ and then No (Corresponding_Remote_Type (Opnd_Type))
and then Conversion_Check
(Ekind (Base_Type (Opnd_Type)) = E_Access_Subprogram_Type,
"illegal operand for access subprogram conversion")
then
-- Check that the designated types are subtype conformant
- if not Subtype_Conformant (Designated_Type (Opnd_Type),
- Designated_Type (Target_Type))
- then
- Error_Msg_N
- ("operand type is not subtype conformant with target type",
- Operand);
- end if;
+ Check_Subtype_Conformant (New_Id => Designated_Type (Target_Type),
+ Old_Id => Designated_Type (Opnd_Type),
+ Err_Loc => N);
-- Check the static accessibility rule of 4.6(20)
O_Gen : constant Node_Id :=
Enclosing_Generic_Body (Opnd_Type);
- T_Gen : Node_Id :=
- Enclosing_Generic_Body (Target_Type);
+ T_Gen : Node_Id;
begin
+ T_Gen := Enclosing_Generic_Body (Target_Type);
while Present (T_Gen) and then T_Gen /= O_Gen loop
T_Gen := Enclosing_Generic_Body (T_Gen);
end loop;
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;
+ -- Tagged types
+
elsif Is_Tagged_Type (Target_Type) then
return Valid_Tagged_Conversion (Target_Type, Opnd_Type);
- -- Types derived from the same root type are convertible.
+ -- Types derived from the same root type are convertible
elsif Root_Type (Target_Type) = Root_Type (Opnd_Type) then
return True;
OSDN Git Service
