2011-08-01 Robert Dewar <dewar@adacore.com>

[pf3gnuchains/gcc-fork.git] / gcc / ada / sem_util.adb

diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index b218b8e..5fcfd6f 100644 (file)
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2010, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2011, 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- --
@@ -4889,51 +4889,48 @@ package body Sem_Util is
 
    function Has_Overriding_Initialize (T : Entity_Id) return Boolean is
       BT   : constant Entity_Id := Base_Type (T);
-      Comp : Entity_Id;
       P    : Elmt_Id;
 
    begin
       if Is_Controlled (BT) then
-
-         --  For derived types, check immediate ancestor, excluding
-         --  Controlled itself.
-
-         if Is_Derived_Type (BT)
-           and then not In_Predefined_Unit (Etype (BT))
-           and then Has_Overriding_Initialize (Etype (BT))
-         then
-            return True;
+         if Is_RTU (Scope (BT), Ada_Finalization) then
+            return False;
 
          elsif Present (Primitive_Operations (BT)) then
             P := First_Elmt (Primitive_Operations (BT));
             while Present (P) loop
-               if Chars (Node (P)) = Name_Initialize
-                 and then Comes_From_Source (Node (P))
-               then
-                  return True;
-               end if;
+               declare
+                  Init : constant Entity_Id := Node (P);
+                  Formal : constant Entity_Id := First_Formal (Init);
+               begin
+                  if Ekind (Init) = E_Procedure
+                       and then Chars (Init) = Name_Initialize
+                       and then Comes_From_Source (Init)
+                       and then Present (Formal)
+                       and then Etype (Formal) = BT
+                       and then No (Next_Formal (Formal))
+                       and then (Ada_Version < Ada_2012
+                                   or else not Null_Present (Parent (Init)))
+                  then
+                     return True;
+                  end if;
+               end;
 
                Next_Elmt (P);
             end loop;
          end if;
 
-         return False;
-
-      elsif Has_Controlled_Component (BT) then
-         Comp := First_Component (BT);
-         while Present (Comp) loop
-            if Has_Overriding_Initialize (Etype (Comp)) then
-               return True;
-            end if;
-
-            Next_Component (Comp);
-         end loop;
-
-         return False;
+         --  Here if type itself does not have a non-null Initialize operation:
+         --  check immediate ancestor.
 
-      else
-         return False;
+         if Is_Derived_Type (BT)
+           and then Has_Overriding_Initialize (Etype (BT))
+         then
+            return True;
+         end if;
       end if;
+
+      return False;
    end Has_Overriding_Initialize;
 
    --------------------------------------
@@ -6665,9 +6662,19 @@ package body Sem_Util is
 
    function Is_LHS (N : Node_Id) return Boolean is
       P : constant Node_Id := Parent (N);
+
    begin
-      return Nkind (P) = N_Assignment_Statement
-        and then Name (P) = N;
+      if Nkind (P) = N_Assignment_Statement then
+         return Name (P) = N;
+
+      elsif
+        Nkind_In (P, N_Indexed_Component, N_Selected_Component, N_Slice)
+      then
+         return N = Prefix (P) and then Is_LHS (P);
+
+      else
+         return False;
+      end if;
    end Is_LHS;
 
    ----------------------------
@@ -10473,11 +10480,11 @@ package body Sem_Util is
          if Requires_Transient_Scope (Component_Type (Typ)) then
             return True;
 
-         --  Otherwise, we only need a transient scope if the size is not
-         --  known at compile time.
+         --  Otherwise, we only need a transient scope if the size depends on
+         --  the value of one or more discriminants.
 
          else
-            return not Size_Known_At_Compile_Time (Typ);
+            return Size_Depends_On_Discriminant (Typ);
          end if;
 
       --  All other cases do not require a transient scope
@@ -11231,6 +11238,38 @@ package body Sem_Util is
    end Set_Size_Info;
 
    --------------------
+   -- Static_Boolean --
+   --------------------
+
+   function Static_Boolean (N : Node_Id) return Uint is
+   begin
+      Analyze_And_Resolve (N, Standard_Boolean);
+
+      if N = Error
+        or else Error_Posted (N)
+        or else Etype (N) = Any_Type
+      then
+         return No_Uint;
+      end if;
+
+      if Is_Static_Expression (N) then
+         if not Raises_Constraint_Error (N) then
+            return Expr_Value (N);
+         else
+            return No_Uint;
+         end if;
+
+      elsif Etype (N) = Any_Type then
+         return No_Uint;
+
+      else
+         Flag_Non_Static_Expr
+           ("static boolean expression required here", N);
+         return No_Uint;
+      end if;
+   end Static_Boolean;
+
+   --------------------
    -- Static_Integer --
    --------------------