sem_res.adb, [...]: Minor reformatting.

2010-10-21  Thomas Quinot  <quinot@adacore.com>

	* sem_res.adb, exp_ch13.adb: Minor reformatting.

2010-10-21  Thomas Quinot  <quinot@adacore.com>

	* sem_ch3.adb (Check_Or_Process_Discriminant): Reject illegal attempt
	to provide a tagged full view as the completion of an untagged partial
	view if the partial view has a discriminant with default.

From-SVN: r165775

4 files changed, 78 insertions, 35 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index f9dded2..587474f 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,13 @@
+2010-10-21  Thomas Quinot  <quinot@adacore.com>
+
+	* sem_res.adb, exp_ch13.adb: Minor reformatting.
+
+2010-10-21  Thomas Quinot  <quinot@adacore.com>
+
+	* sem_ch3.adb (Check_Or_Process_Discriminant): Reject illegal attempt
+	to provide a tagged full view as the completion of an untagged partial
+	view if the partial view has a discriminant with default.
+
 2010-10-21  Arnaud Charlet  <charlet@adacore.com>
 
 	* gcc-interface/Make-lang.in: Update dependencies.
diff --git a/gcc/ada/exp_ch13.adb b/gcc/ada/exp_ch13.adb
index bee3325..eaf90f7 100644
--- a/gcc/ada/exp_ch13.adb
+++ b/gcc/ada/exp_ch13.adb
@@ -105,8 +105,8 @@ package body Exp_Ch13 is
       --  is build by connecting the component predicates with AND THEN.
 
       procedure Add_Call (T : Entity_Id);
-      --  Includes a call statement to the predicate function for type T in
-      --  Expr if T has predicates and Predicate_Function (T) is non-empty.
+      --  Includes a call to the predicate function for type T in Expr if T
+      --  has predicates and Predicate_Function (T) is non-empty.
 
       procedure Add_Predicates;
       --  Appends expressions for any Predicate pragmas in the rep item chain
@@ -125,15 +125,12 @@ package body Exp_Ch13 is
          Exp : Node_Id;
 
       begin
-         if Present (T)
-           and then Present (Predicate_Function (T))
-         then
+         if Present (T) and then Present (Predicate_Function (T)) then
             Exp :=
               Make_Predicate_Call
                 (T,
                  Convert_To (T,
-                   Make_Identifier (Loc,
-                     Chars => Object_Name)));
+                   Make_Identifier (Loc, Chars => Object_Name)));
 
             if No (Expr) then
                Expr := Exp;
@@ -170,9 +167,8 @@ package body Exp_Ch13 is
          begin
             --  Case of entity name referencing the type
 
-            if Is_Entity_Name (N)
-              and then Entity (N) = Typ
-            then
+            if Is_Entity_Name (N) and then Entity (N) = Typ then
+
                --  Replace with object
 
                Rewrite (N,
@@ -183,13 +179,15 @@ package body Exp_Ch13 is
 
                return Skip;
 
-            --  Not an instance of the type entity, keep going
+            --  Not an occurrence of the type entity, keep going
 
             else
                return OK;
             end if;
          end Replace_Node;
 
+      --  Start of processing for Add_Predicates
+
       begin
          Ritem := First_Rep_Item (Typ);
          while Present (Ritem) loop
@@ -208,7 +206,7 @@ package body Exp_Ch13 is
                --  looking for the type entity, doing the needed substitution.
                --  The preanalysis is done with the special OK_To_Reference
                --  flag set on the type, so that if we get an occurrence of
-               --  this type, it will be reognized as legitimate.
+               --  this type, it will be recognized as legitimate.
 
                Set_OK_To_Reference (Typ, True);
                Preanalyze_Spec_Expression (Arg2, Standard_Boolean);
@@ -241,7 +239,7 @@ package body Exp_Ch13 is
    begin
       --  Initialize for construction of statement list
 
-      Expr := Empty;
+      Expr  := Empty;
       FDecl := Empty;
       FBody := Empty;
 
@@ -289,6 +287,7 @@ package body Exp_Ch13 is
                loop
                   Elmt := First_Elmt (Iface_List);
                   exit when No (Elmt);
+
                   Add_Call (Node (Elmt));
                   Remove_Elmt (Iface_List, Elmt);
                end loop;
@@ -313,10 +312,8 @@ package body Exp_Ch13 is
              Parameter_Specifications => New_List (
                Make_Parameter_Specification (Loc,
                  Defining_Identifier =>
-                   Make_Defining_Identifier (Loc,
-                     Chars => Object_Name),
-                 Parameter_Type =>
-                   New_Occurrence_Of (Typ, Loc))),
+                   Make_Defining_Identifier (Loc, Chars => Object_Name),
+                 Parameter_Type      => New_Occurrence_Of (Typ, Loc))),
              Result_Definition        =>
                New_Occurrence_Of (Standard_Boolean, Loc));
 
@@ -336,8 +333,7 @@ package body Exp_Ch13 is
              Parameter_Specifications => New_List (
                Make_Parameter_Specification (Loc,
                  Defining_Identifier =>
-                   Make_Defining_Identifier (Loc,
-                     Chars => Object_Name),
+                   Make_Defining_Identifier (Loc, Chars => Object_Name),
                  Parameter_Type =>
                    New_Occurrence_Of (Typ, Loc))),
              Result_Definition        =>
