sem_util.ads, [...] (Check_Dynamically_Tagged_Expression): New subprogram.

2009-07-20  Javier Miranda  <miranda@adacore.com>

	* sem_util.ads, sem_util.adb (Check_Dynamically_Tagged_Expression): New
	subprogram.
	* sem_aggr.adb (Resolve_Array_Aggregate): Check incorrect use of
	dynamically tagged expression.
	* sem_ch3.adb (Analyze_Object_Declaration): Call new routine that
	factorizes code.
	* sem_ch6.adb (Analyze_Function_Return, Process_Formals): Ditto.
	* sem_ch8.adb (Analyze_Object_Renaming): Ditto.

From-SVN: r149817

gcc/ada/ChangeLog

+2009-07-20  Javier Miranda  <miranda@adacore.com>
+
+	* sem_util.ads, sem_util.adb (Check_Dynamically_Tagged_Expression): New
+	subprogram.
+	* sem_aggr.adb (Resolve_Array_Aggregate): Check incorrect use of
+	dynamically tagged expression.
+	* sem_ch3.adb (Analyze_Object_Declaration): Call new routine that
+	factorizes code.
+	* sem_ch6.adb (Analyze_Function_Return, Process_Formals): Ditto.
+	* sem_ch8.adb (Analyze_Object_Renaming): Ditto.
+
 2009-07-20  Arnaud Charlet  <charlet@adacore.com>
 
 	* gnat1drv.adb (Gnat1drv): Set operating mode to Generate_Code when

gcc/ada/sem_aggr.adb

@@ -28,6 +28,7 @@ with Checks;   use Checks;
 with Einfo;    use Einfo;
 with Elists;   use Elists;
 with Errout;   use Errout;
+with Expander; use Expander;
 with Exp_Tss;  use Exp_Tss;
 with Exp_Util; use Exp_Util;
 with Freeze;   use Freeze;
@@ -1759,6 +1760,42 @@ package body Sem_Aggr is
                                             Single_Elmt => Single_Choice)
                then
                   return Failure;
+
+               --  Check incorrect use of dynamically tagged expression
+
+               --  We differentiate here two cases because the expression may
+               --  not be decorated. For example, the analysis and resolution
+               --  of the expression associated with the others choice will
+               --  be done later with the full aggregate. In such case we
+               --  duplicate the expression tree to analyze the copy and
+               --  perform the required check.
+
+               elsif not Present (Etype (Expression (Assoc))) then
+                  declare
+                     Save_Analysis : constant Boolean := Full_Analysis;
+                     Expr          : constant Node_Id :=
+                                       New_Copy_Tree (Expression (Assoc));
+
+                  begin
+                     Expander_Mode_Save_And_Set (False);
+                     Full_Analysis := False;
+                     Analyze (Expr);
+                     Full_Analysis := Save_Analysis;
+                     Expander_Mode_Restore;
+
+                     if Is_Tagged_Type (Etype (Expr)) then
+                        Check_Dynamically_Tagged_Expression
+                          (Expr => Expr,
+                           Typ  => Component_Type (Etype (N)),
+                           Related_Nod => N);
+                     end if;
+                  end;
+
+               elsif Is_Tagged_Type (Etype (Expression (Assoc))) then
+                  Check_Dynamically_Tagged_Expression
+                    (Expr => Expression (Assoc),
+                     Typ  => Component_Type (Etype (N)),
+                     Related_Nod => N);
                end if;
 
                Next (Assoc);
@@ -1992,6 +2029,15 @@ package body Sem_Aggr is
                return Failure;
             end if;
 
+            --  Check incorrect use of dynamically tagged expression
+
+            if Is_Tagged_Type (Etype (Expr)) then
+               Check_Dynamically_Tagged_Expression
+                 (Expr => Expr,
+                  Typ  => Component_Type (Etype (N)),
+                  Related_Nod => N);
+            end if;
+
             Next (Expr);
          end loop;
 
@@ -2021,6 +2067,32 @@ package body Sem_Aggr is
                                          Single_Elmt => False)
             then
                return Failure;
+
+            --  Check incorrect use of dynamically tagged expression. The
+            --  expression of the others choice has not been resolved yet.
+            --  In order to diagnose the semantic error we create a duplicate
+            --  tree to analyze it and perform the check.
+
+            else
+               declare
+                  Save_Analysis : constant Boolean := Full_Analysis;
+                  Expr          : constant Node_Id :=
+                                    New_Copy_Tree (Expression (Assoc));
+
+               begin
+                  Expander_Mode_Save_And_Set (False);
+                  Full_Analysis := False;
+                  Analyze (Expr);
+                  Full_Analysis := Save_Analysis;
+                  Expander_Mode_Restore;
+
+                  if Is_Tagged_Type (Etype (Expr)) then
+                     Check_Dynamically_Tagged_Expression
+                       (Expr => Expr,
+                        Typ  => Component_Type (Etype (N)),
+                        Related_Nod => N);
+                  end if;
+               end;
             end if;
          end if;
 

gcc/ada/sem_ch3.adb

@@ -2608,16 +2608,13 @@ package body Sem_Ch3 is
             end if;
          end if;
 
