Merge from trunk revision f3e9c98a9f40fc24bb4ecef6aaa94ff799c8d587.

7 files changed, 89 insertions, 19 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index a78e724..8cc9403 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,38 @@
+2021-03-15  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/99345
+	* frontend-passes.c (doloop_contained_procedure_code):
+	Properly handle EXEC_IOLENGTH.
+
+2021-03-15  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/99545
+	* trans-stmt.c (gfc_trans_allocate): Mark the initialization
+	assignment by setting init_flag.
+
+2021-03-14  Harald Anlauf  <anlauf@gmx.de>
+	    Paul Thomas  <pault@gcc.gnu.org>
+
+	* trans-expr.c (gfc_conv_procedure_call): Fix runtime checks for
+	CLASS arguments.
+	* trans-intrinsic.c (gfc_conv_intrinsic_size): Likewise.
+
+2021-03-13  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/99125
+	* trans-array.c (gfc_conv_expr_descriptor): For deferred length
+	length components use the ss_info string length instead of
+	gfc_get_expr_charlen. Make sure that the deferred string length
+	is a variable before assigning to it. Otherwise use the expr.
+	* trans-expr.c (gfc_conv_string_length): Make sure that the
+	deferred string length is a variable before assigning to it.
+
+2021-03-12  Tobias Burnus  <tobias@codesourcery.com>
+
+	PR fortran/99514
+	* resolve.c (resolve_symbol): Accept vars which are in DATA
+	and hence (either) implicit SAVE (or in common).
+
 2021-03-10  Harald Anlauf  <anlauf@gmx.de>
 
 	PR fortran/99205
diff --git a/gcc/fortran/frontend-passes.c b/gcc/fortran/frontend-passes.c
index 2b9c2d1..cfc4747 100644
--- a/gcc/fortran/frontend-passes.c
+++ b/gcc/fortran/frontend-passes.c
@@ -2405,6 +2405,7 @@ doloop_contained_procedure_code (gfc_code **c,
     case EXEC_READ:
     case EXEC_WRITE:
     case EXEC_INQUIRE:
+    case EXEC_IOLENGTH:
       saved_io_op = last_io_op;
       last_io_op = co->op;
       break;
@@ -2460,6 +2461,12 @@ doloop_contained_procedure_code (gfc_code **c,
 			   info->procedure->name, &info->where_do);
 	  break;
 
+	case EXEC_IOLENGTH:
+	  if (co->expr1 && co->expr1->symtree->n.sym == do_var)
+	    gfc_error_now (errmsg, do_var->name, &co->expr1->where,
+			   info->procedure->name, &info->where_do);
+	  break;
+
 	default:
 	  gcc_unreachable ();
 	}
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 2a91ae7..32015c2 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -16024,12 +16024,12 @@ resolve_symbol (gfc_symbol *sym)
     }
 
   /* Check threadprivate restrictions.  */
