2008-05-20 Javier Miranda <miranda@adacore.com>

	    Ed Schonberg  <schonberg@adacore.com>
	    Hristian Kirtchev  <kirtchev@adacore.com>

	* sem_ch3.adb
	(Analyze_Object_Declaration): Fix over-conservative condition
	restricting use of predefined assignment with tagged types that have
	convention CPP.
	(Analyze_Object_Declaration): Relax the check regarding deferred
	constants declared in scopes other than packages since they can be
	completed with pragma Import.
	Add missing escaping of all-caps word 'CPP' in error messages.
	(Build_Discriminated_Subtype): Do not inherit representation clauses
	from parent type if subtype already carries them, because they are
	inherited earlier during derivation and already include those that may
	come from a partial view.

	* sem_ch9.adb, sem_ch5.adb, sem_ch6.adb (Analyze_Subprogram_Body):
	Check the declarations of a subprogram body for proper deferred
	constant completion.

	* sem_ch7.ads, sem_ch7.adb
	(Inspect_Deferred_Constant_Completion): Moved to sem_util.

From-SVN: r135638

6 files changed, 116 insertions, 95 deletions

diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index dd08710e37e..1b367373720 100644
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -2404,16 +2404,34 @@ package body Sem_Ch3 is
 
          if Is_Imported (Defining_Identifier (N))
            and then
-            (T = RTE (RE_Tag)
-              or else (Present (Full_View (T))
-                        and then Full_View (T) = RTE (RE_Tag)))
+             (T = RTE (RE_Tag)
+               or else
+                 (Present (Full_View (T))
+                   and then Full_View (T) = RTE (RE_Tag)))
          then
             null;
 
-         elsif not Is_Package_Or_Generic_Package (Current_Scope) then
+         --  A deferred constant may appear in the declarative part of the
+         --  following constructs:
+
+         --     blocks
+         --     entry bodies
+         --     extended return statements
+         --     package specs
+         --     package bodies
+         --     subprogram bodies
+         --     task bodies
+
+         --  When declared inside a package spec, a deferred constant must be
+         --  completed by a full constant declaration or pragma Import. In all
+         --  other cases, the only proper completion is pragma Import. Extended
+         --  return statements are flagged as invalid contexts because they do
+         --  not have a declarative part and so cannot accommodate the pragma.
+
+         elsif Ekind (Current_Scope) = E_Return_Statement then
             Error_Msg_N
               ("invalid context for deferred constant declaration (RM 7.4)",
-                N);
+               N);
             Error_Msg_N
               ("\declaration requires an initialization expression",
                 N);
@@ -2482,10 +2500,16 @@ package body Sem_Ch3 is
          --  (primitive that is not available in CPP tagged types).
 
          if Is_Class_Wide_Type (Act_T)
-           and then Convention (Act_T) = Convention_CPP
+           and then
+             (Is_CPP_Class (Root_Type (Etype (Act_T)))
+               or else
+                 (Present (Full_View (Root_Type (Etype (Act_T))))
+                    and then
+                      Is_CPP_Class (Full_View (Root_Type (Etype (Act_T))))))
          then
             Error_Msg_N
-              ("predefined assignment not available in CPP tagged types", E);
+              ("predefined assignment not available for 'C'P'P tagged types",
+               E);
          end if;
 
          Mark_Coextensions (N, E);
@@ -3844,8 +3868,9 @@ package body Sem_Ch3 is
 
                Validate_Access_Type_Declaration (T, N);
 
-               --  If we are in a Remote_Call_Interface package and define
-               --  a RACW, Read and Write attribute must be added.
+               --  If we are in a Remote_Call_Interface package and define a
+               --  RACW, then calling stubs and specific stream attributes
+               --  must be added.
 
                if Is_Remote
                  and then Is_Remote_Access_To_Class_Wide_Type (Def_Id)
@@ -3908,10 +3933,10 @@ package body Sem_Ch3 is
          B : constant Entity_Id := Base_Type (T);
 
       begin
-         --  In the case where the base type is different from the first
-         --  subtype, we pre-allocate a freeze node, and set the proper link
-         --  to the first subtype. Freeze_Entity will use this preallocated
-         --  freeze node when it freezes the entity.
+         --  In the case where the base type differs from the first subtype, we
+         --  pre-allocate a freeze node, and set the proper link to the first
+         --  subtype. Freeze_Entity will use this preallocated freeze node when
+         --  it freezes the entity.
 
          if B /= T then
             Ensure_Freeze_Node (B);
@@ -3929,11 +3954,11 @@ package body Sem_Ch3 is
       if T /= Def_Id and then Is_Private_Type (Def_Id) then
          Process_Full_View (N, T, Def_Id);
 
