[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

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index d549a870de57795bacc8a23490af4f068a05f968..9731513188fbf26817b10d32c75551df65cd2dce 100644 (file)
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,9 @@
+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

diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb
index ec681af91dbabf8f8e3618be54573c8dbb555e32..cf277c1bb5d83be4c12340fd70838a44b047df09 100644 (file)
--- a/gcc/ada/exp_util.adb
+++ b/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,

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 6cb08cdafbb66bcdc377978ead89874d2dc2f4b8..e285be64939219686e5880660df6f270f1948781 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,15 @@
+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.

diff --git a/gcc/testsuite/gnat.dg/predicate2-containers.ads b/gcc/testsuite/gnat.dg/predicate2-containers.ads
new file mode 100644 (file)
index 0000000..d02cfe3
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/predicate2-containers.ads
@@ -0,0 +1,13 @@
+----
+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;

diff --git a/gcc/testsuite/gnat.dg/predicate2-project-name_values.ads b/gcc/testsuite/gnat.dg/predicate2-project-name_values.ads
new file mode 100644 (file)
index 0000000..a68fa0e
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/predicate2-project-name_values.ads
@@ -0,0 +1,37 @@
+
+----
+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;

diff --git a/gcc/testsuite/gnat.dg/predicate2-project-registry-attribute.ads b/gcc/testsuite/gnat.dg/predicate2-project-registry-attribute.ads
new file mode 100644 (file)
index 0000000..b0d671e
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/predicate2-project-registry-attribute.ads
@@ -0,0 +1,7 @@
+
+----
+package Predicate2.Project.Registry.Attribute is
+
+   type Value_Kind is (Single, List);
+
+end Predicate2.Project.Registry.Attribute;

diff --git a/gcc/testsuite/gnat.dg/predicate2-project-registry.ads b/gcc/testsuite/gnat.dg/predicate2-project-registry.ads
new file mode 100644 (file)
index 0000000..680cb9f
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/predicate2-project-registry.ads
@@ -0,0 +1,3 @@
+----
+package Predicate2.Project.Registry is
+end Predicate2.Project.Registry;

diff --git a/gcc/testsuite/gnat.dg/predicate2-project-typ-set.ads b/gcc/testsuite/gnat.dg/predicate2-project-typ-set.ads
new file mode 100644 (file)
index 0000000..1ba0580
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/predicate2-project-typ-set.ads
@@ -0,0 +1,13 @@
+----
+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;

diff --git a/gcc/testsuite/gnat.dg/predicate2-project-typ.ads b/gcc/testsuite/gnat.dg/predicate2-project-typ.ads
new file mode 100644 (file)
index 0000000..353833b
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/predicate2-project-typ.ads
@@ -0,0 +1,24 @@
+----
+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;

diff --git a/gcc/testsuite/gnat.dg/predicate2-project.ads b/gcc/testsuite/gnat.dg/predicate2-project.ads
new file mode 100644 (file)
index 0000000..4036ff3
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/predicate2-project.ads
@@ -0,0 +1,4 @@
+----
+package Predicate2.Project is
+
+end Predicate2.Project;

diff --git a/gcc/testsuite/gnat.dg/predicate2-source_reference.ads b/gcc/testsuite/gnat.dg/predicate2-source_reference.ads
new file mode 100644 (file)
index 0000000..1ad4c3f
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/predicate2-source_reference.ads
@@ -0,0 +1,33 @@
+
+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;

diff --git a/gcc/testsuite/gnat.dg/predicate2.ads b/gcc/testsuite/gnat.dg/predicate2.ads
new file mode 100644 (file)
index 0000000..4e918f9
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/predicate2.ads
@@ -0,0 +1,14 @@
+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;

diff --git a/gcc/testsuite/gnat.dg/predicate2_main.adb b/gcc/testsuite/gnat.dg/predicate2_main.adb
new file mode 100644 (file)
index 0000000..3dc9528
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/predicate2_main.adb
@@ -0,0 +1,10 @@
+--  { 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;