Fortran: Fix some more blockers in associate meta-bug [PR87477]

2023-06-08  Paul Thomas  <pault@gcc.gnu.org>

gcc/fortran
	PR fortran/87477
	PR fortran/99350
	PR fortran/107821
	PR fortran/109451
	* decl.cc (char_len_param_value): Simplify a copy of the expr
	and replace the original if there is no error.
	* gfortran.h : Remove the redundant field 'rankguessed' from
	'gfc_association_list'.
	* resolve.cc (resolve_assoc_var): Remove refs to 'rankguessed'.
	(resolve_variable): Associate names with constant or structure
	constructor targets cannot have array refs.
	* trans-array.cc (gfc_conv_expr_descriptor): Guard expression
	character length backend decl before using it. Suppress the
	assignment if lhs equals rhs.
	* trans-io.cc (gfc_trans_transfer): Scalarize transfer of
	associate variables pointing to a variable. Add comment.
	* trans-stmt.cc (trans_associate_var): Remove requirement that
	the character length be deferred before assigning the value
	returned by gfc_conv_expr_descriptor. Also, guard the backend
	decl before testing with VAR_P.

gcc/testsuite/
	PR fortran/99350
	* gfortran.dg/pr99350.f90 : New test.

	PR fortran/107821
	* gfortran.dg/associate_5.f03 : Changed error message.
	* gfortran.dg/pr107821.f90 : New test.

	PR fortran/109451
	* gfortran.dg/associate_61.f90 : New test

diff --git a/gcc/fortran/decl.cc b/gcc/fortran/decl.cc
index f5d39e2a3d86d2bfa9878139f40be3f434bfae20..d09c8bc97d9ea252fec8988a01a48cf44567d4c0 100644 (file)
--- a/gcc/fortran/decl.cc
+++ b/gcc/fortran/decl.cc
@@ -1056,6 +1056,7 @@ static match
 char_len_param_value (gfc_expr **expr, bool *deferred)
 {
   match m;
+  gfc_expr *p;
 
   *expr = NULL;
   *deferred = false;
@@ -1081,10 +1082,10 @@ char_len_param_value (gfc_expr **expr, bool *deferred)
   if (!gfc_expr_check_typed (*expr, gfc_current_ns, false))
     return MATCH_ERROR;
 
-  /* If gfortran gets an EXPR_OP, try to simplify it.  This catches things
-     like CHARACTER(([1])).   */
-  if ((*expr)->expr_type == EXPR_OP)
-    gfc_simplify_expr (*expr, 1);
+  /* Try to simplify the expression to catch things like CHARACTER(([1])).   */
+  p = gfc_copy_expr (*expr);
+  if (gfc_is_constant_expr (p) && gfc_simplify_expr (p, 1))
+    gfc_replace_expr (*expr, p);
 
   if ((*expr)->expr_type == EXPR_FUNCTION)
     {

diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 33ca4986f69b769e60ac5d47ab96d9265d971cbb..a58c60e9828ed99cd847ebab446ac0fa0057e686 100644 (file)
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -2922,9 +2922,6 @@ typedef struct gfc_association_list
      for memory handling.  */
   unsigned dangling:1;
 
-  /* True when the rank of the target expression is guessed during parsing.  */
-  unsigned rankguessed:1;
-
   char name[GFC_MAX_SYMBOL_LEN + 1];
   gfc_symtree *st; /* Symtree corresponding to name.  */
   locus where;

diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index fd059dddf051a216ddfa0e7b4db41f833a5fc369..50b49d0cb833f6a5cded567b7eff97034b9bbe9a 100644 (file)
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -5872,7 +5872,15 @@ resolve_variable (gfc_expr *e)
       if (sym->ts.type == BT_CLASS)
        gfc_fix_class_refs (e);
       if (!sym->attr.dimension && e->ref && e->ref->type == REF_ARRAY)
-       return false;
+       {
+         /* Unambiguously scalar!  */
+         if (sym->assoc->target
+             && (sym->assoc->target->expr_type == EXPR_CONSTANT
+                 || sym->assoc->target->expr_type == EXPR_STRUCTURE))
+           gfc_error ("Scalar variable %qs has an array reference at %L",
+                      sym->name, &e->where);
+         return false;
+       }
       else if (sym->attr.dimension && (!e->ref || e->ref->type != REF_ARRAY))
        {
          /* This can happen because the parser did not detect that the
@@ -9279,7 +9287,7 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
       gfc_array_spec *as;
       /* The rank may be incorrectly guessed at parsing, therefore make sure
         it is corrected now.  */
-      if (sym->ts.type != BT_CLASS && (!sym->as || sym->assoc->rankguessed))
+      if (sym->ts.type != BT_CLASS && !sym->as)
        {
          if (!sym->as)
            sym->as = gfc_get_array_spec ();
@@ -9292,8 +9300,7 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
            sym->attr.codimension = 1;
        }
       else if (sym->ts.type == BT_CLASS
-              && CLASS_DATA (sym)
-              && (!CLASS_DATA (sym)->as || sym->assoc->rankguessed))
+              && CLASS_DATA (sym) && !CLASS_DATA (sym)->as)
        {
          if (!CLASS_DATA (sym)->as)
            CLASS_DATA (sym)->as = gfc_get_array_spec ();

diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 1c7ea900ea1c81f3ffe411a500ff1f9d309d9d75..e1c75e9fe0266d760b635f0dc7869a00ce53bf48 100644 (file)
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -7934,7 +7934,8 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
          else
            tmp = se->string_length;
 
-         if (expr->ts.deferred && VAR_P (expr->ts.u.cl->backend_decl))
+         if (expr->ts.deferred && expr->ts.u.cl->backend_decl
+             && VAR_P (expr->ts.u.cl->backend_decl))
            gfc_add_modify (&se->pre, expr->ts.u.cl->backend_decl, tmp);
          else
            expr->ts.u.cl->backend_decl = tmp;
@@ -7999,6 +8000,15 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
            }
        }
 
+      if (expr->ts.type == BT_CHARACTER
+         && VAR_P (TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (parm)))))
+       {
+         tree elem_len = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (parm)));
+         gfc_add_modify (&loop.pre, elem_len,
+                         fold_convert (TREE_TYPE (elem_len),
+                         gfc_get_array_span (desc, expr)));
+       }
+
       /* Set the span field.  */
       tmp = NULL_TREE;
       if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))

