[Ada] Incorrect discriminant check on call to access to subprogram

[Ada] Incorrect discriminant check on call to access to subprogram

[Pierre-Marie de Rodat]

[-- Attachment #1: Type: text/plain, Size: 765 bytes --]

When calling an access to a subprogram taking an unconstrained
discriminated record as parameter, we fail to pass the extra constrained
actual parameter, which would lead to spurious or missed discriminant
checks.

At the same time we noticed that GNAT sometimes generates trees of the
form:

  (Field1 => 1, Field2 => 2).Field1

we now recognize these in Sem_Eval and rewrite the tree as simply the
value given for the field (1 in the example above).

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

gcc/ada/

	* exp_ch6.adb: Fix typo in comment.
	* sem_ch3.adb (Access_Subprogram_Declaration): Add missing call
	to Create_Extra_Formals. Remove obsolete bootstrap check.
	* sem_eval.adb (Eval_Selected_Component): Simplify a
	selected_component on an aggregate.

[-- Attachment #2: patch.diff --]
[-- Type: text/x-diff, Size: 3167 bytes --]

diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb
--- a/gcc/ada/exp_ch6.adb
+++ b/gcc/ada/exp_ch6.adb
@@ -3801,7 +3801,7 @@ package body Exp_Ch6 is
                   --  is internally generated code that manipulates addresses,
                   --  e.g. when building interface tables. No check should
                   --  occur in this case, and the discriminated object is not
-                  --  directly a hand.
+                  --  directly at hand.
 
                   if not Comes_From_Source (Actual)
                     and then Nkind (Actual) = N_Unchecked_Type_Conversion


diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -840,13 +840,6 @@ package body Sem_Ch3 is
       --  the corresponding semantic routine
 
       if Present (Access_To_Subprogram_Definition (N)) then
-
-         --  Compiler runtime units are compiled in Ada 2005 mode when building
-         --  the runtime library but must also be compilable in Ada 95 mode
-         --  (when bootstrapping the compiler).
-
-         Check_Compiler_Unit ("anonymous access to subprogram", N);
-
          Access_Subprogram_Declaration
            (T_Name => Anon_Type,
             T_Def  => Access_To_Subprogram_Definition (N));
@@ -1312,6 +1305,8 @@ package body Sem_Ch3 is
       Set_Can_Never_Be_Null (T_Name, Null_Exclusion_Present (T_Def));
 
       Check_Restriction (No_Access_Subprograms, T_Def);
+
+      Create_Extra_Formals (Desig_Type);
    end Access_Subprogram_Declaration;
 
    ----------------------------


diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb
--- a/gcc/ada/sem_eval.adb
+++ b/gcc/ada/sem_eval.adb
@@ -3830,6 +3830,11 @@ package body Sem_Eval is
    -----------------------------
 
    procedure Eval_Selected_Component (N : Node_Id) is
+      Node : Node_Id;
+      Comp : Node_Id;
+      C    : Node_Id;
+      Nam  : Name_Id;
+
    begin
       --  If an attribute reference or a LHS, nothing to do.
       --  Also do not fold if N is an [in] out subprogram parameter.
@@ -3839,7 +3844,36 @@ package body Sem_Eval is
         and then Is_LHS (N) = No
         and then not Is_Actual_Out_Or_In_Out_Parameter (N)
       then
-         Fold (N);
+         --  Simplify a selected_component on an aggregate by extracting
+         --  the field directly.
+
+         Node := Prefix (N);
+
+         while Nkind (Node) = N_Qualified_Expression loop
+            Node := Expression (Node);
+         end loop;
+
+         if Nkind (Node) = N_Aggregate then
+            Comp := First (Component_Associations (Node));
+            Nam  := Chars (Selector_Name (N));
+
+            while Present (Comp) loop
+               C := First (Choices (Comp));
+
+               while Present (C) loop
+                  if Chars (C) = Nam then
+                     Rewrite (N, Relocate_Node (Expression (Comp)));
+                     return;
+                  end if;
+
+                  Next (C);
+               end loop;
+
+               Next (Comp);
+            end loop;
+         else
+            Fold (N);
+         end if;
       end if;
    end Eval_Selected_Component;