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.

Author: harald-anlauf

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))

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