diff --git a/gcc/fortran/trans-io.cc b/gcc/fortran/trans-io.cc
index 0c0e3332778e8eefcfb825086c1cd25f4bbd555c..e36ad0e3db442e437011cf394f45f52eff53abd1 100644 (file)
--- a/gcc/fortran/trans-io.cc
+++ b/gcc/fortran/trans-io.cc
@@ -2620,9 +2620,13 @@ gfc_trans_transfer (gfc_code * code)
          gcc_assert (ref && ref->type == REF_ARRAY);
        }
 
+      /* These expressions don't always have the dtype element length set
+        correctly, rendering them useless for array transfer.  */
       if (expr->ts.type != BT_CLASS
         && expr->expr_type == EXPR_VARIABLE
         && ((expr->symtree->n.sym->ts.type == BT_DERIVED && expr->ts.deferred)
+            || (expr->symtree->n.sym->assoc
+                && expr->symtree->n.sym->assoc->variable)
             || gfc_expr_attr (expr).pointer))
        goto scalarize;
 

diff --git a/gcc/fortran/trans-stmt.cc b/gcc/fortran/trans-stmt.cc
index b5b82941b419cabf5eeb443bdc22d6610fec2267..dcabeca007849b4ab0ae620ca2559c70024c5d64 100644 (file)
--- a/gcc/fortran/trans-stmt.cc
+++ b/gcc/fortran/trans-stmt.cc
@@ -1930,15 +1930,13 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
       gfc_conv_expr_descriptor (&se, e);
 
       if (sym->ts.type == BT_CHARACTER
-         && sym->ts.deferred
          && !sym->attr.select_type_temporary
+         && sym->ts.u.cl->backend_decl
          && VAR_P (sym->ts.u.cl->backend_decl)
          && se.string_length != sym->ts.u.cl->backend_decl)
