[multiple changes]

2014-08-01  Hristian Kirtchev  <kirtchev@adacore.com>

	* sem_attr.adb (Analyze_Attribute): Preanalyze and resolve the
	prefix of attribute Loop_Entry.
	* sem_prag.adb (Analyze_Pragma): Verify the placement of pragma
	Loop_Variant with respect to an enclosing loop (if any).
	(Contains_Loop_Entry): Update the parameter profile and all
	calls to this routine.
	* sem_res.adb (Resolve_Call): Code reformatting. Do not ask
	for the corresponding body before determining the nature of the
	ultimate alias's declarative node.

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

	* gnat1drv.adb, sem_ch4.adb: Minor reformatting.

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

	* sem_eval.adb (Rewrite_In_Raise_CE): Don't try to reuse inner
	constraint error node since it is a list member.

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

	* sem_warn.adb: Minor reformatting.

2014-08-01  Eric Botcazou  <ebotcazou@adacore.com>

	* einfo.adb (Underlying_Type): Return the underlying full view
	of a private type if present.
	* freeze.adb (Freeze_Entity):
	Build a single freeze node for partial, full and underlying full
	views, if any.
	* gcc-interface/decl.c (gnat_to_gnu_entity) <E_Private_Type>: Add a
	missing guard before the access to the Underlying_Full_View.
	* gcc-interface/trans.c (process_freeze_entity): Deal with underlying
	full view if present.
	* gcc-interface/utils.c (make_dummy_type): Avoid superfluous work.

From-SVN: r213463

12 files changed, 162 insertions, 92 deletions

diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb
index 84e7763..6afc37c 100644
--- a/gcc/ada/einfo.adb
+++ b/gcc/ada/einfo.adb
@@ -8118,7 +8118,7 @@ package body Einfo is
       elsif Ekind (Id) in Incomplete_Or_Private_Kind then
 
          --  If we have an incomplete or private type with a full view,
-         --  then we return the Underlying_Type of this full view
+         --  then we return the Underlying_Type of this full view.
 
          if Present (Full_View (Id)) then
             if Id = Full_View (Id) then
@@ -8131,6 +8131,14 @@ package body Einfo is
                return Underlying_Type (Full_View (Id));
             end if;
 
+         --  If we have a private type with an underlying full view, then we
+         --  return the Underlying_Type of this underlying full view.
+
+         elsif Ekind (Id) in Private_Kind
+           and then Present (Underlying_Full_View (Id))
+         then
+            return Underlying_Type (Underlying_Full_View (Id));
+
          --  If we have an incomplete entity that comes from the limited
          --  view then we return the Underlying_Type of its non-limited
          --  view.
diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb
index b59e6ec..9af48a8 100644
--- a/gcc/ada/freeze.adb
+++ b/gcc/ada/freeze.adb
@@ -4977,7 +4977,7 @@ package body Freeze is
          --  view, we can retrieve the full view, but not the reverse).
          --  However, in order to freeze correctly, we need to freeze the full
          --  view. If we are freezing at the end of a scope (or within the
-         --  scope of the private type), the partial and full views will have
+         --  scope) of the private type, the partial and full views will have
          --  been swapped, the full view appears first in the entity chain and
          --  the swapping mechanism ensures that the pointers are properly set
          --  (on scope exit).
@@ -4987,6 +4987,11 @@ package body Freeze is
          --  set the pointers appropriately since we cannot rely on swapping to
          --  fix things up (subtypes in an outer scope might not get swapped).
 
+         --  If the full view is itself private, the above requirements apply
+         --  to the underlying full view instead of the full view. But there is
+         --  no swapping mechanism for the underlying full view so we need to
+         --  set the pointers appropriately in both cases.
+
          elsif Is_Incomplete_Or_Private_Type (E)
            and then not Is_Generic_Type (E)
          then
@@ -5025,29 +5030,45 @@ package body Freeze is
                if Is_Frozen (Full_View (E)) then
                   Set_Has_Delayed_Freeze (E, False);
                   Set_Freeze_Node (E, Empty);