-         --  Record the reference. The form of this is a little strange,
-         --  since the full declaration has been swapped in. So the first
-         --  parameter here represents the entity to which a reference is
-         --  made which is the "real" entity, i.e. the one swapped in,
-         --  and the second parameter provides the reference location.
+         --  Record the reference. The form of this is a little strange, since
+         --  the full declaration has been swapped in. So the first parameter
+         --  here represents the entity to which a reference is made which is
+         --  the "real" entity, i.e. the one swapped in, and the second
+         --  parameter provides the reference location.
 
          --  Also, we want to kill Has_Pragma_Unreferenced temporarily here
          --  since we don't want a complaint about the full type being an
@@ -3985,12 +4010,12 @@ package body Sem_Ch3 is
    procedure Analyze_Variant_Part (N : Node_Id) is
 
       procedure Non_Static_Choice_Error (Choice : Node_Id);
-      --  Error routine invoked by the generic instantiation below when
-      --  the variant part has a non static choice.
+      --  Error routine invoked by the generic instantiation below when the
+      --  variant part has a non static choice.
 
       procedure Process_Declarations (Variant : Node_Id);
-      --  Analyzes all the declarations associated with a Variant.
-      --  Needed by the generic instantiation below.
+      --  Analyzes all the declarations associated with a Variant. Needed by
+      --  the generic instantiation below.
 
       package Variant_Choices_Processing is new
         Generic_Choices_Processing
@@ -4097,9 +4122,9 @@ package body Sem_Ch3 is
          Index := First (Subtype_Marks (Def));
       end if;
 
-      --  Find proper names for the implicit types which may be public.
-      --  in case of anonymous arrays we use the name of the first object
-      --  of that type as prefix.
+      --  Find proper names for the implicit types which may be public. In case
+      --  of anonymous arrays we use the name of the first object of that type
+      --  as prefix.
 
       if No (T) then
          Related_Id :=  Defining_Identifier (P);
@@ -4120,9 +4145,9 @@ package body Sem_Ch3 is
          --        type Table is array (Index) of ...
          --     end;
 
-         --  This is currently required by the expander to generate the
-         --  internally generated equality subprogram of records with variant
-         --  parts in which the etype of some component is such private type.
+         --  This is currently required by the expander for the internally
+         --  generated equality subprogram of records with variant parts in
+         --  which the etype of some component is such private type.
 
          if Ekind (Current_Scope) = E_Package
            and then In_Private_Part (Current_Scope)
@@ -4195,9 +4220,9 @@ package body Sem_Ch3 is
 
          Set_Parent (Element_Type, Parent (T));
 
-         --  Ada 2005 (AI-230): In case of components that are anonymous
-         --  access types the level of accessibility depends on the enclosing
-         --  type declaration
+         --  Ada 2005 (AI-230): In case of components that are anonymous access
+         --  types the level of accessibility depends on the enclosing type
+         --  declaration
 
          Set_Scope (Element_Type, Current_Scope); -- Ada 2005 (AI-230)
 
@@ -4296,8 +4321,8 @@ package body Sem_Ch3 is
 
          if Null_Exclusion_Present (Component_Definition (Def))
 
-            --  No need to check itypes because in their case this check
-            --  was done at their point of creation
+            --  No need to check itypes because in their case this check was
+            --  done at their point of creation
 
            and then not Is_Itype (Element_Type)
          then
@@ -4331,8 +4356,8 @@ package body Sem_Ch3 is
          end if;
       end if;
 
-      --  A syntax error in the declaration itself may lead to an empty
-      --  index list, in which case do a minimal patch.
+      --  A syntax error in the declaration itself may lead to an empty index
+      --  list, in which case do a minimal patch.
 
       if No (First_Index (T)) then
          Error_Msg_N ("missing index definition in array type declaration", T);
@@ -7631,7 +7656,16 @@ package body Sem_Ch3 is
 
       Set_First_Entity      (Def_Id, First_Entity   (T));
       Set_Last_Entity       (Def_Id, Last_Entity    (T));
-      Set_First_Rep_Item    (Def_Id, First_Rep_Item (T));
+
+      --  If the subtype is the completion of a private declaration, there may
+      --  have been representation clauses for the partial view, and they must
+      --  be preserved. Build_Derived_Type chains the inherited clauses with
+      --  the ones appearing on the extension. If this comes from a subtype
+      --  declaration, all clauses are inherited.
+
+      if No (First_Rep_Item (Def_Id)) then
+         Set_First_Rep_Item    (Def_Id, First_Rep_Item (T));
+      end if;
 
       if Is_Tagged_Type (T) then
          Set_Is_Tagged_Type  (Def_Id);
