[Ada] Spurious error on private extension with predicate

This patch fixes a spurious error involving a private extension whose
full view includes a dynamic predicate, when the parent type is itself
private at the point of the predicate check.  The conversion is known to
be legal so no extra conversion checks are required.

2018-09-26  Ed Schonberg  <schonberg@adacore.com>

gcc/ada/

	* exp_util.adb (Make_Predicate_Call): Use OK_Convert_To when
	applying a predicate check to prevent spurious errors when
	private ancestors are involved.

gcc/testsuite/

	* gnat.dg/predicate2-containers.ads,
	gnat.dg/predicate2-project-name_values.ads,
	gnat.dg/predicate2-project-registry-attribute.ads,
	gnat.dg/predicate2-project-registry.ads,
	gnat.dg/predicate2-project-typ-set.ads,
	gnat.dg/predicate2-project-typ.ads,
	gnat.dg/predicate2-project.ads,
	gnat.dg/predicate2-source_reference.ads, gnat.dg/predicate2.ads,
	gnat.dg/predicate2_main.adb: New testcase.

From-SVN: r264626

gcc/ada/ChangeLog

+2018-09-26  Ed Schonberg  <schonberg@adacore.com>
+
+	* exp_util.adb (Make_Predicate_Call): Use OK_Convert_To when
+	applying a predicate check to prevent spurious errors when
+	private ancestors are involved.
+
 2018-09-26  Hristian Kirtchev  <kirtchev@adacore.com>
 
 	* exp_ch4.adb (Expand_N_Allocator): Ensure that the use of the

gcc/ada/exp_util.adb

@@ -9313,14 +9313,16 @@ package body Exp_Util is
 
       --  If the type is tagged, the expression may be class-wide, in which
       --  case it has to be converted to its root type, given that the
