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

Message ID 20200619082834.GA31400@adacore.com
State New
Headers show
  • [Ada] Plug small loophole in implementation of AI12-0100
Related show

Commit Message

Pierre-Marie de Rodat June 19, 2020, 8:28 a.m.
The qualified expressions present in allocators use a specific circuitry
during type resolution and, therefore, escape the new static predicate
check required by AI12-0100 and present in Resolve_Qualified_Expression.

This removes the specific circuitry, as well as makes small adjustments
to Resolve_Qualified_Expression needed in allocator contexts.

Tested on x86_64-pc-linux-gnu, committed on trunk

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


	* 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.


--- gcc/ada/sem_res.adb
+++ 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
-           (N, Target_Typ, Static_Failure_Is_Error => True);
+           (Expr, Target_Typ, Static_Failure_Is_Error => True);
       end if;
    end Resolve_Qualified_Expression;