@@ -9922,7 +9956,7 @@ package body Sem_Ch3 is
                --  discriminant is declared in the private entity.
 
                or else (Is_Private_Type (Typ)
-                        and then Chars (Discrim_Scope) = Chars (Typ))
+                         and then Chars (Discrim_Scope) = Chars (Typ))
 
                --  Or we are constrained the corresponding record of a
                --  synchronized type that completes a private declaration.
@@ -9935,7 +9969,7 @@ package body Sem_Ch3 is
                --  discriminant found belongs to the root type.
 
                or else (Is_Class_Wide_Type (Typ)
-                        and then Etype (Typ) = Discrim_Scope));
+                         and then Etype (Typ) = Discrim_Scope));
 
             return True;
          end if;
@@ -12892,6 +12926,31 @@ package body Sem_Ch3 is
       New_Id   : Entity_Id;
       Prev_Par : Node_Id;
 
+      procedure Tag_Mismatch;
+      --  Diagnose a tagged partial view whose full view is untagged;
+      --  We post the message on the full view, with a reference to
+      --  the previous partial view. The partial view can be private
+      --  or incomplete, and these are handled in a different manner,
+      --  so we determine the position of the error message from the
+      --  respective slocs of both.
+
+      ------------------
+      -- Tag_Mismatch --
+      ------------------
+
+      procedure Tag_Mismatch is
+      begin
+         if Sloc (Prev) < Sloc (Id) then
+            Error_Msg_NE
+              ("full declaration of } must be a tagged type ", Id, Prev);
+         else
+            Error_Msg_NE
+              ("full declaration of } must be a tagged type ", Prev, Id);
+         end if;
+      end Tag_Mismatch;
+
+   --  Start processing for Find_Type_Name
+
    begin
       --  Find incomplete declaration, if one was given
 
@@ -13024,7 +13083,7 @@ package body Sem_Ch3 is
             New_Id := Prev;
          end if;
 
-         --  Verify that full declaration conforms to incomplete one
+         --  Verify that full declaration conforms to partial one
 
          if Is_Incomplete_Or_Private_Type (Prev)
            and then Present (Discriminant_Specifications (Prev_Par))
@@ -13048,9 +13107,10 @@ package body Sem_Ch3 is
             end if;
          end if;
 
-         --  A prior untagged private type can have an associated class-wide
+         --  A prior untagged partial view can have an associated class-wide
          --  type due to use of the class attribute, and in this case also the
-         --  full type is required to be tagged.
+         --  full type is required to be tagged. This Ada95 usage is deprecated
+         --  in favor of incomplete tagged declarations but we check for it.
 
          if Is_Type (Prev)
            and then (Is_Tagged_Type (Prev)
@@ -13066,8 +13126,7 @@ package body Sem_Ch3 is
                if No (Interface_List (N))
                  and then not Error_Posted (N)
                then
-                  Error_Msg_NE
-                    ("full declaration of } must be a tagged type ", Id, Prev);
+                  Tag_Mismatch;
                end if;
 
             elsif Nkind (Type_Definition (N)) = N_Record_Definition then
@@ -13076,8 +13135,7 @@ package body Sem_Ch3 is
                --  or private declaration) requires the same on the full one.
 
                if not Tagged_Present (Type_Definition (N)) then
-                  Error_Msg_NE
-                    ("full declaration of } must be tagged", Prev, Id);
+                  Tag_Mismatch;
                   Set_Is_Tagged_Type (Id);
                   Set_Primitive_Operations (Id, New_Elmt_List);
                end if;
@@ -13092,9 +13150,7 @@ package body Sem_Ch3 is
                end if;
 
             else
-               Error_Msg_NE
-                 ("full declaration of } must be a tagged type", Prev, Id);
-
+               Tag_Mismatch;
             end if;
          end if;
 
@@ -17074,11 +17130,12 @@ package body Sem_Ch3 is
 
          elsif Has_Controlled_Component (Etype (Component))
            or else (Chars (Component) /= Name_uParent
-                    and then Is_Controlled (Etype (Component)))
+                     and then Is_Controlled (Etype (Component)))
          then
             Set_Has_Controlled_Component (T, True);
-            Final_Storage_Only := Final_Storage_Only
-              and then Finalize_Storage_Only (Etype (Component));
+            Final_Storage_Only :=
+              Final_Storage_Only
+                and then Finalize_Storage_Only (Etype (Component));
             Ctrl_Components := True;
          end if;
 
diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb
index a1cd552dfe3..e5de05b3a58 100644
--- a/gcc/ada/sem_ch5.adb
+++ b/gcc/ada/sem_ch5.adb
@@ -870,6 +870,7 @@ package body Sem_Ch5 is
          if Present (Decls) then
             Analyze_Declarations (Decls);
             Check_Completion;
+            Inspect_Deferred_Constant_Completion (Decls);
          end if;
 
          Analyze (HSS);
diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb
index fbac48cd1af..b4b1dcf9e04 100644
--- a/gcc/ada/sem_ch6.adb
+++ b/gcc/ada/sem_ch6.adb
@@ -1257,10 +1257,10 @@ package body Sem_Ch6 is
 
    procedure Analyze_Subprogram_Body (N : Node_Id) is
       Loc          : constant Source_Ptr := Sloc (N);
+      Body_Deleted : constant Boolean    := False;
       Body_Spec    : constant Node_Id    := Specification (N);
       Body_Id      : Entity_Id           := Defining_Entity (Body_Spec);
       Prev_Id      : constant Entity_Id  := Current_Entity_In_Scope (Body_Id);
-      Body_Deleted : constant Boolean    := False;
       Conformant   : Boolean;
       HSS          : Node_Id;
       Missing_Ret  : Boolean;
@@ -1369,7 +1369,8 @@ package body Sem_Ch6 is
          Plist : List_Id;
 
          function Is_Inline_Pragma (N : Node_Id) return Boolean;
-         --  Simple predicate, used twice.
+         --  True when N is a pragma Inline or Inline_Awlays that applies
+         --  to this subprogram.
 
          -----------------------
          --  Is_Inline_Pragma --
@@ -2045,6 +2046,7 @@ package body Sem_Ch6 is
       --  Check completion, and analyze the statements
 
       Check_Completion;
+      Inspect_Deferred_Constant_Completion (Declarations (N));
       Analyze (HSS);
 
       --  Deal with end of scope processing for the body
diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb
index fe1bcb5f24f..ee3300bb938 100644
--- a/gcc/ada/sem_ch7.adb
+++ b/gcc/ada/sem_ch7.adb
@@ -100,12 +100,6 @@ package body Sem_Ch7 is
    --  created at the beginning of the corresponding package body and inserted
    --  before other body declarations.
 
-   procedure Inspect_Deferred_Constant_Completion (Decls : List_Id);
-   --  Examines the deferred constants in the private part of the package
-   --  specification, or in a package body. Emits the error message
-   --  "constant declaration requires initialization expression" if not
-   --  completed by an Import pragma.
-
    procedure Install_Package_Entity (Id : Entity_Id);
    --  Supporting procedure for Install_{Visible,Private}_Declarations.
    --  Places one entity on its visibility chain, and recurses on the visible
@@ -1604,41 +1598,6 @@ package body Sem_Ch7 is
       Set_Homonym     (Full_Id, H2);
    end Exchange_Declarations;
 
-   ------------------------------------------
-   -- Inspect_Deferred_Constant_Completion --
-   ------------------------------------------
-
-   procedure Inspect_Deferred_Constant_Completion (Decls : List_Id) is
-      Decl   : Node_Id;
-
-   begin
-      Decl := First (Decls);
-      while Present (Decl) loop
-
-         --  Deferred constant signature
-
-         if Nkind (Decl) = N_Object_Declaration
-           and then Constant_Present (Decl)
-           and then No (Expression (Decl))
-
-            --  No need to check internally generated constants
-
-           and then Comes_From_Source (Decl)
-
-            --  The constant is not completed. A full object declaration
-            --  or a pragma Import complete a deferred constant.
-
-           and then not Has_Completion (Defining_Identifier (Decl))
-         then
-            Error_Msg_N
-              ("constant declaration requires initialization expression",
-              Defining_Identifier (Decl));
-         end if;
-
-         Decl := Next (Decl);
-      end loop;
-   end Inspect_Deferred_Constant_Completion;
-
    ----------------------------
    -- Install_Package_Entity --
    ----------------------------
diff --git a/gcc/ada/sem_ch7.ads b/gcc/ada/sem_ch7.ads
index bcdaf000839..0445b242949 100644
--- a/gcc/ada/sem_ch7.ads
+++ b/gcc/ada/sem_ch7.ads
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 1992-2007, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2008, 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- --
diff --git a/gcc/ada/sem_ch9.adb b/gcc/ada/sem_ch9.adb
index fe3634e8fe9..9482b565feb 100644
--- a/gcc/ada/sem_ch9.adb
+++ b/gcc/ada/sem_ch9.adb
@@ -795,6 +795,7 @@ package body Sem_Ch9 is
 
       if Present (Decls) then
          Analyze_Declarations (Decls);
+         Inspect_Deferred_Constant_Completion (Decls);
       end if;
 
       if Present (Stats) then
@@ -1908,6 +1909,7 @@ package body Sem_Ch9 is
       Last_E := Last_Entity (Spec_Id);
 
       Analyze_Declarations (Decls);
+      Inspect_Deferred_Constant_Completion (Decls);
 
       --  For visibility purposes, all entities in the body are private. Set
       --  First_Private_Entity accordingly, if there was no private part in the