-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2008, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
with Sem_Ch13; use Sem_Ch13;
with Sem_Disp; use Sem_Disp;
with Sem_Dist; use Sem_Dist;
+with Sem_Elim; use Sem_Elim;
with Sem_Elab; use Sem_Elab;
with Sem_Eval; use Sem_Eval;
with Sem_Intr; use Sem_Intr;
with Stand; use Stand;
with Stringt; use Stringt;
with Style; use Style;
-with Targparm; use Targparm;
with Tbuild; use Tbuild;
with Uintp; use Uintp;
with Urealp; use Urealp;
-- initialization of individual components within the init proc itself.
-- Could be optimized away perhaps?
+ procedure Check_No_Direct_Boolean_Operators (N : Node_Id);
+ -- N is the node for a logical operator. If the operator is predefined, and
+ -- the root type of the operands is Standard.Boolean, then a check is made
+ -- for restriction No_Direct_Boolean_Operators. This procedure also handles
+ -- the style check for Style_Check_Boolean_And_Or.
+
function Is_Definite_Access_Type (E : Entity_Id) return Boolean;
-- Determine whether E is an access type declared by an access
-- declaration, and not an (anonymous) allocator type.
elsif Ada_Version >= Ada_05
and then Is_Entity_Name (Pref)
+ and then Is_Access_Type (Etype (Pref))
and then Ekind (Directly_Designated_Type (Etype (Pref))) =
E_Incomplete_Type
and then Is_Tagged_Type (Directly_Designated_Type (Etype (Pref)))
end if;
end Check_Initialization_Call;
+ ---------------------------------------
+ -- Check_No_Direct_Boolean_Operators --
+ ---------------------------------------
+
+ procedure Check_No_Direct_Boolean_Operators (N : Node_Id) is
+ begin
+ if Scope (Entity (N)) = Standard_Standard
+ and then Root_Type (Etype (Left_Opnd (N))) = Standard_Boolean
+ then
+ -- Restriction only applies to original source code
+
+ if Comes_From_Source (N) then
+ Check_Restriction (No_Direct_Boolean_Operators, N);
+ end if;
+ end if;
+
+ if Style_Check then
+ Check_Boolean_Operator (N);
+ end if;
+ end Check_No_Direct_Boolean_Operators;
+
------------------------------
-- Check_Parameterless_Call --
------------------------------
and then (Ekind (Entity (N)) /= E_Enumeration_Literal
or else Is_Overloaded (N)))
- -- Rewrite as call if it is an explicit deference of an expression of
+ -- Rewrite as call if it is an explicit dereference of an expression of
-- a subprogram access type, and the subprogram type is not that of a
-- procedure or entry.
("ambiguous expression "
& "(cannot resolve indirect call)!", N);
else
- Error_Msg_NE
+ Error_Msg_NE -- CODEFIX
("ambiguous expression (cannot resolve&)!",
N, It.Nam);
end if;
Error_Msg_N
("\\possible interpretation (inherited)#!", N);
else
- Error_Msg_N ("\\possible interpretation#!", N);
+ Error_Msg_N -- CODEFIX
+ ("\\possible interpretation#!", N);
end if;
end if;
Error_Msg_N
("\\possible interpretation (inherited)#!", N);
else
- Error_Msg_N ("\\possible interpretation#!", N);
+ Error_Msg_N -- CODEFIX
+ ("\\possible interpretation#!", N);
end if;
end if;
elsif Nkind (N) = N_Character_Literal then
Set_Etype (N, Expr_Type);
+ elsif Nkind (N) = N_Conditional_Expression then
+ Set_Etype (N, Expr_Type);
+
-- For an explicit dereference, attribute reference, range,
-- short-circuit form (which is not an operator node), or call
-- with a name that is an explicit dereference, there is
when N_Allocator => Resolve_Allocator (N, Ctx_Type);
- when N_And_Then | N_Or_Else
+ when N_Short_Circuit
=> Resolve_Short_Circuit (N, Ctx_Type);
when N_Attribute_Reference
-- common type. Used to enforce the restrictions on array conversions
-- of AI95-00246.
+ function Static_Concatenation (N : Node_Id) return Boolean;
+ -- Predicate to determine whether an actual that is a concatenation
+ -- will be evaluated statically and does not need a transient scope.
+ -- This must be determined before the actual is resolved and expanded
+ -- because if needed the transient scope must be introduced earlier.
+
--------------------------
-- Check_Argument_Order --
--------------------------
-- anomalies: the subtype was first built in the subprogram
-- declaration, and the current call may be nested.
- if Nkind (Actval) = N_Aggregate
- and then Has_Discriminants (Etype (Actval))
- then
- Analyze_And_Resolve (Actval, Base_Type (Etype (Actval)));
+ if Nkind (Actval) = N_Aggregate then
+ Analyze_And_Resolve (Actval, Etype (F));
else
Analyze_And_Resolve (Actval, Etype (Actval));
end if;
return Root_Type (Base_Type (FT1)) = Root_Type (Base_Type (FT2));
end Same_Ancestor;
+ --------------------------
+ -- Static_Concatenation --
+ --------------------------
+
+ function Static_Concatenation (N : Node_Id) return Boolean is
+ begin
+ case Nkind (N) is
+ when N_String_Literal =>
+ return True;
+
+ when N_Op_Concat =>
+
+ -- Concatenation is static when both operands are static
+ -- and the concatenation operator is a predefined one.
+
+ return Scope (Entity (N)) = Standard_Standard
+ and then
+ Static_Concatenation (Left_Opnd (N))
+ and then
+ Static_Concatenation (Right_Opnd (N));
+
+ when others =>
+ if Is_Entity_Name (N) then
+ declare
+ Ent : constant Entity_Id := Entity (N);
+ begin
+ return Ekind (Ent) = E_Constant
+ and then Present (Constant_Value (Ent))
+ and then
+ Is_Static_Expression (Constant_Value (Ent));
+ end;
+
+ else
+ return False;
+ end if;
+ end case;
+ end Static_Concatenation;
+
-- Start of processing for Resolve_Actuals
begin
if No (A) and then Needs_No_Actuals (Nam) then
null;
- -- If we have an error in any actual or formal, indicated by
- -- a type of Any_Type, then abandon resolution attempt, and
- -- set result type to Any_Type.
+ -- If we have an error in any actual or formal, indicated by a type
+ -- of Any_Type, then abandon resolution attempt, and set result type
+ -- to Any_Type.
elsif (Present (A) and then Etype (A) = Any_Type)
or else Etype (F) = Any_Type
-- aliased, or neither (4.6 (8)).
-- The additional rule 4.6 (24.9.2) seems unduly
- -- restrictive: the privacy requirement should not
- -- apply to generic types, and should be checked in
- -- an instance. ARG query is in order.
+ -- restrictive: the privacy requirement should not apply
+ -- to generic types, and should be checked in an
+ -- instance. ARG query is in order ???
Error_Msg_N
("both component types in a view conversion must be"
then
Establish_Transient_Scope (A, False);
+ -- A small optimization: if one of the actuals is a concatenation
+ -- create a block around a procedure call to recover stack space.
+ -- This alleviates stack usage when several procedure calls in
+ -- the same statement list use concatenation. We do not perform
+ -- this wrapping for code statements, where the argument is a
+ -- static string, and we want to preserve warnings involving
+ -- sequences of such statements.
+
+ elsif Nkind (A) = N_Op_Concat
+ and then Nkind (N) = N_Procedure_Call_Statement
+ and then Expander_Active
+ and then
+ not (Is_Intrinsic_Subprogram (Nam)
+ and then Chars (Nam) = Name_Asm)
+ and then not Static_Concatenation (A)
+ then
+ Establish_Transient_Scope (A, False);
+ Resolve (A, Etype (F));
+
else
if Nkind (A) = N_Type_Conversion
and then Is_Array_Type (Etype (F))
end if;
-- Check that subprograms don't have improper controlling
- -- arguments (RM 3.9.2 (9))
+ -- arguments (RM 3.9.2 (9)).
-- A primitive operation may have an access parameter of an
-- incomplete tagged type, but a dispatching call is illegal
and then (Is_Class_Wide_Type (Designated_Type (A_Typ))
or else (Nkind (A) = N_Attribute_Reference
and then
- Is_Class_Wide_Type (Etype (Prefix (A)))))
+ Is_Class_Wide_Type (Etype (Prefix (A)))))
and then not Is_Class_Wide_Type (Designated_Type (F_Typ))
and then not Is_Controlling_Formal (F)
+
+ -- Disable these checks for call to imported C++ subprograms
+
+ and then not
+ (Is_Entity_Name (Name (N))
+ and then Is_Imported (Entity (Name (N)))
+ and then Convention (Entity (Name (N))) = Convention_CPP)
then
Error_Msg_N
("access to class-wide argument not allowed here!", A);
-- class-wide matching is not allowed.
if (Is_Class_Wide_Type (Etype (Expression (E)))
- or else Is_Class_Wide_Type (Etype (E)))
+ or else Is_Class_Wide_Type (Etype (E)))
and then Base_Type (Etype (Expression (E))) /= Base_Type (Etype (E))
then
Wrong_Type (Expression (E), Etype (E));
-- Set if corresponding operand might be negative
begin
- Determine_Range (Left_Opnd (N), OK, Lo, Hi);
+ Determine_Range
+ (Left_Opnd (N), OK, Lo, Hi, Assume_Valid => True);
LNeg := (not OK) or else Lo < 0;
- Determine_Range (Right_Opnd (N), OK, Lo, Hi);
+ Determine_Range
+ (Right_Opnd (N), OK, Lo, Hi, Assume_Valid => True);
RNeg := (not OK) or else Lo < 0;
+ -- Check if we will be generating conditionals. There are two
+ -- cases where that can happen, first for REM, the only case
+ -- is largest negative integer mod -1, where the division can
+ -- overflow, but we still have to give the right result. The
+ -- front end generates a test for this annoying case. Here we
+ -- just test if both operands can be negative (that's what the
+ -- expander does, so we match its logic here).
+
+ -- The second case is mod where either operand can be negative.
+ -- In this case, the back end has to generate additonal tests.
+
if (Nkind (N) = N_Op_Rem and then (LNeg and RNeg))
or else
(Nkind (N) = N_Op_Mod and then (LNeg or RNeg))
else
pragma Assert (Is_Overloaded (Subp));
- Nam := Empty; -- We know that it will be assigned in loop below
+
+ -- Initialize Nam to prevent warning (we know it will be assigned
+ -- in the loop below, but the compiler does not know that).
+
+ Nam := Empty;
Get_First_Interp (Subp, I, It);
while Present (It.Typ) loop
New_Subp := Relocate_Node (Subp);
Set_Entity (Subp, Nam);
- if Component_Type (Ret_Type) /= Any_Type then
+ if (Is_Array_Type (Ret_Type)
+ and then Component_Type (Ret_Type) /= Any_Type)
+ or else
+ (Is_Access_Type (Ret_Type)
+ and then
+ Component_Type (Designated_Type (Ret_Type)) /= Any_Type)
+ then
if Needs_No_Actuals (Nam) then
-- Indexed call to a parameterless function
-- There are several notable exceptions:
- -- a) in init procs, the transient scope overhead is not needed, and is
+ -- a) In init procs, the transient scope overhead is not needed, and is
-- even incorrect when the call is a nested initialization call for a
-- component whose expansion may generate adjust calls. However, if the
-- call is some other procedure call within an initialization procedure
-- (for example a call to Create_Task in the init_proc of the task
-- run-time record) a transient scope must be created around this call.
- -- b) enumeration literal pseudo-calls need no transient scope.
+ -- b) Enumeration literal pseudo-calls need no transient scope
- -- c) intrinsic subprograms (Unchecked_Conversion and source info
+ -- c) Intrinsic subprograms (Unchecked_Conversion and source info
-- functions) do not use the secondary stack even though the return
- -- type may be unconstrained;
+ -- type may be unconstrained.
- -- d) calls to a build-in-place function, since such functions may
+ -- d) Calls to a build-in-place function, since such functions may
-- allocate their result directly in a target object, and cases where
-- the result does get allocated in the secondary stack are checked for
-- within the specialized Exp_Ch6 procedures for expanding those
if Present (First_Formal (Nam)) then
Resolve_Actuals (N, Nam);
- -- Overloaded literals are rewritten as function calls, for
- -- purpose of resolution. After resolution, we can replace
- -- the call with the literal itself.
+ -- Overloaded literals are rewritten as function calls, for purpose of
+ -- resolution. After resolution, we can replace the call with the
+ -- literal itself.
elsif Ekind (Nam) = E_Enumeration_Literal then
Copy_Node (Subp, N);
A := First_Actual (N);
while Present (F) and then Present (A) loop
if (Ekind (F) = E_Out_Parameter
- or else Ekind (F) = E_In_Out_Parameter)
+ or else
+ Ekind (F) = E_In_Out_Parameter)
and then Warn_On_Modified_As_Out_Parameter (F)
and then Is_Entity_Name (A)
and then Present (Entity (A))
and then Present (Controlling_Argument (N))
then
Generate_Reference (Nam, Subp, 'R');
+
+ -- Normal case, not a dispatching call
+
else
Generate_Reference (Nam, Subp);
end if;
Check_Potentially_Blocking_Operation (N);
end if;
+ -- Issue an error for a call to an eliminated subprogram
+
+ Check_For_Eliminated_Subprogram (Subp, Nam);
+
-- All done, evaluate call and deal with elaboration issues
Eval_Call (N);
Check_Elab_Call (N);
+ Warn_On_Overlapping_Actuals (Nam, N);
end Resolve_Call;
-------------------------------
elsif Root_Type (B_Typ) = Standard_Wide_Wide_Character then
return;
- -- If the entity is already set, this has already been resolved in
- -- a generic context, or comes from expansion. Nothing else to do.
+ -- If the entity is already set, this has already been resolved in a
+ -- generic context, or comes from expansion. Nothing else to do.
elsif Present (Entity (N)) then
return;
- -- Otherwise we have a user defined character type, and we can use
- -- the standard visibility mechanisms to locate the referenced entity
+ -- Otherwise we have a user defined character type, and we can use the
+ -- standard visibility mechanisms to locate the referenced entity.
else
C := Current_Entity (N);
T : Entity_Id;
begin
- -- If this is an intrinsic operation which is not predefined, use
- -- the types of its declared arguments to resolve the possibly
- -- overloaded operands. Otherwise the operands are unambiguous and
- -- specify the expected type.
+ -- If this is an intrinsic operation which is not predefined, use the
+ -- types of its declared arguments to resolve the possibly overloaded
+ -- operands. Otherwise the operands are unambiguous and specify the
+ -- expected type.
if Scope (Entity (N)) /= Standard_Standard then
T := Etype (First_Entity (Entity (N)));
Generate_Reference (T, N, ' ');
if T /= Any_Type then
- if T = Any_String
- or else T = Any_Composite
- or else T = Any_Character
+ if T = Any_String or else
+ T = Any_Composite or else
+ T = Any_Character
then
if T = Any_Character then
Ambiguous_Character (L);
Check_Unset_Reference (L);
Check_Unset_Reference (R);
Generate_Operator_Reference (N, T);
+ Check_Low_Bound_Tested (N);
Eval_Relational_Op (N);
end if;
end if;
procedure Resolve_Conditional_Expression (N : Node_Id; Typ : Entity_Id) is
Condition : constant Node_Id := First (Expressions (N));
Then_Expr : constant Node_Id := Next (Condition);
- Else_Expr : constant Node_Id := Next (Then_Expr);
+ Else_Expr : Node_Id := Next (Then_Expr);
begin
- Resolve (Condition, Standard_Boolean);
+ Resolve (Condition, Any_Boolean);
Resolve (Then_Expr, Typ);
- Resolve (Else_Expr, Typ);
+
+ -- If ELSE expression present, just resolve using the determined type
+
+ if Present (Else_Expr) then
+ Resolve (Else_Expr, Typ);
+
+ -- If no ELSE expression is present, root type must be Standard.Boolean
+ -- and we provide a Standard.True result converted to the appropriate
+ -- Boolean type (in case it is a derived boolean type).
+
+ elsif Root_Type (Typ) = Standard_Boolean then
+ Else_Expr :=
+ Convert_To (Typ, New_Occurrence_Of (Standard_True, Sloc (N)));
+ Analyze_And_Resolve (Else_Expr, Typ);
+ Append_To (Expressions (N), Else_Expr);
+
+ else
+ Error_Msg_N ("can only omit ELSE expression in Boolean case", N);
+ Append_To (Expressions (N), Error);
+ end if;
Set_Etype (N, Typ);
Eval_Conditional_Expression (N);
Eval_Named_Real (N);
-- Allow use of subtype only if it is a concurrent type where we are
- -- currently inside the body. This will eventually be expanded
- -- into a call to Self (for tasks) or _object (for protected
- -- objects). Any other use of a subtype is invalid.
+ -- currently inside the body. This will eventually be expanded into a
+ -- call to Self (for tasks) or _object (for protected objects). Any
+ -- other use of a subtype is invalid.
elsif Is_Type (E) then
if Is_Concurrent_Type (E)
-- In all other cases, just do the possible static evaluation
else
- -- A deferred constant that appears in an expression must have
- -- a completion, unless it has been removed by in-place expansion
- -- of an aggregate.
+ -- A deferred constant that appears in an expression must have a
+ -- completion, unless it has been removed by in-place expansion of
+ -- an aggregate.
if Ekind (E) = E_Constant
and then Comes_From_Source (E)
function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id;
-- If the bound is given by a discriminant, replace with a reference
- -- to the discriminant of the same name in the target task.
- -- If the entry name is the target of a requeue statement and the
- -- entry is in the current protected object, the bound to be used
- -- is the discriminal of the object (see apply_range_checks for
- -- details of the transformation).
+ -- to the discriminant of the same name in the target task. If the
+ -- entry name is the target of a requeue statement and the entry is
+ -- in the current protected object, the bound to be used is the
+ -- discriminal of the object (see apply_range_checks for details of
+ -- the transformation).
-----------------------------
-- Actual_Discriminant_Ref --
begin
if not Has_Discriminants (Tsk)
or else (not Is_Entity_Name (Lo)
- and then not Is_Entity_Name (Hi))
+ and then
+ not Is_Entity_Name (Hi))
then
return Entry_Index_Type (E);
end if;
if Is_Entity_Name (E_Name) then
- -- Entry call to an entry (or entry family) in the current task.
- -- This is legal even though the task will deadlock. Rewrite as
- -- call to current task.
- -- This can also be a call to an entry in an enclosing task.
- -- If this is a single task, we have to retrieve its name,
- -- because the scope of the entry is the task type, not the
- -- object. If the enclosing task is a task type, the identity
- -- of the task is given by its own self variable.
+ -- Entry call to an entry (or entry family) in the current task. This
+ -- is legal even though the task will deadlock. Rewrite as call to
+ -- current task.
+
+ -- This can also be a call to an entry in an enclosing task. If this
+ -- is a single task, we have to retrieve its name, because the scope
+ -- of the entry is the task type, not the object. If the enclosing
+ -- task is a task type, the identity of the task is given by its own
+ -- self variable.
- -- Finally this can be a requeue on an entry of the same task
- -- or protected object.
+ -- Finally this can be a requeue on an entry of the same task or
+ -- protected object.
S := Scope (Entity (E_Name));
for J in reverse 0 .. Scope_Stack.Last loop
-
if Is_Task_Type (Scope_Stack.Table (J).Entity)
and then not Comes_From_Source (S)
then
elsif Nkind (Entry_Name) = N_Selected_Component
and then Is_Overloaded (Prefix (Entry_Name))
then
- -- Use the entry name (which must be unique at this point) to
- -- find the prefix that returns the corresponding task type or
- -- protected type.
+ -- Use the entry name (which must be unique at this point) to find
+ -- the prefix that returns the corresponding task type or protected
+ -- type.
declare
Pref : constant Node_Id := Prefix (Entry_Name);
Index := First (Expressions (Entry_Name));
Resolve (Index, Entry_Index_Type (Nam));
- -- Up to this point the expression could have been the actual
- -- in a simple entry call, and be given by a named association.
+ -- Up to this point the expression could have been the actual in a
+ -- simple entry call, and be given by a named association.
if Nkind (Index) = N_Parameter_Association then
Error_Msg_N ("expect expression for entry index", Index);
Was_Over : Boolean;
begin
- -- We kill all checks here, because it does not seem worth the
- -- effort to do anything better, an entry call is a big operation.
+ -- We kill all checks here, because it does not seem worth the effort to
+ -- do anything better, an entry call is a big operation.
Kill_All_Checks;
end if;
end if;
- -- After resolution, entry calls and protected procedure calls
- -- are changed into entry calls, for expansion. The structure
- -- of the node does not change, so it can safely be done in place.
- -- Protected function calls must keep their structure because they
- -- are subexpressions.
+ -- After resolution, entry calls and protected procedure calls are
+ -- changed into entry calls, for expansion. The structure of the node
+ -- does not change, so it can safely be done in place. Protected
+ -- function calls must keep their structure because they are
+ -- subexpressions.
if Ekind (Nam) /= E_Function then
-- A protected operation that is not a function may modify the
- -- corresponding object, and cannot apply to a constant.
- -- If this is an internal call, the prefix is the type itself.
+ -- corresponding object, and cannot apply to a constant. If this
+ -- is an internal call, the prefix is the type itself.
if Is_Protected_Type (Scope (Nam))
and then not Is_Variable (Obj)
-- Resolve_Equality_Op --
-------------------------
- -- Both arguments must have the same type, and the boolean context
- -- does not participate in the resolution. The first pass verifies
- -- that the interpretation is not ambiguous, and the type of the left
- -- argument is correctly set, or is Any_Type in case of ambiguity.
- -- If both arguments are strings or aggregates, allocators, or Null,
- -- they are ambiguous even though they carry a single (universal) type.
- -- Diagnose this case here.
+ -- Both arguments must have the same type, and the boolean context does
+ -- not participate in the resolution. The first pass verifies that the
+ -- interpretation is not ambiguous, and the type of the left argument is
+ -- correctly set, or is Any_Type in case of ambiguity. If both arguments
+ -- are strings or aggregates, allocators, or Null, they are ambiguous even
+ -- though they carry a single (universal) type. Diagnose this case here.
procedure Resolve_Equality_Op (N : Node_Id; Typ : Entity_Id) is
L : constant Node_Id := Left_Opnd (N);
Check_Unset_Reference (L);
Check_Unset_Reference (R);
Generate_Operator_Reference (N, T);
+ Check_Low_Bound_Tested (N);
-- If this is an inequality, it may be the implicit inequality
-- created for a user-defined operation, in which case the corres-
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. Same for access_to_subprogram, and the
- -- conversion verifies that the types are subtype conformant.
+ -- Ada 2005: If one operand is an anonymous access type, convert the
+ -- other operand to it, to ensure that the underlying types match in
+ -- the back-end. Same for access_to_subprogram, and the conversion
+ -- verifies that the types are subtype conformant.
- -- We apply the same conversion in the case one of the operands is
- -- a private subtype of the type of the other.
+ -- We apply the same conversion in the case one of the operands is a
+ -- private subtype of the type of the other.
-- Why the Expander_Active test here ???
Set_Etype (N, Get_Actual_Subtype (N));
end if;
- -- Note: there is no Eval processing required for an explicit deference,
- -- because the type is known to be an allocators, and allocator
- -- expressions can never be static.
+ -- Note: No Eval processing is required for an explicit dereference,
+ -- because such a name can never be static.
end Resolve_Explicit_Dereference;
elsif Typ /= Etype (Left_Opnd (N))
or else Typ /= Etype (Right_Opnd (N))
then
- -- Add explicit conversion where needed, and save interpretations
- -- in case operands are overloaded.
+ -- Add explicit conversion where needed, and save interpretations in
+ -- case operands are overloaded.
Arg1 := Convert_To (Typ, Left_Opnd (N));
Arg2 := Convert_To (Typ, Right_Opnd (N));
procedure Resolve_Logical_Op (N : Node_Id; Typ : Entity_Id) is
B_Typ : Entity_Id;
- N_Opr : constant Node_Kind := Nkind (N);
begin
+ Check_No_Direct_Boolean_Operators (N);
+
-- Predefined operations on scalar types yield the base type. On the
-- other hand, logical operations on arrays yield the type of the
-- arguments (and the context).
Set_Etype (N, B_Typ);
Generate_Operator_Reference (N, B_Typ);
Eval_Logical_Op (N);
-
- -- Check for violation of restriction No_Direct_Boolean_Operators
- -- if the operator was not eliminated by the Eval_Logical_Op call.
-
- if Nkind (N) = N_Opr
- and then Root_Type (Etype (Left_Opnd (N))) = Standard_Boolean
- then
- Check_Restriction (No_Direct_Boolean_Operators, N);
- end if;
end Resolve_Logical_Op;
---------------------------
procedure Resolve_Membership_Op (N : Node_Id; Typ : Entity_Id) is
pragma Warnings (Off, Typ);
- L : constant Node_Id := Left_Opnd (N);
+ L : constant Node_Id := Left_Opnd (N);
R : constant Node_Id := Right_Opnd (N);
T : Entity_Id;
+ procedure Resolve_Set_Membership;
+ -- Analysis has determined a unique type for the left operand.
+ -- Use it to resolve the disjuncts.
+
+ ----------------------------
+ -- Resolve_Set_Membership --
+ ----------------------------
+
+ procedure Resolve_Set_Membership is
+ Alt : Node_Id;
+
+ begin
+ Resolve (L, Etype (L));
+
+ Alt := First (Alternatives (N));
+ while Present (Alt) loop
+
+ -- Alternative is an expression, a range
+ -- or a subtype mark.
+
+ if not Is_Entity_Name (Alt)
+ or else not Is_Type (Entity (Alt))
+ then
+ Resolve (Alt, Etype (L));
+ end if;
+
+ Next (Alt);
+ end loop;
+ end Resolve_Set_Membership;
+
+ -- Start of processing for Resolve_Membership_Op
+
begin
if L = Error or else R = Error then
return;
end if;
- if not Is_Overloaded (R)
+ if Present (Alternatives (N)) then
+ Resolve_Set_Membership;
+ return;
+
+ elsif not Is_Overloaded (R)
and then
(Etype (R) = Universal_Integer or else
Etype (R) = Universal_Real)
then
T := Etype (R);
- -- Ada 2005 (AI-251): Give support to the following case:
+ -- Ada 2005 (AI-251): Support the following case:
-- type I is interface;
-- type T is tagged ...
-- return O in T'Class.
-- end Test;
- -- In this case we have nothing else to do; the membership test will be
+ -- In this case we have nothing else to do. The membership test will be
-- done at run-time.
elsif Ada_Version >= Ada_05
and then Ekind (Typ) = E_Anonymous_Access_Type
and then Comes_From_Source (N)
then
- -- In the common case of a call which uses an explicitly null
- -- value for an access parameter, give specialized error message.
+ -- In the common case of a call which uses an explicitly null value
+ -- for an access parameter, give specialized error message.
if Nkind_In (Parent (N), N_Procedure_Call_Statement,
N_Function_Call)
end if;
end if;
- -- In a distributed context, null for a remote access to subprogram
- -- may need to be replaced with a special record aggregate. In this
- -- case, return after having done the transformation.
+ -- In a distributed context, null for a remote access to subprogram may
+ -- need to be replaced with a special record aggregate. In this case,
+ -- return after having done the transformation.
if (Ekind (Typ) = E_Record_Type
or else Is_Remote_Access_To_Subprogram_Type (Typ))
-- up the tree following Parent pointers, calling Resolve_Op_Concat_Rest
-- to do the rest of the work at each level. The Parent pointers allow
-- us to avoid recursion, and thus avoid running out of memory. See also
- -- Sem_Ch4.Analyze_Concatenation, where a similar hack is used.
+ -- Sem_Ch4.Analyze_Concatenation, where a similar approach is used.
NN : Node_Id := N;
Op1 : Node_Id;
or else Base_Type (It.Typ) =
Base_Type (Component_Type (Typ))
then
- Error_Msg_N ("\\possible interpretation#", Arg);
+ Error_Msg_N -- CODEFIX
+ ("\\possible interpretation#", Arg);
end if;
Get_Next_Interp (I, It);
begin
-- The parser folds an enormous sequence of concatenations of string
-- literals into "" & "...", where the Is_Folded_In_Parser flag is set
- -- in the right. If the expression resolves to a predefined "&"
+ -- in the right operand. If the expression resolves to a predefined "&"
-- operator, all is well. Otherwise, the parser's folding is wrong, so
-- we give an error. See P_Simple_Expression in Par.Ch4.
Eval_Concatenation (N);
end if;
- -- If this is not a static concatenation, but the result is a
- -- string type (and not an array of strings) ensure that static
- -- string operands have their subtypes properly constructed.
+ -- If this is not a static concatenation, but the result is a string
+ -- type (and not an array of strings) ensure that static string operands
+ -- have their subtypes properly constructed.
if Nkind (N) /= N_String_Literal
and then Is_Character_Type (Component_Type (Typ))
-- Generate cross-reference. We needed to wait until full overloading
-- resolution was complete to do this, since otherwise we can't tell if
- -- we are an Lvalue of not.
+ -- we are an lvalue or not.
if May_Be_Lvalue (N) then
Generate_Reference (Entity (S), S, 'm');
begin
if Is_Overloaded (Name) then
- -- Use the context type to select the prefix that yields the
- -- correct array type.
+ -- Use the context type to select the prefix that yields the correct
+ -- array type.
declare
I : Interp_Index;
Insert_Action (N, Act_Decl);
Array_Type := Defining_Identifier (Act_Decl);
end;
+
+ -- Maybe this should just be "else", instead of checking for the
+ -- specific case of slice??? This is needed for the case where
+ -- the prefix is an Image attribute, which gets expanded to a
+ -- slice, and so has a constrained subtype which we want to use
+ -- for the slice range check applied below (the range check won't
+ -- get done if the unconstrained subtype of the 'Image is used).
+
+ elsif Nkind (Name) = N_Slice then
+ Array_Type := Etype (Name);
end if;
-- If name was overloaded, set slice type correctly now
-- undesired dependence on such run-time unit.
and then
- (VM_Target /= No_VM
- or else not
- (RTU_Loaded (Ada_Tags)
- and then Nkind (Prefix (N)) = N_Selected_Component
- and then Present (Entity (Selector_Name (Prefix (N))))
- and then Entity (Selector_Name (Prefix (N))) =
- RTE_Record_Component (RE_Prims_Ptr)))
+ (not Tagged_Type_Expansion
+ or else not
+ (RTU_Loaded (Ada_Tags)
+ and then Nkind (Prefix (N)) = N_Selected_Component
+ and then Present (Entity (Selector_Name (Prefix (N))))
+ and then Entity (Selector_Name (Prefix (N))) =
+ RTE_Record_Component (RE_Prims_Ptr)))
then
Apply_Range_Check (Drange, Etype (Index));
end if;
or else Typ = Standard_Wide_Wide_String)
and then Nkind (Original_Node (N)) /= N_String_Literal);
- -- If the resolving type is itself a string literal subtype, we
- -- can just reuse it, since there is no point in creating another.
+ -- If the resolving type is itself a string literal subtype, we can just
+ -- reuse it, since there is no point in creating another.
if Ekind (Typ) = E_String_Literal_Subtype then
Subtype_Id := Typ;
return;
end if;
- -- The validity of a null string has been checked in the
- -- call to Eval_String_Literal.
+ -- The validity of a null string has been checked in the call to
+ -- Eval_String_Literal.
if Strlen = 0 then
return;
-- If we are out of range, post error. This is one of the
-- very few places that we place the flag in the middle of
- -- a token, right under the offending wide character.
+ -- a token, right under the offending wide character. Not
+ -- quite clear if this is right wrt wide character encoding
+ -- sequences, but it's only an error message!
Error_Msg
("literal out of range of type Standard.Character",
-----------------------------
procedure Resolve_Type_Conversion (N : Node_Id; Typ : Entity_Id) is
- Conv_OK : constant Boolean := Conversion_OK (N);
- Operand : constant Node_Id := Expression (N);
+ Conv_OK : constant Boolean := Conversion_OK (N);
+ Operand : constant Node_Id := Expression (N);
Operand_Typ : constant Entity_Id := Etype (Operand);
Target_Typ : constant Entity_Id := Etype (N);
Rop : Node_Id;
Resolve (Operand);
-- Note: we do the Eval_Type_Conversion call before applying the
- -- required checks for a subtype conversion. This is important,
- -- since both are prepared under certain circumstances to change
- -- the type conversion to a constraint error node, but in the case
- -- of Eval_Type_Conversion this may reflect an illegality in the
- -- static case, and we would miss the illegality (getting only a
- -- warning message), if we applied the type conversion checks first.
+ -- required checks for a subtype conversion. This is important, since
+ -- both are prepared under certain circumstances to change the type
+ -- conversion to a constraint error node, but in the case of
+ -- Eval_Type_Conversion this may reflect an illegality in the static
+ -- case, and we would miss the illegality (getting only a warning
+ -- message), if we applied the type conversion checks first.
Eval_Type_Conversion (N);
- -- Even when evaluation is not possible, we may be able to simplify
- -- the conversion or its expression. This needs to be done before
- -- applying checks, since otherwise the checks may use the original
- -- expression and defeat the simplifications. This is specifically
- -- the case for elimination of the floating-point Truncation
- -- attribute in float-to-int conversions.
+ -- Even when evaluation is not possible, we may be able to simplify the
+ -- conversion or its expression. This needs to be done before applying
+ -- checks, since otherwise the checks may use the original expression
+ -- and defeat the simplifications. This is specifically the case for
+ -- elimination of the floating-point Truncation attribute in
+ -- float-to-int conversions.
Simplify_Type_Conversion (N);
- -- If after evaluation we still have a type conversion, then we
- -- may need to apply checks required for a subtype conversion.
+ -- If after evaluation we still have a type conversion, then we may need
+ -- to apply checks required for a subtype conversion.
-- Skip these type conversion checks if universal fixed operands
-- operands involved, since range checks are handled separately for
Apply_Type_Conversion_Checks (N);
end if;
- -- Issue warning for conversion of simple object to its own type
- -- We have to test the original nodes, since they may have been
- -- rewritten by various optimizations.
+ -- Issue warning for conversion of simple object to its own type. We
+ -- have to test the original nodes, since they may have been rewritten
+ -- by various optimizations.
Orig_N := Original_Node (N);
(Ekind (Entity (Orig_N)) = E_Loop_Parameter
and then Covers (Orig_T, Etype (Entity (Orig_N)))))
then
- Error_Msg_Node_2 := Orig_T;
- Error_Msg_NE
- ("?redundant conversion, & is of type &!", N, Entity (Orig_N));
+ -- One more check, do not give warning if the analyzed conversion
+ -- has an expression with non-static bounds, and the bounds of the
+ -- target are static. This avoids junk warnings in cases where the
+ -- conversion is necessary to establish staticness, for example in
+ -- a case statement.
+
+ if not Is_OK_Static_Subtype (Operand_Typ)
+ and then Is_OK_Static_Subtype (Target_Typ)
+ then
+ null;
+
+ -- Here we give the redundant conversion warning
+
+ else
+ Error_Msg_Node_2 := Orig_T;
+ Error_Msg_NE -- CODEFIX
+ ("?redundant conversion, & is of type &!",
+ N, Entity (Orig_N));
+ end if;
end if;
end if;
if From_With_Type (Opnd) then
Error_Msg_Qual_Level := 99;
- Error_Msg_NE ("missing with-clause on package &", N,
+ Error_Msg_NE ("missing WITH clause on package &", N,
Cunit_Entity (Get_Source_Unit (Base_Type (Opnd))));
Error_Msg_N
("type conversions require visibility of the full view",
and then Present (Non_Limited_View (Etype (Target))))
then
Error_Msg_Qual_Level := 99;
- Error_Msg_NE ("missing with-clause on package &", N,
+ Error_Msg_NE ("missing WITH clause on package &", N,
Cunit_Entity (Get_Source_Unit (Base_Type (Target))));
Error_Msg_N
("type conversions require visibility of the full view",
end if;
end if;
- -- Generate warning for expressions like -5 mod 3 for integers. No
- -- need to worry in the floating-point case, since parens do not affect
- -- the result so there is no point in giving in a warning.
+ -- Generate warning for expressions like -5 mod 3 for integers. No need
+ -- to worry in the floating-point case, since parens do not affect the
+ -- result so there is no point in giving in a warning.
declare
Norig : constant Node_Id := Original_Node (N);
then
-- For mod, we always give the warning, since the value is
-- affected by the parenthesization (e.g. (-5) mod 315 /=
- -- (5 mod 315)). But for the other cases, the only concern is
+ -- -(5 mod 315)). But for the other cases, the only concern is
-- overflow, e.g. for the case of 8 big signed (-(2 * 64)
-- overflows, but (-2) * 64 does not). So we try to give the
-- message only when overflow is possible.
LB := Expr_Value (Type_Low_Bound (Base_Type (Typ)));
end if;
- -- Note that the test below is deliberately excluding
- -- the largest negative number, since that is a potentially
+ -- Note that the test below is deliberately excluding the
+ -- largest negative number, since that is a potentially
-- troublesome case (e.g. -2 * x, where the result is the
-- largest negative integer has an overflow with 2 * x).
Op_Node : Node_Id;
begin
- -- Rewrite the operator node using the real operator, not its
- -- renaming. Exclude user-defined intrinsic operations of the same
- -- name, which are treated separately and rewritten as calls.
+ -- Rewrite the operator node using the real operator, not its renaming.
+ -- Exclude user-defined intrinsic operations of the same name, which are
+ -- treated separately and rewritten as calls.
if Ekind (Op) /= E_Function
or else Chars (N) /= Nam
N_Op_Expon | N_Op_Mod | N_Op_Rem =>
Resolve_Intrinsic_Operator (N, Typ);
- when N_Op_Plus | N_Op_Minus | N_Op_Abs =>
+ when N_Op_Plus | N_Op_Minus | N_Op_Abs =>
Resolve_Intrinsic_Unary_Operator (N, Typ);
when others =>
procedure Set_String_Literal_Subtype (N : Node_Id; Typ : Entity_Id) is
Loc : constant Source_Ptr := Sloc (N);
Low_Bound : constant Node_Id :=
- Type_Low_Bound (Etype (First_Index (Typ)));
+ Type_Low_Bound (Etype (First_Index (Typ)));
Subtype_Id : Entity_Id;
begin
Scop : Entity_Id;
procedure Fixed_Point_Error;
- -- If true ambiguity, give details
+ -- Give error messages for true ambiguity. Messages are posted on node
+ -- N, and entities T1, T2 are the possible interpretations.
-----------------------
-- Fixed_Point_Error --
N1 : Entity_Id;
begin
- -- Remove procedure calls, which syntactically cannot appear
- -- in this context, but which cannot be removed by type checking,
+ -- Remove procedure calls, which syntactically cannot appear in
+ -- this context, but which cannot be removed by type checking,
-- because the context does not impose a type.
-- When compiling for VMS, spurious ambiguities can be produced
Error_Msg_N ("ambiguous operand in conversion", Operand);
Error_Msg_Sloc := Sloc (It.Nam);
- Error_Msg_N ("\\possible interpretation#!", Operand);
+ Error_Msg_N -- CODEFIX
+ ("\\possible interpretation#!", Operand);
Error_Msg_Sloc := Sloc (N1);
- Error_Msg_N ("\\possible interpretation#!", Operand);
+ Error_Msg_N -- CODEFIX
+ ("\\possible interpretation#!", Operand);
return False;
end if;
and then Is_Interface (Directly_Designated_Type (Target_Type))
then
-- Check the static accessibility rule of 4.6(17). Note that the
- -- check is not enforced when within an instance body, since the RM
- -- requires such cases to be caught at run time.
+ -- check is not enforced when within an instance body, since the
+ -- RM requires such cases to be caught at run time.
if Ekind (Target_Type) /= E_Anonymous_Access_Type then
if Type_Access_Level (Opnd_Type) >
then
-- When the operand is a selected access discriminant the check
-- needs to be made against the level of the object denoted by
- -- the prefix of the selected name. (Object_Access_Level
- -- handles checking the prefix of the operand for this case.)
+ -- the prefix of the selected name (Object_Access_Level handles
+ -- checking the prefix of the operand for this case).
if Nkind (Operand) = N_Selected_Component
and then Object_Access_Level (Operand) >
Type_Access_Level (Target_Type)
then
- -- In an instance, this is a run-time check, but one we
- -- know will fail, so generate an appropriate warning.
- -- The raise will be generated by Expand_N_Type_Conversion.
+ -- In an instance, this is a run-time check, but one we know
+ -- will fail, so generate an appropriate warning. The raise
+ -- will be generated by Expand_N_Type_Conversion.
if In_Instance_Body then
Error_Msg_N
if Type_Access_Level (Opnd_Type)
> Type_Access_Level (Target_Type)
then
- -- In an instance, this is a run-time check, but one we
- -- know will fail, so generate an appropriate warning.
- -- The raise will be generated by Expand_N_Type_Conversion.
+ -- In an instance, this is a run-time check, but one we know
+ -- will fail, so generate an appropriate warning. The raise
+ -- will be generated by Expand_N_Type_Conversion.
if In_Instance_Body then
Error_Msg_N
-- When the operand is a selected access discriminant the check
-- needs to be made against the level of the object denoted by
- -- the prefix of the selected name. (Object_Access_Level
- -- handles checking the prefix of the operand for this case.)
+ -- the prefix of the selected name (Object_Access_Level handles
+ -- checking the prefix of the operand for this case).
if Nkind (Operand) = N_Selected_Component
and then Object_Access_Level (Operand) >
Type_Access_Level (Target_Type)
then
- -- In an instance, this is a run-time check, but one we
- -- know will fail, so generate an appropriate warning.
- -- The raise will be generated by Expand_N_Type_Conversion.
+ -- In an instance, this is a run-time check, but one we know
+ -- will fail, so generate an appropriate warning. The raise
+ -- will be generated by Expand_N_Type_Conversion.
if In_Instance_Body then
Error_Msg_N
end if;
end if;
- declare
+ -- In the presence of limited_with clauses we have to use non-limited
+ -- views, if available.
+
+ Check_Limited : declare
function Full_Designated_Type (T : Entity_Id) return Entity_Id;
-- Helper function to handle limited views
function Full_Designated_Type (T : Entity_Id) return Entity_Id is
Desig : constant Entity_Id := Designated_Type (T);
+
begin
- if From_With_Type (Desig)
- and then Is_Incomplete_Type (Desig)
+ -- Handle the limited view of a type
+
+ if Is_Incomplete_Type (Desig)
+ and then From_With_Type (Desig)
and then Present (Non_Limited_View (Desig))
then
- return Non_Limited_View (Desig);
+ return Available_View (Desig);
else
return Desig;
end if;
end Full_Designated_Type;
+ -- Local Declarations
+
Target : constant Entity_Id := Full_Designated_Type (Target_Type);
Opnd : constant Entity_Id := Full_Designated_Type (Opnd_Type);
Same_Base : constant Boolean :=
Base_Type (Target) = Base_Type (Opnd);
+ -- Start of processing for Check_Limited
+
begin
if Is_Tagged_Type (Target) then
return Valid_Tagged_Conversion (Target, Opnd);
return False;
end if;
end if;
- end;
+ end Check_Limited;
-- Access to subprogram types. If the operand is an access parameter,
-- the type has a deeper accessibility that any master, and cannot
elsif (In_Instance or In_Inlined_Body)
and then
- Root_Type (Underlying_Type (Target_Type)) =
- Root_Type (Underlying_Type (Opnd_Type))
+ Root_Type (Underlying_Type (Target_Type)) =
+ Root_Type (Underlying_Type (Opnd_Type))
then
return True;
then
Error_Msg_N ("target type must be general access type!", N);
Error_Msg_NE ("add ALL to }!", N, Target_Type);
-
return False;
else
Error_Msg_NE ("invalid conversion, not compatible with }",
N, Opnd_Type);
-
return False;
end if;
end Valid_Conversion;
OSDN Git Service
