ada: Constraint error not raised in ACATS test c413007

The Constraint_Error exception is not raised when a subprogram
is called using prefix notation, and the prefix of the call is
an access-to-subprogram type with a null value. This new check
is enabled by switch -gnatd_P

gcc/ada/ChangeLog:

	* gen_il-fields.ads: New node field (Is_Expanded_Prefixed_Call).
	* gen_il-gen-gen_nodes.adb: New semantic field for N_Function_Call
	and N_Procedure_Call_Statement nodes.
	* sem_ch4.adb (Complete_Object_Operation): Mark the rewritten node
	with the Is_Expanded_Prefixed_Call flag.
	* sem_res.adb (Check_Prefixed_Call): Code cleanup and addition of
	documentation.
	(Resolve_Actuals): Add a null-exclusion check on the
	prefix of the call when it is an access-type.
	* sinfo.ads: Adding new semantic flag (Is_Expanded_Prefixed_Call)
	to N_Function_Call and N_Procedure_Call_Statement nodes.
	* debug.adb: Adding documentation for switch d_P.

6 files changed, 79 insertions, 41 deletions

diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb
index 3dbf3a7b..9daa011 100644
--- a/gcc/ada/debug.adb
+++ b/gcc/ada/debug.adb
@@ -180,7 +180,7 @@ package body Debug is
    --  d_M  Ignore Source_File_Name and Source_File_Name_Project pragmas
    --  d_N
    --  d_O
-   --  d_P
+   --  d_P  Enable runtime check for null prefix of prefixed subprogram call
    --  d_Q
    --  d_R  For LLVM, dump the representation of records
    --  d_S
@@ -1040,6 +1040,14 @@ package body Debug is
    --       it is checked, and the progress of the recursive trace through
    --       elaboration calls at compile time.
 
+   --  d_P  For prefixed subprogram calls with an access-type prefix, generate
+   --       a null-excluding runtime check on the prefix, even when the called
+   --       subprogram has a first access parameter that does not exclude null
+   --       (that is the case only for class-wide parameter, as controlling
+   --       parameters are automatically null-excluding). In such a case,
+   --       P.Proc is equivalent to Proc(P.all'Access); see RM 6.4(9.1/5).
+   --       This includes a dereference, and thus a null check.
+
    --  d_R  In the LLVM backend, output the internal representation of
    --       each record
 
diff --git a/gcc/ada/gen_il-fields.ads b/gcc/ada/gen_il-fields.ads
index dcebab6..5563a9d 100644
--- a/gcc/ada/gen_il-fields.ads
+++ b/gcc/ada/gen_il-fields.ads
@@ -255,6 +255,7 @@ package Gen_IL.Fields is
       Is_Elsif,
       Is_Entry_Barrier_Function,
       Is_Expanded_Build_In_Place_Call,
+      Is_Expanded_Prefixed_Call,
       Is_Folded_In_Parser,
       Is_Generic_Contract_Pragma,
       Is_Homogeneous_Aggregate,
diff --git a/gcc/ada/gen_il-gen-gen_nodes.adb b/gcc/ada/gen_il-gen-gen_nodes.adb
index d211343..55d5435 100644
--- a/gcc/ada/gen_il-gen-gen_nodes.adb
+++ b/gcc/ada/gen_il-gen-gen_nodes.adb
@@ -408,11 +408,13 @@ begin -- Gen_IL.Gen.Gen_Nodes
    Cc (N_Function_Call, N_Subprogram_Call,
        (Sy (Name, Node_Id, Default_Empty),
         Sy (Parameter_Associations, List_Id, Default_No_List),
-        Sm (Is_Expanded_Build_In_Place_Call, Flag)));
+        Sm (Is_Expanded_Build_In_Place_Call, Flag),
+        Sm (Is_Expanded_Prefixed_Call, Flag)));
 
    Cc (N_Procedure_Call_Statement, N_Subprogram_Call,
        (Sy (Name, Node_Id, Default_Empty),
-        Sy (Parameter_Associations, List_Id, Default_No_List)));
+        Sy (Parameter_Associations, List_Id, Default_No_List),
+        Sm (Is_Expanded_Prefixed_Call, Flag)));
 
    Ab (N_Raise_xxx_Error, N_Subexpr);
 
diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb
index bf0d7cf..c1f6622 100644
--- a/gcc/ada/sem_ch4.adb
+++ b/gcc/ada/sem_ch4.adb
@@ -9510,7 +9510,6 @@ package body Sem_Ch4 is
                Error_Msg_NE
                  ("expect variable in call to&", Prefix (N), Entity (Subprog));
             end if;
-
          --  Conversely, if the formal is an access parameter and the object is
          --  not an access type or a reference type (i.e. a type with the
          --  Implicit_Dereference aspect specified), replace the actual with a
@@ -9581,6 +9580,8 @@ package body Sem_Ch4 is
 
          Rewrite (Node_To_Replace, Call_Node);
 
+         Set_Is_Expanded_Prefixed_Call (Node_To_Replace);
+
          --  Propagate the interpretations collected in subprog to the new
          --  function call node, to be resolved from context.
 
@@ -10746,6 +10747,7 @@ package body Sem_Ch4 is
             Complete_Object_Operation
               (Call_Node       => New_Call_Node,
                Node_To_Replace => Node_To_Replace);
+
             return True;
          end if;
 
diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb
index 5f77dda..6a2680b 100644
--- a/gcc/ada/sem_res.adb
+++ b/gcc/ada/sem_res.adb
@@ -3889,54 +3889,48 @@ package body Sem_Res is
       -------------------------
 
       procedure Check_Prefixed_Call is
