sem_ch3.adb (Check_Nonoverridable_Aspects): New procedure within Analyze_Full_Type_ Declaration...

2015-10-20  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch3.adb (Check_Nonoverridable_Aspects): New procedure within
	Analyze_Full_Type_ Declaration, used to apply legality rules in
	13,1,1 (18.3.3) concerning aspects that cannot be overridden in
	a type extension.
	(Check_Duplicate_Aspects): It is not legal to specify the
	Implicit_Dereference aspect on a full view if partial view has
	known discriminants.
	* sem_ch13.adb (Analyze_Aspect_Implicit_Dereference): Verify that
	the specification of the aspect on a derived type confirms the
	value of the inherited one.
	* sem_util.adb (Reference_Discriminant): Return empty if none
	specified.

From-SVN: r229026

4 files changed, 176 insertions, 35 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 4089992..2bfc507 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,18 @@
+2015-10-20  Ed Schonberg  <schonberg@adacore.com>
+
+	* sem_ch3.adb (Check_Nonoverridable_Aspects): New procedure within
+	Analyze_Full_Type_ Declaration, used to apply legality rules in
+	13,1,1 (18.3.3) concerning aspects that cannot be overridden in
+	a type extension.
+	(Check_Duplicate_Aspects): It is not legal to specify the
+	Implicit_Dereference aspect on a full view if partial view has
+	known discriminants.
+	* sem_ch13.adb (Analyze_Aspect_Implicit_Dereference): Verify that
+	the specification of the aspect on a derived type confirms the
+	value of the inherited one.
+	* sem_util.adb (Reference_Discriminant): Return empty if none
+	specified.
+
 2015-10-20  Thomas Quinot  <quinot@adacore.com>
 
 	* exp_ch5.adb, sem_ch3.adb: Minor reformatting.
diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb
index c1c7132..5de48dd 100644
--- a/gcc/ada/sem_ch13.adb
+++ b/gcc/ada/sem_ch13.adb
@@ -1444,35 +1444,56 @@ package body Sem_Ch13 is
             -----------------------------------------
 
             procedure Analyze_Aspect_Implicit_Dereference is
+               Disc        : Entity_Id;
+               Parent_Disc : Entity_Id;
+
+               --  For a type extension, check whether parent has a
+               --  reference discriminant, to verify that use is proper.
+
             begin
                if not Is_Type (E) or else not Has_Discriminants (E) then
                   Error_Msg_N
-                    ("aspect must apply to a type with discriminants", N);
+                    ("aspect must apply to a type with discriminants", Expr);
 
-               else
-                  declare
-                     Disc : Entity_Id;
+               elsif not Is_Entity_Name (Expr) then
+                  Error_Msg_N
+                    ("aspect must name a discriminant of current type", Expr);
 
-                  begin
-                     Disc := First_Discriminant (E);
-                     while Present (Disc) loop
-                        if Chars (Expr) = Chars (Disc)
-                          and then Ekind (Etype (Disc)) =
-                                     E_Anonymous_Access_Type
-                        then
-                           Set_Has_Implicit_Dereference (E);
-                           Set_Has_Implicit_Dereference (Disc);
-                           return;
-                        end if;
+               else
+                  Disc := First_Discriminant (E);
+                  while Present (Disc) loop
+                     if Chars (Expr) = Chars (Disc)
+                       and then Ekind (Etype (Disc)) =
+                                  E_Anonymous_Access_Type
+                     then
+                        Set_Has_Implicit_Dereference (E);
+                        Set_Has_Implicit_Dereference (Disc);
+                        exit;
+                     end if;
 
-                        Next_Discriminant (Disc);
-                     end loop;
+                     Next_Discriminant (Disc);
+                  end loop;
 
-                     --  Error if no proper access discriminant.
+                  --  Error if no proper access discriminant.
 
+                  if No (Disc) then
                      Error_Msg_NE
                       ("not an access discriminant of&", Expr, E);
-                  end;
+                     return;
+                  end if;
+               end if;
+
+               if Is_Derived_Type (E)
+                 and then Has_Discriminants (Etype (E))
+               then
+                  Parent_Disc := Get_Reference_Discriminant (Etype (E));
+
+                  if Present (Parent_Disc)
+                    and then Corresponding_Discriminant (Disc) /= Parent_Disc
+                  then
+                     Error_Msg_N ("reference discriminant does not match " &
+                       "discriminant of parent type", Expr);
+                  end if;
                end if;
             end Analyze_Aspect_Implicit_Dereference;
 
diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index 1dce0fa..2000f42 100644
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -2567,6 +2567,10 @@ package body Sem_Ch3 is
                       and then not (In_Private_Part (Current_Scope)
                                      or else In_Package_Body (Current_Scope));
 
+      procedure Check_Nonoverridable_Aspects;
+      --  Apply the rule in RM 13.1.1(18.4/4) on iterator aspects that cannot
+      --  be overridden, and can only be confirmed on derivation.
+
       procedure Check_Ops_From_Incomplete_Type;
       --  If there is a tagged incomplete partial view of the type, traverse
       --  the primitives of the incomplete view and change the type of any
@@ -2575,6 +2579,90 @@ package body Sem_Ch3 is
       --  list later in Sem_Disp.Check_Operation_From_Incomplete_Type (which
       --  is called from Process_Incomplete_Dependents).
 
