From 804670f120cd78a0304b630e7e53b1e13c9f5bfb Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Mon, 2 Apr 2012 11:28:52 +0200 Subject: [PATCH] [multiple changes] 2012-04-02 Emmanuel Briot * g-expect.adb (Expect_Internal): Fix leak of the input file descriptor. 2012-04-02 Hristian Kirtchev * 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 * 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 --- gcc/ada/ChangeLog | 47 ++ gcc/ada/exp_ch4.adb | 77 ++-- gcc/ada/g-expect.adb | 23 +- gcc/ada/sem.adb | 4 +- gcc/ada/sem_ch4.adb | 100 +---- gcc/ada/sem_ch5.adb | 1225 +++++++++++++++++++++++++------------------------- gcc/ada/sem_ch5.ads | 29 +- gcc/ada/sem_ch6.adb | 10 +- gcc/ada/sem_res.adb | 64 +-- gcc/ada/sem_util.adb | 18 +- 10 files changed, 798 insertions(+), 799 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 2e4f8e5..73da545 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,50 @@ +2012-04-02 Emmanuel Briot + + * g-expect.adb (Expect_Internal): Fix leak of the input file descriptor. + +2012-04-02 Hristian Kirtchev + + * 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 + + * 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 * gnat_ugn.texi: Add some minimal documentation about how to diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 09949a1..d08e375 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -7884,73 +7884,78 @@ package body Exp_Ch4 is -- given by an iterator specification, not a loop parameter specification. 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; - Tnn : constant Entity_Id := Make_Temporary (Loc, 'T', N); - Cond : Node_Id; - Decl : Node_Id; - I_Scheme : Node_Id; - Original_N : Node_Id; - Test : Node_Id; + Actions : constant List_Id := New_List; + 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; + Flag : Entity_Id; + Scheme : Node_Id; + Stmts : List_Id; 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 - Original_N := Parent (Parent (Loop_Parameter_Specification (N))); - else - Original_N := Parent (Parent (Iterator_Specification (N))); - end if; + -- Flag : Boolean := (True | False); - -- Rewrite N with the original quantified expression + Flag := Make_Temporary (Loc, 'T', N); - Rewrite (N, Original_N); - - Decl := + Append_To (Actions, Make_Object_Declaration (Loc, - Defining_Identifier => Tnn, + Defining_Identifier => Flag, Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc), Expression => - New_Occurrence_Of (Boolean_Literals (Is_Universal), Loc)); - Append_To (Actions, Decl); + New_Occurrence_Of (Boolean_Literals (For_All), Loc))); + + -- 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)); - if Is_Universal then + if For_All then Cond := Make_Op_Not (Loc, Cond); end if; - Test := + Stmts := New_List ( Make_Implicit_If_Statement (N, Condition => Cond, Then_Statements => New_List ( Make_Assignment_Statement (Loc, - Name => New_Occurrence_Of (Tnn, Loc), + Name => New_Occurrence_Of (Flag, Loc), Expression => - New_Occurrence_Of (Boolean_Literals (not Is_Universal), Loc)), - Make_Exit_Statement (Loc))); + New_Occurrence_Of (Boolean_Literals (not For_All), Loc)), + Make_Exit_Statement (Loc)))); - if Present (Loop_Parameter_Specification (N)) then - I_Scheme := + -- Build the loop equivalent of the quantified expression + + if Present (Iter_Spec) then + Scheme := Make_Iteration_Scheme (Loc, - Loop_Parameter_Specification => - Loop_Parameter_Specification (N)); + Iterator_Specification => Iter_Spec); else - I_Scheme := + Scheme := Make_Iteration_Scheme (Loc, - Iterator_Specification => Iterator_Specification (N)); + Loop_Parameter_Specification => Loop_Spec); end if; Append_To (Actions, Make_Loop_Statement (Loc, - Iteration_Scheme => I_Scheme, - Statements => New_List (Test), + Iteration_Scheme => Scheme, + Statements => Stmts, End_Label => Empty)); + -- Transform the quantified expression + Rewrite (N, Make_Expression_With_Actions (Loc, - Expression => New_Occurrence_Of (Tnn, Loc), + Expression => New_Occurrence_Of (Flag, Loc), Actions => Actions)); Analyze_And_Resolve (N, Standard_Boolean); diff --git a/gcc/ada/g-expect.adb b/gcc/ada/g-expect.adb index c6e18ef..94f6964 100644 --- a/gcc/ada/g-expect.adb +++ b/gcc/ada/g-expect.adb @@ -6,7 +6,7 @@ -- -- -- 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 -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -33,7 +33,7 @@ with System; use System; with System.OS_Constants; use System.OS_Constants; 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.Regpat; use GNAT.Regpat; @@ -678,6 +678,7 @@ package body GNAT.Expect is -- ??? Note that ddd tries again up to three times -- in that case. See LiterateA.C:174 + Close (Descriptors (D).Input_Fd); Descriptors (D).Input_Fd := Invalid_FD; Result := Expect_Process_Died; return; @@ -893,7 +894,8 @@ package body GNAT.Expect is begin 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 Send (Process, Input); @@ -1055,17 +1057,18 @@ package body GNAT.Expect is Command_With_Path : String_Access; 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); if Command_With_Path = null then raise Invalid_Process; 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 Descriptor.Pid := Fork; @@ -1365,6 +1368,8 @@ package body GNAT.Expect is end if; if Create_Pipe (Pipe2) /= 0 then + Close (Pipe1.Input); + Close (Pipe1.Output); return; end if; @@ -1389,7 +1394,7 @@ package body GNAT.Expect is -- Create a separate pipe for standard error if Create_Pipe (Pipe3) /= 0 then - return; + Pipe3.all := Pipe2.all; end if; end if; diff --git a/gcc/ada/sem.adb b/gcc/ada/sem.adb index 2e50d3d..503d1f4 100644 --- a/gcc/ada/sem.adb +++ b/gcc/ada/sem.adb @@ -314,6 +314,9 @@ package body Sem is when N_Label => Analyze_Label (N); + when N_Loop_Parameter_Specification => + Analyze_Loop_Parameter_Specification (N); + when N_Loop_Statement => Analyze_Loop_Statement (N); @@ -681,7 +684,6 @@ package body Sem is N_Generic_Association | N_Index_Or_Discriminant_Constraint | N_Iteration_Scheme | - N_Loop_Parameter_Specification | N_Mod_Clause | N_Modular_Type_Definition | N_Ordinary_Fixed_Point_Definition | diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index d56da36..55238e2 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -47,7 +47,6 @@ with Sem_Aux; use Sem_Aux; with Sem_Case; use Sem_Case; with Sem_Cat; use Sem_Cat; with Sem_Ch3; use Sem_Ch3; -with Sem_Ch5; use Sem_Ch5; with Sem_Ch6; use Sem_Ch6; with Sem_Ch8; use Sem_Ch8; with Sem_Dim; use Sem_Dim; @@ -3403,101 +3402,38 @@ package body Sem_Ch4 is ----------------------------------- procedure Analyze_Quantified_Expression (N : Node_Id) is - Loc : constant Source_Ptr := Sloc (N); - 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; + QE_Scop : Entity_Id; 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); - -- The following seems like expansion activity done at analysis - -- time, which seems weird ??? + -- Create a scope to emulate the loop-like behavior of the quantified + -- 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; + 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); - Push_Scope (Ent); - Set_Parent (Iterator, N); - Analyze_Iteration_Scheme (Iterator); + Push_Scope (QE_Scop); - -- The loop specification may have been converted into an iterator - -- specification during its analysis. Update the quantified node - -- accordingly. + -- 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. - 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 - - -- The full analysis will be performed during the expansion of the - -- quantified expression, only a preanalysis of the condition needs - -- to be done. - - -- This is strange for two reasons - - -- First, there is almost no situation in which Preanalyze vs - -- Analyze should be conditioned on -gnatc mode (since error msgs - -- 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)); + if Present (Iterator_Specification (N)) then + Preanalyze (Iterator_Specification (N)); else - Analyze (Condition (N)); + Preanalyze (Loop_Parameter_Specification (N)); end if; + Preanalyze_And_Resolve (Condition (N), Standard_Boolean); + End_Scope; 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; ------------------- diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index 7155ba9..6b45c07 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -76,7 +76,7 @@ package body Sem_Ch5 is -- 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 @@ -1607,178 +1607,284 @@ package body Sem_Ch5 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); - -- 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 -- @@ -1787,13 +1893,12 @@ package body Sem_Ch5 is 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); @@ -1809,17 +1914,17 @@ package body Sem_Ch5 is 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; @@ -1889,561 +1994,435 @@ package body Sem_Ch5 is 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 -- @@ -2485,7 +2464,7 @@ package body Sem_Ch5 is 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. @@ -2504,7 +2483,7 @@ package body Sem_Ch5 is 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 () @@ -2910,11 +2889,11 @@ package body Sem_Ch5 is 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 @@ -2980,6 +2959,6 @@ package body Sem_Ch5 is Expander_Mode_Restore; Full_Analysis := Save_Analysis; - end Pre_Analyze_Range; + end Preanalyze_Range; end Sem_Ch5; diff --git a/gcc/ada/sem_ch5.ads b/gcc/ada/sem_ch5.ads index fdf09db..86a92b7 100644 --- a/gcc/ada/sem_ch5.ads +++ b/gcc/ada/sem_ch5.ads @@ -6,7 +6,7 @@ -- -- -- 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 -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -27,19 +27,20 @@ with Types; use Types; package Sem_Ch5 is - procedure Analyze_Assignment (N : Node_Id); - procedure Analyze_Block_Statement (N : Node_Id); - procedure Analyze_Case_Statement (N : Node_Id); - procedure Analyze_Exit_Statement (N : Node_Id); - procedure Analyze_Goto_Statement (N : Node_Id); - procedure Analyze_If_Statement (N : Node_Id); - procedure Analyze_Implicit_Label_Declaration (N : Node_Id); - procedure Analyze_Iterator_Specification (N : Node_Id); - procedure Analyze_Iteration_Scheme (N : Node_Id); - procedure Analyze_Label (N : Node_Id); - procedure Analyze_Loop_Statement (N : Node_Id); - procedure Analyze_Null_Statement (N : Node_Id); - procedure Analyze_Statements (L : List_Id); + procedure Analyze_Assignment (N : Node_Id); + procedure Analyze_Block_Statement (N : Node_Id); + procedure Analyze_Case_Statement (N : Node_Id); + procedure Analyze_Exit_Statement (N : Node_Id); + procedure Analyze_Goto_Statement (N : Node_Id); + procedure Analyze_If_Statement (N : Node_Id); + procedure Analyze_Implicit_Label_Declaration (N : Node_Id); + procedure Analyze_Iterator_Specification (N : Node_Id); + procedure Analyze_Iteration_Scheme (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_Null_Statement (N : Node_Id); + procedure Analyze_Statements (L : List_Id); procedure Analyze_Label_Entity (E : Entity_Id); -- This procedure performs direct analysis of the label entity E. It diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index f925905..4c7f2e4 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -8702,7 +8702,9 @@ package body Sem_Ch6 is Discrete_Subtype_Definition (L2)); end; - else -- quantified expression with an iterator + elsif Present (Iterator_Specification (E1)) + and then Present (Iterator_Specification (E2)) + then declare I1 : constant Node_Id := Iterator_Specification (E1); I2 : constant Node_Id := Iterator_Specification (E2); @@ -8719,6 +8721,12 @@ package body Sem_Ch6 is and then FCE (Subtype_Indication (I1), Subtype_Indication (I2)); end; + + -- The quantified expressions used different specifications to + -- walk their respective ranges. + + else + return False; end if; when N_Range => diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index fc95bb8..ab08e77 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -193,7 +193,6 @@ package body Sem_Res is procedure Resolve_Op_Expon (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_Quantified_Expression (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_Reference (N : Node_Id; Typ : Entity_Id); @@ -1770,6 +1769,10 @@ package body Sem_Res is -- Try and fix up a literal so that it matches its expected type. New -- 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; -- Additional diagnostics when an ambiguous call has an ambiguous -- argument (typically a controlling actual). @@ -1832,6 +1835,30 @@ package body Sem_Res is end if; 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 -- ------------------------------- @@ -2761,8 +2788,7 @@ package body Sem_Res is when N_Qualified_Expression => Resolve_Qualified_Expression (N, Ctx_Type); - when N_Quantified_Expression - => Resolve_Quantified_Expression (N, Ctx_Type); + when N_Quantified_Expression => null; when N_Raise_xxx_Error => Set_Etype (N, Ctx_Type); @@ -2857,10 +2883,9 @@ package body Sem_Res is -- Ada 2012 (AI05-177): Expression functions do not freeze. Only -- their use (in an expanded call) freezes. - if Ekind (Current_Scope) /= E_Function - or else - Nkind (Original_Node (Unit_Declaration_Node (Current_Scope))) /= - N_Expression_Function + if Ekind (Proper_Current_Scope) /= E_Function + or else Nkind (Original_Node (Unit_Declaration_Node + (Proper_Current_Scope))) /= N_Expression_Function then Freeze_Expression (N); end if; @@ -8290,31 +8315,6 @@ package body Sem_Res is Eval_Qualified_Expression (N); 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 -- ------------------- diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index e07d5bb..e7958058 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -740,12 +740,28 @@ package body Sem_Util is N : Node_Id) return Entity_Id is Loc : constant Source_Ptr := Sloc (N); + Bas : Entity_Id; + -- The base type that is to be constrained by the defaults. + Disc : Entity_Id; begin if not Has_Discriminants (T) or else Is_Constrained (T) then return T; 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); @@ -770,7 +786,7 @@ package body Sem_Util is Defining_Identifier => Act, Subtype_Indication => Make_Subtype_Indication (Loc, - Subtype_Mark => New_Occurrence_Of (T, Loc), + Subtype_Mark => New_Occurrence_Of (Bas, Loc), Constraint => Make_Index_Or_Discriminant_Constraint (Loc, Constraints => Constraints))); -- 2.7.4