[Ada] Plug small loophole in implementation of AI12-0100

2020-06-19  Eric Botcazou  <ebotcazou@adacore.com>

gcc/ada/

	* sem_res.adb (Resolve_Allocator): Call Resolve_Qualified_Expression
	on the qualified expression, if any, instead of doing an incomplete
	type resolution manually.
	(Resolve_Qualified_Expression): Apply predicate check to operand.

diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb
index e6b4e6cd81fbdd704a110f9afd677a65655fa423..e4c0c072ab9f13d5b702630b3f6a947cdfee8509 100644 (file)
--- a/gcc/ada/sem_res.adb
+++ b/gcc/ada/sem_res.adb
@@ -5133,8 +5133,9 @@ package body Sem_Res is
               ("class-wide allocator not allowed for this access type", N);
          end if;
 
-         Resolve (Expression (E), Etype (E));
-         Check_Non_Static_Context (Expression (E));
+         --  Do a full resolution to apply constraint and predicate checks
+
+         Resolve_Qualified_Expression (E, Etype (E));
          Check_Unset_Reference (Expression (E));
 
          --  Allocators generated by the build-in-place expansion mechanism
@@ -5168,16 +5169,6 @@ package body Sem_Res is
             end if;
          end if;
 
-         --  A qualified expression requires an exact match of the type. Class-
-         --  wide matching is not allowed.
-
-         if (Is_Class_Wide_Type (Etype (Expression (E)))
-              or else Is_Class_Wide_Type (Etype (E)))
-           and then Base_Type (Etype (Expression (E))) /= Base_Type (Etype (E))
-         then
-            Wrong_Type (Expression (E), Etype (E));
-         end if;
-
          --  Calls to build-in-place functions are not currently supported in
          --  allocators for access types associated with a simple storage pool.
          --  Supporting such allocators may require passing additional implicit
@@ -10199,7 +10190,7 @@ package body Sem_Res is
 
       if Has_Predicates (Target_Typ) then
          Check_Expression_Against_Static_Predicate
-           (N, Target_Typ, Static_Failure_Is_Error => True);
+           (Expr, Target_Typ, Static_Failure_Is_Error => True);
       end if;
    end Resolve_Qualified_Expression;