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

commit r14-10927-gcaa2b2038dadcb545f825d5c736cc50d90245bbc
Author: Paul Thomas <pa...@gcc.gnu.org>
Date:   Thu Oct 31 07:22:36 2024 +0000

    Fortran: Fix problem with substring selectors in ASSOCIATE [PR115700]
    
    2024-10-31  Paul Thomas  <pa...@gcc.gnu.org>
    
    gcc/fortran
            PR fortran/115700
            * resolve.cc (resolve_variable): The typespec of an expression,
            which is not a substring, can be shared with a deferred length
            associate name.
            (resolve_assoc_var): Extract a substring reference with non-
            constant start or end. Use it to flag up the need for array
            associate name to be a pointer.
            (resolve_block_construct): Change comment from past to future
            tense.
    
    gcc/testsuite/
            PR fortran/115700
            * gfortran.dg/associate_70.f90: New test.
    
    (cherry picked from commit 159fb203231c503418e7ab9f45282957e40cb195)

Diff:
---
 gcc/fortran/resolve.cc                     | 33 ++++++++++++++++++++----
 gcc/testsuite/gfortran.dg/associate_70.f90 | 40 ++++++++++++++++++++++++++++++
 2 files changed, 68 insertions(+), 5 deletions(-)

diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index d7a0856fcca1..50427f7450b4 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -6011,6 +6011,15 @@ resolve_variable (gfc_expr *e)
          e->ref = newref;
        }
     }
+  else if (sym->assoc && sym->ts.type == BT_CHARACTER && sym->ts.deferred)
+    {
+      gfc_ref *ref;
+      for (ref = e->ref; ref; ref = ref->next)
+       if (ref->type == REF_SUBSTRING)
+         break;
+      if (ref == NULL)
+       e->ts = sym->ts;
+    }
 
   if (e->ref && !gfc_resolve_ref (e))
     return false;
@@ -9676,6 +9685,15 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
   /* Fix up the type-spec for CHARACTER types.  */
   if (sym->ts.type == BT_CHARACTER && !sym->attr.select_type_temporary)
     {
+      gfc_ref *ref;
+      for (ref = target->ref; ref; ref = ref->next)
+       if (ref->type == REF_SUBSTRING
+           && ((ref->u.ss.start
+                && ref->u.ss.start->expr_type != EXPR_CONSTANT)
+               || (ref->u.ss.end
+                   && ref->u.ss.end->expr_type != EXPR_CONSTANT)))
+         break;
+
       if (!sym->ts.u.cl)
        sym->ts.u.cl = target->ts.u.cl;
 
@@ -9694,9 +9712,10 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
                gfc_get_int_expr (gfc_charlen_int_kind, NULL,
                                  target->value.character.length);
        }
-      else if ((!sym->ts.u.cl->length
-               || sym->ts.u.cl->length->expr_type != EXPR_CONSTANT)
+      else if (((!sym->ts.u.cl->length
+                || sym->ts.u.cl->length->expr_type != EXPR_CONSTANT)
                && target->expr_type != EXPR_VARIABLE)
+              || ref)
        {
          if (!sym->ts.deferred)
            {
@@ -9706,7 +9725,10 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
 
          /* This is reset in trans-stmt.cc after the assignment
             of the target expression to the associate name.  */
-         sym->attr.allocatable = 1;
+         if (ref && sym->as)
+           sym->attr.pointer = 1;
+         else
+           sym->attr.allocatable = 1;
        }
     }
 
@@ -11290,8 +11312,9 @@ resolve_block_construct (gfc_code* code)
 {
   gfc_namespace *ns = code->ext.block.ns;
 
-  /* For an ASSOCIATE block, the associations (and their targets) are already
-     resolved during resolve_symbol. Resolve the BLOCK's namespace.  */
+  /* For an ASSOCIATE block, the associations (and their targets) will be
+     resolved by gfc_resolve_symbol, during resolution of the BLOCK's
+     namespace.  */
   gfc_resolve (ns);
 }
 
diff --git a/gcc/testsuite/gfortran.dg/associate_70.f90 
b/gcc/testsuite/gfortran.dg/associate_70.f90
new file mode 100644
index 000000000000..b8916f4c70fd
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/associate_70.f90
@@ -0,0 +1,40 @@
+! { dg-do run }
+! ( dg-options "-Wuninitialized" )
+!
+! Test fix for PR115700 comment 5, in which ‘.tmp1’ is used uninitialized and
+! both normal and scalarized array references did not work correctly.
+!
+! Contributed by Harald Anlauf  <anl...@gcc.gnu.org>
+!
+  character(4), dimension(3) :: chr = ['abcd', 'efgh', 'ijkl']
+  call mvce (chr)
+  if (any (chr /= ['ABcd', 'EFgh', 'IJkl'])) stop 1
+contains
+  subroutine mvce(x)
+    implicit none
+    character(len=*), dimension(:), intent(inOUT), target :: x
+    integer :: i
+    i = len(x)
+
+! This was broken
+    associate (tmp1 => x(:)(1:i/2))
+      if (len (tmp1) /= i/2) stop 2
+      if (tmp1(2) /= 'ef') stop 3
+      if (any (tmp1 /= ['ab', 'ef', 'ij'])) stop 4
+      tmp1 = ['AB','EF','IJ']
+    end associate
+
+! Retest things that worked previously.
+    associate (tmp2 => x(:)(1:2))
+      if (len (tmp2) /= i/2) stop 5
+      if (tmp2(2) /= 'EF') stop 6
+      if (any (tmp2 /= ['AB','EF','IJ'])) stop 7
+    end associate
+
+    associate (tmp3 => x(3)(1:i/2))
+      if (len (tmp3) /= i/2) stop 8
+      if (tmp3 /= 'IJ') stop 9
+    end associate
+
+  end subroutine mvce
+end

Reply via email to