sem_disp.adb (Is_Dynamically_Tagged): when applied to an entity or a function call...

2015-01-30  Ed Schonberg  <schonberg@adacore.com>

	* sem_disp.adb (Is_Dynamically_Tagged): when applied to an entity
	or a function call, return True if type is class-wide.
	* sem_res.adb (Resolve_Case_Expression, Resolve_If_Expression);
	Apply RM 4.5.7 (17/3): all or none of the dependent expression
	of a conditional expression must be dynamically tagged.

From-SVN: r220276

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index be0188ddad70a3195e31fe3c454217d16143dabb..a67b7d37ded276a223c11d5c00538bacdfc99973 100644 (file)
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,11 @@
+2015-01-30  Ed Schonberg  <schonberg@adacore.com>
+
+       * sem_disp.adb (Is_Dynamically_Tagged): when applied to an entity
+       or a function call, return True if type is class-wide.
+       * sem_res.adb (Resolve_Case_Expression, Resolve_If_Expression);
+       Apply RM 4.5.7 (17/3): all or none of the dependent expression
+       of a conditional expression must be dynamically tagged.
+
 2015-01-30  Ed Schonberg  <schonberg@adacore.com>
 
        * sem_ch6.adb (Analyze_Function_Return): In an extended return

diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb
index a915ab05e77c005dda482a58a6ecf8183ae7f061..0a9bfba594228997bcddc29f09f5b5ac092c164d 100644 (file)
--- a/gcc/ada/sem_disp.adb
+++ b/gcc/ada/sem_disp.adb
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2014, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2015, 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- --
@@ -562,6 +562,12 @@ package body Sem_Disp is
             then
                null;
 
+            elsif Ekind (Current_Scope) = E_Function
+              and then Nkind (Unit_Declaration_Node (Current_Scope))
+                 = N_Generic_Subprogram_Declaration
+            then
+               null;
+
             else
                --  We need to determine whether the context of the call
                --  provides a tag to make the call dispatching. This requires
@@ -2162,8 +2168,24 @@ package body Sem_Disp is
    begin
       if Nkind (N) = N_Error then
          return False;
+
+      elsif Present (Find_Controlling_Arg (N)) then
+         return True;
+
+      --  Special cases : entities, and calls that dispatch on result.
+
+      elsif Is_Entity_Name (N) then
+         return Is_Class_Wide_Type (Etype (N));
+
+      elsif Nkind (N) = N_Function_Call
+         and then Is_Class_Wide_Type (Etype (N))
+      then
+         return True;
+
+      --  Otherwise check whether call has controlling argument.
+
       else
-         return Find_Controlling_Arg (N) /= Empty;
+         return False;
       end if;
    end Is_Dynamically_Tagged;
 

diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb
index 82890810a4852a6a87866dacc5cc1969fe59fb26..5096c6a626423fb58bf7b69471b91a92efc9b9e7 100644 (file)
--- a/gcc/ada/sem_res.adb
+++ b/gcc/ada/sem_res.adb
@@ -6416,7 +6416,8 @@ package body Sem_Res is
    -----------------------------
 
    procedure Resolve_Case_Expression (N : Node_Id; Typ : Entity_Id) is
-      Alt : Node_Id;
+      Alt    : Node_Id;
+      Is_Dyn : Boolean;
 
    begin
       Alt := First (Alternatives (N));
@@ -6425,6 +6426,23 @@ package body Sem_Res is
          Next (Alt);
       end loop;
 
+      --  Apply RM 4.5.7 (17/3): whether the expression is statically or
+      --  dynamically tagged must be known statically.
+
+      if Is_Tagged_Type (Typ) and then not Is_Class_Wide_Type (Typ) then
+         Alt := First (Alternatives (N));
+         Is_Dyn := Is_Dynamically_Tagged (Expression (Alt));
+
+         while Present (Alt) loop
+            if Is_Dynamically_Tagged (Expression (Alt)) /= Is_Dyn then
+               Error_Msg_N ("all or none of the dependent expressions "
+                            & "can be dynamically tagged", N);
+            end if;
+
+            Next (Alt);
+         end loop;
+      end if;
+
       Set_Etype (N, Typ);
       Eval_Case_Expression (N);
    end Resolve_Case_Expression;
@@ -8061,11 +8079,20 @@ package body Sem_Res is
          Resolve (Else_Expr, Typ);
          Else_Typ := Etype (Else_Expr);
 
-         if Is_Scalar_Type (Else_Typ)
-           and then Else_Typ /= Typ
-         then
+         if Is_Scalar_Type (Else_Typ) and then Else_Typ /= Typ then
             Rewrite (Else_Expr, Convert_To (Typ, Else_Expr));
             Analyze_And_Resolve (Else_Expr, Typ);
+
+         --  Apply RM 4.5.7 (17/3): whether the expression is statically or
+         --  dynamically tagged must be known statically.
+
+         elsif Is_Tagged_Type (Typ) and then not Is_Class_Wide_Type (Typ) then
+            if Is_Dynamically_Tagged (Then_Expr) /=
+               Is_Dynamically_Tagged (Else_Expr)
+            then
+               Error_Msg_N ("all or none of the dependent expressions "
+                            & "can be dynamically tagged", N);
+            end if;
          end if;
 
       --  If no ELSE expression is present, root type must be Standard.Boolean
@@ -8232,10 +8259,10 @@ package body Sem_Res is
                                             (Entity (Prefix (N)))))
         and then not Is_Atomic (Component_Type (Array_Type))
       then
-         Error_Msg_N ("??access to non-atomic component of atomic array",
-                      Prefix (N));
-         Error_Msg_N ("??\may cause unexpected accesses to atomic object",
-                      Prefix (N));
+         Error_Msg_N
+           ("??access to non-atomic component of atomic array", Prefix (N));
+         Error_Msg_N
+           ("??\may cause unexpected accesses to atomic object", Prefix (N));
       end if;
    end Resolve_Indexed_Component;
 
@@ -8263,9 +8290,14 @@ package body Sem_Res is
       --  If the operand is a literal, it cannot be the expression in a
       --  conversion. Use a qualified expression instead.
 
+      ---------------------
+      -- Convert_Operand --
+      ---------------------
+
       function Convert_Operand (Opnd : Node_Id) return Node_Id is
          Loc : constant Source_Ptr := Sloc (Opnd);
          Res : Node_Id;
+
       begin
          if Nkind_In (Opnd, N_Integer_Literal, N_Real_Literal) then
             Res :=
@@ -8309,8 +8341,6 @@ package body Sem_Res is
         or else Is_Private_Type (Etype (Right_Opnd (N)))
       then
          Arg1 := Convert_Operand (Left_Opnd (N));
-         --  Unchecked_Convert_To (Btyp, Left_Opnd  (N));
-         --  What on earth is this commented out fragment of code???
 
          if Nkind (N) = N_Op_Expon then
             Arg2 := Unchecked_Convert_To (Standard_Integer, Right_Opnd (N));