-      --  generated predicate function is not dispatching.
+      --  generated predicate function is not dispatching. The conversion
+      --  is type-safe and does not need validation, which matters when
+      --  private extensions are involved.
 
       if Is_Tagged_Type (Typ) then
          Call :=
            Make_Function_Call (Loc,
              Name                   => New_Occurrence_Of (Func_Id, Loc),
              Parameter_Associations =>
-               New_List (Convert_To (Typ, Relocate_Node (Expr))));
+               New_List (OK_Convert_To (Typ, Relocate_Node (Expr))));
       else
          Call :=
            Make_Function_Call (Loc,

gcc/testsuite/ChangeLog

+2018-09-26  Ed Schonberg  <schonberg@adacore.com>
+
+	* gnat.dg/predicate2-containers.ads,
+	gnat.dg/predicate2-project-name_values.ads,
+	gnat.dg/predicate2-project-registry-attribute.ads,
+	gnat.dg/predicate2-project-registry.ads,
+	gnat.dg/predicate2-project-typ-set.ads,
+	gnat.dg/predicate2-project-typ.ads,
+	gnat.dg/predicate2-project.ads,
+	gnat.dg/predicate2-source_reference.ads, gnat.dg/predicate2.ads,
+	gnat.dg/predicate2_main.adb: New testcase.
+
 2018-09-26  Hristian Kirtchev  <kirtchev@adacore.com>
 
 	* gnat.dg/dynhash1.adb: New testcase.

gcc/testsuite/gnat.dg/predicate2-containers.ads

+----
+with Ada.Containers.Indefinite_Vectors;
+
+package Predicate2.Containers is
+
+   subtype Count_Type is Ada.Containers.Count_Type;
+
+   package Value_Type_List is
+     new Ada.Containers.Indefinite_Vectors (Positive, Value_Type);
+
+   subtype Value_List is Value_Type_List.Vector;
+
+end Predicate2.Containers;

gcc/testsuite/gnat.dg/predicate2-project-name_values.ads

+
+----
+with Predicate2.Containers;
+with Predicate2.Project.Registry.Attribute;
+with Predicate2.Source_Reference;
+
+private with Ada.Strings.Unbounded;
+
+package Predicate2.Project.Name_Values is
+
+   use type Containers.Count_Type;
+   use all type Registry.Attribute.Value_Kind;
+
+   type Object is new Source_Reference.Object with private;
+
+   Undefined : constant Object;
+
+   subtype Value_Kind is Registry.Attribute.Value_Kind;
+
+   function Kind (Self : Object'Class) return Registry.Attribute.Value_Kind
+     with Pre => Object (Self) /= Undefined;
+   --  Returns the Kind for the Name/Values pair object
+
+private
+
+   use Ada.Strings.Unbounded;
+
+   type Object is new Source_Reference.Object with record
+      Kind   : Registry.Attribute.Value_Kind := List;
+      Name   : Unbounded_String;
+      Values : Containers.Value_List;
+   end record;
+
+   Undefined : constant Object :=
+                 Object'(Source_Reference.Object with others => <>);
+
+end Predicate2.Project.Name_Values;

gcc/testsuite/gnat.dg/predicate2-project-registry-attribute.ads

+
+----
+package Predicate2.Project.Registry.Attribute is
+
+   type Value_Kind is (Single, List);
+
+end Predicate2.Project.Registry.Attribute;

gcc/testsuite/gnat.dg/predicate2-project-registry.ads

+----
+package Predicate2.Project.Registry is
+end Predicate2.Project.Registry;

gcc/testsuite/gnat.dg/predicate2-project-typ-set.ads

+----
+with Ada.Containers.Indefinite_Ordered_Maps;
+
+package Predicate2.Project.Typ.Set is
+
+   --  The type names must not be case-sensitive
+
+   package Set is new Ada.Containers.Indefinite_Ordered_Maps
+     (Name_Type, Object, "<");
+
+   subtype Object is Set.Map;
+
+end Predicate2.Project.Typ.Set;

gcc/testsuite/gnat.dg/predicate2-project-typ.ads

+----
+with Predicate2.Project.Name_Values;
+
+private with Predicate2.Project.Registry.Attribute;
+
+package Predicate2.Project.Typ is
+
+   type Object is new Name_Values.Object with private;
+
+   Undefined : constant Object;
+
+private
+
+   use all type Predicate2.Project.Registry.Attribute.Value_Kind;
+
+   -- ???? BUG HERE: removing the Dynamic_Predicate below will allow
+   --  compilation of the unit.
+
+   type Object is new Name_Values.Object with null record
+    with Dynamic_Predicate => Object.Kind = List;
+
+   Undefined : constant Object := (Name_Values.Undefined with null record);
+
+end Predicate2.Project.Typ;

gcc/testsuite/gnat.dg/predicate2-project.ads

+----
+package Predicate2.Project is
+
+end Predicate2.Project;

gcc/testsuite/gnat.dg/predicate2-source_reference.ads

+
+private with Ada.Strings.Unbounded;
+
+package Predicate2.Source_Reference is
+
+   type Object is tagged private;
+
+   subtype Source_Reference is Object;
+
+   function "<" (Left, Right : Object) return Boolean;
+
+   Undefined : constant Object;
+
+private
+
+   use Ada.Strings.Unbounded;
+
+   type Object is tagged record
+      Line     : Natural;
+      Column   : Natural;
+      Filename : Unbounded_String;
+   end record
+     with Dynamic_Predicate => Filename /= Null_Unbounded_String;
+
+   function "<" (Left, Right : Object) return Boolean is
+     (Left.Filename < Right.Filename
+       or else
+      (Left.Filename = Right.Filename and then Left.Line < Right.Line));
+
+   Undefined : constant Object :=
+                 (0, 0, To_Unbounded_String ("@"));
+
+end Predicate2.Source_Reference;

gcc/testsuite/gnat.dg/predicate2.ads

+package Predicate2 is
+
+   type Optional_Name_Type is new String;
+
+   subtype Name_Type is Optional_Name_Type
+     with Dynamic_Predicate => Name_Type'Length > 0;
+   --  A non case sensitive name
+
+   subtype Value_Type is String;
+
+   overriding function "=" (Left, Right : Optional_Name_Type) return Boolean;
+   overriding function "<" (Left, Right : Optional_Name_Type) return Boolean;
+
+end Predicate2;

gcc/testsuite/gnat.dg/predicate2_main.adb

+--  { dg-do compile }
+
+with Predicate2.Project.Typ.Set;
+
+procedure Predicate2_Main is
+   Type_Def : Predicate2.Project.Typ.Object := Predicate2.Project.Typ.Undefined;
+   Types    : Predicate2.Project.Typ.Set.Object;
+begin
+   Type_Def := Types ("toto");
+end Predicate2_Main;