-       {
-         gfc_add_modify (&se.pre, sym->ts.u.cl->backend_decl,
+       gfc_add_modify (&se.pre, sym->ts.u.cl->backend_decl,
                          fold_convert (TREE_TYPE (sym->ts.u.cl->backend_decl),
                                        se.string_length));
-       }
 
       /* If we didn't already do the pointer assignment, set associate-name
         descriptor to the one generated for the temporary.  */

diff --git a/gcc/testsuite/gfortran.dg/associate_5.f03 b/gcc/testsuite/gfortran.dg/associate_5.f03
index 64345d323f3216946c2e3815aee5904f71d57f9e..c91f88f4e12a72f5dbf63cf5705c688454138070 100644 (file)
--- a/gcc/testsuite/gfortran.dg/associate_5.f03
+++ b/gcc/testsuite/gfortran.dg/associate_5.f03
@@ -11,7 +11,7 @@ PROGRAM main
   INTEGER, POINTER :: ptr
 
   ASSOCIATE (a => 5) ! { dg-error "is used as array" }
-    PRINT *, a(3)
+    PRINT *, a(3) ! { dg-error "has an array reference" }
   END ASSOCIATE
 
   ASSOCIATE (a => nontarget)

diff --git a/gcc/testsuite/gfortran.dg/associate_61.f90 b/gcc/testsuite/gfortran.dg/associate_61.f90
new file mode 100644 (file)
index 0000000..da55288
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/associate_61.f90
@@ -0,0 +1,54 @@
+! { dg-do run }
+! Test fixes for PR109451
+! Contributed by Harald Anlauf  <anlauf@gcc.gnu.org>
+!
+program p
+   implicit none
+   character(4) :: c(2) = ["abcd","efgh"]
+   call dcs3 (c)
+   call dcs0 (c)
+contains
+  subroutine dcs3 (a)
+    character(len=*), intent(in)  :: a(:)
+    character(:),     allocatable :: b(:)
+    b = a(:)
+    call test (b, a, 1)
+    associate (q => b(:))    ! no ICE but print repeated first element
+      call test (q, a, 2)
+      print *, q             ! Checked with dg-output
+      q = q(:)(2:3)
+    end associate
+    call test (b, ["bc  ","fg  "], 4)
+    b = a(:)
+    associate (q => b(:)(:)) ! ICE
+      call test (q, a, 3)
+      associate (r => q(:)(1:3))
+        call test (r, a(:)(1:3), 5)
+      end associate
+    end associate
+    associate (q => b(:)(2:3))
+      call test (q, a(:)(2:3), 6)
+    end associate
+  end subroutine dcs3
+
+! The associate vars in dsc0 had string length not set
+  subroutine dcs0 (a)
+    character(len=*), intent(in) :: a(:)
+    associate (q => a)
+      call test (q, a, 7)
+    end associate
+    associate (q => a(:))
+      call test (q, a, 8)
+    end associate
+    associate (q => a(:)(:))
+      call test (q, a, 9)
+    end associate
+  end subroutine dcs0
+
+  subroutine test (x, y, i)
+    character(len=*), intent(in) :: x(:), y(:)
+    integer, intent(in) :: i
+    if (any (x .ne. y)) stop i
+  end subroutine test
+end program p
+! { dg-output " abcdefgh" }

diff --git a/gcc/testsuite/gfortran.dg/pr107821.f90 b/gcc/testsuite/gfortran.dg/pr107821.f90
new file mode 100644 (file)
index 0000000..5d86997
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr107821.f90
@@ -0,0 +1,9 @@
+! { dg-do compile }
+!
+! Contributed by Gerhard Steinmetz  <gscfq@t-online.de>
+!
+program p
+   associate (a => 1)
+      print *, [character((a(1))) :: '1'] ! { dg-error "has an array reference" }
+   end associate
+end

diff --git a/gcc/testsuite/gfortran.dg/pr99350.f90 b/gcc/testsuite/gfortran.dg/pr99350.f90
new file mode 100644 (file)
index 0000000..7f751b9
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr99350.f90
@@ -0,0 +1,16 @@
+! { dg-do compile }
+!
+! Contributed by Gerhard Steinmetz  <gscfq@t-online.de>
+!
+program p
+   type t
+      character(:), pointer :: a
+   end type
+   type(t) :: z
+   character((0.)/0), target :: c = 'abc' ! { dg-error "Division by zero" }
+   z%a => c
+! The associate statement was not needed to trigger the ICE.
+   associate (y => z%a)
+      print *, y
+   end associate
+end