Patchwork [Ada] Illegal tagged completion of private type with discriminant and default

login
register
mail settings
Submitter Arnaud Charlet
Date Oct. 21, 2010, 1:18 p.m.
Message ID <20101021131808.GA13417@adacore.com>
Download mbox | patch
Permalink /patch/68605/
State New
Headers show

Comments

Arnaud Charlet - Oct. 21, 2010, 1:18 p.m.
When an untagged private type declaration has a discriminant with default
expression, its completion cannot be a tagged type declaration, because
a tagged type can't have such a discriminant (3.7(9.1/2)). This change adds
missing circuitry to detect this case and reject the compilation. The
following compilation must fail with the indicated error:

$ gcc -c bad_tagged_completion_disc_default.ads
bad_tagged_completion_disc_defaults.ads:5:28: discriminants of tagged type cannot have defaults

package Bad_Tagged_Completion_Disc_Defaults is
   type T (L : Integer) is tagged null record;
   type DT (L : Integer := 0) is private;
private     
   type DT (L : Integer := 0) is new T (L => L) with null record;
end Bad_Tagged_Completion_Disc_Defaults;

Tested on x86_64-pc-linux-gnu, committed on trunk

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.

Patch

Index: sem_ch3.adb
===================================================================
--- sem_ch3.adb	(revision 165766)
+++ sem_ch3.adb	(working copy)
@@ -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));