-         --  Check incorrect use of dynamically tagged expressions. Note
-         --  the use of Is_Tagged_Type (T) which seems redundant but is in
-         --  fact important to avoid spurious errors due to expanded code
-         --  for dispatching functions over an anonymous access type
+         --  Check incorrect use of dynamically tagged expressions.
 
-         if (Is_Class_Wide_Type (Etype (E)) or else Is_Dynamically_Tagged (E))
-           and then Is_Tagged_Type (T)
-           and then not Is_Class_Wide_Type (T)
-         then
-            Error_Msg_N ("dynamically tagged expression not allowed!", E);
+         if Is_Tagged_Type (T) then
+            Check_Dynamically_Tagged_Expression
+              (Expr        => E,
+               Typ         => T,
+               Related_Nod => N);
          end if;
 
          Apply_Scalar_Range_Check (E, T);

gcc/ada/sem_ch6.adb

@@ -749,12 +749,13 @@ package body Sem_Ch6 is
             end if;
          end if;
 
-         if (Is_Class_Wide_Type (Etype (Expr))
-              or else Is_Dynamically_Tagged (Expr))
-           and then not Is_Class_Wide_Type (R_Type)
-         then
-            Error_Msg_N
-              ("dynamically tagged expression not allowed!", Expr);
+         --  Check incorrect use of dynamically tagged expression
+
+         if Is_Tagged_Type (R_Type) then
+            Check_Dynamically_Tagged_Expression
+              (Expr => Expr,
+               Typ  => R_Type,
+               Related_Nod => N);
          end if;
 
          --  ??? A real run-time accessibility check is needed in cases
@@ -8084,6 +8085,15 @@ package body Sem_Ch6 is
                Error_Msg_N
                  ("access to class-wide expression not allowed here", Default);
             end if;
+
+            --  Check incorrect use of dynamically tagged expressions
+
+            if Is_Tagged_Type (Formal_Type) then
+               Check_Dynamically_Tagged_Expression
+                 (Expr        => Default,
+                  Typ         => Formal_Type,
+                  Related_Nod => Default);
+            end if;
          end if;
 
          --  Ada 2005 (AI-231): Static checks

gcc/ada/sem_ch8.adb

@@ -754,12 +754,11 @@ package body Sem_Ch8 is
          --  cases where the renamed object is a dynamically tagged access
          --  result, such as occurs in certain expansions.
 
-         if (Is_Class_Wide_Type (Etype (Nam))
-              or else (Is_Dynamically_Tagged (Nam)
-                        and then not Is_Access_Type (T)))
-           and then not Is_Class_Wide_Type (T)
-         then
-            Error_Msg_N ("dynamically tagged expression not allowed!", Nam);
+         if Is_Tagged_Type (T) then
+            Check_Dynamically_Tagged_Expression
+              (Expr        => Nam,
+               Typ         => T,
+               Related_Nod => N);
          end if;
 
       --  Ada 2005 (AI-230/AI-254): Access renaming

gcc/ada/sem_util.adb

@@ -47,6 +47,7 @@ with Sem;      use Sem;
 with Sem_Aux;  use Sem_Aux;
 with Sem_Attr; use Sem_Attr;
 with Sem_Ch8;  use Sem_Ch8;
+with Sem_Disp; use Sem_Disp;
 with Sem_Eval; use Sem_Eval;
 with Sem_Res;  use Sem_Res;
 with Sem_Type; use Sem_Type;
@@ -1032,6 +1033,28 @@ package body Sem_Util is
       end if;
    end Cannot_Raise_Constraint_Error;
 
+   -----------------------------------------
+   -- Check_Dynamically_Tagged_Expression --
+   -----------------------------------------
+
+   procedure Check_Dynamically_Tagged_Expression
+     (Expr        : Node_Id;
+      Typ         : Entity_Id;
+      Related_Nod : Node_Id)
+   is
+   begin
+      pragma Assert (Is_Tagged_Type (Typ));
+
+      if Comes_From_Source (Related_Nod)
+        and then (Is_Class_Wide_Type (Etype (Expr))
+                   or else Is_Dynamically_Tagged (Expr))
+        and then Is_Tagged_Type (Typ)
+        and then not Is_Class_Wide_Type (Typ)
+      then
+         Error_Msg_N ("dynamically tagged expression not allowed!", Expr);
+      end if;
+   end Check_Dynamically_Tagged_Expression;
+
    --------------------------
    -- Check_Fully_Declared --
    --------------------------

gcc/ada/sem_util.ads

@@ -125,6 +125,12 @@ package Sem_Util is
    --  not necessarily mean that CE could be raised, but a response of True
    --  means that for sure CE cannot be raised.
 
+   procedure Check_Dynamically_Tagged_Expression
+     (Expr        : Node_Id;
+      Typ         : Entity_Id;
+      Related_Nod : Node_Id);
+   --  Check wrong use of dynamically tagged expression
+
    procedure Check_Fully_Declared (T : Entity_Id; N : Node_Id);
    --  Verify that the full declaration of type T has been seen. If not,
    --  place error message on node N. Used in  object declarations, type