From: Ed Schonberg Date: Wed, 26 Sep 2018 09:18:52 +0000 (+0000) Subject: [Ada] Spurious error on private extension with predicate X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=6cd1ee98eaf775b062c90cb1ef0dc777c086afc2;p=gcc.git [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 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 d549a870de5..9731513188f 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,9 @@ +2018-09-26 Ed Schonberg + + * 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 * 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 ec681af91db..cf277c1bb5d 100644 --- 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 6cb08cdafbb..e285be64939 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,15 @@ +2018-09-26 Ed Schonberg + + * 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 * 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 index 00000000000..d02cfe3cdf0 --- /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 index 00000000000..a68fa0e1ffe --- /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 index 00000000000..b0d671eb644 --- /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 index 00000000000..680cb9f7dce --- /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 index 00000000000..1ba058052e9 --- /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 index 00000000000..353833bf689 --- /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 index 00000000000..4036ff3cdc3 --- /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 index 00000000000..1ad4c3fe647 --- /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 index 00000000000..4e918f93250 --- /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 index 00000000000..3dc9528d728 --- /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;