-         Act    : constant Node_Id   := First_Actual (N);
-         A_Type : constant Entity_Id := Etype (Act);
-         F_Type : constant Entity_Id := Etype (First_Formal (Nam));
-         Orig   : constant Node_Id := Original_Node (N);
-         New_A  : Node_Id;
+         Actual      : constant Node_Id   := First_Actual (N);
+         Actual_Type : constant Entity_Id := Etype (Actual);
+         Formal_Type : constant Entity_Id := Etype (First_Formal (Nam));
+         New_Actual  : Node_Id;
 
       begin
          --  Check whether the call is a prefixed call, with or without
          --  additional actuals.
 
-         if Nkind (Orig) = N_Selected_Component
-           or else
-             (Nkind (Orig) = N_Indexed_Component
-               and then Nkind (Prefix (Orig)) = N_Selected_Component
-               and then Is_Entity_Name (Prefix (Prefix (Orig)))
-               and then Is_Entity_Name (Act)
-               and then Chars (Act) = Chars (Prefix (Prefix (Orig))))
-         then
-            if Is_Access_Type (A_Type)
-              and then not Is_Access_Type (F_Type)
-            then
-               --  Introduce dereference on object in prefix
+         if Is_Expanded_Prefixed_Call (N) then
 
-               New_A :=
-                 Make_Explicit_Dereference (Sloc (Act),
-                   Prefix => Relocate_Node (Act));
-               Rewrite (Act, New_A);
-               Analyze (Act);
+            --  Introduce dereference on object in prefix
 
-            elsif Is_Access_Type (F_Type)
-              and then not Is_Access_Type (A_Type)
+            if Is_Access_Type (Actual_Type)
+              and then not Is_Access_Type (Formal_Type)
             then
-               --  Introduce an implicit 'Access in prefix
-
-               if not Is_Aliased_View (Act) then
-                  Error_Msg_NE
-                    ("object in prefixed call to& must be aliased "
-                     & "(RM 4.1.3 (13 1/2))",
-                    Prefix (Act), Nam);
-               end if;
-
-               Rewrite (Act,
+               New_Actual :=
+                 Make_Explicit_Dereference (Sloc (Actual),
+                   Prefix => Relocate_Node (Actual));
+               Rewrite (Actual, New_Actual);
+               Analyze (Actual);
+
+            --  Conversely, if the formal is an access parameter and the object
+            --  is not an access type or a reference type (i.e. a type with the
+            --  Implicit_Dereference aspect specified), add an implicit 'Access
+            --  to the prefix. Its analysis will check that the object is
+            --  aliased.
+
+            elsif Is_Access_Type (Formal_Type)
+              and then not Is_Access_Type (Actual_Type)
+              and then (not Has_Implicit_Dereference (Actual_Type)
+                or else
+                  not Is_Access_Type
+                        (Designated_Type
+                           (Etype (Get_Reference_Discriminant (Actual_Type)))))
+            then
+               Rewrite (Actual,
                  Make_Attribute_Reference (Loc,
                    Attribute_Name => Name_Access,
-                   Prefix         => Relocate_Node (Act)));
+                   Prefix         => Relocate_Node (Actual)));
+               Analyze (Actual);
             end if;
-
-            Analyze (Act);
          end if;
       end Check_Prefixed_Call;
 
@@ -4935,6 +4929,31 @@ package body Sem_Res is
                         Reason => CE_Null_Not_Allowed);
                   end if;
                end if;
+
+               --  In a prefixed call, if the prefix is an access type
+               --  it cannot be null.
+
+               if Is_Access_Type (F_Typ)
+                 and then A = First_Actual (N)
+                 and then Is_Expanded_Prefixed_Call (N)
+               then
+                  if not Is_Access_Type (A_Typ)
+                    and then not Is_Aliased_View (A)
+                  then
+                     Error_Msg_NE
+                       ("object in prefixed call to& must be aliased "
+                        & "(RM 4.1.3 (13 1/2))",
+                       A, Nam);
+                  end if;
+
+                  if Debug_Flag_Underscore_PP
+                    and then
+                      (Is_Controlling_Formal (F)
+                         or else Is_Class_Wide_Type (Designated_Type (F_Typ)))
+                  then
+                     Install_Null_Excluding_Check (A);
+                  end if;
+               end if;
             end if;
 
             --  Checks for OUT parameters and IN OUT parameters
diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads
index 746207a..78cc236 100644
--- a/gcc/ada/sinfo.ads
+++ b/gcc/ada/sinfo.ads
@@ -1686,6 +1686,10 @@ package Sinfo is
    --    actuals to support a build-in-place style of call have been added to
    --    the call.
 
+   --  Is_Expanded_Prefixed_Call
+   --    This flag is set in N_Function_Call and N_Procedure_Call_Statement
+   --    nodes to indicate that it is an expanded prefixed call.
+
    --  Is_Generic_Contract_Pragma
    --    This flag is present in N_Pragma nodes. It is set when the pragma is
    --    a source construct, applies to a generic unit or its body, and denotes
@@ -5505,6 +5509,7 @@ package Sinfo is
       --  First_Named_Actual
       --  Controlling_Argument (set to Empty if not dispatching)
       --  Is_Elaboration_Checks_OK_Node
+      --  Is_Expanded_Prefixed_Call
       --  Is_SPARK_Mode_On_Node
       --  Is_Elaboration_Warnings_OK_Node
       --  No_Elaboration_Check
@@ -5541,6 +5546,7 @@ package Sinfo is
       --  Is_Elaboration_Warnings_OK_Node
       --  No_Elaboration_Check
       --  Is_Expanded_Build_In_Place_Call
+      --  Is_Expanded_Prefixed_Call
       --  Is_Known_Guaranteed_ABE
       --  plus fields for expression