Skip to content

R
riscv-gcc-1
Commit 804670f1 by Arnaud Charlet
Options

[multiple changes] 

2012-04-02  Emmanuel Briot  <briot@adacore.com>

	* g-expect.adb (Expect_Internal): Fix leak of the input file descriptor.

2012-04-02  Hristian Kirtchev  <kirtchev@adacore.com>

	* exp_ch4.adb (Expand_N_Quantified_Expression): Reimplemented.
	The expansion no longer uses the copy of the original QE created
	during analysis.
	* sem.adb (Analyze): Add processing for loop parameter specifications.
	* sem_ch4.adb (Analyze_Quantified_Expression): Reimplemented. The
	routine no longer creates a copy of the original QE. All
	constituents of a QE are now preanalyzed and resolved.
	* sem_ch5.adb (Analyze_Iteration_Scheme): Remove the guard which
	bypasses all processing when the iteration scheme is related to a
	QE. Relovate the code which analyzes loop parameter specifications
	to a separate routine.	(Analyze_Iterator_Specification):
	Preanalyze the iterator name. This action was originally
	done in Analyze_Iteration_Scheme. Update the check which
	detects an iterator specification in the context of a QE.
	(Analyze_Loop_Parameter_Specification): New routine. This
	procedure allows for a stand-alone analysis of a loop parameter
	specification without the need of a parent iteration scheme. Add
	code to update the type of the loop variable when the range
	generates an itype and the context is a QE.
	(Pre_Analyze_Range): Renamed to Preanalyze_Range. Update all references
	to the routine.
	* sem_ch5.ads: Code reformatting.
	(Analyze_Loop_Parameter_Specification): New routine.
	* sem_ch6.adb (Fully_Conformant_Expressions): Detect a case
	when establishing conformance between two QEs utilizing different
	specifications.
	* sem_res.adb (Proper_Current_Scope): New routine.
	(Resolve): Do not resolve a QE as there is nothing to be done now.
	Ignore any loop scopes generated for QEs when detecting an expression
	function as the scopes are cosmetic and do not appear in the tree.
	(Resolve_Quantified_Expression): Removed. All resolution of
	QE constituents is now performed during analysis. This ensures
	that loop variables appearing in array aggregates are properly
	resolved.

2012-04-02  Ed Schonberg  <schonberg@adacore.com>

	* sem_util.adb (Build_Default_Subtype): If the base type is
	private and its full view is available, use the full view in
	the subtype declaration.

