-- messages. This variable is recursively saved on entry to processing the
-- construct, and restored on exit.
- procedure Pre_Analyze_Range (R_Copy : Node_Id);
+ procedure Preanalyze_Range (R_Copy : Node_Id);
-- Determine expected type of range or domain of iteration of Ada 2012
-- loop by analyzing separate copy. Do the analysis and resolution of the
-- copy of the bound(s) with expansion disabled, to prevent the generation
------------------------------
procedure Analyze_Iteration_Scheme (N : Node_Id) is
+ Cond : Node_Id;
+ Iter_Spec : Node_Id;
+ Loop_Spec : Node_Id;
- procedure Process_Bounds (R : Node_Id);
- -- If the iteration is given by a range, create temporaries and
- -- assignment statements block to capture the bounds and perform
- -- required finalization actions in case a bound includes a function
- -- call that uses the temporary stack. We first pre-analyze a copy of
- -- the range in order to determine the expected type, and analyze and
- -- resolve the original bounds.
+ begin
+ -- For an infinite loop, there is no iteration scheme
- procedure Check_Controlled_Array_Attribute (DS : Node_Id);
- -- If the bounds are given by a 'Range reference on a function call
- -- that returns a controlled array, introduce an explicit declaration
- -- to capture the bounds, so that the function result can be finalized
- -- in timely fashion.
+ if No (N) then
+ return;
+ end if;
- function Has_Call_Using_Secondary_Stack (N : Node_Id) return Boolean;
- -- N is the node for an arbitrary construct. This function searches the
- -- construct N to see if any expressions within it contain function
- -- calls that use the secondary stack, returning True if any such call
- -- is found, and False otherwise.
+ Cond := Condition (N);
+ Iter_Spec := Iterator_Specification (N);
+ Loop_Spec := Loop_Parameter_Specification (N);
- --------------------
- -- Process_Bounds --
- --------------------
+ if Present (Cond) then
+ Analyze_And_Resolve (Cond, Any_Boolean);
+ Check_Unset_Reference (Cond);
+ Set_Current_Value_Condition (N);
- procedure Process_Bounds (R : Node_Id) is
- Loc : constant Source_Ptr := Sloc (N);
- R_Copy : constant Node_Id := New_Copy_Tree (R);
- Lo : constant Node_Id := Low_Bound (R);
- Hi : constant Node_Id := High_Bound (R);
- New_Lo_Bound : Node_Id;
- New_Hi_Bound : Node_Id;
- Typ : Entity_Id;
+ elsif Present (Iter_Spec) then
+ Analyze_Iterator_Specification (Iter_Spec);
- function One_Bound
- (Original_Bound : Node_Id;
- Analyzed_Bound : Node_Id) return Node_Id;
- -- Capture value of bound and return captured value
+ else
+ Analyze_Loop_Parameter_Specification (Loop_Spec);
+ end if;
+ end Analyze_Iteration_Scheme;
- ---------------
- -- One_Bound --
- ---------------
+ ------------------------------------
+ -- Analyze_Iterator_Specification --
+ ------------------------------------
- function One_Bound
- (Original_Bound : Node_Id;
- Analyzed_Bound : Node_Id) return Node_Id
- is
- Assign : Node_Id;
- Decl : Node_Id;
- Id : Entity_Id;
+ procedure Analyze_Iterator_Specification (N : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (N);
+ Def_Id : constant Node_Id := Defining_Identifier (N);
+ Subt : constant Node_Id := Subtype_Indication (N);
+ Iter_Name : constant Node_Id := Name (N);
- begin
- -- If the bound is a constant or an object, no need for a separate
- -- declaration. If the bound is the result of previous expansion
- -- it is already analyzed and should not be modified. Note that
- -- the Bound will be resolved later, if needed, as part of the
- -- call to Make_Index (literal bounds may need to be resolved to
- -- type Integer).
+ Ent : Entity_Id;
+ Typ : Entity_Id;
- if Analyzed (Original_Bound) then
- return Original_Bound;
+ begin
+ Enter_Name (Def_Id);
+ Set_Ekind (Def_Id, E_Variable);
- elsif Nkind_In (Analyzed_Bound, N_Integer_Literal,
- N_Character_Literal)
- or else Is_Entity_Name (Analyzed_Bound)
- then
- Analyze_And_Resolve (Original_Bound, Typ);
- return Original_Bound;
- end if;
+ if Present (Subt) then
+ Analyze (Subt);
+ end if;
- -- 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.
+ Preanalyze_Range (Iter_Name);
- -- 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.
+ -- If the 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. When the context is a quantified expression, the
+ -- renaming declaration is delayed until the expansion phase.
- if not Has_Call_Using_Secondary_Stack (Analyzed_Bound) then
- Analyze_And_Resolve (Original_Bound, Typ);
- Force_Evaluation (Original_Bound);
- return Original_Bound;
- end if;
+ if not Is_Entity_Name (Iter_Name)
+ and then (Nkind (Parent (N)) /= N_Quantified_Expression
+ or else Operating_Mode = Check_Semantics
+ or else Alfa_Mode)
+ then
+ declare
+ Id : constant Entity_Id := Make_Temporary (Loc, 'R', Iter_Name);
+ Decl : Node_Id;
- Id := Make_Temporary (Loc, 'R', Original_Bound);
+ begin
+ Typ := Etype (Iter_Name);
- -- Here we make a declaration with a separate assignment
- -- statement, and insert before loop header.
+ -- The name in the renaming declaration may be a function call.
+ -- Indicate that it does not come from source, to suppress
+ -- spurious warnings on renamings of parameterless functions,
+ -- a common enough idiom in user-defined iterators.
Decl :=
- Make_Object_Declaration (Loc,
+ Make_Object_Renaming_Declaration (Loc,
Defining_Identifier => Id,
- Object_Definition => New_Occurrence_Of (Typ, Loc));
+ Subtype_Mark => New_Occurrence_Of (Typ, Loc),
+ Name =>
+ New_Copy_Tree (Iter_Name, New_Sloc => Loc));
- Assign :=
- Make_Assignment_Statement (Loc,
- Name => New_Occurrence_Of (Id, Loc),
- Expression => Relocate_Node (Original_Bound));
+ 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;
- Insert_Actions (Parent (N), New_List (Decl, Assign));
+ -- 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.
- -- Now that this temporary variable is initialized we decorate it
- -- as safe-to-reevaluate to inform to the backend that no further
- -- asignment will be issued and hence it can be handled as side
- -- effect free. Note that this decoration must be done when the
- -- assignment has been analyzed because otherwise it will be
- -- rejected (see Analyze_Assignment).
+ elsif Is_Entity_Name (Iter_Name) then
+ Analyze (Iter_Name);
- Set_Is_Safe_To_Reevaluate (Id);
+ if Nkind (Iter_Name) = N_Function_Call then
+ declare
+ C : constant Node_Id := Name (Iter_Name);
+ I : Interp_Index;
+ It : Interp;
- Rewrite (Original_Bound, New_Occurrence_Of (Id, Loc));
+ begin
+ if not Is_Overloaded (Iter_Name) then
+ Resolve (Iter_Name, Etype (C));
- if Nkind (Assign) = N_Assignment_Statement then
- return Expression (Assign);
- else
- return Original_Bound;
+ 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;
+
+ -- Domain of iteration is not overloaded
+
+ else
+ Resolve (Iter_Name, Etype (Iter_Name));
+ end if;
+ end if;
+
+ 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
+ ("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;
- end One_Bound;
- -- Start of processing for Process_Bounds
+ -- Prevent cascaded errors
- begin
- Set_Parent (R_Copy, Parent (R));
- Pre_Analyze_Range (R_Copy);
- Typ := Etype (R_Copy);
+ Set_Ekind (Def_Id, E_Loop_Parameter);
+ Set_Etype (Def_Id, Etype (First_Index (Typ)));
+ end if;
- -- If the type of the discrete range is Universal_Integer, then the
- -- bound's type must be resolved to Integer, and any object used to
- -- hold the bound must also have type Integer, unless the literal
- -- bounds are constant-folded expressions with a user-defined type.
+ -- Check for type error in iterator
- if Typ = Universal_Integer then
- if Nkind (Lo) = N_Integer_Literal
- and then Present (Etype (Lo))
- and then Scope (Etype (Lo)) /= Standard_Standard
- then
- Typ := Etype (Lo);
+ elsif Typ = Any_Type then
+ return;
- elsif Nkind (Hi) = N_Integer_Literal
- and then Present (Etype (Hi))
- and then Scope (Etype (Hi)) /= Standard_Standard
+ -- Iteration over a container
+
+ else
+ Set_Ekind (Def_Id, E_Loop_Parameter);
+
+ if Of_Present (N) then
+
+ -- The type of the loop variable is the Iterator_Element aspect of
+ -- the container type.
+
+ declare
+ Element : constant Entity_Id :=
+ Find_Aspect (Typ, Aspect_Iterator_Element);
+ begin
+ if No (Element) then
+ Error_Msg_NE ("cannot iterate over&", N, Typ);
+ return;
+ else
+ Set_Etype (Def_Id, Entity (Element));
+ end if;
+ end;
+
+ else
+ -- 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.
+
+ if Is_Entity_Name (Original_Node (Name (N)))
+ and then not Is_Iterator (Typ)
then
- Typ := Etype (Hi);
+ if No (Find_Aspect (Typ, Aspect_Iterator_Element)) then
+ Error_Msg_NE
+ ("cannot iterate over&", Name (N), Typ);
+ else
+ Error_Msg_N
+ ("name must be an iterator, not a container", Name (N));
+ end if;
- else
- Typ := Standard_Integer;
+ Error_Msg_NE
+ ("\to iterate directly over the elements of 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, Etype (Ent));
+ exit;
+ end if;
+
+ Next_Entity (Ent);
+ end loop;
end if;
+ end if;
+ end Analyze_Iterator_Specification;
- Set_Etype (R, Typ);
+ -------------------
+ -- Analyze_Label --
+ -------------------
+
+ -- Note: the semantic work required for analyzing labels (setting them as
+ -- reachable) was done in a prepass through the statements in the block,
+ -- so that forward gotos would be properly handled. See Analyze_Statements
+ -- for further details. The only processing required here is to deal with
+ -- optimizations that depend on an assumption of sequential control flow,
+ -- since of course the occurrence of a label breaks this assumption.
- New_Lo_Bound := One_Bound (Lo, Low_Bound (R_Copy));
- New_Hi_Bound := One_Bound (Hi, High_Bound (R_Copy));
+ procedure Analyze_Label (N : Node_Id) is
+ pragma Warnings (Off, N);
+ begin
+ Kill_Current_Values;
+ end Analyze_Label;
- -- Propagate staticness to loop range itself, in case the
- -- corresponding subtype is static.
+ --------------------------
+ -- Analyze_Label_Entity --
+ --------------------------
- if New_Lo_Bound /= Lo
- and then Is_Static_Expression (New_Lo_Bound)
- then
- Rewrite (Low_Bound (R), New_Copy (New_Lo_Bound));
- end if;
+ procedure Analyze_Label_Entity (E : Entity_Id) is
+ begin
+ Set_Ekind (E, E_Label);
+ Set_Etype (E, Standard_Void_Type);
+ Set_Enclosing_Scope (E, Current_Scope);
+ Set_Reachable (E, True);
+ end Analyze_Label_Entity;
- if New_Hi_Bound /= Hi
- and then Is_Static_Expression (New_Hi_Bound)
- then
- Rewrite (High_Bound (R), New_Copy (New_Hi_Bound));
- end if;
- end Process_Bounds;
+ ------------------------------------------
+ -- Analyze_Loop_Parameter_Specification --
+ ------------------------------------------
+
+ procedure Analyze_Loop_Parameter_Specification (N : Node_Id) is
+ Loop_Nod : constant Node_Id := Parent (Parent (N));
+
+ procedure Check_Controlled_Array_Attribute (DS : Node_Id);
+ -- If the bounds are given by a 'Range reference on a function call
+ -- that returns a controlled array, introduce an explicit declaration
+ -- to capture the bounds, so that the function result can be finalized
+ -- in timely fashion.
+
+ function Has_Call_Using_Secondary_Stack (N : Node_Id) return Boolean;
+ -- N is the node for an arbitrary construct. This function searches the
+ -- construct N to see if any expressions within it contain function
+ -- calls that use the secondary stack, returning True if any such call
+ -- is found, and False otherwise.
+
+ procedure Process_Bounds (R : Node_Id);
+ -- If the iteration is given by a range, create temporaries and
+ -- assignment statements block to capture the bounds and perform
+ -- required finalization actions in case a bound includes a function
+ -- call that uses the temporary stack. We first pre-analyze a copy of
+ -- the range in order to determine the expected type, and analyze and
+ -- resolve the original bounds.
--------------------------------------
-- Check_Controlled_Array_Attribute --
procedure Check_Controlled_Array_Attribute (DS : Node_Id) is
begin
if Nkind (DS) = N_Attribute_Reference
- and then Is_Entity_Name (Prefix (DS))
- and then Ekind (Entity (Prefix (DS))) = E_Function
- and then Is_Array_Type (Etype (Entity (Prefix (DS))))
- and then
- Is_Controlled (
- Component_Type (Etype (Entity (Prefix (DS)))))
- and then Expander_Active
+ and then Is_Entity_Name (Prefix (DS))
+ and then Ekind (Entity (Prefix (DS))) = E_Function
+ and then Is_Array_Type (Etype (Entity (Prefix (DS))))
+ and then
+ Is_Controlled (Component_Type (Etype (Entity (Prefix (DS)))))
+ and then Expander_Active
then
declare
Loc : constant Source_Ptr := Sloc (N);
Defining_Identifier => Subt,
Subtype_Indication =>
Make_Subtype_Indication (Loc,
- Subtype_Mark => New_Reference_To (Indx, Loc),
- Constraint =>
- Make_Range_Constraint (Loc,
- Relocate_Node (DS))));
- Insert_Before (Parent (N), Decl);
+ Subtype_Mark => New_Reference_To (Indx, Loc),
+ Constraint =>
+ Make_Range_Constraint (Loc, Relocate_Node (DS))));
+ Insert_Before (Loop_Nod, Decl);
Analyze (Decl);
Rewrite (DS,
- Make_Attribute_Reference (Loc,
- Prefix => New_Reference_To (Subt, Loc),
- Attribute_Name => Attribute_Name (DS)));
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (Subt, Loc),
+ Attribute_Name => Attribute_Name (DS)));
+
Analyze (DS);
end;
end if;
return Check_Calls (N) = Abandon;
end Has_Call_Using_Secondary_Stack;
- -- Start of processing for Analyze_Iteration_Scheme
-
- begin
- -- If this is a rewritten quantified expression, the iteration scheme
- -- has been analyzed already. Do no repeat analysis because the loop
- -- variable is already declared.
-
- if Analyzed (N) then
- return;
- end if;
-
- -- For an infinite loop, there is no iteration scheme
-
- if No (N) then
- return;
- end if;
-
- -- Iteration scheme is present
-
- declare
- Cond : constant Node_Id := Condition (N);
-
- begin
- -- For WHILE loop, verify that the condition is a Boolean expression
- -- and resolve and check it.
-
- if Present (Cond) then
- Analyze_And_Resolve (Cond, Any_Boolean);
- Check_Unset_Reference (Cond);
- Set_Current_Value_Condition (N);
- return;
-
- -- For an iterator specification with "of", pre-analyze range to
- -- capture function calls that may require finalization actions.
-
- elsif Present (Iterator_Specification (N)) then
- Pre_Analyze_Range (Name (Iterator_Specification (N)));
- Analyze_Iterator_Specification (Iterator_Specification (N));
-
- -- Else we have a FOR loop
-
- else
- declare
- LP : constant Node_Id := Loop_Parameter_Specification (N);
- Id : constant Entity_Id := Defining_Identifier (LP);
- DS : constant Node_Id := Discrete_Subtype_Definition (LP);
-
- D_Copy : Node_Id;
-
- begin
- Enter_Name (Id);
-
- -- We always consider the loop variable to be referenced, since
- -- the loop may be used just for counting purposes.
-
- Generate_Reference (Id, N, ' ');
-
- -- Check for the case of loop variable hiding a local variable
- -- (used later on to give a nice warning if the hidden variable
- -- is never assigned).
-
- declare
- H : constant Entity_Id := Homonym (Id);
- begin
- if Present (H)
- and then Enclosing_Dynamic_Scope (H) =
- Enclosing_Dynamic_Scope (Id)
- and then Ekind (H) = E_Variable
- and then Is_Discrete_Type (Etype (H))
- then
- Set_Hiding_Loop_Variable (H, Id);
- end if;
- end;
-
- -- Loop parameter specification must include subtype mark in
- -- SPARK.
-
- if Nkind (DS) = N_Range then
- Check_SPARK_Restriction
- ("loop parameter specification must include subtype mark",
- N);
- end if;
-
- -- Analyze the subtype definition and create temporaries for
- -- the bounds. Do not evaluate the range when preanalyzing a
- -- quantified expression because bounds expressed as function
- -- calls with side effects will be erroneously replicated.
-
- if Nkind (DS) = N_Range
- and then Expander_Active
- and then Nkind (Parent (N)) /= N_Quantified_Expression
- then
- Process_Bounds (DS);
-
- -- Expander not active or else range of iteration is a subtype
- -- indication, an entity, or a function call that yields an
- -- aggregate or a container.
-
- else
- D_Copy := New_Copy_Tree (DS);
- 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.
+ --------------------
+ -- Process_Bounds --
+ --------------------
- -- 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.
+ procedure Process_Bounds (R : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (N);
- 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
- -- This is an iterator specification. Rewrite as such
- -- and analyze, to capture function calls that may
- -- require finalization actions.
-
- declare
- I_Spec : constant Node_Id :=
- Make_Iterator_Specification (Sloc (LP),
- Defining_Identifier =>
- Relocate_Node (Id),
- Name => D_Copy,
- Subtype_Indication => Empty,
- Reverse_Present =>
- Reverse_Present (LP));
- begin
- 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;
+ function One_Bound
+ (Original_Bound : Node_Id;
+ Analyzed_Bound : Node_Id;
+ Typ : Entity_Id) return Node_Id;
+ -- Capture value of bound and return captured value
- -- Set kind of loop parameter, which may be used in
- -- the subsequent analysis of the condition in a
- -- quantified expression.
+ ---------------
+ -- One_Bound --
+ ---------------
- Set_Ekind (Id, E_Loop_Parameter);
- return;
- end;
+ function One_Bound
+ (Original_Bound : Node_Id;
+ Analyzed_Bound : Node_Id;
+ Typ : Entity_Id) return Node_Id
+ is
+ Assign : Node_Id;
+ Decl : Node_Id;
+ Id : Entity_Id;
- -- Domain of iteration is not a function call, and is
- -- side-effect free.
+ begin
+ -- If the bound is a constant or an object, no need for a separate
+ -- declaration. If the bound is the result of previous expansion
+ -- it is already analyzed and should not be modified. Note that
+ -- the Bound will be resolved later, if needed, as part of the
+ -- call to Make_Index (literal bounds may need to be resolved to
+ -- type Integer).
- else
- Analyze (DS);
- end if;
- end if;
+ if Analyzed (Original_Bound) then
+ return Original_Bound;
- if DS = Error then
- return;
- end if;
+ elsif Nkind_In (Analyzed_Bound, N_Integer_Literal,
+ N_Character_Literal)
+ or else Is_Entity_Name (Analyzed_Bound)
+ then
+ Analyze_And_Resolve (Original_Bound, Typ);
+ return Original_Bound;
+ end if;
- -- Some additional checks if we are iterating through a type
+ -- 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.
- if Is_Entity_Name (DS)
- and then Present (Entity (DS))
- and then Is_Type (Entity (DS))
- then
- -- The subtype indication may denote the completion of an
- -- incomplete type declaration.
+ -- 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.
- if Ekind (Entity (DS)) = E_Incomplete_Type then
- Set_Entity (DS, Get_Full_View (Entity (DS)));
- Set_Etype (DS, Entity (DS));
- end if;
+ if not Has_Call_Using_Secondary_Stack (Analyzed_Bound) then
+ Analyze_And_Resolve (Original_Bound, Typ);
+ Force_Evaluation (Original_Bound);
+ return Original_Bound;
+ end if;
- -- Attempt to iterate through non-static predicate
+ Id := Make_Temporary (Loc, 'R', Original_Bound);
- if Is_Discrete_Type (Entity (DS))
- and then Present (Predicate_Function (Entity (DS)))
- and then No (Static_Predicate (Entity (DS)))
- then
- Bad_Predicated_Subtype_Use
- ("cannot use subtype& with non-static "
- & "predicate for loop iteration", DS, Entity (DS));
- end if;
- end if;
+ -- Here we make a declaration with a separate assignment
+ -- statement, and insert before loop header.
- -- Error if not discrete type
+ Decl :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Id,
+ Object_Definition => New_Occurrence_Of (Typ, Loc));
- if not Is_Discrete_Type (Etype (DS)) then
- Wrong_Type (DS, Any_Discrete);
- Set_Etype (DS, Any_Type);
- end if;
+ Assign :=
+ Make_Assignment_Statement (Loc,
+ Name => New_Occurrence_Of (Id, Loc),
+ Expression => Relocate_Node (Original_Bound));
- Check_Controlled_Array_Attribute (DS);
+ Insert_Actions (Loop_Nod, New_List (Decl, Assign));
- -- The index is not processed during analysis of a quantified
- -- expression but delayed to its expansion where the quantified
- -- expression is transformed into an expression with actions.
+ -- Now that this temporary variable is initialized we decorate it
+ -- as safe-to-reevaluate to inform to the backend that no further
+ -- asignment will be issued and hence it can be handled as side
+ -- effect free. Note that this decoration must be done when the
+ -- assignment has been analyzed because otherwise it will be
+ -- rejected (see Analyze_Assignment).
- if Nkind (Parent (N)) /= N_Quantified_Expression
- or else Operating_Mode = Check_Semantics
- or else Alfa_Mode
- then
- Make_Index (DS, LP, In_Iter_Schm => True);
- end if;
+ Set_Is_Safe_To_Reevaluate (Id);
- Set_Ekind (Id, E_Loop_Parameter);
+ Rewrite (Original_Bound, New_Occurrence_Of (Id, Loc));
- -- If the loop is part of a predicate or precondition, it may
- -- be analyzed twice, once in the source and once on the copy
- -- used to check conformance. Preserve the original itype
- -- because the second one may be created in a different scope,
- -- e.g. a precondition procedure, leading to a crash in GIGI.
+ if Nkind (Assign) = N_Assignment_Statement then
+ return Expression (Assign);
+ else
+ return Original_Bound;
+ end if;
+ end One_Bound;
- if No (Etype (Id)) or else Etype (Id) = Any_Type then
- Set_Etype (Id, Etype (DS));
- end if;
+ Hi : constant Node_Id := High_Bound (R);
+ Lo : constant Node_Id := Low_Bound (R);
+ R_Copy : constant Node_Id := New_Copy_Tree (R);
+ New_Hi : Node_Id;
+ New_Lo : Node_Id;
+ Typ : Entity_Id;
- -- Treat a range as an implicit reference to the type, to
- -- inhibit spurious warnings.
+ -- Start of processing for Process_Bounds
- Generate_Reference (Base_Type (Etype (DS)), N, ' ');
- Set_Is_Known_Valid (Id, True);
+ begin
+ Set_Parent (R_Copy, Parent (R));
+ Preanalyze_Range (R_Copy);
+ Typ := Etype (R_Copy);
- -- The loop is not a declarative part, so the only entity
- -- declared "within" must be frozen explicitly.
+ -- If the type of the discrete range is Universal_Integer, then the
+ -- bound's type must be resolved to Integer, and any object used to
+ -- hold the bound must also have type Integer, unless the literal
+ -- bounds are constant-folded expressions with a user-defined type.
- declare
- Flist : constant List_Id := Freeze_Entity (Id, N);
- begin
- if Is_Non_Empty_List (Flist) then
- Insert_Actions (N, Flist);
- end if;
- end;
-
- -- Check for null or possibly null range and issue warning. We
- -- suppress such messages in generic templates and instances,
- -- because in practice they tend to be dubious in these cases.
-
- if Nkind (DS) = N_Range and then Comes_From_Source (N) then
- declare
- L : constant Node_Id := Low_Bound (DS);
- H : constant Node_Id := High_Bound (DS);
-
- begin
- -- If range of loop is null, issue warning
-
- 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 they can result from
- -- intended parametrization.
-
- if not Inside_A_Generic
- and then not In_Instance
- then
- -- 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;
+ if Typ = Universal_Integer then
+ if Nkind (Lo) = N_Integer_Literal
+ and then Present (Etype (Lo))
+ and then Scope (Etype (Lo)) /= Standard_Standard
+ then
+ Typ := Etype (Lo);
- -- 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 likely.
+ elsif Nkind (Hi) = N_Integer_Literal
+ and then Present (Etype (Hi))
+ and then Scope (Etype (Hi)) /= Standard_Standard
+ then
+ Typ := Etype (Hi);
- Set_Suppress_Loop_Warnings (Parent (N));
+ else
+ Typ := Standard_Integer;
+ end if;
+ end if;
- -- The other case for a warning is a reverse loop
- -- where the upper bound is the integer literal zero
- -- or one, and the lower bound can be positive.
+ Set_Etype (R, Typ);
- -- For example, we have
+ New_Lo := One_Bound (Lo, Low_Bound (R_Copy), Typ);
+ New_Hi := One_Bound (Hi, High_Bound (R_Copy), Typ);
- -- for J in reverse N .. 1 loop
+ -- Propagate staticness to loop range itself, in case the
+ -- corresponding subtype is static.
- -- In practice, this is very likely to be a case of
- -- reversing the bounds incorrectly in the range.
+ if New_Lo /= Lo
+ and then Is_Static_Expression (New_Lo)
+ then
+ Rewrite (Low_Bound (R), New_Copy (New_Lo));
+ end if;
- elsif Reverse_Present (LP)
- and then Nkind (Original_Node (H)) =
- N_Integer_Literal
- and then (Intval (Original_Node (H)) = Uint_0
- or else
- 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);
- end if;
- end;
- end if;
- end;
+ if New_Hi /= Hi
+ and then Is_Static_Expression (New_Hi)
+ then
+ Rewrite (High_Bound (R), New_Copy (New_Hi));
end if;
- end;
- end Analyze_Iteration_Scheme;
+ end Process_Bounds;
- ------------------------------------
- -- Analyze_Iterator_Specification --
- ------------------------------------
+ -- Local variables
- procedure Analyze_Iterator_Specification (N : Node_Id) is
- Loc : constant Source_Ptr := Sloc (N);
- Def_Id : constant Node_Id := Defining_Identifier (N);
- Subt : constant Node_Id := Subtype_Indication (N);
- Iter_Name : constant Node_Id := Name (N);
+ DS : constant Node_Id := Discrete_Subtype_Definition (N);
+ Id : constant Entity_Id := Defining_Identifier (N);
- Ent : Entity_Id;
- Typ : Entity_Id;
+ DS_Copy : Node_Id;
+
+ -- Start of processing for Analyze_Loop_Parameter_Specification
begin
- Enter_Name (Def_Id);
+ Enter_Name (Id);
- Set_Ekind (Def_Id, E_Variable);
+ -- We always consider the loop variable to be referenced, since the loop
+ -- may be used just for counting purposes.
- if Present (Subt) then
- Analyze (Subt);
- end if;
+ Generate_Reference (Id, N, ' ');
- -- 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. In case of a quantified expression, this
- -- declaration is delayed to its expansion where the node is rewritten
- -- as an expression with actions.
+ -- Check for the case of loop variable hiding a local variable (used
+ -- later on to give a nice warning if the hidden variable is never
+ -- assigned).
- if not Is_Entity_Name (Iter_Name)
- and then (Nkind (Parent (Parent (N))) /= N_Quantified_Expression
- or else Operating_Mode = Check_Semantics
- or else Alfa_Mode)
- then
- declare
- Id : constant Entity_Id := Make_Temporary (Loc, 'R', Iter_Name);
- Decl : Node_Id;
+ declare
+ H : constant Entity_Id := Homonym (Id);
+ begin
+ if Present (H)
+ and then Ekind (H) = E_Variable
+ and then Is_Discrete_Type (Etype (H))
+ and then Enclosing_Dynamic_Scope (H) = Enclosing_Dynamic_Scope (Id)
+ then
+ Set_Hiding_Loop_Variable (H, Id);
+ end if;
+ end;
- begin
- Typ := Etype (Iter_Name);
+ -- Loop parameter specification must include subtype mark in SPARK
- -- The name in the renaming declaration may be a function call.
- -- Indicate that it does not come from source, to suppress
- -- spurious warnings on renamings of parameterless functions,
- -- a common enough idiom in user-defined iterators.
+ if Nkind (DS) = N_Range then
+ Check_SPARK_Restriction
+ ("loop parameter specification must include subtype mark", N);
+ end if;
- Decl :=
- Make_Object_Renaming_Declaration (Loc,
- Defining_Identifier => Id,
- Subtype_Mark => New_Occurrence_Of (Typ, Loc),
- Name =>
- New_Copy_Tree (Iter_Name, New_Sloc => Loc));
+ -- Analyze the subtype definition and create temporaries for the bounds.
+ -- Do not evaluate the range when preanalyzing a quantified expression
+ -- because bounds expressed as function calls with side effects will be
+ -- erroneously replicated.
- 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;
+ if Nkind (DS) = N_Range
+ and then Expander_Active
+ and then Nkind (Parent (N)) /= N_Quantified_Expression
+ then
+ Process_Bounds (DS);
- -- 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.
+ -- Either the expander not active or the range of iteration is a subtype
+ -- indication, an entity, or a function call that yields an aggregate or
+ -- a container.
- elsif Is_Entity_Name (Iter_Name) then
- Analyze (Iter_Name);
+ else
+ DS_Copy := New_Copy_Tree (DS);
+ Set_Parent (DS_Copy, Parent (DS));
+ Preanalyze_Range (DS_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 (DS_Copy) = N_Function_Call
+ or else
+ (Alfa_Mode
+ and then (Nkind (DS_Copy) = N_Attribute_Reference
+ and then
+ (Attribute_Name (DS_Copy) = Name_Result
+ or else Attribute_Name (DS_Copy) = Name_Old)))
+ or else
+ (Is_Entity_Name (DS_Copy)
+ and then not Is_Type (Entity (DS_Copy)))
+ then
+ -- This is an iterator specification. Rewrite it as such and
+ -- analyze it to capture function calls that may require
+ -- finalization actions.
- if Nkind (Iter_Name) = N_Function_Call then
declare
- C : constant Node_Id := Name (Iter_Name);
- I : Interp_Index;
- It : Interp;
+ I_Spec : constant Node_Id :=
+ Make_Iterator_Specification (Sloc (N),
+ Defining_Identifier => Relocate_Node (Id),
+ Name => DS_Copy,
+ Subtype_Indication => Empty,
+ Reverse_Present => Reverse_Present (N));
+ Scheme : constant Node_Id := Parent (N);
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;
+ Set_Iterator_Specification (Scheme, I_Spec);
+ Set_Loop_Parameter_Specification (Scheme, Empty);
+ Analyze_Iterator_Specification (I_Spec);
- elsif Is_Iterator (It.Typ) then
- Resolve (Iter_Name, It.Typ);
- exit;
- end if;
+ -- In a generic context, analyze the original domain of
+ -- iteration, for name capture.
- Get_Next_Interp (I, It);
- end loop;
+ 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;
- -- Domain of iteration is not overloaded
+ -- Domain of iteration is not a function call, and is side-effect
+ -- free.
else
- Resolve (Iter_Name, Etype (Iter_Name));
+ Analyze (DS);
end if;
end if;
- Typ := Etype (Iter_Name);
+ if DS = Error then
+ return;
+ end if;
- if Is_Array_Type (Typ) then
- if Of_Present (N) then
- Set_Etype (Def_Id, Component_Type (Typ));
+ -- Some additional checks if we are iterating through a type
- -- Here we have a missing Range attribute
+ if Is_Entity_Name (DS)
+ and then Present (Entity (DS))
+ and then Is_Type (Entity (DS))
+ then
+ -- The subtype indication may denote the completion of an incomplete
+ -- type declaration.
- else
- Error_Msg_N
- ("missing Range attribute in iteration over an array", N);
+ if Ekind (Entity (DS)) = E_Incomplete_Type then
+ Set_Entity (DS, Get_Full_View (Entity (DS)));
+ Set_Etype (DS, Entity (DS));
+ end if;
- -- In Ada 2012 mode, this may be an attempt at an iterator
+ -- Attempt to iterate through non-static predicate
- 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;
+ if Is_Discrete_Type (Entity (DS))
+ and then Present (Predicate_Function (Entity (DS)))
+ and then No (Static_Predicate (Entity (DS)))
+ then
+ Bad_Predicated_Subtype_Use
+ ("cannot use subtype& with non-static predicate for loop " &
+ "iteration", DS, Entity (DS));
+ end if;
+ end if;
- -- Prevent cascaded errors
+ -- Error if not discrete type
- Set_Ekind (Def_Id, E_Loop_Parameter);
- Set_Etype (Def_Id, Etype (First_Index (Typ)));
- end if;
+ if not Is_Discrete_Type (Etype (DS)) then
+ Wrong_Type (DS, Any_Discrete);
+ Set_Etype (DS, Any_Type);
+ end if;
- -- Check for type error in iterator
+ Check_Controlled_Array_Attribute (DS);
+
+ Make_Index (DS, N, In_Iter_Schm => True);
+ Set_Ekind (Id, E_Loop_Parameter);
+
+ -- A quantified expression which appears in a pre- or post-condition may
+ -- be analyzed multiple times. The analysis of the range creates several
+ -- itypes which reside in different scopes depending on whether the pre-
+ -- or post-condition has been expanded. Update the type of the loop
+ -- variable to reflect the proper itype at each stage of analysis.
+
+ if No (Etype (Id))
+ or else Etype (Id) = Any_Type
+ or else
+ (Present (Etype (Id))
+ and then Is_Itype (Etype (Id))
+ and then Nkind (Parent (Loop_Nod)) = N_Expression_With_Actions
+ and then Nkind (Original_Node (Parent (Loop_Nod))) =
+ N_Quantified_Expression)
+ then
+ Set_Etype (Id, Etype (DS));
+ end if;
- elsif Typ = Any_Type then
- return;
+ -- Treat a range as an implicit reference to the type, to inhibit
+ -- spurious warnings.
- -- Iteration over a container
+ Generate_Reference (Base_Type (Etype (DS)), N, ' ');
+ Set_Is_Known_Valid (Id, True);
- else
- Set_Ekind (Def_Id, E_Loop_Parameter);
+ -- The loop is not a declarative part, so the only entity declared
+ -- "within" must be frozen explicitly.
- if Of_Present (N) then
+ declare
+ Flist : constant List_Id := Freeze_Entity (Id, N);
+ begin
+ if Is_Non_Empty_List (Flist) then
+ Insert_Actions (N, Flist);
+ end if;
+ end;
- -- The type of the loop variable is the Iterator_Element aspect of
- -- the container type.
+ -- Check for null or possibly null range and issue warning. We suppress
+ -- such messages in generic templates and instances, because in practice
+ -- they tend to be dubious in these cases.
- declare
- Element : constant Entity_Id :=
- Find_Aspect (Typ, Aspect_Iterator_Element);
- begin
- if No (Element) then
- Error_Msg_NE ("cannot iterate over&", N, Typ);
- return;
- else
- Set_Etype (Def_Id, Entity (Element));
- end if;
- end;
+ if Nkind (DS) = N_Range and then Comes_From_Source (N) then
+ declare
+ L : constant Node_Id := Low_Bound (DS);
+ H : constant Node_Id := High_Bound (DS);
- else
- -- 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.
+ begin
+ -- If range of loop is null, issue warning
- if Is_Entity_Name (Original_Node (Name (N)))
- and then not Is_Iterator (Typ)
- then
- if No (Find_Aspect (Typ, Aspect_Iterator_Element)) then
- Error_Msg_NE
- ("cannot iterate over&", Name (N), Typ);
- else
- Error_Msg_N
- ("name must be an iterator, not a container", Name (N));
- end if;
+ if Compile_Time_Compare (L, H, Assume_Valid => True) = GT then
- Error_Msg_NE
- ("\to iterate directly over the elements of a container, " &
- "write `of &`", Name (N), Original_Node (Name (N)));
- end if;
+ -- Suppress the warning if inside a generic template or
+ -- instance, since in practice they tend to be dubious in these
+ -- cases since they can result from intended parametrization.
- -- 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.
+ if not Inside_A_Generic
+ and then not In_Instance
+ then
+ -- Specialize msg if invalid values could make the loop
+ -- non-null after all.
- Ent := First_Entity (Scope (Typ));
- while Present (Ent) loop
- if Chars (Ent) = Name_Cursor then
- Set_Etype (Def_Id, Etype (Ent));
- exit;
+ 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 (Loop_Nod);
+
+ -- 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;
- Next_Entity (Ent);
- end loop;
- end if;
- end if;
- end Analyze_Iterator_Specification;
+ -- 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 likely.
- -------------------
- -- Analyze_Label --
- -------------------
+ Set_Suppress_Loop_Warnings (Loop_Nod);
- -- Note: the semantic work required for analyzing labels (setting them as
- -- reachable) was done in a prepass through the statements in the block,
- -- so that forward gotos would be properly handled. See Analyze_Statements
- -- for further details. The only processing required here is to deal with
- -- optimizations that depend on an assumption of sequential control flow,
- -- since of course the occurrence of a label breaks this assumption.
+ -- The other case for a warning is a reverse loop where the
+ -- upper bound is the integer literal zero or one, and the
+ -- lower bound can be positive.
- procedure Analyze_Label (N : Node_Id) is
- pragma Warnings (Off, N);
- begin
- Kill_Current_Values;
- end Analyze_Label;
+ -- For example, we have
- --------------------------
- -- Analyze_Label_Entity --
- --------------------------
+ -- for J in reverse N .. 1 loop
- procedure Analyze_Label_Entity (E : Entity_Id) is
- begin
- Set_Ekind (E, E_Label);
- Set_Etype (E, Standard_Void_Type);
- Set_Enclosing_Scope (E, Current_Scope);
- Set_Reachable (E, True);
- end Analyze_Label_Entity;
+ -- In practice, this is very likely to be a case of reversing
+ -- the bounds incorrectly in the range.
+
+ elsif Reverse_Present (N)
+ and then Nkind (Original_Node (H)) = N_Integer_Literal
+ and then
+ (Intval (Original_Node (H)) = Uint_0
+ or else 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);
+ end if;
+ end;
+ end if;
+ end Analyze_Loop_Parameter_Specification;
----------------------------
-- Analyze_Loop_Statement --
begin
Nam_Copy := New_Copy_Tree (Nam);
Set_Parent (Nam_Copy, Parent (Nam));
- Pre_Analyze_Range (Nam_Copy);
+ Preanalyze_Range (Nam_Copy);
-- The only two options here are iteration over a container or
-- an array.
begin
DS_Copy := New_Copy_Tree (DS);
Set_Parent (DS_Copy, Parent (DS));
- Pre_Analyze_Range (DS_Copy);
+ Preanalyze_Range (DS_Copy);
-- Check for a call to Iterate ()
end if;
end Check_Unreachable_Code;
- -----------------------
- -- Pre_Analyze_Range --
- -----------------------
+ ----------------------
+ -- Preanalyze_Range --
+ ----------------------
- procedure Pre_Analyze_Range (R_Copy : Node_Id) is
+ procedure Preanalyze_Range (R_Copy : Node_Id) is
Save_Analysis : constant Boolean := Full_Analysis;
begin
Expander_Mode_Restore;
Full_Analysis := Save_Analysis;
- end Pre_Analyze_Range;
+ end Preanalyze_Range;
end Sem_Ch5;