-                  Check_Debug_Info_Needed (E);
 
                --  Otherwise freeze full view and patch the pointers so that
-               --  the freeze node will elaborate both views in the back-end.
+               --  the freeze node will elaborate both views in the back end.
+               --  However, if full view is itself private, freeze underlying
+               --  full view instead and patch the pointer so that the freeze
+               --  node will elaborate the three views in the back end.
 
                else
                   declare
-                     Full : constant Entity_Id := Full_View (E);
+                     Full : Entity_Id := Full_View (E);
 
                   begin
                      if Is_Private_Type (Full)
                        and then Present (Underlying_Full_View (Full))
                      then
-                        Freeze_And_Append
-                          (Underlying_Full_View (Full), N, Result);
+                        Full := Underlying_Full_View (Full);
                      end if;
 
                      Freeze_And_Append (Full, N, Result);
 
-                     if Has_Delayed_Freeze (E) then
+                     if Full /= Full_View (E)
+                       and then Has_Delayed_Freeze (Full_View (E))
+                     then
                         F_Node := Freeze_Node (Full);
 
                         if Present (F_Node) then
+                           Set_Freeze_Node (Full_View (E), F_Node);
+                           Set_Entity (F_Node, Full_View (E));
+
+                        else
+                           Set_Has_Delayed_Freeze (Full_View (E), False);
+                           Set_Freeze_Node (Full_View (E), Empty);
+                        end if;
+                     end if;
+
+                     if Has_Delayed_Freeze (E) then
+                        F_Node := Freeze_Node (Full_View (E));
+
+                        if Present (F_Node) then
                            Set_Freeze_Node (E, F_Node);
                            Set_Entity (F_Node, E);
 
@@ -5060,10 +5081,10 @@ package body Freeze is
                         end if;
                      end if;
                   end;
-
-                  Check_Debug_Info_Needed (E);
                end if;
 
+               Check_Debug_Info_Needed (E);
+
                --  AI-117 requires that the convention of a partial view be the
                --  same as the convention of the full view. Note that this is a
                --  recognized breach of privacy, but it's essential for logical
@@ -5090,6 +5111,35 @@ package body Freeze is
 
                return Result;
 
+            --  Case of underlying full view present
+
+            elsif Is_Private_Type (E)
+              and then Present (Underlying_Full_View (E))
+            then
+               if not Is_Frozen (Underlying_Full_View (E)) then
+                  Freeze_And_Append (Underlying_Full_View (E), N, Result);
+               end if;
+
+               --  Patch the pointers so that the freeze node will elaborate
+               --  both views in the back end.
+
+               if Has_Delayed_Freeze (E) then
+                  F_Node := Freeze_Node (Underlying_Full_View (E));
+
+                  if Present (F_Node) then
+                     Set_Freeze_Node (E, F_Node);
+                     Set_Entity (F_Node, E);
+
+                  else
+                     Set_Has_Delayed_Freeze (E, False);
+                     Set_Freeze_Node (E, Empty);
+                  end if;
+               end if;
+
+               Check_Debug_Info_Needed (E);
+
+               return Result;
+
             --  Case of no full view present. If entity is derived or subtype,
             --  it is safe to freeze, correctness depends on the frozen status
             --  of parent. Otherwise it is either premature usage, or a Taft
diff --git a/gcc/ada/gcc-interface/decl.c b/gcc/ada/gcc-interface/decl.c
index 2145a47..bf70486 100644
--- a/gcc/ada/gcc-interface/decl.c
+++ b/gcc/ada/gcc-interface/decl.c
@@ -4654,7 +4654,9 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
 	    ? Non_Limited_View (gnat_entity)
 	    : Present (Full_View (gnat_entity))
 	      ? Full_View (gnat_entity)
