2011-08-29 Yannick Moy <moy@adacore.com>

	* gnat1drv.adb (Adjust_Global_Switches): Restore expansion of tagged
	types and dispatching calls in Alfa mode.
	* lib-xref-alfa.adb (Collect_ALFA): Rewrite computation of
	correspondance between body and spec scopes, to reuse utility functions
	(Traverse_Declarations_Or_Statements): Protect access to body for stub
	by testing the presence of the library unit for the body
	* sem_ch6.adb (Set_Actual_Subtypes): take into account that in Alfa
	mode the expansion of accept statements is skipped
	* sem_util.adb, sem_util.ads (Unique_Entity): New function returning
	the unique entity corresponding to the one returned by
	Unique_Defining_Entity applied to the enclosing declaration of the
	argument.

2011-08-29  Bob Duff  <duff@adacore.com>

	* treepr.ads: Improve debugging facilities. pn(x) no longer crashes in
	gdb when x is not a node (it can be a node list, name_id, etc). pp is
	an alias for pn. ppp is an alias for pt.

2011-08-29  Javier Miranda  <miranda@adacore.com>

	* exp_aggr.adb (Expand_Record_Aggregate): Use the top-level enclosing
	aggregate to take a consistent decision on the need to convert into
	assignments aggregates that initialize constant objects.

2011-08-29  Hristian Kirtchev  <kirtchev@adacore.com>

	* exp_ch4.adb (Expand_Allocator_Expression): Add a call to
	Build_Allocate_Deallocate_Proc in order to handle allocation of
	non-controlled objects on subpools.
	* impunit.adb: Remove s-finmas and s-spsufi since they were never meant
	to be end-user visible.
	* s-finmas.adb: Add with and use clause for System.HTable.
	Add an instantiation of Simple_HTable which provides a mapping between
	the address of a controlled object and the corresponding
	Finalize_Address used to clean up the object. The table is used when a
	master is operating in heterogeneous mode.
	(Attach): Explain why the input node is not verified on being already
	attached.
	(Delete_Finalize_Address): New routine.
	(Detach): Add pragma Assert which ensures that a node is already
	attached.
	(Finalize): Add local variable Cleanup. Rewrite the iteration scheme
	since nodes are no longer removed on traversal. Explain why node
	detachment is undesirable in this case.
	(Get_Finalize_Address): New routine.
	(Hash): New routine.
	(Is_Empty_List): Removed.
	(pm): Renamed to Print_Master. Add output for discriminant
	Is_Homogeneous.
	Comment reformatting.
	(Set_Finalize_Address (Address, Finalize_Address_Ptr)): New routine.
	* s-finmas.ads: Various comments additions / improvements.
	Type Finalization_Master has a discriminant which determines the mode of
	operation.
	(Delete_Finalize_Address): New routine.
	(Get_Finalize_Address): New routine.
	(pm): Renamed to Print_Master.
	(Set_Finalize_Address (Address, Finalize_Address_Ptr)): New routine.
	* s-stposu.adb: Add with clause for System.Address_Image; Add with and
	use clause for System.IO.
	(Allocate_Any_Controlled): Add machinery to set TSS primitive
	Finalize_Address depending on the mode of allocation and the mode of
	the master.
	(Deallocate_Any_Controlled): Remove the relation pair object -
	Finalize_Address regardless of the master mode. Add comment explaining
	the reason.
	(Detach): Ensure that fields Prev and Next are null after detachment.
	(Finalize_Pool): Remove local variable Next_Ptr. Rewrite the iteration
	scheme to check whether the list of subpools is empty. There is no
	longer need to store the next subpool or advance the current pointer.
	(Is_Empty_List): New routine.
	(Print_Pool): New routine.
	(Print_Subpool): New routine.
	* s-stposu.ads: Various comments additions / improvements.
	Field Master of type Root_Subpool is now a heterogeneous collection.
	(Print_Pool): New routine.
	(Print_Subpool): New routine.

2011-08-29  Ed Schonberg  <schonberg@adacore.com>

	* exp_ch5.adb (Expand_N_Iterator_Loop): Implement Ada2012 loop iterator
	forms, using aspects of container types.
	* sem_ch3.adb (Find_Type_Name): Preserve Has_Delayed_Aspects and
	Has_Implicit_Dereference flags, that may be set on the partial view.
	* sem_ch4.adb (Process_Overloaded_Indexed_Component): Prefix may be a
	container type with an indexing aspect.
	(Analyze_Quantified_Expression): Analyze construct with expansion
	disabled, because it will be rewritten as a loop during expansion.
	(Try_Container_Indexing): The prefix itself may be a container type
	with an indexing aspect, as with a vector of vectors.
	* sem_ch5.adb (Analyze_Iteration_Scheme): In a generic context, analyze
	the original doamin of iteration, for name capture.
	(Analyze_Iterator_Specification): If the domain is an expression that
	needs finalization, create a separate declaration for it.
	For an iterator with "of" retrieve default iterator info from aspect of
	container type. For "in" iterator, retrieve type of Iterate function.
	* sem_ch13.adb (Check_Iterator_Function): Fix typo.
	(Check_Aspect_At_End_Of_Declaration): Make type unfrozen before
	analysis, to prevent spurious errors about late attributes.
	* sprint.adb: Handle quantified expression with either loop or iterator
	specification.
	* a-convec.ads, a-convec.adb: Iterate function returns a reversible
	iterator.



git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@178235 138bc75d-0d04-0410-961f-82ee72b054a4

1 files changed, 119 insertions, 32 deletions

diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb
index 2e4adcde4a9..ef74ed9df03 100644
--- a/gcc/ada/sem_ch5.adb
+++ b/gcc/ada/sem_ch5.adb
@@ -23,6 +23,7 @@
 --                                                                          --
 ------------------------------------------------------------------------------
 
+with Aspects;  use Aspects;
 with Atree;    use Atree;
 with Checks;   use Checks;
 with Einfo;    use Einfo;
@@ -2005,8 +2006,23 @@ package body Sem_Ch5 is
                   Set_Parent (D_Copy, Parent (DS));
                   Pre_Analyze_Range (D_Copy);
 
+                  --  Ada2012 : 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 the attributes Old and Result
+                  --  must be treated as entity names  over which iterators are
+                  --  legal.
+
                   if Nkind (D_Copy) = N_Function_Call
                     or else
+                      (ALFA_Mode
+                       and then (Nkind (D_Copy) = N_Attribute_Reference
+                       and then
+                         (Attribute_Name (D_Copy) = Name_Result
+                            or else Attribute_Name (D_Copy) = Name_Old)))
+
+                    or else
                       (Is_Entity_Name (D_Copy)
                         and then not Is_Type (Entity (D_Copy)))
                   then
@@ -2027,6 +2043,14 @@ package body Sem_Ch5 is
                         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;
+
                         return;
                      end;
 
@@ -2207,7 +2231,7 @@ package body Sem_Ch5 is
       Loc       : constant Source_Ptr := Sloc (N);
       Def_Id    : constant Node_Id    := Defining_Identifier (N);
       Subt      : constant Node_Id    := Subtype_Indication (N);
-      Container : constant Node_Id    := Name (N);
+      Iter_Name : constant Node_Id    := Name (N);
 
       Ent : Entity_Id;
       Typ : Entity_Id;
@@ -2220,45 +2244,83 @@ package body Sem_Ch5 is
          Analyze (Subt);
       end if;
 
-      --  If it is an expression, the container is pre-analyzed in the caller.
+      --  If it is an expression, the name is pre-analyzed in the caller.
       --  If it it of a controlled type we need a block for the finalization
       --  actions. As for loop bounds that need finalization, we create a
       --  declaration and an assignment to trigger these actions.
 
-      if Present (Etype (Container))
-        and then Is_Controlled (Etype (Container))
-        and then not Is_Entity_Name (Container)
+      if Present (Etype (Iter_Name))
+        and then Is_Controlled (Etype (Iter_Name))
+        and then not Is_Entity_Name (Iter_Name)
       then
          declare
-            Id : constant Entity_Id := Make_Temporary (Loc, 'R', Container);
+            Id : constant Entity_Id := Make_Temporary (Loc, 'R', Iter_Name);
 
             Decl   : Node_Id;
-            Assign : Node_Id;
 
          begin
-            Typ := Etype (Container);
+            Typ := Etype (Iter_Name);
 
             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 (Container));
-
-            Insert_Actions (Parent (N), New_List (Decl, Assign));
+                Object_Definition   => New_Occurrence_Of (Typ, Loc),
+                Expression          => Relocate_Node (Iter_Name));
+
+            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;
 
       else
 
-         --  Container is an entity or an array with uncontrolled components
+         --  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.
+
+         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;
 
-         Analyze_And_Resolve (Container);
+                     Get_Next_Interp (I, It);
+                  end loop;
+               end if;
+            end;
+
+         else
+
+            --  domain of iteration is not overloaded.
+
+            Resolve (Iter_Name, Etype (Iter_Name));
+         end if;
       end if;
 
-      Typ := Etype (Container);
+      Typ := Etype (Iter_Name);
 
       if Is_Array_Type (Typ) then
          if Of_Present (N) then
@@ -2269,33 +2331,58 @@ package body Sem_Ch5 is
             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
+            --  If the container has already been rewritten as a
+            --  call to the default iterator, nothing to do. This
+            --  is the case with the expansion of a quantified
+            --  expression.
 
-            --  Find the Element_Type in the package instance that defines the
-            --  container type.
+            if Nkind (Name (N)) = N_Function_Call
+              and then not Comes_From_Source (Name (N))
+            then
+               null;
 
-            Ent := First_Entity (Scope (Base_Type (Typ)));
-            while Present (Ent) loop
-               if Chars (Ent) = Name_Element_Type then
-                  Set_Etype (Def_Id, Ent);
-                  exit;
-               end if;
+            elsif Expander_Active then
 
-               Next_Entity (Ent);
-            end loop;
+               --  Find the Iterator_Element and the default_iterator
+               --   of the container type.
+
+               Set_Etype (Def_Id,
+                 Entity (
+                   Find_Aspect (Typ, Aspect_Iterator_Element)));
+
+               declare
+                  Default_Iter : constant Entity_Id :=
+                    Find_Aspect (Typ, Aspect_Default_Iterator);
+               begin
+                  Rewrite (Name (N),
+                    Make_Function_Call (Loc,
+                      Name => Default_Iter,
+                      Parameter_Associations =>
+                        New_List (Relocate_Node (Iter_Name))));
+                  Analyze_And_Resolve (Name (N));
+               end;
+            end if;
 
          else
-            --  Find the Cursor type in similar fashion
+            --  result type of Iterate function is the classwide
+            --  type of the interface parent. We need the specific
+            --  Cursor type defined in the package.
 
-            Ent := First_Entity (Scope (Base_Type (Typ)));
+            Ent := First_Entity (Scope (Typ));
             while Present (Ent) loop
                if Chars (Ent) = Name_Cursor then
-                  Set_Etype (Def_Id, Ent);
+                  Set_Etype (Def_Id, Etype (Ent));
                   exit;
                end if;