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.



git-svn-id: https://gcc.gnu.org/svn/gcc/trunk@257781 138bc75d-0d04-0410-961f-82ee72b054a4

8 files changed, 84 insertions, 16 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 445b9cce222..af345eafd5c 100644
--- 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 3d076736fdc..9e6a8fe0d80 100644
--- 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 01e2c38952c..e1d2aa27ad1 100644
--- 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 4ffda26ca7d..79d4d171bdd 100644
--- 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 a4185820531..04e06efbe38 100644
--- 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 573fd4818d4..71e22d80e98 100644
--- 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 f3b1f9bccbf..4bc2d3e7f76 100644
--- 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 417ec7c426b..67329785bc4 100644
--- 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