-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2011, 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 Aspects; use Aspects;
with Atree; use Atree;
with Checks; use Checks;
with Einfo; use Einfo;
with Errout; use Errout;
with Expander; use Expander;
+with Exp_Ch6; use Exp_Ch6;
with Exp_Util; use Exp_Util;
with Freeze; use Freeze;
with Lib; use Lib;
with Sem_Aux; use Sem_Aux;
with Sem_Case; use Sem_Case;
with Sem_Ch3; use Sem_Ch3;
+with Sem_Ch6; use Sem_Ch6;
with Sem_Ch8; use Sem_Ch8;
with Sem_Disp; use Sem_Disp;
with Sem_Elab; use Sem_Elab;
then
if Is_Local_Anonymous_Access (T1)
or else Ekind (T2) = E_Anonymous_Access_Subprogram_Type
+
+ -- Handle assignment to an Ada 2012 stand-alone object
+ -- of an anonymous access type.
+
+ or else (Ekind (T1) = E_Anonymous_Access_Type
+ and then Nkind (Associated_Node_For_Itype (T1)) =
+ N_Object_Declaration)
+
then
Rewrite (Rhs, Convert_To (T1, Relocate_Node (Rhs)));
Analyze_And_Resolve (Rhs, T1);
if Safe_To_Capture_Value (N, Ent) then
-- If simple variable on left side, warn if this assignment
- -- blots out another one (rendering it useless) and note
- -- location of assignment in case no one references value. We
- -- only do this for source assignments, otherwise we can
- -- generate bogus warnings when an assignment is rewritten as
- -- another assignment, and gets tied up with itself.
-
- -- Note: we don't use Record_Last_Assignment here, because we
- -- have lots of other stuff to do under control of this test.
+ -- blots out another one (rendering it useless). We only do
+ -- this for source assignments, otherwise we can generate bogus
+ -- warnings when an assignment is rewritten as another
+ -- assignment, and gets tied up with itself.
if Warn_On_Modified_Unread
and then Is_Assignable (Ent)
and then In_Extended_Main_Source_Unit (Ent)
then
Warn_On_Useless_Assignment (Ent, N);
- Set_Last_Assignment (Ent, Lhs);
end if;
-- If we are assigning an access type and the left side is an
end if;
end;
end if;
+
+ -- If assigning to an object in whole or in part, note location of
+ -- assignment in case no one references value. We only do this for
+ -- source assignments, otherwise we can generate bogus warnings when an
+ -- assignment is rewritten as another assignment, and gets tied up with
+ -- itself.
+
+ declare
+ Ent : constant Entity_Id := Get_Enclosing_Object (Lhs);
+
+ begin
+ if Present (Ent)
+ and then Safe_To_Capture_Value (N, Ent)
+ and then Nkind (N) = N_Assignment_Statement
+ and then Warn_On_Modified_Unread
+ and then Is_Assignable (Ent)
+ and then Comes_From_Source (N)
+ and then In_Extended_Main_Source_Unit (Ent)
+ then
+ Set_Last_Assignment (Ent, Lhs);
+ end if;
+ end;
end Analyze_Assignment;
-----------------------------
-----------------------------
procedure Analyze_Block_Statement (N : Node_Id) is
+ procedure Install_Return_Entities (Scop : Entity_Id);
+ -- Install all entities of return statement scope Scop in the visibility
+ -- chain except for the return object since its entity is reused in a
+ -- renaming.
+
+ -----------------------------
+ -- Install_Return_Entities --
+ -----------------------------
+
+ procedure Install_Return_Entities (Scop : Entity_Id) is
+ Id : Entity_Id;
+
+ begin
+ Id := First_Entity (Scop);
+ while Present (Id) loop
+
+ -- Do not install the return object
+
+ if not Ekind_In (Id, E_Constant, E_Variable)
+ or else not Is_Return_Object (Id)
+ then
+ Install_Entity (Id);
+ end if;
+
+ Next_Entity (Id);
+ end loop;
+ end Install_Return_Entities;
+
+ -- Local constants and variables
+
Decls : constant List_Id := Declarations (N);
Id : constant Node_Id := Identifier (N);
HSS : constant Node_Id := Handled_Statement_Sequence (N);
+ Is_BIP_Return_Statement : Boolean;
+
+ -- Start of processing for Analyze_Block_Statement
+
begin
- -- In formal mode, we reject block statements. Note that the case of
+ -- In SPARK mode, we reject block statements. Note that the case of
-- block statements generated by the expander is fine.
if Nkind (Original_Node (N)) = N_Block_Statement then
- Check_Formal_Restriction ("block statement is not allowed", N);
+ Check_SPARK_Restriction ("block statement is not allowed", N);
end if;
-- If no handled statement sequence is present, things are really messed
return;
end if;
+ -- Detect whether the block is actually a rewritten return statement of
+ -- a build-in-place function.
+
+ Is_BIP_Return_Statement :=
+ Present (Id)
+ and then Present (Entity (Id))
+ and then Ekind (Entity (Id)) = E_Return_Statement
+ and then Is_Build_In_Place_Function
+ (Return_Applies_To (Entity (Id)));
+
-- Normal processing with HSS present
declare
Set_Block_Node (Ent, Identifier (N));
Push_Scope (Ent);
+ -- The block served as an extended return statement. Ensure that any
+ -- entities created during the analysis and expansion of the return
+ -- object declaration are once again visible.
+
+ if Is_BIP_Return_Statement then
+ Install_Return_Entities (Ent);
+ end if;
+
if Present (Decls) then
Analyze_Declarations (Decls);
Check_Completion;
Analyze_Choices (N, Exp_Type, Dont_Care, Others_Present);
-- A case statement with a single OTHERS alternative is not allowed
- -- in SPARK or ALFA.
+ -- in SPARK.
if Others_Present
and then List_Length (Alternatives (N)) = 1
then
- Check_Formal_Restriction
+ Check_SPARK_Restriction
("OTHERS as unique case alternative is not allowed", N);
end if;
-- loop. Otherwise there must be an innermost open loop on the stack, to
-- which the statement implicitly refers.
- -- Additionally, in formal mode:
+ -- Additionally, in SPARK mode:
-- The exit can only name the closest enclosing loop;
else
if Has_Loop_In_Inner_Open_Scopes (U_Name) then
- Check_Formal_Restriction
+ Check_SPARK_Restriction
("exit label must name the closest enclosing loop", N);
end if;
Check_Unset_Reference (Cond);
end if;
- -- In formal mode, verify that the exit statement respects the SPARK
+ -- In SPARK mode, verify that the exit statement respects the SPARK
-- restrictions.
if Present (Cond) then
if Nkind (Parent (N)) /= N_Loop_Statement then
- Check_Formal_Restriction
+ Check_SPARK_Restriction
("exit with when clause must be directly in loop", N);
end if;
else
if Nkind (Parent (N)) /= N_If_Statement then
if Nkind (Parent (N)) = N_Elsif_Part then
- Check_Formal_Restriction
+ Check_SPARK_Restriction
("exit must be in IF without ELSIF", N);
else
- Check_Formal_Restriction ("exit must be directly in IF", N);
+ Check_SPARK_Restriction ("exit must be directly in IF", N);
end if;
elsif Nkind (Parent (Parent (N))) /= N_Loop_Statement then
- Check_Formal_Restriction
+ Check_SPARK_Restriction
("exit must be in IF directly in loop", N);
- -- First test the presence of ELSE, so that an exit in an ELSE
- -- leads to an error mentioning the ELSE.
+ -- First test the presence of ELSE, so that an exit in an ELSE leads
+ -- to an error mentioning the ELSE.
elsif Present (Else_Statements (Parent (N))) then
- Check_Formal_Restriction ("exit must be in IF without ELSE", N);
+ Check_SPARK_Restriction ("exit must be in IF without ELSE", N);
- -- An exit in an ELSIF does not reach here, as it would have been
- -- detected in the case (Nkind (Parent (N)) /= N_If_Statement).
+ -- An exit in an ELSIF does not reach here, as it would have been
+ -- detected in the case (Nkind (Parent (N)) /= N_If_Statement).
elsif Present (Elsif_Parts (Parent (N))) then
- Check_Formal_Restriction ("exit must be in IF without ELSIF", N);
+ Check_SPARK_Restriction ("exit must be in IF without ELSIF", N);
end if;
end if;
Label_Ent : Entity_Id;
begin
- Check_Formal_Restriction ("goto statement is not allowed", N);
+ Check_SPARK_Restriction ("goto statement is not allowed", N);
-- Actual semantic checks
end;
-- Loop parameter specification must include subtype mark in
- -- SPARK or ALFA.
+ -- SPARK.
if Nkind (DS) = N_Range then
- Check_Formal_Restriction
+ Check_SPARK_Restriction
("loop parameter specification must include subtype mark",
N);
end if;
Set_Parent (D_Copy, Parent (DS));
Pre_Analyze_Range (D_Copy);
+ -- Ada 2012: If the domain of iteration is a function call,
+ -- it is the new iterator form.
+
+ -- We have also implemented the shorter form : for X in S
+ -- for Alfa use. In this case, 'Old and 'Result must be
+ -- treated as entity names over which iterators are legal.
+
if Nkind (D_Copy) = N_Function_Call
or else
+ (Alfa_Mode
+ and then (Nkind (D_Copy) = N_Attribute_Reference
+ and then
+ (Attribute_Name (D_Copy) = Name_Result
+ or else Attribute_Name (D_Copy) = Name_Old)))
+ or else
(Is_Entity_Name (D_Copy)
and then not Is_Type (Entity (D_Copy)))
then
Set_Iterator_Specification (N, I_Spec);
Set_Loop_Parameter_Specification (N, Empty);
Analyze_Iterator_Specification (I_Spec);
+
+ -- In a generic context, analyze the original domain
+ -- of iteration, for name capture.
+
+ if not Expander_Active then
+ Analyze (DS);
+ end if;
+
+ -- Set kind of loop parameter, which may be used in
+ -- the subsequent analysis of the condition in a
+ -- quantified expression.
+
+ Set_Ekind (Id, E_Loop_Parameter);
return;
end;
Check_Controlled_Array_Attribute (DS);
- Make_Index (DS, LP);
+ Make_Index (DS, LP, In_Iter_Schm => True);
Set_Ekind (Id, E_Loop_Parameter);
Loc : constant Source_Ptr := Sloc (N);
Def_Id : constant Node_Id := Defining_Identifier (N);
Subt : constant Node_Id := Subtype_Indication (N);
- Container : constant Node_Id := Name (N);
+ Iter_Name : constant Node_Id := Name (N);
Ent : Entity_Id;
Typ : Entity_Id;
begin
- Enter_Name (Def_Id);
+ -- In semantics/Alfa modes, we won't be further expanding the loop, so
+ -- introduce loop variable so that loop body can be properly analyzed.
+ -- Otherwise this happens after expansion.
+
+ if Operating_Mode = Check_Semantics
+ or else Alfa_Mode
+ then
+ Enter_Name (Def_Id);
+ end if;
+
Set_Ekind (Def_Id, E_Variable);
if Present (Subt) then
Analyze (Subt);
end if;
- -- If it is an expression, the container is pre-analyzed in the caller.
- -- If it it of a controlled type we need a block for the finalization
- -- actions. As for loop bounds that need finalization, we create a
- -- declaration and an assignment to trigger these actions.
+ -- If domain of iteration is an expression, create a declaration for
+ -- it, so that finalization actions are introduced outside of the loop.
+ -- The declaration must be a renaming because the body of the loop may
+ -- assign to elements.
- if Present (Etype (Container))
- and then Is_Controlled (Etype (Container))
- and then not Is_Entity_Name (Container)
- then
+ if not Is_Entity_Name (Iter_Name) then
declare
- Id : constant Entity_Id := Make_Temporary (Loc, 'R', Container);
-
- Decl : Node_Id;
- Assign : Node_Id;
+ Id : constant Entity_Id := Make_Temporary (Loc, 'R', Iter_Name);
+ Decl : Node_Id;
begin
- Typ := Etype (Container);
+ Typ := Etype (Iter_Name);
Decl :=
- Make_Object_Declaration (Loc,
+ Make_Object_Renaming_Declaration (Loc,
Defining_Identifier => Id,
- Object_Definition => New_Occurrence_Of (Typ, Loc));
-
- Assign :=
- Make_Assignment_Statement (Loc,
- Name => New_Occurrence_Of (Id, Loc),
- Expression => Relocate_Node (Container));
+ Subtype_Mark => New_Occurrence_Of (Typ, Loc),
+ Name => Relocate_Node (Iter_Name));
- Insert_Actions (Parent (N), New_List (Decl, Assign));
+ Insert_Actions (Parent (Parent (N)), New_List (Decl));
+ Rewrite (Name (N), New_Occurrence_Of (Id, Loc));
+ Set_Etype (Id, Typ);
+ Set_Etype (Name (N), Typ);
end;
+ -- Container is an entity or an array with uncontrolled components, or
+ -- else it is a container iterator given by a function call, typically
+ -- called Iterate in the case of predefined containers, even though
+ -- Iterate is not a reserved name. What matter is that the return type
+ -- of the function is an iterator type.
+
else
+ Analyze (Iter_Name);
+
+ if Nkind (Iter_Name) = N_Function_Call then
+ declare
+ C : constant Node_Id := Name (Iter_Name);
+ I : Interp_Index;
+ It : Interp;
+
+ begin
+ if not Is_Overloaded (Iter_Name) then
+ Resolve (Iter_Name, Etype (C));
+
+ else
+ Get_First_Interp (C, I, It);
+ while It.Typ /= Empty loop
+ if Reverse_Present (N) then
+ if Is_Reversible_Iterator (It.Typ) then
+ Resolve (Iter_Name, It.Typ);
+ exit;
+ end if;
+
+ elsif Is_Iterator (It.Typ) then
+ Resolve (Iter_Name, It.Typ);
+ exit;
+ end if;
+
+ Get_Next_Interp (I, It);
+ end loop;
+ end if;
+ end;
- -- Container is an entity or an array with uncontrolled components
+ -- Domain of iteration is not overloaded
- Analyze_And_Resolve (Container);
+ else
+ Resolve (Iter_Name, Etype (Iter_Name));
+ end if;
end if;
- Typ := Etype (Container);
+ Typ := Etype (Iter_Name);
if Is_Array_Type (Typ) then
if Of_Present (N) then
Set_Etype (Def_Id, Component_Type (Typ));
+
+ -- Here we have a missing Range attribute
+
else
Error_Msg_N
- ("to iterate over the elements of an array, use OF", N);
+ ("missing Range attribute in iteration over an array", N);
+
+ -- In Ada 2012 mode, this may be an attempt at an iterator
+
+ if Ada_Version >= Ada_2012 then
+ Error_Msg_NE
+ ("\if& is meant to designate an element of the array, use OF",
+ N, Def_Id);
+ end if;
+
+ -- Prevent cascaded errors
+
+ Set_Ekind (Def_Id, E_Loop_Parameter);
Set_Etype (Def_Id, Etype (First_Index (Typ)));
end if;
+ -- Check for type error in iterator
+
+ elsif Typ = Any_Type then
+ return;
+
-- Iteration over a container
else
if Of_Present (N) then
- -- Find the Element_Type in the package instance that defines the
- -- container type.
+ -- The type of the loop variable is the Iterator_Element aspect of
+ -- the container type.
- Ent := First_Entity (Scope (Base_Type (Typ)));
- while Present (Ent) loop
- if Chars (Ent) = Name_Element_Type then
- Set_Etype (Def_Id, Ent);
- exit;
- end if;
-
- Next_Entity (Ent);
- end loop;
+ Set_Etype (Def_Id,
+ Entity (Find_Aspect (Typ, Aspect_Iterator_Element)));
else
- -- Find the Cursor type in similar fashion
+ -- For an iteration of the form IN, the name must denote an
+ -- iterator, typically the result of a call to Iterate. Give a
+ -- useful error message when the name is a container by itself.
- Ent := First_Entity (Scope (Base_Type (Typ)));
+ if Is_Entity_Name (Original_Node (Name (N)))
+ and then not Is_Iterator (Typ)
+ then
+ Error_Msg_N
+ ("name must be an iterator, not a container", Name (N));
+
+ Error_Msg_NE
+ ("\to iterate directly over a container, write `of &`",
+ Name (N), Original_Node (Name (N)));
+ end if;
+
+ -- The result type of Iterate function is the classwide type of
+ -- the interface parent. We need the specific Cursor type defined
+ -- in the container package.
+
+ Ent := First_Entity (Scope (Typ));
while Present (Ent) loop
if Chars (Ent) = Name_Cursor then
- Set_Etype (Def_Id, Ent);
+ Set_Etype (Def_Id, Etype (Ent));
exit;
end if;
Kill_Current_Values;
Push_Scope (Ent);
Analyze_Iteration_Scheme (Iter);
- Analyze_Statements (Statements (Loop_Statement));
+
+ -- Analyze the statements of the body except in the case of an Ada 2012
+ -- iterator with the expander active. In this case the expander will do
+ -- a rewrite of the loop into a while loop. We will then analyze the
+ -- loop body when we analyze this while loop.
+
+ -- We need to do this delay because if the container is for indefinite
+ -- types the actual subtype of the components will only be determined
+ -- when the cursor declaration is analyzed.
+
+ -- If the expander is not active, then we want to analyze the loop body
+ -- now even in the Ada 2012 iterator case, since the rewriting will not
+ -- be done. Insert the loop variable in the current scope, if not done
+ -- when analysing the iteration scheme.
+
+ if No (Iter)
+ or else No (Iterator_Specification (Iter))
+ or else not Expander_Active
+ then
+ if Present (Iter)
+ and then Present (Iterator_Specification (Iter))
+ then
+ declare
+ Id : constant Entity_Id :=
+ Defining_Identifier (Iterator_Specification (Iter));
+ begin
+ if Scope (Id) /= Current_Scope then
+ Enter_Name (Id);
+ end if;
+ end;
+ end if;
+
+ Analyze_Statements (Statements (Loop_Statement));
+ end if;
+
+ -- Finish up processing for the loop. We kill all current values, since
+ -- in general we don't know if the statements in the loop have been
+ -- executed. We could do a bit better than this with a loop that we
+ -- know will execute at least once, but it's not worth the trouble and
+ -- the front end is not in the business of flow tracing.
+
Process_End_Label (Loop_Statement, 'e', Ent);
End_Scope;
Kill_Current_Values;
-- we are in formal mode where goto statements are not allowed.
if Nkind (Nxt) = N_Label
- and then not (Formal_Verification_Mode
- or else Restriction_Check_Required (SPARK))
+ and then not Restriction_Check_Required (SPARK)
then
return;
-- Now issue the warning (or error in formal mode)
- if SPARK_Mode or else Restriction_Check_Required (SPARK) then
- Check_Formal_Restriction
+ if Restriction_Check_Required (SPARK) then
+ Check_SPARK_Restriction
("unreachable code is not allowed", Error_Node);
else
Error_Msg ("?unreachable code!", Sloc (Error_Node));
OSDN Git Service
