[Ada] Constraint check on aggregate in allocator

[Arnaud Charlet]

This patch adds a missing constraint check on allocators with a qualified
expression. The subtype mark may impose a discriminant constraint that is
not satisfied by the enclosed aggregate.

Compilation and execution of main.adb must yield:

main.adb:17:35: warning: incorrect value for discriminant "K"
main.adb:17:35: warning: "Constraint_Error" will be raised at run time

raised CONSTRAINT_ERROR : main.adb:17 discriminant check failed

---
procedure Main is
   type Kind is (A, B);

   type Base (K : Kind) is abstract tagged record
      case K is
         when A =>
            null;
         when B =>
            Dummy : Natural;
      end case;
   end record;

   type Base_Access is access all Base'Class;

   type Child is new Base (B) with null record;

   Var : Base_Access := new Child'(K => A);
begin
   null;
end Main;

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

2009-04-17  Ed Schonberg  <schonberg@adacore.com>

	* exp_ch4.adb (Expand_Allocator_Expression): Apply constraint check to
	aggregate, using context imposed by subtype mark in allocator.

-------------- next part --------------
Index: exp_ch4.adb
===================================================================
--- exp_ch4.adb	(revision 146235)
+++ exp_ch4.adb	(working copy)
@@ -3449,8 +3449,13 @@ package body Exp_Ch4 is
       end if;
 
       --  Handle case of qualified expression (other than optimization above)
+      --  First apply constraint checks, because the bounds or discriminants
+      --  in the aggregate might not match the subtype mark in the allocator.
 
       if Nkind (Expression (N)) = N_Qualified_Expression then
+         Apply_Constraint_Check
+           (Expression (Expression (N)), Etype (Expression (N)));
+
          Expand_Allocator_Expression (N);
          return;
       end if;