[gcc r14-9261] Fortran: improve checks of NULL without MOLD as actual argument [PR104819]

[gcc r14-9261] Fortran: improve checks of NULL without MOLD as actual argument [PR104819]

[Harald Anlauf]

https://gcc.gnu.org/g:db0b6746be075e43c8142585968483e125bb52d0

commit r14-9261-gdb0b6746be075e43c8142585968483e125bb52d0
Author: Harald Anlauf <anlauf@gmx.de>
Date:   Fri Mar 1 19:21:27 2024 +0100

    Fortran: improve checks of NULL without MOLD as actual argument [PR104819]
    
    gcc/fortran/ChangeLog:
    
            PR fortran/104819
            * check.cc (gfc_check_null): Handle nested NULL()s.
            (is_c_interoperable): Check for MOLD argument of NULL() as part of
            the interoperability check.
            * interface.cc (gfc_compare_actual_formal): Extend checks for NULL()
            actual arguments for presence of MOLD argument when required by
            Interp J3/22-146.
    
    gcc/testsuite/ChangeLog:
    
            PR fortran/104819
            * gfortran.dg/assumed_rank_9.f90: Adjust testcase use of NULL().
            * gfortran.dg/pr101329.f90: Adjust testcase to conform to interp.
            * gfortran.dg/null_actual_4.f90: New test.

Diff:
---
 gcc/fortran/check.cc                         |  5 +++-
 gcc/fortran/interface.cc                     | 30 ++++++++++++++++++++++++
 gcc/testsuite/gfortran.dg/assumed_rank_9.f90 | 13 +++++++----
 gcc/testsuite/gfortran.dg/null_actual_4.f90  | 35 ++++++++++++++++++++++++++++
 gcc/testsuite/gfortran.dg/pr101329.f90       |  4 ++--
 5 files changed, 79 insertions(+), 8 deletions(-)

diff --git a/gcc/fortran/check.cc b/gcc/fortran/check.cc
index d661cf37f01..db74dcf3f40 100644
--- a/gcc/fortran/check.cc
+++ b/gcc/fortran/check.cc
@@ -4384,6 +4384,9 @@ gfc_check_null (gfc_expr *mold)
   if (mold == NULL)
     return true;
 
+  if (mold->expr_type == EXPR_NULL)
+    return true;
+
   if (!variable_check (mold, 0, true))
     return false;
 