-	      : Underlying_Full_View (gnat_entity);
+	      : IN (kind, Private_Kind)
+		? Underlying_Full_View (gnat_entity)
+		: Empty;
 
 	/* If this is an incomplete type with no full view, it must be a Taft
 	   Amendment type, in which case we return a dummy type.  Otherwise,
diff --git a/gcc/ada/gcc-interface/trans.c b/gcc/ada/gcc-interface/trans.c
index 1b7d861..64e428a 100644
--- a/gcc/ada/gcc-interface/trans.c
+++ b/gcc/ada/gcc-interface/trans.c
@@ -7893,10 +7893,20 @@ process_freeze_entity (Node_Id gnat_node)
   if (gnu_old)
     {
       save_gnu_tree (gnat_entity, NULL_TREE, false);
+
       if (IN (kind, Incomplete_Or_Private_Kind)
-	  && Present (Full_View (gnat_entity))
-	  && present_gnu_tree (Full_View (gnat_entity)))
-	save_gnu_tree (Full_View (gnat_entity), NULL_TREE, false);
+	  && Present (Full_View (gnat_entity)))
+	{
+	  Entity_Id full_view = Full_View (gnat_entity);
+
+          if (IN (Ekind (full_view), Private_Kind)
+	      && Present (Underlying_Full_View (full_view)))
+	    full_view = Underlying_Full_View (full_view);
+
+	  if (present_gnu_tree (full_view))
+	    save_gnu_tree (full_view, NULL_TREE, false);
+	}
+
       if (IN (kind, Type_Kind)
 	  && Present (Class_Wide_Type (gnat_entity))
 	  && Root_Type (Class_Wide_Type (gnat_entity)) == gnat_entity)
@@ -7906,17 +7916,23 @@ process_freeze_entity (Node_Id gnat_node)
   if (IN (kind, Incomplete_Or_Private_Kind)
       && Present (Full_View (gnat_entity)))
     {
-      gnu_new = gnat_to_gnu_entity (Full_View (gnat_entity), NULL_TREE, 1);
+      Entity_Id full_view = Full_View (gnat_entity);
+
+      if (IN (Ekind (full_view), Private_Kind)
+	  && Present (Underlying_Full_View (full_view)))
+	full_view = Underlying_Full_View (full_view);
+
+      gnu_new = gnat_to_gnu_entity (full_view, NULL_TREE, 1);
 
       /* Propagate back-annotations from full view to partial view.  */
       if (Unknown_Alignment (gnat_entity))
-	Set_Alignment (gnat_entity, Alignment (Full_View (gnat_entity)));
+	Set_Alignment (gnat_entity, Alignment (full_view));
 
       if (Unknown_Esize (gnat_entity))
-	Set_Esize (gnat_entity, Esize (Full_View (gnat_entity)));
+	Set_Esize (gnat_entity, Esize (full_view));
 
       if (Unknown_RM_Size (gnat_entity))
-	Set_RM_Size (gnat_entity, RM_Size (Full_View (gnat_entity)));
+	Set_RM_Size (gnat_entity, RM_Size (full_view));
 
       /* The above call may have defined this entity (the simplest example
 	 of this is when we have a private enumeral type since the bounds
diff --git a/gcc/ada/gcc-interface/utils.c b/gcc/ada/gcc-interface/utils.c
index f450f24..f44bda3 100644
--- a/gcc/ada/gcc-interface/utils.c
+++ b/gcc/ada/gcc-interface/utils.c
@@ -328,35 +328,31 @@ present_gnu_tree (Entity_Id gnat_entity)
 tree
 make_dummy_type (Entity_Id gnat_type)
 {
-  Entity_Id gnat_underlying = Gigi_Equivalent_Type (gnat_type);
+  Entity_Id gnat_equiv = Gigi_Equivalent_Type (Underlying_Type (gnat_type));
   tree gnu_type;
 
-  /* If there is an equivalent type, get its underlying type.  */
-  if (Present (gnat_underlying))
-    gnat_underlying = Gigi_Equivalent_Type (Underlying_Type (gnat_underlying));
-
   /* If there was no equivalent type (can only happen when just annotating
      types) or underlying type, go back to the original type.  */
