[gcc r15-9845] Fortran: fix checking of MOLD= in ALLOCATE statements [PR51961]

[Harald Anlauf]

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

commit r15-9845-gf34f1b1d6c451604645e2e42cf57b876f3d955df
Author: Harald Anlauf <anlauf@gmx.de>
Date:   Sun Jun 15 21:09:28 2025 +0200

    Fortran: fix checking of MOLD= in ALLOCATE statements [PR51961]
    
    In ALLOCATE statements where the MOLD= argument is present and is not
    scalar, and the allocate-object has an explicit-shape-spec, the standard
    does not require the ranks to agree.  In that case we skip the rank check,
    but emit a warning if -Wsurprising is given.
    
            PR fortran/51961
    
    gcc/fortran/ChangeLog:
    
            * resolve.cc (conformable_arrays): Use modified rank check when
            MOLD= expression is given.
    
    gcc/testsuite/ChangeLog:
    
            * gfortran.dg/allocate_with_mold_5.f90: New test.
    
    (cherry picked from commit 3b276fe0d22f9052657dbbffbb8ad6f8585bd304)

Diff:
---
 gcc/fortran/resolve.cc                             | 17 ++++++++
 gcc/testsuite/gfortran.dg/allocate_with_mold_5.f90 | 51 ++++++++++++++++++++++
 2 files changed, 68 insertions(+)

diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index 1fb16cabb78c..c5c10205dadf 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -8740,8 +8740,25 @@ static bool
 conformable_arrays (gfc_expr *e1, gfc_expr *e2)
 {
   gfc_ref *tail;
+  bool scalar;
+
   for (tail = e2->ref; tail && tail->next; tail = tail->next);
 
+  /* If MOLD= is present and is not scalar, and the allocate-object has an
+     explicit-shape-spec, the ranks need not agree.  This may be unintended,
+     so let's emit a warning if -Wsurprising is given.  */
+  scalar = !tail || tail->type == REF_COMPONENT;
+  if (e1->mold && e1->rank > 0
+      && (scalar || (tail->type == REF_ARRAY && tail->u.ar.type != AR_FULL)))
+    {
+      if (scalar || (tail->u.ar.as && e1->rank != tail->u.ar.as->rank))
+	gfc_warning (OPT_Wsurprising, "Allocate-object at %L has rank %d "
+		     "but MOLD= expression at %L has rank %d",
+		     &e2->where, scalar ? 0 : tail->u.ar.as->rank,
+		     &e1->where, e1->rank);
+      return true;
+    }
+
   /* First compare rank.  */
   if ((tail && (!tail->u.ar.as || e1->rank != tail->u.ar.as->rank))
       || (!tail && e1->rank != e2->rank))
diff --git a/gcc/testsuite/gfortran.dg/allocate_with_mold_5.f90 b/gcc/testsuite/gfortran.dg/allocate_with_mold_5.f90
new file mode 100644
index 000000000000..f5e2fc93d0a4
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/allocate_with_mold_5.f90
@@ -0,0 +1,51 @@
+! { dg-do compile }
+! { dg-additional-options "-Wsurprising" }
+!
+! PR fortran/51961 - fix checking of MOLD= in ALLOCATE statements
+!
+! Contributed by Tobias Burnus
+
+program p
+  implicit none
+  type t
+  end type t
+  type u
+     class(t), allocatable :: a(:), b(:,:), c
+  end type u
+  class(T), allocatable :: a(:), b(:,:), c
+  type(u) :: z
+
+  allocate (b(2,2))
+  allocate (z% b(2,2))
+
+  allocate (a(2),      mold=b(:,1))
+  allocate (a(1:2),    mold=b(1,:))
+  allocate (a(2),      mold=b)        ! { dg-warning "but MOLD= expression at" }
+  allocate (a(1:2),    mold=b)        ! { dg-warning "but MOLD= expression at" }
+  allocate (z% a(2),   mold=b(:,1))
+  allocate (z% a(1:2), mold=b(1,:))
+  allocate (z% a(2),   mold=b)        ! { dg-warning "but MOLD= expression at" }
+  allocate (z% a(1:2), mold=b)        ! { dg-warning "but MOLD= expression at" }
+  allocate (z% a(2),   mold=z% b(:,1))
+  allocate (z% a(1:2), mold=z% b(1,:))
+  allocate (z% a(2),   mold=z% b)     ! { dg-warning "but MOLD= expression at" }
+  allocate (z% a(1:2), mold=z% b)     ! { dg-warning "but MOLD= expression at" }
+
+  allocate (c,      mold=b(1,1))
+  allocate (c,      mold=b)           ! { dg-warning "but MOLD= expression at" }
+  allocate (z% c,   mold=b(1,1))
+  allocate (z% c,   mold=b)           ! { dg-warning "but MOLD= expression at" }
+  allocate (z% c,   mold=z% b(1,1))
+  allocate (z% c,   mold=z% b)        ! { dg-warning "but MOLD= expression at" }
+
+  allocate (a,      mold=b(:,1))
+  allocate (a,      mold=b(1,:))
+  allocate (z% a,   mold=b(:,1))
+  allocate (z% a,   mold=b(1,:))
+  allocate (z% a,   mold=z% b(:,1))
+  allocate (z% a,   mold=z% b(1,:))
+
+  allocate (a,      mold=b)      ! { dg-error "or have the same rank" }
+  allocate (z% a,   mold=b)      ! { dg-error "or have the same rank" }
+  allocate (z% a,   mold=z% b)   ! { dg-error "or have the same rank" }
+end