@@ -5216,7 +5219,7 @@ is_c_interoperable (gfc_expr *expr, const char **msg, bool c_loc, bool c_f_ptr)
 {
   *msg = NULL;
 
-  if (expr->expr_type == EXPR_NULL)
+  if (expr->expr_type == EXPR_NULL && expr->ts.type == BT_UNKNOWN)
     {
       *msg = "NULL() is not interoperable";
       return false;
diff --git a/gcc/fortran/interface.cc b/gcc/fortran/interface.cc
index 231f2f252af..64b90550be2 100644
--- a/gcc/fortran/interface.cc
+++ b/gcc/fortran/interface.cc
@@ -3296,6 +3296,36 @@ gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
 	  && a->expr->ts.type != BT_ASSUMED)
 	gfc_find_vtab (&a->expr->ts);
 
+      /* Interp J3/22-146:
+	 "If the context of the reference to NULL is an <actual argument>
+	 corresponding to an <assumed-rank> dummy argument, MOLD shall be
+	 present."  */
+      if (a->expr->expr_type == EXPR_NULL
+	  && a->expr->ts.type == BT_UNKNOWN
+	  && f->sym->as
+	  && f->sym->as->type == AS_ASSUMED_RANK)
+	{
+	  gfc_error ("Intrinsic %<NULL()%> without %<MOLD%> argument at %L "
+		     "passed to assumed-rank dummy %qs",
+		     &a->expr->where, f->sym->name);
+	  ok = false;
+	  goto match;
+	}
+
+      if (a->expr->expr_type == EXPR_NULL
+	  && a->expr->ts.type == BT_UNKNOWN
+	  && f->sym->ts.type == BT_CHARACTER
+	  && !f->sym->ts.deferred
+	  && f->sym->ts.u.cl
+	  && f->sym->ts.u.cl->length == NULL)
+	{
+	  gfc_error ("Intrinsic %<NULL()%> without %<MOLD%> argument at %L "
+		     "passed to assumed-length dummy %qs",
+		     &a->expr->where, f->sym->name);
+	  ok = false;
+	  goto match;
+	}
+
       if (a->expr->expr_type == EXPR_NULL
 	  && ((f->sym->ts.type != BT_CLASS && !f->sym->attr.pointer
 	       && (f->sym->attr.allocatable || !f->sym->attr.optional
diff --git a/gcc/testsuite/gfortran.dg/assumed_rank_9.f90 b/gcc/testsuite/gfortran.dg/assumed_rank_9.f90
index 1296d068959..5e59ec136c9 100644
--- a/gcc/testsuite/gfortran.dg/assumed_rank_9.f90
+++ b/gcc/testsuite/gfortran.dg/assumed_rank_9.f90
@@ -26,19 +26,20 @@ program main
 
   type(t), target :: y
   class(t), allocatable, target :: yac
-  
+  type(t),  pointer             :: ypt
+
   y%i = 489
   allocate (yac)
   yac%i = 489
   j = 0
   call fc()
-  call fc(null())
+  call fc(null(yac))
   call fc(y)
   call fc(yac)
   if (j /= 2) STOP 1
 
   j = 0
-  call gc(null())
+! call gc(null(yac)) ! ICE
   call gc(y)
   call gc(yac)
   deallocate (yac)
@@ -54,13 +55,14 @@ program main
 
   j = 0
   call ft()
-  call ft(null())
+  call ft(null(yac))
   call ft(y)
   call ft(yac)
   if (j /= 2) STOP 4
 
   j = 0
-  call gt(null())
+  call gt(null(ypt))
+! call gt(null(yac)) ! ICE
   call gt(y)
   call gt(yac)
   deallocate (yac)
@@ -73,6 +75,7 @@ program main
   yac%i = 489
   call ht(yac)
   if (j /= 1) STOP 6
+  deallocate (yac)
 
 contains
 
diff --git a/gcc/testsuite/gfortran.dg/null_actual_4.f90 b/gcc/testsuite/gfortran.dg/null_actual_4.f90
new file mode 100644
index 00000000000..e03d5c8f7de
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/null_actual_4.f90
@@ -0,0 +1,35 @@
+! { dg-do compile }
+! PR fortran/104819
+!
+! Reject NULL without MOLD as actual to an assumed-rank dummy.
+! See also interpretation request at
+! https://j3-fortran.org/doc/year/22/22-101r1.txt
+!
+! Test nested NULL()
+
+program p
+  implicit none
+  integer, pointer :: a, a3(:,:,:)
+  character(10), pointer :: c
+
+  call foo (a)
+  call foo (a3)
+  call foo (null (a))
+  call foo (null (a3))
+  call foo (null (null (a)))  ! Valid: nested NULL()s
+  call foo (null (null (a3))) ! Valid: nested NULL()s
+  call foo (null ())          ! { dg-error "passed to assumed-rank dummy" }
+
+  call str (null (c))
+  call str (null (null (c)))
+  call str (null ())          ! { dg-error "passed to assumed-length dummy" }
+contains
+  subroutine foo (x)
+    integer, pointer, intent(in) :: x(..)
+    print *, rank (x)
+  end
+
+  subroutine str (x)
+    character(len=*), pointer, intent(in) :: x
+  end
+end
diff --git a/gcc/testsuite/gfortran.dg/pr101329.f90 b/gcc/testsuite/gfortran.dg/pr101329.f90
index b82210d4e28..aca171bd4f8 100644
--- a/gcc/testsuite/gfortran.dg/pr101329.f90
+++ b/gcc/testsuite/gfortran.dg/pr101329.f90
@@ -8,6 +8,6 @@ program p
   integer(c_int64_t), pointer :: ip8
   print *, c_sizeof (c_null_ptr) ! valid
   print *, c_sizeof (null ())    ! { dg-error "is not interoperable" }
-  print *, c_sizeof (null (ip4)) ! { dg-error "is not interoperable" }
-  print *, c_sizeof (null (ip8)) ! { dg-error "is not interoperable" }
+  print *, c_sizeof (null (ip4)) ! valid
+  print *, c_sizeof (null (ip8)) ! valid
 end