-  if (No (gnat_underlying))
-    gnat_underlying = gnat_type;
+  if (No (gnat_equiv))
+    gnat_equiv = gnat_type;
 
   /* If it there already a dummy type, use that one.  Else make one.  */
-  if (PRESENT_DUMMY_NODE (gnat_underlying))
-    return GET_DUMMY_NODE (gnat_underlying);
+  if (PRESENT_DUMMY_NODE (gnat_equiv))
+    return GET_DUMMY_NODE (gnat_equiv);
 
   /* If this is a record, make a RECORD_TYPE or UNION_TYPE; else make
      an ENUMERAL_TYPE.  */
-  gnu_type = make_node (Is_Record_Type (gnat_underlying)
-			? tree_code_for_record_type (gnat_underlying)
+  gnu_type = make_node (Is_Record_Type (gnat_equiv)
+			? tree_code_for_record_type (gnat_equiv)
 			: ENUMERAL_TYPE);
   TYPE_NAME (gnu_type) = get_entity_name (gnat_type);
   TYPE_DUMMY_P (gnu_type) = 1;
   TYPE_STUB_DECL (gnu_type)
     = create_type_stub_decl (TYPE_NAME (gnu_type), gnu_type);
-  if (Is_By_Reference_Type (gnat_underlying))
+  if (Is_By_Reference_Type (gnat_equiv))
     TYPE_BY_REFERENCE_P (gnu_type) = 1;
 
-  SET_DUMMY_NODE (gnat_underlying, gnu_type);
+  SET_DUMMY_NODE (gnat_equiv, gnu_type);
 
   return gnu_type;
 }
diff --git a/gcc/ada/gnat1drv.adb b/gcc/ada/gnat1drv.adb
index 4650548b..2ed7755 100644
--- a/gcc/ada/gnat1drv.adb
+++ b/gcc/ada/gnat1drv.adb
@@ -872,7 +872,6 @@ begin
       if Operating_Mode /= Check_Syntax then
 
          --  Acquire target parameters from system.ads (package System source)
-         --  System).
 
          Targparm_Acquire : declare
             use Sinput;
diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb
index 904595e..e3e9f5a 100644
--- a/gcc/ada/sem_attr.adb
+++ b/gcc/ada/sem_attr.adb
@@ -4027,24 +4027,24 @@ package body Sem_Attr is
            and then Entity (Identifier (Enclosing_Loop)) /= Loop_Id
          then
             Error_Attr_P
-              ("prefix of attribute % that applies to "
-               & "outer loop must denote an entity");
+              ("prefix of attribute % that applies to outer loop must denote "
+               & "an entity");
 
          elsif Is_Potentially_Unevaluated (P) then
             Uneval_Old_Msg;
          end if;
 
-         --  Finally, if the Loop_Entry attribute appears within a pragma
-         --  that is ignored, we replace P'Loop_Entity by P to avoid useless
-         --  generation of the loop entity variable. Note that in this case
-         --  the expression won't be executed anyway, and this substitution
-         --  keeps types happy!
-
-         --  We should really do this in the expander, but it's easier here
+         --  Replace the Loop_Entry attribute reference by its prefix if the
+         --  related pragma is ignored. This transformation is OK with respect
+         --  to typing because Loop_Entry's type is that of its prefix. This
+         --  early transformation also avoids the generation of a useless loop
+         --  entry constant.
 
          if Is_Ignored (Enclosing_Pragma) then
             Rewrite (N, Relocate_Node (P));
          end if;
+
+         Preanalyze_And_Resolve (P);
       end Loop_Entry;
 
       -------------
diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb
index 26496df..332bd28 100644
--- a/gcc/ada/sem_ch4.adb
+++ b/gcc/ada/sem_ch4.adb
@@ -1441,6 +1441,8 @@ package body Sem_Ch4 is
       if Exp_Btype = Any_Discrete or else Exp_Btype = Any_Type then
          return;
 
+      --  Special casee message for character literal
+
       elsif Exp_Btype = Any_Character then
          Error_Msg_N
            ("character literal as case expression is ambiguous", Expr);
@@ -1448,8 +1450,9 @@ package body Sem_Ch4 is
       end if;
 
       if Etype (N) = Any_Type and then Present (Wrong_Alt) then
-         Error_Msg_N ("type incompatible with that of previous alternatives",
-           Expression (Wrong_Alt));
+         Error_Msg_N
+           ("type incompatible with that of previous alternatives",
+            Expression (Wrong_Alt));
          return;
       end if;
 
diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb
index 640aaa6..3e5458f 100644
--- a/gcc/ada/sem_eval.adb
+++ b/gcc/ada/sem_eval.adb
@@ -5465,13 +5465,6 @@ package body Sem_Eval is
       then
          Set_Condition (Parent (N), Empty);
 
-      --  If the expression raising CE is a N_Raise_CE node, we can use that
-      --  one. We just preserve the type of the context.
-
-      elsif Nkind (Exp) = N_Raise_Constraint_Error then
-         Rewrite (N, Exp);
-         Set_Etype (N, Typ);
-
       --  Else build an explicit N_Raise_CE
 
       else
diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb
index da08930..5a3a255 100644
--- a/gcc/ada/sem_prag.adb
+++ b/gcc/ada/sem_prag.adb
@@ -10926,20 +10926,17 @@ package body Sem_Prag is
               Pragma_Assume         |
               Pragma_Loop_Invariant =>
          Assert : declare
-            Expr : Node_Id;
-            Newa : List_Id;
-
-            Has_Loop_Entry : Boolean;
-            --  Set True by
-
-            function Contains_Loop_Entry return Boolean;
-            --  Tests if Expr contains a Loop_Entry attribute reference
+            function Contains_Loop_Entry (Expr : Node_Id) return Boolean;
+            --  Determine whether expression Expr contains a Loop_Entry
+            --  attribute reference.
 
             -------------------------
             -- Contains_Loop_Entry --
             -------------------------
 
-            function Contains_Loop_Entry return Boolean is
+            function Contains_Loop_Entry (Expr : Node_Id) return Boolean is
+               Has_Loop_Entry : Boolean := False;
+
                function Process (N : Node_Id) return Traverse_Result;
                --  Process function for traversal to look for Loop_Entry
 
@@ -10964,11 +10961,15 @@ package body Sem_Prag is
             --  Start of processing for Contains_Loop_Entry
 
             begin
-               Has_Loop_Entry := False;
                Traverse (Expr);
                return Has_Loop_Entry;
             end Contains_Loop_Entry;
 
+            --  Local variables
+
+            Expr : Node_Id;
+            Newa : List_Id;
+
          --  Start of processing for Assert
 
          begin
@@ -10989,17 +10990,19 @@ package body Sem_Prag is
             Check_Optional_Identifier (Arg1, Name_Check);
             Expr := Get_Pragma_Arg (Arg1);
 
-            --  Special processing for Loop_Invariant or for other cases if
-            --  a Loop_Entry attribute is present.
+            --  Special processing for Loop_Invariant, Loop_Variant or for
+            --  other cases where a Loop_Entry attribute is present. If the
+            --  assertion pragma contains attribute Loop_Entry, ensure that
+            --  the related pragma is within a loop.
 
             if Prag_Id = Pragma_Loop_Invariant
-              or else Contains_Loop_Entry
+              or else Prag_Id = Pragma_Loop_Variant
+              or else Contains_Loop_Entry (Expr)
             then
-               --  Check restricted placement, must be within a loop
-
                Check_Loop_Pragma_Placement;
 
-               --  Do preanalyze to deal with embedded Loop_Entry attribute
+               --  Perform preanalysis to deal with embedded Loop_Entry
+               --  attributes.
 
                Preanalyze_Assert_Expression (Expression (Arg1), Any_Boolean);
             end if;
diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb
index 92c8bfa..9509b23 100644
--- a/gcc/ada/sem_res.adb
+++ b/gcc/ada/sem_res.adb
@@ -5371,15 +5371,6 @@ package body Sem_Res is
    ------------------
 
    procedure Resolve_Call (N : Node_Id; Typ : Entity_Id) is