From-SVN: r186074
parent a7942a0e
Showing with 678 additions and 679 deletions
gcc/ada/ChangeLog
2012-04-02 Emmanuel Briot <briot@adacore.com>
* g-expect.adb (Expect_Internal): Fix leak of the input file descriptor.
2012-04-02 Hristian Kirtchev <kirtchev@adacore.com>
* exp_ch4.adb (Expand_N_Quantified_Expression): Reimplemented.
The expansion no longer uses the copy of the original QE created
during analysis.
* sem.adb (Analyze): Add processing for loop parameter specifications.
* sem_ch4.adb (Analyze_Quantified_Expression): Reimplemented. The
routine no longer creates a copy of the original QE. All
constituents of a QE are now preanalyzed and resolved.
* sem_ch5.adb (Analyze_Iteration_Scheme): Remove the guard which
bypasses all processing when the iteration scheme is related to a
QE. Relovate the code which analyzes loop parameter specifications
to a separate routine. (Analyze_Iterator_Specification):
Preanalyze the iterator name. This action was originally
done in Analyze_Iteration_Scheme. Update the check which
detects an iterator specification in the context of a QE.
(Analyze_Loop_Parameter_Specification): New routine. This
procedure allows for a stand-alone analysis of a loop parameter
specification without the need of a parent iteration scheme. Add
code to update the type of the loop variable when the range
generates an itype and the context is a QE.
(Pre_Analyze_Range): Renamed to Preanalyze_Range. Update all references
to the routine.
* sem_ch5.ads: Code reformatting.
(Analyze_Loop_Parameter_Specification): New routine.
* sem_ch6.adb (Fully_Conformant_Expressions): Detect a case
when establishing conformance between two QEs utilizing different
specifications.
* sem_res.adb (Proper_Current_Scope): New routine.
(Resolve): Do not resolve a QE as there is nothing to be done now.
Ignore any loop scopes generated for QEs when detecting an expression
function as the scopes are cosmetic and do not appear in the tree.
(Resolve_Quantified_Expression): Removed. All resolution of
QE constituents is now performed during analysis. This ensures
that loop variables appearing in array aggregates are properly
resolved.
2012-04-02 Ed Schonberg <schonberg@adacore.com>
* sem_util.adb (Build_Default_Subtype): If the base type is
private and its full view is available, use the full view in
the subtype declaration.
2012-04-02 Jose Ruiz <ruiz@adacore.com> 2012-04-02 Jose Ruiz <ruiz@adacore.com>
* gnat_ugn.texi: Add some minimal documentation about how to * gnat_ugn.texi: Add some minimal documentation about how to
......
gcc/ada/exp_ch4.adb
...@@ -7884,73 +7884,78 @@ package body Exp_Ch4 is ...@@ -7884,73 +7884,78 @@ package body Exp_Ch4 is
-- given by an iterator specification, not a loop parameter specification. -- given by an iterator specification, not a loop parameter specification.
procedure Expand_N_Quantified_Expression (N : Node_Id) is procedure Expand_N_Quantified_Expression (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Is_Universal : constant Boolean := All_Present (N);
Actions : constant List_Id := New_List; Actions : constant List_Id := New_List;
Tnn : constant Entity_Id := Make_Temporary (Loc, 'T', N); For_All : constant Boolean := All_Present (N);
Iter_Spec : constant Node_Id := Iterator_Specification (N);
Loc : constant Source_Ptr := Sloc (N);
Loop_Spec : constant Node_Id := Loop_Parameter_Specification (N);
Cond : Node_Id; Cond : Node_Id;
Decl : Node_Id; Flag : Entity_Id;
I_Scheme : Node_Id; Scheme : Node_Id;
Original_N : Node_Id; Stmts : List_Id;
Test : Node_Id;
begin begin
-- Retrieve the original quantified expression (non analyzed) -- Create the declaration of the flag which tracks the status of the
-- quantified expression. Generate:
if Present (Loop_Parameter_Specification (N)) then -- Flag : Boolean := (True | False);
Original_N := Parent (Parent (Loop_Parameter_Specification (N)));
else
Original_N := Parent (Parent (Iterator_Specification (N)));
end if;
-- Rewrite N with the original quantified expression
Rewrite (N, Original_N); Flag := Make_Temporary (Loc, 'T', N);
Decl := Append_To (Actions,
Make_Object_Declaration (Loc, Make_Object_Declaration (Loc,
Defining_Identifier => Tnn, Defining_Identifier => Flag,
Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc), Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc),
Expression => Expression =>
New_Occurrence_Of (Boolean_Literals (Is_Universal), Loc)); New_Occurrence_Of (Boolean_Literals (For_All), Loc)));
Append_To (Actions, Decl);
-- Construct the circuitry which tracks the status of the quantified
-- expression. Generate:
-- if [not] Cond then
-- Flag := (False | True);
-- exit;
-- end if;
Cond := Relocate_Node (Condition (N)); Cond := Relocate_Node (Condition (N));
if Is_Universal then if For_All then
Cond := Make_Op_Not (Loc, Cond); Cond := Make_Op_Not (Loc, Cond);
end if; end if;
Test := Stmts := New_List (
Make_Implicit_If_Statement (N, Make_Implicit_If_Statement (N,
Condition => Cond, Condition => Cond,
Then_Statements => New_List ( Then_Statements => New_List (
Make_Assignment_Statement (Loc, Make_Assignment_Statement (Loc,
Name => New_Occurrence_Of (Tnn, Loc), Name => New_Occurrence_Of (Flag, Loc),
Expression => Expression =>
New_Occurrence_Of (Boolean_Literals (not Is_Universal), Loc)), New_Occurrence_Of (Boolean_Literals (not For_All), Loc)),
Make_Exit_Statement (Loc))); Make_Exit_Statement (Loc))));
-- Build the loop equivalent of the quantified expression
if Present (Loop_Parameter_Specification (N)) then if Present (Iter_Spec) then
I_Scheme := Scheme :=
Make_Iteration_Scheme (Loc, Make_Iteration_Scheme (Loc,
Loop_Parameter_Specification => Iterator_Specification => Iter_Spec);
Loop_Parameter_Specification (N));
else else
I_Scheme := Scheme :=
Make_Iteration_Scheme (Loc, Make_Iteration_Scheme (Loc,
Iterator_Specification => Iterator_Specification (N)); Loop_Parameter_Specification => Loop_Spec);
end if; end if;
Append_To (Actions, Append_To (Actions,
Make_Loop_Statement (Loc, Make_Loop_Statement (Loc,
Iteration_Scheme => I_Scheme, Iteration_Scheme => Scheme,
Statements => New_List (Test), Statements => Stmts,
End_Label => Empty)); End_Label => Empty));
-- Transform the quantified expression
Rewrite (N, Rewrite (N,
Make_Expression_With_Actions (Loc, Make_Expression_With_Actions (Loc,
Expression => New_Occurrence_Of (Tnn, Loc), Expression => New_Occurrence_Of (Flag, Loc),
Actions => Actions)); Actions => Actions));
Analyze_And_Resolve (N, Standard_Boolean); Analyze_And_Resolve (N, Standard_Boolean);
......
gcc/ada/g-expect.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 2000-2011, AdaCore -- -- Copyright (C) 2000-2012, AdaCore --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -33,7 +33,7 @@ with System; use System; ...@@ -33,7 +33,7 @@ with System; use System;
with System.OS_Constants; use System.OS_Constants; with System.OS_Constants; use System.OS_Constants;
with Ada.Calendar; use Ada.Calendar; with Ada.Calendar; use Ada.Calendar;
with GNAT.IO; with GNAT.IO; use GNAT.IO;
with GNAT.OS_Lib; use GNAT.OS_Lib; with GNAT.OS_Lib; use GNAT.OS_Lib;
with GNAT.Regpat; use GNAT.Regpat; with GNAT.Regpat; use GNAT.Regpat;
...@@ -678,6 +678,7 @@ package body GNAT.Expect is ...@@ -678,6 +678,7 @@ package body GNAT.Expect is
-- ??? Note that ddd tries again up to three times -- ??? Note that ddd tries again up to three times
-- in that case. See LiterateA.C:174 -- in that case. See LiterateA.C:174
Close (Descriptors (D).Input_Fd);
Descriptors (D).Input_Fd := Invalid_FD; Descriptors (D).Input_Fd := Invalid_FD;
Result := Expect_Process_Died; Result := Expect_Process_Died;
return; return;
...@@ -893,7 +894,8 @@ package body GNAT.Expect is ...@@ -893,7 +894,8 @@ package body GNAT.Expect is
begin begin
Non_Blocking_Spawn Non_Blocking_Spawn
(Process, Command, Arguments, Err_To_Out => Err_To_Out); (Process, Command, Arguments, Err_To_Out => Err_To_Out,
Buffer_Size => 0);
if Input'Length > 0 then if Input'Length > 0 then
Send (Process, Input); Send (Process, Input);
...@@ -1055,17 +1057,18 @@ package body GNAT.Expect is ...@@ -1055,17 +1057,18 @@ package body GNAT.Expect is
Command_With_Path : String_Access; Command_With_Path : String_Access;
begin begin
-- Create the rest of the pipes
Set_Up_Communications
(Descriptor, Err_To_Out, Pipe1'Access, Pipe2'Access, Pipe3'Access);
Command_With_Path := Locate_Exec_On_Path (Command); Command_With_Path := Locate_Exec_On_Path (Command);
if Command_With_Path = null then if Command_With_Path = null then
raise Invalid_Process; raise Invalid_Process;
end if; end if;
-- Create the rest of the pipes once we know we will be able to
-- execute the process.
Set_Up_Communications
(Descriptor, Err_To_Out, Pipe1'Access, Pipe2'Access, Pipe3'Access);
-- Fork a new process -- Fork a new process
Descriptor.Pid := Fork; Descriptor.Pid := Fork;
...@@ -1365,6 +1368,8 @@ package body GNAT.Expect is ...@@ -1365,6 +1368,8 @@ package body GNAT.Expect is
end if; end if;
if Create_Pipe (Pipe2) /= 0 then if Create_Pipe (Pipe2) /= 0 then
Close (Pipe1.Input);
Close (Pipe1.Output);
return; return;
end if; end if;
...@@ -1389,7 +1394,7 @@ package body GNAT.Expect is ...@@ -1389,7 +1394,7 @@ package body GNAT.Expect is
-- Create a separate pipe for standard error -- Create a separate pipe for standard error
if Create_Pipe (Pipe3) /= 0 then if Create_Pipe (Pipe3) /= 0 then
return; Pipe3.all := Pipe2.all;
end if; end if;
end if; end if;
......
gcc/ada/sem.adb
...@@ -314,6 +314,9 @@ package body Sem is ...@@ -314,6 +314,9 @@ package body Sem is
when N_Label => when N_Label =>
Analyze_Label (N); Analyze_Label (N);
when N_Loop_Parameter_Specification =>
Analyze_Loop_Parameter_Specification (N);
when N_Loop_Statement => when N_Loop_Statement =>
Analyze_Loop_Statement (N); Analyze_Loop_Statement (N);
...@@ -681,7 +684,6 @@ package body Sem is ...@@ -681,7 +684,6 @@ package body Sem is
N_Generic_Association | N_Generic_Association |
N_Index_Or_Discriminant_Constraint | N_Index_Or_Discriminant_Constraint |
N_Iteration_Scheme | N_Iteration_Scheme |
N_Loop_Parameter_Specification |
N_Mod_Clause | N_Mod_Clause |
N_Modular_Type_Definition | N_Modular_Type_Definition |
N_Ordinary_Fixed_Point_Definition | N_Ordinary_Fixed_Point_Definition |
......
gcc/ada/sem_ch4.adb
...@@ -47,7 +47,6 @@ with Sem_Aux; use Sem_Aux; ...@@ -47,7 +47,6 @@ with Sem_Aux; use Sem_Aux;
with Sem_Case; use Sem_Case; with Sem_Case; use Sem_Case;
with Sem_Cat; use Sem_Cat; with Sem_Cat; use Sem_Cat;
with Sem_Ch3; use Sem_Ch3; with Sem_Ch3; use Sem_Ch3;
with Sem_Ch5; use Sem_Ch5;
with Sem_Ch6; use Sem_Ch6; with Sem_Ch6; use Sem_Ch6;
with Sem_Ch8; use Sem_Ch8; with Sem_Ch8; use Sem_Ch8;
with Sem_Dim; use Sem_Dim; with Sem_Dim; use Sem_Dim;
...@@ -3403,101 +3402,38 @@ package body Sem_Ch4 is ...@@ -3403,101 +3402,38 @@ package body Sem_Ch4 is
----------------------------------- -----------------------------------
procedure Analyze_Quantified_Expression (N : Node_Id) is procedure Analyze_Quantified_Expression (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N); QE_Scop : Entity_Id;
Ent : constant Entity_Id :=
New_Internal_Entity (E_Loop, Current_Scope, Sloc (N), 'L');
Need_Preanalysis : constant Boolean :=
Operating_Mode /= Check_Semantics
and then not Alfa_Mode;
Iterator : Node_Id;
Original_N : Node_Id;
begin begin
-- The approach in this procedure is very non-standard and at the
-- very least, extensive comments are required saying why this very
-- non-standard approach is needed???
-- Also general comments are needed in any case saying what is going
-- on here, since tree rewriting of this kind should normally be done
-- by the expander and not by the analyzer ??? Probably Ent, Iterator,
-- and Original_N, and Needs_Preanalysis, all need comments above ???
-- Preserve the original node used for the expansion of the quantified
-- expression.
-- This is a very unusual use of Copy_Separate_Tree, needs looking at???
if Need_Preanalysis then
Original_N := Copy_Separate_Tree (N);
end if;
Set_Etype (Ent, Standard_Void_Type);
Set_Scope (Ent, Current_Scope);
Set_Parent (Ent, N);
Check_SPARK_Restriction ("quantified expression is not allowed", N); Check_SPARK_Restriction ("quantified expression is not allowed", N);
-- The following seems like expansion activity done at analysis -- Create a scope to emulate the loop-like behavior of the quantified
-- time, which seems weird ??? -- expression. The scope is needed to provide proper visibility of the
-- loop variable.
if Present (Loop_Parameter_Specification (N)) then
Iterator :=
Make_Iteration_Scheme (Loc,
Loop_Parameter_Specification =>
Loop_Parameter_Specification (N));
else
Iterator :=
Make_Iteration_Scheme (Loc,
Iterator_Specification =>
Iterator_Specification (N));
end if;
Push_Scope (Ent);
Set_Parent (Iterator, N);
Analyze_Iteration_Scheme (Iterator);
-- The loop specification may have been converted into an iterator
-- specification during its analysis. Update the quantified node
-- accordingly.
if Present (Iterator_Specification (Iterator)) then
Set_Iterator_Specification
(N, Iterator_Specification (Iterator));
Set_Loop_Parameter_Specification (N, Empty);
Set_Parent (Iterator_Specification (Iterator), Iterator);
end if;
if Need_Preanalysis then QE_Scop := New_Internal_Entity (E_Loop, Current_Scope, Sloc (N), 'L');
Set_Etype (QE_Scop, Standard_Void_Type);
Set_Scope (QE_Scop, Current_Scope);
Set_Parent (QE_Scop, N);
-- The full analysis will be performed during the expansion of the Push_Scope (QE_Scop);
-- quantified expression, only a preanalysis of the condition needs
-- to be done.
-- This is strange for two reasons -- All constituents are preanalyzed and resolved to avoid untimely
-- generation of various temporaries and types. Full analysis and
-- expansion is carried out when the quantified expression is
-- transformed into an expression with actions.
-- First, there is almost no situation in which Preanalyze vs if Present (Iterator_Specification (N)) then
-- Analyze should be conditioned on -gnatc mode (since error msgs Preanalyze (Iterator_Specification (N));
-- must be 100% unaffected by -gnatc). Seconed doing a Preanalyze
-- with no resolution almost certainly means that some messages are
-- either missed, or flagged differently in the two cases.
Preanalyze (Condition (N));
else else
Analyze (Condition (N)); Preanalyze (Loop_Parameter_Specification (N));
end if; end if;
Preanalyze_And_Resolve (Condition (N), Standard_Boolean);
End_Scope; End_Scope;
Set_Etype (N, Standard_Boolean); Set_Etype (N, Standard_Boolean);
-- Attach the original node to the iteration scheme created above
if Need_Preanalysis then
Set_Etype (Original_N, Standard_Boolean);
Set_Parent (Iterator, Original_N);
end if;
end Analyze_Quantified_Expression; end Analyze_Quantified_Expression;
------------------- -------------------
......
gcc/ada/sem_ch5.adb
...@@ -76,7 +76,7 @@ package body Sem_Ch5 is ...@@ -76,7 +76,7 @@ package body Sem_Ch5 is
-- messages. This variable is recursively saved on entry to processing the -- messages. This variable is recursively saved on entry to processing the
-- construct, and restored on exit. -- 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 -- Determine expected type of range or domain of iteration of Ada 2012
-- loop by analyzing separate copy. Do the analysis and resolution of the -- loop by analyzing separate copy. Do the analysis and resolution of the
-- copy of the bound(s) with expansion disabled, to prevent the generation -- copy of the bound(s) with expansion disabled, to prevent the generation
...@@ -1607,178 +1607,284 @@ package body Sem_Ch5 is ...@@ -1607,178 +1607,284 @@ package body Sem_Ch5 is
------------------------------ ------------------------------
procedure Analyze_Iteration_Scheme (N : Node_Id) is 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); begin
-- If the iteration is given by a range, create temporaries and -- For an infinite loop, there is no iteration scheme
-- 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.
procedure Check_Controlled_Array_Attribute (DS : Node_Id); if No (N) then
-- If the bounds are given by a 'Range reference on a function call return;
-- that returns a controlled array, introduce an explicit declaration end if;
-- 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; Cond := Condition (N);
-- N is the node for an arbitrary construct. This function searches the Iter_Spec := Iterator_Specification (N);
-- construct N to see if any expressions within it contain function Loop_Spec := Loop_Parameter_Specification (N);
-- calls that use the secondary stack, returning True if any such call
-- is found, and False otherwise.
-------------------- if Present (Cond) then
-- Process_Bounds -- Analyze_And_Resolve (Cond, Any_Boolean);
-------------------- Check_Unset_Reference (Cond);
Set_Current_Value_Condition (N);
procedure Process_Bounds (R : Node_Id) is elsif Present (Iter_Spec) then
Loc : constant Source_Ptr := Sloc (N); Analyze_Iterator_Specification (Iter_Spec);
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;
function One_Bound else
(Original_Bound : Node_Id; Analyze_Loop_Parameter_Specification (Loop_Spec);
Analyzed_Bound : Node_Id) return Node_Id; end if;
-- Capture value of bound and return captured value end Analyze_Iteration_Scheme;
--------------- ------------------------------------
-- One_Bound -- -- Analyze_Iterator_Specification --
--------------- ------------------------------------
function One_Bound procedure Analyze_Iterator_Specification (N : Node_Id) is
(Original_Bound : Node_Id; Loc : constant Source_Ptr := Sloc (N);
Analyzed_Bound : Node_Id) return Node_Id Def_Id : constant Node_Id := Defining_Identifier (N);
is Subt : constant Node_Id := Subtype_Indication (N);
Assign : Node_Id; Iter_Name : constant Node_Id := Name (N);
Decl : Node_Id;
Id : Entity_Id;
begin Ent : Entity_Id;
-- If the bound is a constant or an object, no need for a separate Typ : Entity_Id;
-- 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).
if Analyzed (Original_Bound) then begin
return Original_Bound; Enter_Name (Def_Id);
Set_Ekind (Def_Id, E_Variable);
elsif Nkind_In (Analyzed_Bound, N_Integer_Literal, if Present (Subt) then
N_Character_Literal) Analyze (Subt);
or else Is_Entity_Name (Analyzed_Bound)
then
Analyze_And_Resolve (Original_Bound, Typ);
return Original_Bound;
end if; end if;
-- Normally, the best approach is simply to generate a constant Preanalyze_Range (Iter_Name);
-- 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 -- If the domain of iteration is an expression, create a declaration for
-- proper trace of the value, useful in optimizations that get rid -- it, so that finalization actions are introduced outside of the loop.
-- of junk range checks. -- 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 if not Is_Entity_Name (Iter_Name)
Analyze_And_Resolve (Original_Bound, Typ); and then (Nkind (Parent (N)) /= N_Quantified_Expression
Force_Evaluation (Original_Bound); or else Operating_Mode = Check_Semantics
return Original_Bound; or else Alfa_Mode)
end if; 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 -- The name in the renaming declaration may be a function call.
-- statement, and insert before loop header. -- 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 := Decl :=
Make_Object_Declaration (Loc, Make_Object_Renaming_Declaration (Loc,
Defining_Identifier => Id, 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 := Insert_Actions (Parent (Parent (N)), New_List (Decl));
Make_Assignment_Statement (Loc, Rewrite (Name (N), New_Occurrence_Of (Id, Loc));
Name => New_Occurrence_Of (Id, Loc), Set_Etype (Id, Typ);
Expression => Relocate_Node (Original_Bound)); 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 elsif Is_Entity_Name (Iter_Name) then
-- as safe-to-reevaluate to inform to the backend that no further Analyze (Iter_Name);
-- 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).
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 else
return Original_Bound; 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; end if;
end One_Bound;
-- Start of processing for Process_Bounds elsif Is_Iterator (It.Typ) then
Resolve (Iter_Name, It.Typ);
exit;
end if;
begin Get_Next_Interp (I, It);
Set_Parent (R_Copy, Parent (R)); end loop;
Pre_Analyze_Range (R_Copy); end if;
Typ := Etype (R_Copy); end;
-- If the type of the discrete range is Universal_Integer, then the -- Domain of iteration is not overloaded
-- 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.
if Typ = Universal_Integer then else
if Nkind (Lo) = N_Integer_Literal Resolve (Iter_Name, Etype (Iter_Name));
and then Present (Etype (Lo)) end if;
and then Scope (Etype (Lo)) /= Standard_Standard end if;
then
Typ := Etype (Lo);
elsif Nkind (Hi) = N_Integer_Literal Typ := Etype (Iter_Name);
and then Present (Etype (Hi))
and then Scope (Etype (Hi)) /= Standard_Standard if Is_Array_Type (Typ) then
then if Of_Present (N) then
Typ := Etype (Hi); Set_Etype (Def_Id, Component_Type (Typ));
-- Here we have a missing Range attribute
else else
Typ := Standard_Integer; 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 if;
-- Prevent cascaded errors
Set_Ekind (Def_Id, E_Loop_Parameter);
Set_Etype (Def_Id, Etype (First_Index (Typ)));
end if; end if;
Set_Etype (R, Typ); -- Check for type error in iterator
New_Lo_Bound := One_Bound (Lo, Low_Bound (R_Copy)); elsif Typ = Any_Type then
New_Hi_Bound := One_Bound (Hi, High_Bound (R_Copy)); return;
-- Propagate staticness to loop range itself, in case the -- Iteration over a container
-- corresponding subtype is static.
if New_Lo_Bound /= Lo else
and then Is_Static_Expression (New_Lo_Bound) Set_Ekind (Def_Id, E_Loop_Parameter);
then
Rewrite (Low_Bound (R), New_Copy (New_Lo_Bound)); 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 if;
end;
if New_Hi_Bound /= Hi else
and then Is_Static_Expression (New_Hi_Bound) -- 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 then
Rewrite (High_Bound (R), New_Copy (New_Hi_Bound)); 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; end if;
end Process_Bounds;
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;
-------------------
-- 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.
procedure Analyze_Label (N : Node_Id) is
pragma Warnings (Off, N);
begin
Kill_Current_Values;
end Analyze_Label;
--------------------------
-- Analyze_Label_Entity --
--------------------------
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;
------------------------------------------
-- 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 -- -- Check_Controlled_Array_Attribute --
...@@ -1791,8 +1897,7 @@ package body Sem_Ch5 is ...@@ -1791,8 +1897,7 @@ package body Sem_Ch5 is
and then Ekind (Entity (Prefix (DS))) = E_Function and then Ekind (Entity (Prefix (DS))) = E_Function
and then Is_Array_Type (Etype (Entity (Prefix (DS)))) and then Is_Array_Type (Etype (Entity (Prefix (DS))))
and then and then
Is_Controlled ( Is_Controlled (Component_Type (Etype (Entity (Prefix (DS)))))
Component_Type (Etype (Entity (Prefix (DS)))))
and then Expander_Active and then Expander_Active
then then
declare declare
...@@ -1811,15 +1916,15 @@ package body Sem_Ch5 is ...@@ -1811,15 +1916,15 @@ package body Sem_Ch5 is
Make_Subtype_Indication (Loc, Make_Subtype_Indication (Loc,
Subtype_Mark => New_Reference_To (Indx, Loc), Subtype_Mark => New_Reference_To (Indx, Loc),
Constraint => Constraint =>
Make_Range_Constraint (Loc, Make_Range_Constraint (Loc, Relocate_Node (DS))));
Relocate_Node (DS)))); Insert_Before (Loop_Nod, Decl);
Insert_Before (Parent (N), Decl);
Analyze (Decl); Analyze (Decl);
Rewrite (DS, Rewrite (DS,
Make_Attribute_Reference (Loc, Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Subt, Loc), Prefix => New_Reference_To (Subt, Loc),
Attribute_Name => Attribute_Name (DS))); Attribute_Name => Attribute_Name (DS)));
Analyze (DS); Analyze (DS);
end; end;
end if; end if;
...@@ -1889,93 +1994,205 @@ package body Sem_Ch5 is ...@@ -1889,93 +1994,205 @@ package body Sem_Ch5 is
return Check_Calls (N) = Abandon; return Check_Calls (N) = Abandon;
end Has_Call_Using_Secondary_Stack; end Has_Call_Using_Secondary_Stack;
-- Start of processing for Analyze_Iteration_Scheme --------------------
-- Process_Bounds --
--------------------
procedure Process_Bounds (R : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
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
---------------
-- One_Bound --
---------------
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;
begin begin
-- If this is a rewritten quantified expression, the iteration scheme -- If the bound is a constant or an object, no need for a separate
-- has been analyzed already. Do no repeat analysis because the loop -- declaration. If the bound is the result of previous expansion
-- variable is already declared. -- 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).
if Analyzed (N) then if Analyzed (Original_Bound) then
return; return Original_Bound;
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; end if;
-- For an infinite loop, there is no iteration scheme -- 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 No (N) then -- We prefer the constant declaration, since it leaves us with a
return; -- proper trace of the value, useful in optimizations that get rid
-- of junk range checks.
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; end if;
-- Iteration scheme is present Id := Make_Temporary (Loc, 'R', Original_Bound);
declare -- Here we make a declaration with a separate assignment
Cond : constant Node_Id := Condition (N); -- statement, and insert before loop header.
Decl :=
Make_Object_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 (Original_Bound));
Insert_Actions (Loop_Nod, New_List (Decl, Assign));
-- 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).
Set_Is_Safe_To_Reevaluate (Id);
Rewrite (Original_Bound, New_Occurrence_Of (Id, Loc));
if Nkind (Assign) = N_Assignment_Statement then
return Expression (Assign);
else
return Original_Bound;
end if;
end One_Bound;
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;
-- Start of processing for Process_Bounds
begin begin
-- For WHILE loop, verify that the condition is a Boolean expression Set_Parent (R_Copy, Parent (R));
-- and resolve and check it. Preanalyze_Range (R_Copy);
Typ := Etype (R_Copy);
-- 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.
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 Nkind (Hi) = N_Integer_Literal
and then Present (Etype (Hi))
and then Scope (Etype (Hi)) /= Standard_Standard
then
Typ := Etype (Hi);
else
Typ := Standard_Integer;
end if;
end if;
Set_Etype (R, Typ);
New_Lo := One_Bound (Lo, Low_Bound (R_Copy), Typ);
New_Hi := One_Bound (Hi, High_Bound (R_Copy), Typ);
-- Propagate staticness to loop range itself, in case the
-- corresponding subtype is static.
if Present (Cond) then if New_Lo /= Lo
Analyze_And_Resolve (Cond, Any_Boolean); and then Is_Static_Expression (New_Lo)
Check_Unset_Reference (Cond); then
Set_Current_Value_Condition (N); Rewrite (Low_Bound (R), New_Copy (New_Lo));
return; end if;
-- For an iterator specification with "of", pre-analyze range to if New_Hi /= Hi
-- capture function calls that may require finalization actions. and then Is_Static_Expression (New_Hi)
then
Rewrite (High_Bound (R), New_Copy (New_Hi));
end if;
end Process_Bounds;
elsif Present (Iterator_Specification (N)) then -- Local variables
Pre_Analyze_Range (Name (Iterator_Specification (N)));
Analyze_Iterator_Specification (Iterator_Specification (N));
-- Else we have a FOR loop DS : constant Node_Id := Discrete_Subtype_Definition (N);
Id : constant Entity_Id := Defining_Identifier (N);
else DS_Copy : Node_Id;
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; -- Start of processing for Analyze_Loop_Parameter_Specification
begin begin
Enter_Name (Id); Enter_Name (Id);
-- We always consider the loop variable to be referenced, since -- We always consider the loop variable to be referenced, since the loop
-- the loop may be used just for counting purposes. -- may be used just for counting purposes.
Generate_Reference (Id, N, ' '); Generate_Reference (Id, N, ' ');
-- Check for the case of loop variable hiding a local variable -- Check for the case of loop variable hiding a local variable (used
-- (used later on to give a nice warning if the hidden variable -- later on to give a nice warning if the hidden variable is never
-- is never assigned). -- assigned).
declare declare
H : constant Entity_Id := Homonym (Id); H : constant Entity_Id := Homonym (Id);
begin begin
if Present (H) if Present (H)
and then Enclosing_Dynamic_Scope (H) =
Enclosing_Dynamic_Scope (Id)
and then Ekind (H) = E_Variable and then Ekind (H) = E_Variable
and then Is_Discrete_Type (Etype (H)) and then Is_Discrete_Type (Etype (H))
and then Enclosing_Dynamic_Scope (H) = Enclosing_Dynamic_Scope (Id)
then then
Set_Hiding_Loop_Variable (H, Id); Set_Hiding_Loop_Variable (H, Id);
end if; end if;
end; end;
-- Loop parameter specification must include subtype mark in -- Loop parameter specification must include subtype mark in SPARK
-- SPARK.
if Nkind (DS) = N_Range then if Nkind (DS) = N_Range then
Check_SPARK_Restriction Check_SPARK_Restriction
("loop parameter specification must include subtype mark", ("loop parameter specification must include subtype mark", N);
N);
end if; end if;
-- Analyze the subtype definition and create temporaries for -- Analyze the subtype definition and create temporaries for the bounds.
-- the bounds. Do not evaluate the range when preanalyzing a -- Do not evaluate the range when preanalyzing a quantified expression
-- quantified expression because bounds expressed as function -- because bounds expressed as function calls with side effects will be
-- calls with side effects will be erroneously replicated. -- erroneously replicated.
if Nkind (DS) = N_Range if Nkind (DS) = N_Range
and then Expander_Active and then Expander_Active
...@@ -1983,68 +2200,68 @@ package body Sem_Ch5 is ...@@ -1983,68 +2200,68 @@ package body Sem_Ch5 is
then then
Process_Bounds (DS); Process_Bounds (DS);
-- Expander not active or else range of iteration is a subtype -- Either the expander not active or the range of iteration is a subtype
-- indication, an entity, or a function call that yields an -- indication, an entity, or a function call that yields an aggregate or
-- aggregate or a container. -- a container.
else else
D_Copy := New_Copy_Tree (DS); DS_Copy := New_Copy_Tree (DS);
Set_Parent (D_Copy, Parent (DS)); Set_Parent (DS_Copy, Parent (DS));
Pre_Analyze_Range (D_Copy); Preanalyze_Range (DS_Copy);
-- Ada 2012: If the domain of iteration is a function call, -- Ada 2012: If the domain of iteration is a function call, it is the
-- it is the new iterator form. -- new iterator form.
-- We have also implemented the shorter form : for X in S -- We have also implemented the shorter form : for X in S for Alfa
-- for Alfa use. In this case, 'Old and 'Result must be -- use. In this case, 'Old and 'Result must be treated as entity
-- treated as entity names over which iterators are legal. -- names over which iterators are legal.
if Nkind (D_Copy) = N_Function_Call if Nkind (DS_Copy) = N_Function_Call
or else or else
(Alfa_Mode (Alfa_Mode
and then (Nkind (D_Copy) = N_Attribute_Reference and then (Nkind (DS_Copy) = N_Attribute_Reference
and then and then
(Attribute_Name (D_Copy) = Name_Result (Attribute_Name (DS_Copy) = Name_Result
or else Attribute_Name (D_Copy) = Name_Old))) or else Attribute_Name (DS_Copy) = Name_Old)))
or else or else
(Is_Entity_Name (D_Copy) (Is_Entity_Name (DS_Copy)
and then not Is_Type (Entity (D_Copy))) and then not Is_Type (Entity (DS_Copy)))
then then
-- This is an iterator specification. Rewrite as such -- This is an iterator specification. Rewrite it as such and
-- and analyze, to capture function calls that may -- analyze it to capture function calls that may require
-- require finalization actions. -- finalization actions.
declare declare
I_Spec : constant Node_Id := I_Spec : constant Node_Id :=
Make_Iterator_Specification (Sloc (LP), Make_Iterator_Specification (Sloc (N),
Defining_Identifier => Defining_Identifier => Relocate_Node (Id),
Relocate_Node (Id), Name => DS_Copy,
Name => D_Copy,
Subtype_Indication => Empty, Subtype_Indication => Empty,
Reverse_Present => Reverse_Present => Reverse_Present (N));
Reverse_Present (LP)); Scheme : constant Node_Id := Parent (N);
begin begin
Set_Iterator_Specification (N, I_Spec); Set_Iterator_Specification (Scheme, I_Spec);
Set_Loop_Parameter_Specification (N, Empty); Set_Loop_Parameter_Specification (Scheme, Empty);
Analyze_Iterator_Specification (I_Spec); Analyze_Iterator_Specification (I_Spec);
-- In a generic context, analyze the original domain -- In a generic context, analyze the original domain of
-- of iteration, for name capture. -- iteration, for name capture.
if not Expander_Active then if not Expander_Active then
Analyze (DS); Analyze (DS);
end if; end if;
-- Set kind of loop parameter, which may be used in -- Set kind of loop parameter, which may be used in the
-- the subsequent analysis of the condition in a -- subsequent analysis of the condition in a quantified
-- quantified expression. -- expression.
Set_Ekind (Id, E_Loop_Parameter); Set_Ekind (Id, E_Loop_Parameter);
return; return;
end; end;
-- Domain of iteration is not a function call, and is -- Domain of iteration is not a function call, and is side-effect
-- side-effect free. -- free.
else else
Analyze (DS); Analyze (DS);
...@@ -2061,8 +2278,8 @@ package body Sem_Ch5 is ...@@ -2061,8 +2278,8 @@ package body Sem_Ch5 is
and then Present (Entity (DS)) and then Present (Entity (DS))
and then Is_Type (Entity (DS)) and then Is_Type (Entity (DS))
then then
-- The subtype indication may denote the completion of an -- The subtype indication may denote the completion of an incomplete
-- incomplete type declaration. -- type declaration.
if Ekind (Entity (DS)) = E_Incomplete_Type then if Ekind (Entity (DS)) = E_Incomplete_Type then
Set_Entity (DS, Get_Full_View (Entity (DS))); Set_Entity (DS, Get_Full_View (Entity (DS)));
...@@ -2076,8 +2293,8 @@ package body Sem_Ch5 is ...@@ -2076,8 +2293,8 @@ package body Sem_Ch5 is
and then No (Static_Predicate (Entity (DS))) and then No (Static_Predicate (Entity (DS)))
then then
Bad_Predicated_Subtype_Use Bad_Predicated_Subtype_Use
("cannot use subtype& with non-static " ("cannot use subtype& with non-static predicate for loop " &
& "predicate for loop iteration", DS, Entity (DS)); "iteration", DS, Entity (DS));
end if; end if;
end if; end if;
...@@ -2090,37 +2307,35 @@ package body Sem_Ch5 is ...@@ -2090,37 +2307,35 @@ package body Sem_Ch5 is
Check_Controlled_Array_Attribute (DS); Check_Controlled_Array_Attribute (DS);
-- The index is not processed during analysis of a quantified Make_Index (DS, N, In_Iter_Schm => True);
-- expression but delayed to its expansion where the quantified
-- expression is transformed into an expression with actions.
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_Ekind (Id, E_Loop_Parameter); Set_Ekind (Id, E_Loop_Parameter);
-- If the loop is part of a predicate or precondition, it may -- A quantified expression which appears in a pre- or post-condition may
-- be analyzed twice, once in the source and once on the copy -- be analyzed multiple times. The analysis of the range creates several
-- used to check conformance. Preserve the original itype -- itypes which reside in different scopes depending on whether the pre-
-- because the second one may be created in a different scope, -- or post-condition has been expanded. Update the type of the loop
-- e.g. a precondition procedure, leading to a crash in GIGI. -- variable to reflect the proper itype at each stage of analysis.
if No (Etype (Id)) or else Etype (Id) = Any_Type then 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)); Set_Etype (Id, Etype (DS));
end if; end if;
-- Treat a range as an implicit reference to the type, to -- Treat a range as an implicit reference to the type, to inhibit
-- inhibit spurious warnings. -- spurious warnings.
Generate_Reference (Base_Type (Etype (DS)), N, ' '); Generate_Reference (Base_Type (Etype (DS)), N, ' ');
Set_Is_Known_Valid (Id, True); Set_Is_Known_Valid (Id, True);
-- The loop is not a declarative part, so the only entity -- The loop is not a declarative part, so the only entity declared
-- declared "within" must be frozen explicitly. -- "within" must be frozen explicitly.
declare declare
Flist : constant List_Id := Freeze_Entity (Id, N); Flist : constant List_Id := Freeze_Entity (Id, N);
...@@ -2130,9 +2345,9 @@ package body Sem_Ch5 is ...@@ -2130,9 +2345,9 @@ package body Sem_Ch5 is
end if; end if;
end; end;
-- Check for null or possibly null range and issue warning. We -- Check for null or possibly null range and issue warning. We suppress
-- suppress such messages in generic templates and instances, -- such messages in generic templates and instances, because in practice
-- because in practice they tend to be dubious in these cases. -- they tend to be dubious in these cases.
if Nkind (DS) = N_Range and then Comes_From_Source (N) then if Nkind (DS) = N_Range and then Comes_From_Source (N) then
declare declare
...@@ -2142,308 +2357,72 @@ package body Sem_Ch5 is ...@@ -2142,308 +2357,72 @@ package body Sem_Ch5 is
begin begin
-- If range of loop is null, issue warning -- If range of loop is null, issue warning
if Compile_Time_Compare if Compile_Time_Compare (L, H, Assume_Valid => True) = GT then
(L, H, Assume_Valid => True) = GT
then -- Suppress the warning if inside a generic template or
-- Suppress the warning if inside a generic template -- instance, since in practice they tend to be dubious in these
-- or instance, since in practice they tend to be -- cases since they can result from intended parametrization.
-- dubious in these cases since they can result from
-- intended parametrization.
if not Inside_A_Generic if not Inside_A_Generic
and then not In_Instance and then not In_Instance
then then
-- Specialize msg if invalid values could make the -- Specialize msg if invalid values could make the loop
-- loop non-null after all. -- non-null after all.
if Compile_Time_Compare if Compile_Time_Compare
(L, H, Assume_Valid => False) = GT (L, H, Assume_Valid => False) = GT
then then
Error_Msg_N Error_Msg_N
("?loop range is null, loop will not execute", ("?loop range is null, loop will not execute", DS);
DS);
-- Since we know the range of the loop is null, -- Since we know the range of the loop is null, set the
-- set the appropriate flag to remove the loop -- appropriate flag to remove the loop entirely during
-- entirely during expansion. -- expansion.
Set_Is_Null_Loop (Parent (N)); Set_Is_Null_Loop (Loop_Nod);
-- Here is where the loop could execute because -- Here is where the loop could execute because of invalid
-- of invalid values, so issue appropriate -- values, so issue appropriate message and in this case we
-- message and in this case we do not set the -- do not set the Is_Null_Loop flag since the loop may
-- Is_Null_Loop flag since the loop may execute. -- execute.
else else
Error_Msg_N Error_Msg_N
("?loop range may be null, " ("?loop range may be null, loop may not execute", DS);
& "loop may not execute",
DS);
Error_Msg_N Error_Msg_N
("?can only execute if invalid values " ("?can only execute if invalid values are present", DS);
& "are present",
DS);
end if; end if;
end if; end if;
-- In either case, suppress warnings in the body of -- In either case, suppress warnings in the body of the loop,
-- the loop, since it is likely that these warnings -- since it is likely that these warnings will be inappropriate
-- will be inappropriate if the loop never actually -- if the loop never actually executes, which is likely.
-- executes, which is likely.
Set_Suppress_Loop_Warnings (Parent (N)); Set_Suppress_Loop_Warnings (Loop_Nod);
-- The other case for a warning is a reverse loop -- The other case for a warning is a reverse loop where the
-- where the upper bound is the integer literal zero -- upper bound is the integer literal zero or one, and the
-- or one, and the lower bound can be positive. -- lower bound can be positive.
-- For example, we have -- For example, we have
-- for J in reverse N .. 1 loop -- for J in reverse N .. 1 loop
-- In practice, this is very likely to be a case of -- In practice, this is very likely to be a case of reversing
-- reversing the bounds incorrectly in the range. -- the bounds incorrectly in the range.
elsif Reverse_Present (LP) elsif Reverse_Present (N)
and then Nkind (Original_Node (H)) = and then Nkind (Original_Node (H)) = N_Integer_Literal
N_Integer_Literal and then
and then (Intval (Original_Node (H)) = Uint_0 (Intval (Original_Node (H)) = Uint_0
or else or else Intval (Original_Node (H)) = Uint_1)
Intval (Original_Node (H)) = Uint_1)
then then
Error_Msg_N ("?loop range may be null", DS); Error_Msg_N ("?loop range may be null", DS);
Error_Msg_N ("\?bounds may be wrong way round", DS); Error_Msg_N ("\?bounds may be wrong way round", DS);
end if; end if;
end; end;
end if; end if;
end; end Analyze_Loop_Parameter_Specification;
end if;
end;
end Analyze_Iteration_Scheme;
------------------------------------
-- Analyze_Iterator_Specification --
------------------------------------
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);
Ent : Entity_Id;
Typ : Entity_Id;
begin
Enter_Name (Def_Id);
Set_Ekind (Def_Id, E_Variable);
if Present (Subt) then
Analyze (Subt);
end if;
-- 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.
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;
begin
Typ := Etype (Iter_Name);
-- 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_Renaming_Declaration (Loc,
Defining_Identifier => Id,
Subtype_Mark => New_Occurrence_Of (Typ, Loc),
Name =>
New_Copy_Tree (Iter_Name, New_Sloc => Loc));
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.
elsif Is_Entity_Name (Iter_Name) then
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;
-- 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;
-- 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
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
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;
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;
-------------------
-- 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.
procedure Analyze_Label (N : Node_Id) is
pragma Warnings (Off, N);
begin
Kill_Current_Values;
end Analyze_Label;
--------------------------
-- Analyze_Label_Entity --
--------------------------
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;
---------------------------- ----------------------------
-- Analyze_Loop_Statement -- -- Analyze_Loop_Statement --
...@@ -2485,7 +2464,7 @@ package body Sem_Ch5 is ...@@ -2485,7 +2464,7 @@ package body Sem_Ch5 is
begin begin
Nam_Copy := New_Copy_Tree (Nam); Nam_Copy := New_Copy_Tree (Nam);
Set_Parent (Nam_Copy, Parent (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 -- The only two options here are iteration over a container or
-- an array. -- an array.
...@@ -2504,7 +2483,7 @@ package body Sem_Ch5 is ...@@ -2504,7 +2483,7 @@ package body Sem_Ch5 is
begin begin
DS_Copy := New_Copy_Tree (DS); DS_Copy := New_Copy_Tree (DS);
Set_Parent (DS_Copy, Parent (DS)); Set_Parent (DS_Copy, Parent (DS));
Pre_Analyze_Range (DS_Copy); Preanalyze_Range (DS_Copy);
-- Check for a call to Iterate () -- Check for a call to Iterate ()
...@@ -2910,11 +2889,11 @@ package body Sem_Ch5 is ...@@ -2910,11 +2889,11 @@ package body Sem_Ch5 is
end if; end if;
end Check_Unreachable_Code; 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; Save_Analysis : constant Boolean := Full_Analysis;
begin begin
...@@ -2980,6 +2959,6 @@ package body Sem_Ch5 is ...@@ -2980,6 +2959,6 @@ package body Sem_Ch5 is
Expander_Mode_Restore; Expander_Mode_Restore;
Full_Analysis := Save_Analysis; Full_Analysis := Save_Analysis;
end Pre_Analyze_Range; end Preanalyze_Range;
end Sem_Ch5; end Sem_Ch5;
gcc/ada/sem_ch5.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -37,6 +37,7 @@ package Sem_Ch5 is ...@@ -37,6 +37,7 @@ package Sem_Ch5 is
procedure Analyze_Iterator_Specification (N : Node_Id); procedure Analyze_Iterator_Specification (N : Node_Id);
procedure Analyze_Iteration_Scheme (N : Node_Id); procedure Analyze_Iteration_Scheme (N : Node_Id);
procedure Analyze_Label (N : Node_Id); procedure Analyze_Label (N : Node_Id);
procedure Analyze_Loop_Parameter_Specification (N : Node_Id);
procedure Analyze_Loop_Statement (N : Node_Id); procedure Analyze_Loop_Statement (N : Node_Id);
procedure Analyze_Null_Statement (N : Node_Id); procedure Analyze_Null_Statement (N : Node_Id);
procedure Analyze_Statements (L : List_Id); procedure Analyze_Statements (L : List_Id);
......
gcc/ada/sem_ch6.adb
...@@ -8702,7 +8702,9 @@ package body Sem_Ch6 is ...@@ -8702,7 +8702,9 @@ package body Sem_Ch6 is
Discrete_Subtype_Definition (L2)); Discrete_Subtype_Definition (L2));
end; end;
else -- quantified expression with an iterator elsif Present (Iterator_Specification (E1))
and then Present (Iterator_Specification (E2))
then
declare declare
I1 : constant Node_Id := Iterator_Specification (E1); I1 : constant Node_Id := Iterator_Specification (E1);
I2 : constant Node_Id := Iterator_Specification (E2); I2 : constant Node_Id := Iterator_Specification (E2);
...@@ -8719,6 +8721,12 @@ package body Sem_Ch6 is ...@@ -8719,6 +8721,12 @@ package body Sem_Ch6 is
and then FCE (Subtype_Indication (I1), and then FCE (Subtype_Indication (I1),
Subtype_Indication (I2)); Subtype_Indication (I2));
end; end;
-- The quantified expressions used different specifications to
-- walk their respective ranges.
else
return False;
end if; end if;
when N_Range => when N_Range =>
......
gcc/ada/sem_res.adb
...@@ -193,7 +193,6 @@ package body Sem_Res is ...@@ -193,7 +193,6 @@ package body Sem_Res is
procedure Resolve_Op_Expon (N : Node_Id; Typ : Entity_Id); procedure Resolve_Op_Expon (N : Node_Id; Typ : Entity_Id);
procedure Resolve_Op_Not (N : Node_Id; Typ : Entity_Id); procedure Resolve_Op_Not (N : Node_Id; Typ : Entity_Id);
procedure Resolve_Qualified_Expression (N : Node_Id; Typ : Entity_Id); procedure Resolve_Qualified_Expression (N : Node_Id; Typ : Entity_Id);
procedure Resolve_Quantified_Expression (N : Node_Id; Typ : Entity_Id);
procedure Resolve_Range (N : Node_Id; Typ : Entity_Id); procedure Resolve_Range (N : Node_Id; Typ : Entity_Id);
procedure Resolve_Real_Literal (N : Node_Id; Typ : Entity_Id); procedure Resolve_Real_Literal (N : Node_Id; Typ : Entity_Id);
procedure Resolve_Reference (N : Node_Id; Typ : Entity_Id); procedure Resolve_Reference (N : Node_Id; Typ : Entity_Id);
...@@ -1770,6 +1769,10 @@ package body Sem_Res is ...@@ -1770,6 +1769,10 @@ package body Sem_Res is
-- Try and fix up a literal so that it matches its expected type. New -- Try and fix up a literal so that it matches its expected type. New
-- literals are manufactured if necessary to avoid cascaded errors. -- literals are manufactured if necessary to avoid cascaded errors.
function Proper_Current_Scope return Entity_Id;
-- Return the current scope. Skip loop scopes created for the purpose of
-- quantified expression analysis since those do not appear in the tree.
procedure Report_Ambiguous_Argument; procedure Report_Ambiguous_Argument;
-- Additional diagnostics when an ambiguous call has an ambiguous -- Additional diagnostics when an ambiguous call has an ambiguous
-- argument (typically a controlling actual). -- argument (typically a controlling actual).
...@@ -1832,6 +1835,30 @@ package body Sem_Res is ...@@ -1832,6 +1835,30 @@ package body Sem_Res is
end if; end if;
end Patch_Up_Value; end Patch_Up_Value;
--------------------------
-- Proper_Current_Scope --
--------------------------
function Proper_Current_Scope return Entity_Id is
S : Entity_Id := Current_Scope;
begin
while Present (S) loop
-- Skip a loop scope created for quantified expression analysis
if Ekind (S) = E_Loop
and then Nkind (Parent (S)) = N_Quantified_Expression
then
S := Scope (S);
else
exit;
end if;
end loop;
return S;
end Proper_Current_Scope;
------------------------------- -------------------------------
-- Report_Ambiguous_Argument -- -- Report_Ambiguous_Argument --
------------------------------- -------------------------------
...@@ -2761,8 +2788,7 @@ package body Sem_Res is ...@@ -2761,8 +2788,7 @@ package body Sem_Res is
when N_Qualified_Expression when N_Qualified_Expression
=> Resolve_Qualified_Expression (N, Ctx_Type); => Resolve_Qualified_Expression (N, Ctx_Type);
when N_Quantified_Expression when N_Quantified_Expression => null;
=> Resolve_Quantified_Expression (N, Ctx_Type);
when N_Raise_xxx_Error when N_Raise_xxx_Error
=> Set_Etype (N, Ctx_Type); => Set_Etype (N, Ctx_Type);
...@@ -2857,10 +2883,9 @@ package body Sem_Res is ...@@ -2857,10 +2883,9 @@ package body Sem_Res is
-- Ada 2012 (AI05-177): Expression functions do not freeze. Only -- Ada 2012 (AI05-177): Expression functions do not freeze. Only
-- their use (in an expanded call) freezes. -- their use (in an expanded call) freezes.
if Ekind (Current_Scope) /= E_Function if Ekind (Proper_Current_Scope) /= E_Function
or else or else Nkind (Original_Node (Unit_Declaration_Node
Nkind (Original_Node (Unit_Declaration_Node (Current_Scope))) /= (Proper_Current_Scope))) /= N_Expression_Function
N_Expression_Function
then then
Freeze_Expression (N); Freeze_Expression (N);
end if; end if;
...@@ -8290,31 +8315,6 @@ package body Sem_Res is ...@@ -8290,31 +8315,6 @@ package body Sem_Res is
Eval_Qualified_Expression (N); Eval_Qualified_Expression (N);
end Resolve_Qualified_Expression; end Resolve_Qualified_Expression;
-----------------------------------
-- Resolve_Quantified_Expression --
-----------------------------------
procedure Resolve_Quantified_Expression (N : Node_Id; Typ : Entity_Id) is
begin
if not Alfa_Mode then
-- The loop structure is already resolved during its analysis, only
-- the resolution of the condition needs to be done. Expansion is
-- disabled so that checks and other generated code are inserted in
-- the tree after expression has been rewritten as a loop.
Expander_Mode_Save_And_Set (False);
Resolve (Condition (N), Typ);
Expander_Mode_Restore;
-- In Alfa mode, we need normal expansion in order to properly introduce
-- the necessary transient scopes.
else
Resolve (Condition (N), Typ);
end if;
end Resolve_Quantified_Expression;
------------------- -------------------
-- Resolve_Range -- -- Resolve_Range --
------------------- -------------------
......
gcc/ada/sem_util.adb
...@@ -740,12 +740,28 @@ package body Sem_Util is ...@@ -740,12 +740,28 @@ package body Sem_Util is
N : Node_Id) return Entity_Id N : Node_Id) return Entity_Id
is is
Loc : constant Source_Ptr := Sloc (N); Loc : constant Source_Ptr := Sloc (N);
Bas : Entity_Id;
-- The base type that is to be constrained by the defaults.
Disc : Entity_Id; Disc : Entity_Id;
begin begin
if not Has_Discriminants (T) or else Is_Constrained (T) then if not Has_Discriminants (T) or else Is_Constrained (T) then
return T; return T;
end if; end if;
Bas := Base_Type (T);
-- If T is non-private but its base type is private, this is
-- the completion of a subtype declaration whose parent type
-- is private (see Complete_Private_Subtype in sem_ch3). The
-- proper discriminants are to be found in the full view of
-- the base.
if Is_Private_Type (Bas)
and then Present (Full_View (Bas))
then
Bas := Full_View (Bas);
end if;
Disc := First_Discriminant (T); Disc := First_Discriminant (T);
...@@ -770,7 +786,7 @@ package body Sem_Util is ...@@ -770,7 +786,7 @@ package body Sem_Util is
Defining_Identifier => Act, Defining_Identifier => Act,
Subtype_Indication => Subtype_Indication =>
Make_Subtype_Indication (Loc, Make_Subtype_Indication (Loc,
Subtype_Mark => New_Occurrence_Of (T, Loc), Subtype_Mark => New_Occurrence_Of (Bas, Loc),
Constraint => Constraint =>
Make_Index_Or_Discriminant_Constraint (Loc, Make_Index_Or_Discriminant_Constraint (Loc,
Constraints => Constraints))); Constraints => Constraints)));
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment