re PR fortran/84115 (Failure in associate construct with concatenated character target)

2018-02-17  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/84115
	* resolve.c (resolve_assoc_var): If a non-constant target expr.
	has no string length expression, make the associate variable
	into a deferred length, allocatable symbol.
	* trans-decl.c (gfc_is_reallocatable_lhs): Add and use a ptr to
	the symbol.
	* trans-stmt.c (trans_associate_var): Null and free scalar
	associate names that are allocatable. After assignment, remove
	the allocatable attribute to prevent reallocation.

2018-02-17  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/84115
	* gfortran.dg/associate_35.f90: Remove error, add stop n's and
	change to run.

From-SVN: r257781

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 445b9cce22244b36208c21ceb3b067115b96cdeb..af345eafd5cb59b339504aa6a6a1e0eba3e14040 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,15 @@
+2018-02-17  Paul Thomas  <pault@gcc.gnu.org>
+
+       PR fortran/84115
+       * resolve.c (resolve_assoc_var): If a non-constant target expr.
+       has no string length expression, make the associate variable
+       into a deferred length, allocatable symbol.
+       * trans-decl.c (gfc_is_reallocatable_lhs): Add and use a ptr to
+       the symbol.
+       * trans-stmt.c (trans_associate_var): Null and free scalar
+       associate names that are allocatable. After assignment, remove
+       the allocatable attribute to prevent reallocation.
+
 2018-02-16  Jakub Jelinek  <jakub@redhat.com>
 
        PR fortran/84418

diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c
index 3d076736fdcb89b65ac5c029aacd1ab62a130810..9e6a8fe0d8019a92906605ab9ed5341345ddc52a 100644 (file)
--- a/gcc/fortran/primary.c
+++ b/gcc/fortran/primary.c
@@ -2082,7 +2082,7 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
     {
       bool permissible;
 
-      /* These target expressions can ge resolved at any time.  */
+      /* These target expressions can be resolved at any time.  */
       permissible = tgt_expr && tgt_expr->symtree && tgt_expr->symtree->n.sym
                    && (tgt_expr->symtree->n.sym->attr.use_assoc
                        || tgt_expr->symtree->n.sym->attr.host_assoc

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 01e2c38952c6f2b633b0d7c6d95ae784af8c3b69..e1d2aa27ad18e85f78b21c063db7161296c22638 100644 (file)
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -8635,7 +8635,20 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
   if (sym->ts.type == BT_CHARACTER && !sym->attr.select_type_temporary)
     {
       if (!sym->ts.u.cl)
-       sym->ts.u.cl = target->ts.u.cl;
+       {
+         if (target->expr_type != EXPR_CONSTANT
+             && !target->ts.u.cl->length)
+           {
+             sym->ts.u.cl = gfc_get_charlen();
+             sym->ts.deferred = 1;
+
+             /* This is reset in trans-stmt.c after the assignment
+                of the target expression to the associate name.  */
+             sym->attr.allocatable = 1;
+           }
+         else
+           sym->ts.u.cl = target->ts.u.cl;
+       }
 
       if (!sym->ts.u.cl->length && !sym->ts.deferred)
        {

diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 4ffda26ca7d2beeff1a237ed873f67c2087b94ba..79d4d171bddb3552195fb9fbbef3e2806a867e8d 100644 (file)
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -9470,29 +9470,32 @@ bool
 gfc_is_reallocatable_lhs (gfc_expr *expr)
 {
   gfc_ref * ref;
+  gfc_symbol *sym;
 
   if (!expr->ref)
     return false;
 
+  sym = expr->symtree->n.sym;
+
   /* An allocatable class variable with no reference.  */
-  if (expr->symtree->n.sym->ts.type == BT_CLASS
-      && CLASS_DATA (expr->symtree->n.sym)->attr.allocatable
+  if (sym->ts.type == BT_CLASS
+      && CLASS_DATA (sym)->attr.allocatable
       && expr->ref && expr->ref->type == REF_COMPONENT
       && strcmp (expr->ref->u.c.component->name, "_data") == 0
       && expr->ref->next == NULL)
     return true;
 
   /* An allocatable variable.  */
-  if (expr->symtree->n.sym->attr.allocatable
+  if (sym->attr.allocatable
        && expr->ref
        && expr->ref->type == REF_ARRAY
        && expr->ref->u.ar.type == AR_FULL)
     return true;
 
   /* All that can be left are allocatable components.  */
-  if ((expr->symtree->n.sym->ts.type != BT_DERIVED
-       && expr->symtree->n.sym->ts.type != BT_CLASS)
-       || !expr->symtree->n.sym->ts.u.derived->attr.alloc_comp)
+  if ((sym->ts.type != BT_DERIVED
+       && sym->ts.type != BT_CLASS)
+       || !sym->ts.u.derived->attr.alloc_comp)
     return false;
 
   /* Find a component ref followed by an array reference.  */

diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index a4185820531f518a0ccd34d69c516eac696685e3..04e06efbe38b17f8b7c17500e6cf27d4a0ee455a 100644 (file)
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -657,7 +657,7 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
              }
 
          /* Array references with vector subscripts and non-variable expressions
-            need be coverted to a one-based descriptor.  */
+            need be converted to a one-based descriptor.  */
          if (ref || e->expr_type != EXPR_VARIABLE)
            {
              for (dim = 0; dim < e->rank; ++dim)

diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index 573fd4818d47a011124aa515889255f00444ac26..71e22d80e98224bd6e9215fa2d654f71d376424e 100644 (file)
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -1926,9 +1926,26 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
     {
       gfc_expr *lhs;
       tree res;
+      gfc_se se;
+
+      gfc_init_se (&se, NULL);
+
+      /* resolve.c converts some associate names to allocatable so that
+        allocation can take place automatically in gfc_trans_assignment.
+        The frontend prevents them from being either allocated,
+        deallocated or reallocated.  */
+      if (sym->attr.allocatable)
+       {
+         tmp = sym->backend_decl;
+         if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
+           tmp = gfc_conv_descriptor_data_get (tmp);
+         gfc_add_modify (&se.pre, tmp, fold_convert (TREE_TYPE (tmp),
+                                                   null_pointer_node));
+       }
 
       lhs = gfc_lval_expr_from_sym (sym);
       res = gfc_trans_assignment (lhs, e, false, true);
+      gfc_add_expr_to_block (&se.pre, res);
 
       tmp = sym->backend_decl;
       if (e->expr_type == EXPR_FUNCTION
@@ -1948,8 +1965,25 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
          tmp = gfc_deallocate_pdt_comp (CLASS_DATA (sym)->ts.u.derived,
                                         tmp, 0);
        }
+      else if (sym->attr.allocatable)
+       {
+         tmp = sym->backend_decl;
+
+         if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
+           tmp = gfc_conv_descriptor_data_get (tmp);
+
+         /* A simple call to free suffices here.  */
+         tmp = gfc_call_free (tmp);
+
+         /* Make sure that reallocation on assignment cannot occur.  */
+         sym->attr.allocatable = 0;
+       }
+      else
+       tmp = NULL_TREE;
 
+      res = gfc_finish_block (&se.pre);
       gfc_add_init_cleanup (block, res, tmp);
+      gfc_free_expr (lhs);
     }
 
   /* Set the stringlength, when needed.  */

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index f3b1f9bccbfcc7717201fa87bfd485f5226fba5b..4bc2d3e7f768606b3e0f7663101f2e5731d67c22 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,9 @@
+2018-02-17  Paul Thomas  <pault@gcc.gnu.org>
+
+       PR fortran/84115
+       * gfortran.dg/associate_35.f90: Remove error, add STOP n and
+       change to dg-run.
+
 2018-02-16  Eric Botcazou  <ebotcazou@adacore.com>
 
        PR ada/84277
@@ -492,7 +498,7 @@
 
        PR sanitizer/83987
        * g++.dg/ubsan/pr83987-2.C: New test.
-       
+
 2018-02-09  Sebastian Perta  <sebastian.perta@renesas.com>
 
        * gcc.target/rx/movsicc.c: New test.

diff --git a/gcc/testsuite/gfortran.dg/associate_35.f90 b/gcc/testsuite/gfortran.dg/associate_35.f90
index 417ec7c426b37a9adeb114cb4a6b54cc4c1fc13e..67329785bc4315fe086f05a4e2163f4fa912687f 100644 (file)
--- a/gcc/testsuite/gfortran.dg/associate_35.f90
+++ b/gcc/testsuite/gfortran.dg/associate_35.f90
@@ -1,6 +1,6 @@
-! { dg-do compile }
+! { dg-do run }
 !
-! Test the fix for PR84115 comment #1 (except for s1(x)!).
+! Test the fix for PR84115 comment #1.
 !
 ! Contributed by G Steinmetz  <gscfq@t-online.de>
 !
@@ -14,22 +14,22 @@
 contains
   subroutine s1(x)
     character(:), allocatable :: x
-    associate (y => x//x)   ! { dg-error "type character and non-constant length" }
-      print *, y
+    associate (y => x//x)
+      if (y .ne. x//x) stop 1
     end associate
   end
 
   subroutine s2(x)
     character(:), allocatable :: x
     associate (y => [x])
-      print *, y
+      if (any(y .ne. [x])) stop 2
     end associate
   end
 
   subroutine s3(x)
     character(:), allocatable :: x
     associate (y => [x,x])
-      print *, y
+      if (any(y .ne. [x,x])) stop 3
     end associate
   end
 end