-      Loc     : constant Source_Ptr := Sloc (N);
-      Subp    : constant Node_Id    := Name (N);
-      Nam     : Entity_Id;
-      I       : Interp_Index;
-      It      : Interp;
-      Norm_OK : Boolean;
-      Scop    : Entity_Id;
-      Rtype   : Entity_Id;
-
       function Same_Or_Aliased_Subprograms
         (S : Entity_Id;
          E : Entity_Id) return Boolean;
@@ -5399,6 +5390,20 @@ package body Sem_Res is
          return S = E or else (Present (Subp_Alias) and then Subp_Alias = E);
       end Same_Or_Aliased_Subprograms;
 
+      --  Local variables
+
+      Loc      : constant Source_Ptr := Sloc (N);
+      Subp     : constant Node_Id    := Name (N);
+      Body_Id  : Entity_Id;
+      I        : Interp_Index;
+      It       : Interp;
+      Nam      : Entity_Id;
+      Nam_Decl : Node_Id;
+      Nam_UA   : Entity_Id;
+      Norm_OK  : Boolean;
+      Rtype    : Entity_Id;
+      Scop     : Entity_Id;
+
    --  Start of processing for Resolve_Call
 
    begin
@@ -6218,21 +6223,16 @@ package body Sem_Res is
         and then Is_Overloadable (Nam)
         and then not Inside_A_Generic
       then
-         --  Retrieve the body to inline from the ultimate alias of Nam, if
-         --  there is one, otherwise calls that should be inlined end up not
-         --  being inlined.
+         Nam_UA   := Ultimate_Alias (Nam);
+         Nam_Decl := Unit_Declaration_Node (Nam_UA);
 
-         declare
-            Nam_UA  : constant Entity_Id := Ultimate_Alias (Nam);
-            Decl    : constant Node_Id   := Unit_Declaration_Node (Nam_UA);
-            Body_Id : constant Entity_Id := Corresponding_Body (Decl);
+         if Nkind (Nam_Decl) = N_Subprogram_Declaration then
+            Body_Id := Corresponding_Body (Nam_Decl);
 
-         begin
-            --  If the subprogram is not eligible for inlining in GNATprove
-            --  mode, do nothing.
+            --  Nothing to do if the subprogram is not eligible for inlining in
+            --  GNATprove mode.
 
-            if Nkind (Decl) /= N_Subprogram_Declaration
-              or else not Is_Inlined_Always (Nam_UA)
+            if not Is_Inlined_Always (Nam_UA)
               or else not Can_Be_Inlined_In_GNATprove_Mode (Nam_UA, Body_Id)
             then
                null;
@@ -6262,7 +6262,7 @@ package body Sem_Res is
                --  the subprogram is not suitable for inlining in GNATprove
                --  mode.
 
-               elsif No (Body_To_Inline (Decl)) then
+               elsif No (Body_To_Inline (Nam_Decl)) then
                   null;
 
                --  Calls cannot be inlined inside potentially unevaluated
@@ -6281,7 +6281,7 @@ package body Sem_Res is
                   Expand_Inlined_Call (N, Nam_UA, Nam);
                end if;
             end if;
-         end;
+         end if;
       end if;
 
       Warn_On_Overlapping_Actuals (Nam, N);
diff --git a/gcc/ada/sem_warn.adb b/gcc/ada/sem_warn.adb
index 3971ccc..d52e2d7 100644
--- a/gcc/ada/sem_warn.adb
+++ b/gcc/ada/sem_warn.adb
@@ -820,9 +820,9 @@ package body Sem_Warn is
          raise Program_Error;
       end Body_Formal;
 
-      -----------------------------------
-      --   May_Need_Initialized_Actual --
-      -----------------------------------
+      ---------------------------------
+      -- May_Need_Initialized_Actual --
+      ---------------------------------
 
       procedure May_Need_Initialized_Actual (Ent : Entity_Id) is
          T   : constant Entity_Id := Etype (Ent);