einfo.ads, einfo.adb (Is_Local_Anonymous_Access): New flag on anonymous access types...

[gcc.git] / gcc / ada / sem_ch7.adb

diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb
index 5660b1555a4c9c6d791f200047c1cd80f83b0653..c8c4a272576f6351cc3d5d95b5a323a9fad5ccee 100644 (file)
--- a/gcc/ada/sem_ch7.adb
+++ b/gcc/ada/sem_ch7.adb
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2005, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2005 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- --
@@ -1114,48 +1114,10 @@ package body Sem_Ch7 is
       Found_Explicit : Boolean;
       Decl_Privates  : Boolean;
 
-      function Has_Overriding_Pragma (Subp : Entity_Id) return Boolean;
-      --  Check whether a pragma Overriding has been provided for a primitive
-      --  operation that is found to be overriding in the private part.
-
       function Is_Primitive_Of (T : Entity_Id; S : Entity_Id) return Boolean;
       --  Check whether an inherited subprogram is an operation of an
       --  untagged derived type.
 
-      ---------------------------
-      -- Has_Overriding_Pragma --
-      ---------------------------
-
-      function Has_Overriding_Pragma (Subp : Entity_Id) return Boolean is
-         Decl : constant Node_Id := Unit_Declaration_Node (Subp);
-         Prag : Node_Id;
-
-      begin
-         if No (Decl)
-           or else Nkind (Decl) /= N_Subprogram_Declaration
-           or else No (Next (Decl))
-         then
-            return False;
-
-         else
-            Prag := Next (Decl);
-
-            while Present (Prag)
-              and then Nkind (Prag) = N_Pragma
-            loop
-               if Chars (Prag) = Name_Overriding
-                 or else Chars (Prag) = Name_Optional_Overriding
-               then
-                  return True;
-               else
-                  Next (Prag);
-               end if;
-            end loop;
-         end if;
-
-         return False;
-      end Has_Overriding_Pragma;
-
       ---------------------
       -- Is_Primitive_Of --
       ---------------------
@@ -1238,20 +1200,9 @@ package body Sem_Ch7 is
                            Replace_Elmt (Op_Elmt, New_Op);
                            Remove_Elmt (Op_List, Op_Elmt_2);
                            Found_Explicit := True;
+                           Set_Is_Overriding_Operation (New_Op);
                            Decl_Privates  := True;
 
-                           --  If explicit_overriding is in effect, check that
-                           --  the overriding operation is properly labelled.
-
-                           if Explicit_Overriding
-                             and then Comes_From_Source (New_Op)
-                              and then not Has_Overriding_Pragma (New_Op)
-                           then
-                              Error_Msg_NE
-                                ("Missing overriding pragma for&",
-                                  New_Op, New_Op);
-                           end if;
-
                            exit;
                         end if;
 
@@ -1692,9 +1643,13 @@ package body Sem_Ch7 is
          Set_RM_Size (Priv, RM_Size (Full));
          Set_Size_Known_At_Compile_Time (Priv, Size_Known_At_Compile_Time
                                                                       (Full));
-         Set_Is_Volatile       (Priv, Is_Volatile       (Full));
-         Set_Treat_As_Volatile (Priv, Treat_As_Volatile (Full));
-         Set_Is_Ada_2005       (Priv, Is_Ada_2005       (Full));
+         Set_Is_Volatile        (Priv, Is_Volatile        (Full));
+         Set_Treat_As_Volatile  (Priv, Treat_As_Volatile  (Full));
+         Set_Is_Ada_2005        (Priv, Is_Ada_2005        (Full));
+
+         if Is_Unchecked_Union (Full) then
+            Set_Is_Unchecked_Union (Base_Type (Priv));
+         end if;
          --  Why is atomic not copied here ???
 
          if Referenced (Full) then
@@ -1717,8 +1672,34 @@ package body Sem_Ch7 is
            and then not Error_Posted (Full)
          then
             if Priv_Is_Base_Type then
-               Set_Access_Disp_Table (Priv, Access_Disp_Table
-                                                           (Base_Type (Full)));
+
+               --  Ada 2005 (AI-345): The full view of a type implementing
+               --  an interface can be a task type.
+
+               --    type T is new I with private;
+               --  private
+               --    task type T is new I with ...
+
+               if Is_Interface (Etype (Priv))
+                 and then Is_Concurrent_Type (Base_Type (Full))
+               then
+                  --  Protect the frontend against previous errors
+
+                  if Present (Corresponding_Record_Type
+                               (Base_Type (Full)))
+                  then
+                     Set_Access_Disp_Table
+                       (Priv, Access_Disp_Table
+                               (Corresponding_Record_Type (Base_Type (Full))));
+                  else
+                     pragma Assert (Serious_Errors_Detected > 0);
+                     null;
+                  end if;
+
+               else
+                  Set_Access_Disp_Table
+                    (Priv, Access_Disp_Table (Base_Type (Full)));
+               end if;
             end if;
 
             Set_First_Entity (Priv, First_Entity (Full));