par-ch6.adb: Correct obsolete name in comments

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

	* par-ch6.adb: Correct obsolete name in comments
	* restrict.adb, restrict.ads (Check_Formal_Restriction): new function
	which takes two message arguments (existing function takes one), with
	second message used for continuation.
	* sem_ch5.adb (Analyze_Block_Statement): in formal mode, only reject
	block statements that originate from a source block statement, not
	generated block statements
	* sem_ch6.adb (Analyze_Function_Call): rename L into Actuals, for
	symmetry with procedure case
	* sem_ch7.adb (Check_One_Tagged_Type_Or_Extension_At_Most): new
	function to issue an error in formal mode if a package specification
	contains more than one tagged type or type extension.
	* sem_res.adb (Resolve_Actuals): in formal mode, check that actual
	parameters matching formals of tagged types are objects (or ancestor
	type conversions of objects), not general expressions. Issue an error
	on view conversions that are not involving ancestor conversion of an
	extended type.
	(Resolve_Type_Conversion): in formal mode, issue an error on the
	operand of an ancestor type conversion which is not an object
	* sem_util.adb, sem_util.ads (Find_Actual): extend the behavior of the
	procedure so that it works also for actuals of function calls
	(Is_Actual_Tagged_Parameter): new function which determines if its
	argument is an actual parameter of a formal of tagged type in a
	subprogram call
	(Is_SPARK_Object_Reference): new function which determines if the tree
	referenced by its argument represents an object in SPARK

From-SVN: r177125

1 files changed, 58 insertions, 0 deletions

diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb
index b36c60069a5..1fbaacd0b8d 100644
--- a/gcc/ada/sem_ch7.adb
+++ b/gcc/ada/sem_ch7.adb
@@ -43,6 +43,7 @@ with Nmake;    use Nmake;
 with Nlists;   use Nlists;
 with Opt;      use Opt;
 with Output;   use Output;
+with Restrict; use Restrict;
 with Sem;      use Sem;
 with Sem_Aux;  use Sem_Aux;
 with Sem_Cat;  use Sem_Cat;
@@ -873,6 +874,11 @@ package body Sem_Ch7 is
       --  private_with_clauses, and remove them at the end of the nested
       --  package.
 
+      procedure Check_One_Tagged_Type_Or_Extension_At_Most;
+      --  Issue an error in formal mode if a package specification contains
+      --  more than one tagged type or type extension. This is a restriction of
+      --  SPARK.
+
       procedure Clear_Constants (Id : Entity_Id; FE : Entity_Id);
       --  Clears constant indications (Never_Set_In_Source, Constant_Value, and
       --  Is_True_Constant) on all variables that are entities of Id, and on
@@ -901,6 +907,56 @@ package body Sem_Ch7 is
       --  private part rather than being done in Sem_Ch12.Install_Parent
       --  (which is where the parents' visible declarations are installed).
 
+      ------------------------------------------------
+      -- Check_One_Tagged_Type_Or_Extension_At_Most --
+      ------------------------------------------------
+
+      procedure Check_One_Tagged_Type_Or_Extension_At_Most is
+         Previous : Node_Id;
+
+         procedure Check_Decls (Decls : List_Id);
+         --  Check that either Previous is Empty and Decls does not contain
+         --  more than one tagged type or type extension, or Previous is
+         --  already set and Decls contains no tagged type or type extension.
+
+         -----------------
+         -- Check_Decls --
+         -----------------
+
+         procedure Check_Decls (Decls : List_Id) is
+            Decl : Node_Id;
+         begin
+            Decl := First (Decls);
+            while Present (Decl) loop
+               if Nkind (Decl) = N_Full_Type_Declaration
+                 and then Is_Tagged_Type (Defining_Identifier (Decl))
+               then
+                  if No (Previous) then
+                     Previous := Decl;
+                  else
+                     Error_Msg_Sloc := Sloc (Previous);
+                     Check_Formal_Restriction
+                       ("at most one tagged type or type extension allowed",
+                        "\\ previous declaration#",
+                        Decl);
+                  end if;
+               end if;
+
+               Next (Decl);
+            end loop;
+         end Check_Decls;
+
+      --  Start of processing for Check_One_Tagged_Type_Or_Extension_At_Most
+
+      begin
+         Previous := Empty;
+         Check_Decls (Vis_Decls);
+
+         if Present (Priv_Decls) then
+            Check_Decls (Priv_Decls);
+         end if;
+      end Check_One_Tagged_Type_Or_Extension_At_Most;
+
       ---------------------
       -- Clear_Constants --
       ---------------------
@@ -1383,6 +1439,8 @@ package body Sem_Ch7 is
          Clear_Constants (Id, First_Entity (Id));
          Clear_Constants (Id, First_Private_Entity (Id));
       end if;
+
+      Check_One_Tagged_Type_Or_Extension_At_Most;
    end Analyze_Package_Specification;
 
    --------------------------------------