Fortran: character length of pointer assignments in structure constructors

gcc/fortran/ChangeLog:

	PR fortran/50549
	* resolve.cc (resolve_structure_cons): Reject pointer assignments
	of character with different lengths in structure constructor.

gcc/testsuite/ChangeLog:

	PR fortran/50549
	* gfortran.dg/char_pointer_assign_7.f90: New test.

diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index 5522be751992c76b79584b265187dc20ecfce075..290767723d857056bd928c1cf3686ffc494786b7 100644 (file)
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -1375,11 +1375,22 @@ resolve_structure_cons (gfc_expr *expr, int init)
          && comp->ts.u.cl->length->expr_type == EXPR_CONSTANT
          && cons->expr->ts.u.cl && cons->expr->ts.u.cl->length
          && cons->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT
-         && cons->expr->rank != 0
          && mpz_cmp (cons->expr->ts.u.cl->length->value.integer,
                      comp->ts.u.cl->length->value.integer) != 0)
        {
+         if (comp->attr.pointer)
+           {
+             HOST_WIDE_INT la, lb;
+             la = gfc_mpz_get_hwi (comp->ts.u.cl->length->value.integer);
+             lb = gfc_mpz_get_hwi (cons->expr->ts.u.cl->length->value.integer);
+             gfc_error ("Unequal character lengths (%wd/%wd) for pointer "
+                        "component %qs in constructor at %L",
+                        la, lb, comp->name, &cons->expr->where);
+             t = false;
+           }
+
          if (cons->expr->expr_type == EXPR_VARIABLE
+             && cons->expr->rank != 0
              && cons->expr->symtree->n.sym->attr.flavor == FL_PARAMETER)
            {
              /* Wrap the parameter in an array constructor (EXPR_ARRAY)

diff --git a/gcc/testsuite/gfortran.dg/char_pointer_assign_7.f90 b/gcc/testsuite/gfortran.dg/char_pointer_assign_7.f90
new file mode 100644 (file)
index 0000000..08bdf17
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/char_pointer_assign_7.f90
@@ -0,0 +1,38 @@
+! { dg-do compile }
+! PR fortran/50549 - should reject pointer assignments of different lengths
+! in structure constructors
+
+program test
+  implicit none
+  type t
+     character(2), pointer ::  p2
+  end type t
+  type t2
+     character(2), pointer ::  p(:)
+  end type t2
+  type td
+     character(:), pointer ::  pd
+  end type td
+  interface
+     function f1 ()
+       character(1), pointer :: f1
+     end function f1
+     function f2 ()
+       character(2), pointer :: f2
+     end function f2
+  end interface
+
+  character(1),    target  ::  p1
+  character(1),    pointer ::  q1(:)
+  character(2),    pointer ::  q2(:)
+  type(t)  :: u
+  type(t2) :: u2
+  type(td) :: v
+  u  = t(p1)    ! { dg-error "Unequal character lengths" }
+  u  = t(f1())  ! { dg-error "Unequal character lengths" }
+  u  = t(f2())  ! OK
+  u2 = t2(q1)   ! { dg-error "Unequal character lengths" }
+  u2 = t2(q2)   ! OK
+  v  = td(p1)   ! OK
+  v  = td(f1()) ! OK
+end