@@ -737,7 +733,7 @@ package body Exp_Ch13 is
          end;
       end if;
 
-      --  Pop scope if we intalled one for the analysis
+      --  Pop scope if we installed one for the analysis
 
       if In_Other_Scope then
          if Ekind (Current_Scope) = E_Package then
diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index f453bcc..f29e747 100644
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -284,9 +284,11 @@ package body Sem_Ch3 is
      (N    : Node_Id;
       T    : Entity_Id;
       Prev : Entity_Id := Empty);
-   --  If T is the full declaration of an incomplete or private type, check the
-   --  conformance of the discriminants, otherwise process them. Prev is the
-   --  entity of the partial declaration, if any.
+   --  If N is the full declaration of the completion T of an incomplete or
+   --  private type, check its discriminants (which are already known to be
+   --  conformant with those of the partial view, see Find_Type_Name),
+   --  otherwise process them. Prev is the entity of the partial declaration,
+   --  if any.
 
    procedure Check_Real_Bound (Bound : Node_Id);
    --  Check given bound for being of real type and static. If not, post an
@@ -9589,7 +9591,9 @@ package body Sem_Ch3 is
    --  If an incomplete or private type declaration was already given for the
    --  type, the discriminants may have already been processed if they were
    --  present on the incomplete declaration. In this case a full conformance
-   --  check is performed otherwise just process them.
+   --  check has been performed in Find_Type_Name, and we then recheck here
+   --  some properties that can't be checked on the partial view alone.
+   --  Otherwise we call Process_Discriminants.
 
    procedure Check_Or_Process_Discriminants
      (N    : Node_Id;
@@ -9599,19 +9603,46 @@ package body Sem_Ch3 is
    begin
       if Has_Discriminants (T) then
 
-         --  Make the discriminants visible to component declarations
+         --  Discriminants are already set on T if they were already present
+         --  on the partial view. Make them visible to component declarations.
 
          declare
             D    : Entity_Id;
-            Prev : Entity_Id;
+            --  Discriminant on T (full view) referencing expression on partial
+            --  view.
+
+            Prev_D : Entity_Id;
+            --  Entity of corresponding discriminant on partial view
 
+            New_D : Node_Id;
+            --  Discriminant specification for full view, expression is the
+            --  syntactic copy on full view (which has been checked for
+            --  conformance with partial view), only used here to post error
+            --  message.
          begin
             D := First_Discriminant (T);
+            New_D := First (Discriminant_Specifications (N));
+
             while Present (D) loop
-               Prev := Current_Entity (D);
+               Prev_D := Current_Entity (D);
                Set_Current_Entity (D);
                Set_Is_Immediately_Visible (D);
-               Set_Homonym (D, Prev);
+               Set_Homonym (D, Prev_D);
+
+               --  Handle the case where there is an untagged partial view and
+               --  the full view is tagged: must disallow discriminants with
+               --  defaults. However suppress the error here if it was already
+               --  reported on the default expression of the partial view.
+
+               if Is_Tagged_Type (T)
+                    and then Present (Expression (Parent (D)))
+                    and then not Error_Posted (Expression (Parent (D)))
+               then
+                  Error_Msg_N
+                    ("discriminants of tagged type "
+                     & "cannot have defaults",
+                     Expression (New_D));
+               end if;
 
                --  Ada 2005 (AI-230): Access discriminant allowed in
                --  non-limited record types.
@@ -9625,6 +9656,7 @@ package body Sem_Ch3 is
                end if;
 
                Next_Discriminant (D);
+               Next (New_D);
             end loop;
          end;
 
@@ -16354,13 +16386,18 @@ package body Sem_Ch3 is
                  ("discriminant defaults not allowed for formal type",
                   Expression (Discr));
 
-            --  Tagged types declarations cannot have defaulted discriminants,
-            --  but an untagged private type with defaulted discriminants can
-            --  have a tagged completion.
-
             elsif Is_Tagged_Type (Current_Scope)
-              and then Comes_From_Source (N)
+                    and then Comes_From_Source (N)
             then
+               --  Note: see also similar test in Check_Or_Process_
+               --  Discriminants, to handle the (illegal) case of the
+               --  completion of an untagged view with discriminants
+               --  with defaults by a tagged full view. We skip the check if
+               --  Discr does not come from source to account for the case of
+               --  an untagged derived type providing defaults for a renamed
+               --  discriminant from a private nontagged ancestor with a tagged
+               --  full view (ACATS B460006).
+
                Error_Msg_N
                  ("discriminants of tagged type cannot have defaults",
                   Expression (Discr));
diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb
index 03c8171..7c823a8 100644
--- a/gcc/ada/sem_res.adb
+++ b/gcc/ada/sem_res.adb
@@ -3848,8 +3848,8 @@ package body Sem_Res is
 
             Eval_Actual (A);
 
-            --  If it is a named association, treat the selector_name as
-            --  a proper identifier, and mark the corresponding entity.
+            --  If it is a named association, treat the selector_name as a
+            --  proper identifier, and mark the corresponding entity.
 
             if Nkind (Parent (A)) = N_Parameter_Association then
                Set_Entity (Selector_Name (Parent (A)), F);