-- --
-- 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 Opt; use Opt;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
+with Sem_Aux; use Sem_Aux;
with Sem_Case; use Sem_Case;
with Sem_Ch3; use Sem_Ch3;
with Sem_Ch8; use Sem_Ch8;
with Sem_Elab; use Sem_Elab;
with Sem_Eval; use Sem_Eval;
with Sem_Res; use Sem_Res;
+with Sem_SCIL; use Sem_SCIL;
with Sem_Type; use Sem_Type;
with Sem_Util; use Sem_Util;
with Sem_Warn; use Sem_Warn;
Decl : Node_Id;
procedure Diagnose_Non_Variable_Lhs (N : Node_Id);
- -- N is the node for the left hand side of an assignment, and it
- -- is not a variable. This routine issues an appropriate diagnostic.
+ -- N is the node for the left hand side of an assignment, and it is not
+ -- a variable. This routine issues an appropriate diagnostic.
procedure Kill_Lhs;
-- This is called to kill current value settings of a simple variable
and then not Assignment_OK (Original_Node (Lhs))
and then not Is_Value_Type (T1)
then
- Error_Msg_N
- ("left hand of assignment must not be limited type", Lhs);
- Explain_Limited_Type (T1, Lhs);
+ -- CPP constructors can only be called in declarations
+
+ if Is_CPP_Constructor_Call (Rhs) then
+ Error_Msg_N ("invalid use of 'C'P'P constructor", Rhs);
+ else
+ Error_Msg_N
+ ("left hand of assignment must not be limited type", Lhs);
+ Explain_Limited_Type (T1, Lhs);
+ end if;
return;
-- Enforce RM 3.9.3 (8): left-hand side cannot be abstract
end if;
end if;
- -- Ada 2005 (AI-230 and AI-385): When the lhs type is an anonymous
- -- access type, apply an implicit conversion of the rhs to that type
- -- to force appropriate static and run-time accessibility checks.
+ -- Ada 2005 (AI-385): When the lhs type is an anonymous access type,
+ -- apply an implicit conversion of the rhs to that type to force
+ -- appropriate static and run-time accessibility checks. This applies
+ -- as well to anonymous access-to-subprogram types that are component
+ -- subtypes or formal parameters.
if Ada_Version >= Ada_05
- and then Ekind (T1) = E_Anonymous_Access_Type
+ and then Is_Access_Type (T1)
then
- Rewrite (Rhs, Convert_To (T1, Relocate_Node (Rhs)));
- Analyze_And_Resolve (Rhs, T1);
+ if Is_Local_Anonymous_Access (T1)
+ or else Ekind (T2) = E_Anonymous_Access_Subprogram_Type
+ then
+ Rewrite (Rhs, Convert_To (T1, Relocate_Node (Rhs)));
+ Analyze_And_Resolve (Rhs, T1);
+ end if;
end if;
-- Ada 2005 (AI-231): Assignment to not null variable
if Present (Decls) then
Analyze_Declarations (Decls);
Check_Completion;
+ Inspect_Deferred_Constant_Completion (Decls);
end if;
Analyze (HSS);
Analyze_And_Resolve (Cond, Any_Boolean);
Check_Unset_Reference (Cond);
end if;
+
+ -- Since the exit may take us out of a loop, any previous assignment
+ -- statement is not useless, so clear last assignment indications. It
+ -- is OK to keep other current values, since if the exit statement
+ -- does not exit, then the current values are still valid.
+
+ Kill_Current_Values (Last_Assignment_Only => True);
end Analyze_Exit_Statement;
----------------------------
function One_Bound
(Original_Bound : Node_Id;
Analyzed_Bound : Node_Id) return Node_Id;
- -- Create one declaration followed by one assignment statement
- -- to capture the value of bound. We create a separate assignment
- -- in order to force the creation of a block in case the bound
- -- contains a call that uses the secondary stack.
+ -- Capture value of bound and return captured value
---------------
-- One_Bound --
then
Analyze_And_Resolve (Original_Bound, Typ);
return Original_Bound;
-
- else
- Analyze_And_Resolve (Original_Bound, Typ);
end if;
+ -- Here we need to capture the value
+
+ Analyze_And_Resolve (Original_Bound, Typ);
+
Id :=
Make_Defining_Identifier (Loc,
Chars => New_Internal_Name ('S'));
+ -- Normally, the best approach is simply to generate a constant
+ -- declaration that captures the bound. However, there is a nasty
+ -- case where this is wrong. If the bound is complex, and has a
+ -- possible use of the secondary stack, we need to generate a
+ -- separate assignment statement to ensure the creation of a block
+ -- which will release the secondary stack.
+
+ -- We prefer the constant declaration, since it leaves us with a
+ -- proper trace of the value, useful in optimizations that get rid
+ -- of junk range checks.
+
+ -- Probably we want something like the Side_Effect_Free routine
+ -- in Exp_Util, but for now, we just optimize the cases of 'Last
+ -- and 'First applied to an entity, since these are the important
+ -- cases for range check optimizations.
+
+ if Nkind (Original_Bound) = N_Attribute_Reference
+ and then (Attribute_Name (Original_Bound) = Name_First
+ or else
+ Attribute_Name (Original_Bound) = Name_Last)
+ and then Is_Entity_Name (Prefix (Original_Bound))
+ then
+ Decl :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Id,
+ Constant_Present => True,
+ Object_Definition => New_Occurrence_Of (Typ, Loc),
+ Expression => Relocate_Node (Original_Bound));
+
+ Insert_Before (Parent (N), Decl);
+ Analyze (Decl);
+ Rewrite (Original_Bound, New_Occurrence_Of (Id, Loc));
+ return Expression (Decl);
+ end if;
+
+ -- Here we make a declaration with a separate assignment statement
+
Decl :=
Make_Object_Declaration (Loc,
Defining_Identifier => Id,
Name => New_Occurrence_Of (Id, Loc),
Expression => Relocate_Node (Original_Bound));
+ -- If the relocated node is a function call then check if some
+ -- SCIL node references it and needs readjustment.
+
+ if Generate_SCIL
+ and then Nkind (Original_Bound) = N_Function_Call
+ then
+ Adjust_SCIL_Node (Original_Bound, Expression (Assign));
+ end if;
+
Insert_Before (Parent (N), Assign);
Analyze (Assign);
Set_Ekind (Id, E_Loop_Parameter);
Set_Etype (Id, Etype (DS));
+
+ -- Treat a range as an implicit reference to the type, to
+ -- inhibit spurious warnings.
+
+ Generate_Reference (Base_Type (Etype (DS)), N, ' ');
Set_Is_Known_Valid (Id, True);
-- The loop is not a declarative part, so the only entity
L : constant Node_Id := Low_Bound (DS);
H : constant Node_Id := High_Bound (DS);
- Llo : Uint;
- Lhi : Uint;
- LOK : Boolean;
- Hlo : Uint;
- Hhi : Uint;
- HOK : Boolean;
-
- pragma Warnings (Off, Hlo);
-
begin
- Determine_Range (L, LOK, Llo, Lhi);
- Determine_Range (H, HOK, Hlo, Hhi);
-
-- If range of loop is null, issue warning
- if (LOK and HOK) and then Llo > Hhi then
-
+ if Compile_Time_Compare
+ (L, H, Assume_Valid => True) = GT
+ then
-- Suppress the warning if inside a generic
-- template or instance, since in practice
-- they tend to be dubious in these cases since
if not Inside_A_Generic
and then not In_Instance
then
- Error_Msg_N
- ("?loop range is null, loop will not execute",
- DS);
+ -- Specialize msg if invalid values could make
+ -- the loop non-null after all.
+
+ if Compile_Time_Compare
+ (L, H, Assume_Valid => False) = GT
+ then
+ Error_Msg_N
+ ("?loop range is null, "
+ & "loop will not execute",
+ DS);
+
+ -- Since we know the range of the loop is
+ -- null, set the appropriate flag to remove
+ -- the loop entirely during expansion.
+
+ Set_Is_Null_Loop (Parent (N));
+
+ -- Here is where the loop could execute because
+ -- of invalid values, so issue appropriate
+ -- message and in this case we do not set the
+ -- Is_Null_Loop flag since the loop may execute.
+
+ else
+ Error_Msg_N
+ ("?loop range may be null, "
+ & "loop may not execute",
+ DS);
+ Error_Msg_N
+ ("?can only execute if invalid values "
+ & "are present",
+ DS);
+ end if;
end if;
- -- Since we know the range of the loop is null,
- -- set the appropriate flag to suppress any
- -- warnings that would otherwise be issued in
- -- the body of the loop that will not execute.
- -- We do this even in the generic case, since
- -- if it is dubious to warn on the null loop
- -- itself, it is certainly dubious to warn for
- -- conditions that occur inside it!
+ -- In either case, suppress warnings in the body of
+ -- the loop, since it is likely that these warnings
+ -- will be inappropriate if the loop never actually
+ -- executes, which is unlikely.
- Set_Is_Null_Loop (Parent (N));
+ Set_Suppress_Loop_Warnings (Parent (N));
-- The other case for a warning is a reverse loop
-- where the upper bound is the integer literal
elsif Reverse_Present (LP)
and then Nkind (Original_Node (H)) =
N_Integer_Literal
- and then (Intval (H) = Uint_0
+ and then (Intval (Original_Node (H)) = Uint_0
or else
- Intval (H) = Uint_1)
- and then Lhi > Hhi
+ Intval (Original_Node (H)) = Uint_1)
then
Error_Msg_N ("?loop range may be null", DS);
Error_Msg_N ("\?bounds may be wrong way round", DS);
Process_End_Label (Loop_Statement, 'e', Ent);
End_Scope;
Kill_Current_Values;
- Check_Infinite_Loop_Warning (N);
+
+ -- Check for infinite loop. We skip this check for generated code, since
+ -- it justs waste time and makes debugging the routine called harder.
+
+ if Comes_From_Source (N) then
+ Check_Infinite_Loop_Warning (N);
+ end if;
-- Code after loop is unreachable if the loop has no WHILE or FOR
-- and contains no EXIT statements within the body of the loop.
OSDN Git Service