-  if (sym->attr.threadprivate && !sym->attr.save
+  if (sym->attr.threadprivate
+      && !(sym->attr.save || sym->attr.data || sym->attr.in_common)
       && !(sym->ns->save_all && !sym->attr.automatic)
-      && (!sym->attr.in_common
-	  && sym->module == NULL
-	  && (sym->ns->proc_name == NULL
-	      || sym->ns->proc_name->attr.flavor != FL_MODULE)))
+      && sym->module == NULL
+      && (sym->ns->proc_name == NULL
+	  || sym->ns->proc_name->attr.flavor != FL_MODULE))
     gfc_error ("Threadprivate at %L isn't SAVEd", &sym->declared_at);
 
   /* Check omp declare target restrictions.  */
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 478cddd..be5eb89 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -7670,15 +7670,21 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
       /* Set the string_length for a character array.  */
       if (expr->ts.type == BT_CHARACTER)
 	{
-	  se->string_length =  gfc_get_expr_charlen (expr);
+	  if (deferred_array_component)
+	    se->string_length = ss_info->string_length;
+	  else
+	    se->string_length =  gfc_get_expr_charlen (expr);
+
 	  if (VAR_P (se->string_length)
 	      && expr->ts.u.cl->backend_decl == se->string_length)
 	    tmp = ss_info->string_length;
 	  else
 	    tmp = se->string_length;
 
-	  if (expr->ts.deferred)
+	  if (expr->ts.deferred && 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;
 	}
 
       /* If we have an array section, are assigning  or passing an array
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 85c16d7..bffe080 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -2485,7 +2485,7 @@ gfc_conv_string_length (gfc_charlen * cl, gfc_expr * expr, stmtblock_t * pblock)
 			     se.expr, build_zero_cst (TREE_TYPE (se.expr)));
   gfc_add_block_to_block (pblock, &se.pre);
 
-  if (cl->backend_decl)
+  if (cl->backend_decl && VAR_P (cl->backend_decl))
     gfc_add_modify (pblock, cl->backend_decl, se.expr);
   else
     cl->backend_decl = gfc_evaluate_now (se.expr, pblock);
@@ -6662,6 +6662,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 	  symbol_attribute attr;
 	  char *msg;
 	  tree cond;
+	  tree tmp;
 
 	  if (e->expr_type == EXPR_VARIABLE || e->expr_type == EXPR_FUNCTION)
 	    attr = gfc_expr_attr (e);
@@ -6732,11 +6733,20 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 	      else
 		goto end_pointer_check;
 
-	      tmp = parmse.expr;
+	      if (fsym && fsym->ts.type == BT_CLASS)
+		{
+		  tmp = build_fold_indirect_ref_loc (input_location,
+						      parmse.expr);
+		  tmp = gfc_class_data_get (tmp);
+		  if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
+		    tmp = gfc_conv_descriptor_data_get (tmp);
+		}
+	      else
+		tmp = parmse.expr;
 
 	      /* If the argument is passed by value, we need to strip the
 		 INDIRECT_REF.  */
-	      if (!POINTER_TYPE_P (TREE_TYPE (parmse.expr)))
+	      if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
 		tmp = gfc_build_addr_expr (NULL_TREE, tmp);
 
 	      cond = fold_build2_loc (input_location, EQ_EXPR,
diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index 9cf3642..5e53d11 100644
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -8006,8 +8006,10 @@ gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr)
     {
       symbol_attribute attr;
       char *msg;
+      tree temp;
+      tree cond;
 
-      attr = gfc_expr_attr (e);
+      attr = sym ? sym->attr : gfc_expr_attr (e);
       if (attr.allocatable)
 	msg = xasprintf ("Allocatable argument '%s' is not allocated",
 			 e->symtree->n.sym->name);
@@ -8017,14 +8019,24 @@ gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr)
       else
 	goto end_arg_check;
 
-      argse.descriptor_only = 1;
-      gfc_conv_expr_descriptor (&argse, actual->expr);
-      tree temp = gfc_conv_descriptor_data_get (argse.expr);
-      tree cond = fold_build2_loc (input_location, EQ_EXPR,
-				   logical_type_node, temp,
-				   fold_convert (TREE_TYPE (temp),
-						 null_pointer_node));
+      if (sym)
+	{
+	  temp = gfc_class_data_get (sym->backend_decl);
+	  temp = gfc_conv_descriptor_data_get (temp);
+	}
+      else
+	{
+	  argse.descriptor_only = 1;
+	  gfc_conv_expr_descriptor (&argse, actual->expr);
+	  temp = gfc_conv_descriptor_data_get (argse.expr);
+	}
+
+      cond = fold_build2_loc (input_location, EQ_EXPR,
+			      logical_type_node, temp,
+			      fold_convert (TREE_TYPE (temp),
+					    null_pointer_node));
       gfc_trans_runtime_check (true, false, cond, &argse.pre, &e->where, msg);
+
       free (msg);
     }
  end_arg_check:
diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index 547468f..7cbdef7 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -7001,7 +7001,7 @@ gfc_trans_allocate (gfc_code * code)
 	  gfc_expr *init_expr = gfc_expr_to_initialize (expr);
 	  gfc_expr *rhs = e3rhs ? e3rhs : gfc_copy_expr (code->expr3);
 	  flag_realloc_lhs = 0;
-	  tmp = gfc_trans_assignment (init_expr, rhs, false, false, true,
+	  tmp = gfc_trans_assignment (init_expr, rhs, true, false, true,
 				      false);
 	  flag_realloc_lhs = realloc_lhs;
 	  /* Free the expression allocated for init_expr.  */