+      ----------------------------------
+      -- Check_Nonoverridable_Aspects --
+      ----------------------------------
+
+      procedure Check_Nonoverridable_Aspects is
+         Prev_Aspects   : constant List_Id :=
+                            Aspect_Specifications (Parent (Def_Id));
+         Par_Type       : Entity_Id;
+
+         function Has_Aspect_Spec
+           (Specs : List_Id;
+            Aspect_Name : Name_Id) return Boolean;
+         --  Check whether a list of aspect specifications includes an entry
+         --  for a specific aspect. The list is either that of a partial or
+         --  a full view.
+
+         ---------------------
+         -- Has_Aspect_Spec --
+         ---------------------
+
+         function Has_Aspect_Spec
+           (Specs : List_Id;
+            Aspect_Name : Name_Id) return Boolean
+         is
+            Spec : Node_Id;
+         begin
+            Spec := First (Specs);
+            while Present (Spec) loop
+               if Chars (Identifier (Spec)) = Aspect_Name then
+                  return True;
+               end if;
+               Next (Spec);
+            end loop;
+            return False;
+         end Has_Aspect_Spec;
+
+         --  Start of processing for Check_Nonoverridable_Aspects
+
+      begin
+
+         --  Get parent type of derived type. Note that Prev is the entity
+         --  in the partial declaration, but its contents are now those of
+         --  full view, while Def_Id reflects the partial view.
+
+         if Is_Private_Type (Def_Id) then
+            Par_Type := Etype (Full_View (Def_Id));
+         else
+            Par_Type := Etype (Def_Id);
+         end if;
+
+         --  If there is an inherited Implicit_Dereference, verify that it is
+         --  made explicit in the partial view.
+
+         if Has_Discriminants (Base_Type (Par_Type))
+           and then Nkind (Parent (Prev)) = N_Full_Type_Declaration
+           and then Present (Discriminant_Specifications (Parent (Prev)))
+           and then Present (Get_Reference_Discriminant (Par_Type))
+         then
+            if
+              not Has_Aspect_Spec (Prev_Aspects, Name_Implicit_Dereference)
+            then
+               Error_Msg_N
+                 ("type does not inherit implicit dereference", Prev);
+
+            else
+               --  If one of the views has the aspect specified, verify that it
+               --  is consistent with that of the parent.
+
+               declare
+                  Par_Discr : constant Entity_Id :=
+                                Get_Reference_Discriminant (Par_Type);
+                  Cur_Discr : constant Entity_Id :=
+                                Get_Reference_Discriminant (Prev);
+               begin
+                  if Corresponding_Discriminant (Cur_Discr) /= Par_Discr then
+                     Error_Msg_N ("aspect incosistent with that of parent", N);
+                  end if;
+               end;
+            end if;
+         end if;
+
+         --  TBD : other nonoverridable aspects.
+      end Check_Nonoverridable_Aspects;
+
       ------------------------------------
       -- Check_Ops_From_Incomplete_Type --
       ------------------------------------
@@ -2894,6 +2982,12 @@ package body Sem_Ch3 is
             Analyze_Aspect_Specifications (N, Def_Id);
          end if;
       end if;
+
+      if Is_Derived_Type (Prev)
+        and then Def_Id /= Prev
+      then
+         Check_Nonoverridable_Aspects;
+      end if;
    end Analyze_Full_Type_Declaration;
 
    ----------------------------------
@@ -16366,28 +16460,41 @@ package body Sem_Ch3 is
       -----------------------------
       -- Check_Duplicate_Aspects --
       -----------------------------
+
       procedure Check_Duplicate_Aspects is
          Prev_Aspects   : constant List_Id := Aspect_Specifications (Prev_Par);
          Full_Aspects   : constant List_Id := Aspect_Specifications (N);
          F_Spec, P_Spec : Node_Id;
 
       begin
-         if Present (Prev_Aspects) and then Present (Full_Aspects) then
+         if Present (Full_Aspects) then
             F_Spec := First (Full_Aspects);
             while Present (F_Spec) loop
-               P_Spec := First (Prev_Aspects);
-               while Present (P_Spec) loop
-                  if Chars (Identifier (P_Spec)) = Chars (Identifier (F_Spec))
-                  then
-                     Error_Msg_N
-                       ("aspect already specified in private declaration",
-                         F_Spec);
-                     Remove (F_Spec);
-                     return;
-                  end if;
+               if Present (Prev_Aspects) then
+                  P_Spec := First (Prev_Aspects);
+                  while Present (P_Spec) loop
+                     if Chars (Identifier (P_Spec)) =
+                       Chars (Identifier (F_Spec))
+                     then
+                        Error_Msg_N
+                          ("aspect already specified in private declaration",
+                            F_Spec);
+                        Remove (F_Spec);
+                        return;
+                     end if;
 
-                  Next (P_Spec);
-               end loop;
+                     Next (P_Spec);
+                  end loop;
+               end if;
+
+               if Has_Discriminants (Prev)
+                 and then not Has_Unknown_Discriminants (Prev)
+                 and then Chars (Identifier (F_Spec)) =
+                   Name_Implicit_Dereference
+               then
+                  Error_Msg_N ("cannot specify aspect " &
+                    "if partial view has known discriminants", F_Spec);
+               end if;
 
                Next (F_Spec);
             end loop;
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index d182229..ce64755 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -7812,9 +7812,7 @@ package body Sem_Util is
          Next_Discriminant (D);
       end loop;
 
-      --  Type must have a proper access discriminant.
-
-      pragma Assert (False);
+      return Empty;
    end Get_Reference_Discriminant;
 
    ---------------------------