array.c (spec_dimen_size): Check for the presence of expressions for the bounds.

2019-09-01  Paul Thomas  <pault@gcc.gnu.org>

	* array.c (spec_dimen_size): Check for the presence of
	expressions for the bounds.
	* decl.c (gfc_match_end): Add case COMP_SELECT_RANK.
	* dump-parse-tree.c(show_symbol): Show the arrayspec of class
	entities.
	(show_code_node): Show the code for SELECT_RANK.
	* expr.c (gfc_check_vardef_context): Omit the context of
	variable definition for select rank associate names since the
	ASSUMED RANK throws.
	* gfortran.h : Add ST_SELECT_RANK and ST_RANK to enum
	gfc_statement. Add select_rank_temporary to symbol attribute
	structure. Add EXEC_SELECT_RANK to enum gfc_exec_op.
	* match.c (match_exit_cycle): Add COMP_SELECT_RANK.
	(copy_ts_from_selector_to_associate): Add as special case for
	assumed rank class variables.
	(select_intrinsic_set_tmp): Clean up the code by using symbols
	for references to the temporary and the selector.
	(select_type_set_tmp): Ditto.
	(select_rank_set_tmp): New function.
	(gfc_match_select_rank): New function.
	(gfc_match_rank_is): New function.
	* match.h : Add prototypes for gfc_match_select_rank and
	gfc_match_rank_is.
	* parse.c (decode_statement): Attempt to match select_rank and
	rank statements.
	(next_statement, gfc_ascii_statement): Add ST_SELECT_RANK.
	(parse_select_rank_block): New function.
	(parse_executable): Parse select rank block for ST_SELECT_RANK.
	* parse.h : Add COMP_SELECT_RANK to enum gfc_compile_state.
	* resolve.c (resolve_variable): Exclude select_rank_temporaries
	from the check on use of ASSUMED RANK.
	(gfc_resolve_expr): Make sure that unlimited polymorphic select
	rank temporaries expressions are not resolved again after being
	successfully resolved.
	(resolve_assoc_var): Do not do the rank check for select rank
	temporaries.
	(resolve_select_rank): New function.
	(gfc_resolve_blocks): Deal with case EXEC_SELECT_RANK.
	(resolve_symbol): Exclude select rank temporaries for check on
	use of ASSUMED RANK.
	* st.c (gfc_free_statement): Include EXEC_SELECT_RANK.
	* trans-array.c (gfc_conv_array_ref): Select rank temporaries
	may have dimen == 0.
	(gfc_conv_expr_descriptor): Zero the offset of select rank
	temporaries.
	* trans-stmt.c (copy_descriptor): New function.
	(trans_associate_var): Add code to associate select rank temps.
	(gfc_trans_select_rank_cases): New function.
	(gfc_trans_select_rank): New function.
	* trans-stmt.h : Add prototype for gfc_trans_select_rank.
	trans.c (trans_code): Add select rank case.


2019-09-01  Paul Thomas  <pault@gcc.gnu.org>

	* gfortran.dg/select_rank_1.f90 : New test.
	* gfortran.dg/select_rank_2.f90 : New test.

From-SVN: r275269

1 files changed, 311 insertions, 4 deletions

diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index 3606880..856a171 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -1641,6 +1641,48 @@ class_has_len_component (gfc_symbol *sym)
 }
 
 
+static void
+copy_descriptor (stmtblock_t *block, tree dst, tree src, int rank)
+{
+  int n;
+  tree dim;
+  tree tmp;
+  tree tmp2;
+  tree size;
+  tree offset;
+
+  offset = gfc_index_zero_node;
+
+  /* Use memcpy to copy the descriptor. The size is the minimum of
+     the sizes of 'src' and 'dst'. This avoids a non-trivial conversion.  */
+  tmp = TYPE_SIZE_UNIT (TREE_TYPE (src));
+  tmp2 = TYPE_SIZE_UNIT (TREE_TYPE (dst));
+  size = fold_build2_loc (input_location, MIN_EXPR,
+			  TREE_TYPE (tmp), tmp, tmp2);
+  tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
+  tmp = build_call_expr_loc (input_location, tmp, 3,
+			     gfc_build_addr_expr (NULL_TREE, dst),
+			     gfc_build_addr_expr (NULL_TREE, src),
+			     fold_convert (size_type_node, size));
+  gfc_add_expr_to_block (block, tmp);
+
+  /* Set the offset correctly.  */
+  for (n = 0; n < rank; n++)
+    {
+      dim = gfc_rank_cst[n];
+      tmp = gfc_conv_descriptor_lbound_get (src, dim);
+      tmp2 = gfc_conv_descriptor_stride_get (src, dim);
+      tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
+			     tmp, tmp2);
+      offset = fold_build2_loc (input_location, MINUS_EXPR,
+			TREE_TYPE (offset), offset, tmp);
+      offset = gfc_evaluate_now (offset, block);
+    }
+
+  gfc_conv_descriptor_offset_set (block, dst, offset);
+}
+
+
 /* Do proper initialization for ASSOCIATE names.  */
 
 static void
@@ -1658,6 +1700,7 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
   bool need_len_assign;
   bool whole_array = true;
   gfc_ref *ref;
+  gfc_symbol *sym2;
 
   gcc_assert (sym->assoc);
   e = sym->assoc->target;
@@ -1690,12 +1733,140 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
                      && e->ts.u.derived->attr.unlimited_polymorphic))
       && (sym->ts.type == BT_CHARACTER
           || ((sym->ts.type == BT_CLASS || sym->ts.type == BT_DERIVED)
-              && class_has_len_component (sym))));
+              && class_has_len_component (sym)))
+      && !sym->attr.select_rank_temporary);
+
   /* Do a `pointer assignment' with updated descriptor (or assign descriptor
      to array temporary) for arrays with either unknown shape or if associating
-     to a variable.  */
-  if (sym->attr.dimension && !class_target
-      && (sym->as->type == AS_DEFERRED || sym->assoc->variable))
+     to a variable. Select rank temporaries need somewhat different treatment
+     to other associate names and case temporaries. This because the selector
+     is assumed rank and so the offset in particular has to be changed. Also,
+     the case temporaries carry both allocatable and target attributes if
+     present in the selector. This means that an allocatation or change of
+     association can occur and so has to be dealt with.  */
+  if (sym->attr.select_rank_temporary)
+    {
+      gfc_se se;
+      tree class_decl = NULL_TREE;
+      int rank = 0;
+      bool class_ptr;
+
+      sym2 = e->symtree->n.sym;
+      gfc_init_se (&se, NULL);
+      if (e->ts.type == BT_CLASS)
+	{
+	  /* Go straight to the class data.  */
+	  if (sym2->attr.dummy)
+	    {
+	      class_decl = DECL_LANG_SPECIFIC (sym2->backend_decl) ?
+			   GFC_DECL_SAVED_DESCRIPTOR (sym2->backend_decl) :
+			   sym2->backend_decl;
+	      if (POINTER_TYPE_P (TREE_TYPE (class_decl)))
+		class_decl = build_fold_indirect_ref_loc (input_location,
+							  class_decl);
+	      gcc_assert (GFC_CLASS_TYPE_P (TREE_TYPE (class_decl)));
+	      se.expr = gfc_class_data_get (class_decl);
+	    }
+	  else
+	    {
+	      class_decl = sym2->backend_decl;
+	      gfc_conv_expr_descriptor (&se, e);
+	      if (POINTER_TYPE_P (TREE_TYPE (se.expr)))
+		se.expr = build_fold_indirect_ref_loc (input_location,
+						       se.expr);
+	    }
+
+	  if (CLASS_DATA (sym)->as && CLASS_DATA (sym)->as->rank > 0)
+	    rank = CLASS_DATA (sym)->as->rank;
+	}
+      else
+	{
+	  gfc_conv_expr_descriptor (&se, e);
+	  if (sym->as && sym->as->rank > 0)
+	    rank = sym->as->rank;
+	}
+
+      desc = sym->backend_decl;
+
+      /* The SELECT TYPE mechanisms turn class temporaries into pointers, which
+	 point to the selector. */
+      class_ptr = class_decl != NULL_TREE && POINTER_TYPE_P (TREE_TYPE (desc));
+      if (class_ptr)
+	{
+	  tmp = gfc_create_var (TREE_TYPE (TREE_TYPE (desc)), "class");
+	  tmp = gfc_build_addr_expr (NULL, tmp);
+	  gfc_add_modify (&se.pre, desc, tmp);
+
+	  tmp = gfc_class_vptr_get (class_decl);
+	  gfc_add_modify (&se.pre, gfc_class_vptr_get (desc), tmp);
+	  if (UNLIMITED_POLY (sym))
+	    gfc_add_modify (&se.pre, gfc_class_len_get (desc),
+			    gfc_class_len_get (class_decl));
+
+	  desc = gfc_class_data_get (desc);
+	}
+
+      /* SELECT RANK temporaries can carry the allocatable and pointer
+	 attributes so the selector descriptor must be copied in and
+	 copied out.  */
+      if (rank > 0)
+	copy_descriptor (&se.pre, desc, se.expr, rank);
+      else
+	{
+	  tmp = gfc_conv_descriptor_data_get (se.expr);
+	  gfc_add_modify (&se.pre, desc,
+			  fold_convert (TREE_TYPE (desc), tmp));
+	}
+
+      /* Deal with associate_name => selector. Class associate names are
+	 treated in the same way as in SELECT TYPE.  */
+      sym2 = sym->assoc->target->symtree->n.sym;
+      if (sym2->assoc && sym->assoc->target && sym2->ts.type != BT_CLASS)
+	{
+	  sym2 = sym2->assoc->target->symtree->n.sym;
+	  se.expr = sym2->backend_decl;
+
+	  if (POINTER_TYPE_P (TREE_TYPE (se.expr)))
+	    se.expr = build_fold_indirect_ref_loc (input_location,
+						   se.expr);
+	}
+
+      /* There could have been reallocation.  Copy descriptor back to the
+	 selector and update the offset.  */
+      if (sym->attr.allocatable || sym->attr.pointer
+	  || (sym->ts.type == BT_CLASS
+	      && (CLASS_DATA (sym)->attr.allocatable
+		  || CLASS_DATA (sym)->attr.pointer)))
+	{
+	  if (rank > 0)
+	    copy_descriptor (&se.post, se.expr, desc, rank);
+	  else
+	    {
+	      tmp = gfc_conv_descriptor_data_get (desc);
+	      gfc_conv_descriptor_data_set (&se.post, se.expr, tmp);
+	    }
+
+	  /* The dynamic type could have changed too.  */
+	  if (sym->ts.type == BT_CLASS)
+	    {
+	      tmp = sym->backend_decl;
+	      if (class_ptr)
+		tmp = build_fold_indirect_ref_loc (input_location, tmp);
+	      gfc_add_modify (&se.post, gfc_class_vptr_get (class_decl),
+			      gfc_class_vptr_get (tmp));
+	      if (UNLIMITED_POLY (sym))
+		gfc_add_modify (&se.post, gfc_class_len_get (class_decl),
+				gfc_class_len_get (tmp));
+	    }
+	}
+
+      tmp = gfc_finish_block (&se.post);
+
+      gfc_add_init_cleanup (block, gfc_finish_block (&se.pre), tmp);
+    }
+  /* Now all the other kinds of associate variable.  */
+  else if (sym->attr.dimension && !class_target
+	   && (sym->as->type == AS_DEFERRED || sym->assoc->variable))
     {
       gfc_se se;
       tree desc;
@@ -3424,6 +3595,142 @@ gfc_trans_select_type (gfc_code * code)
 }
 
 
+static tree
+gfc_trans_select_rank_cases (gfc_code * code)
+{
+  gfc_code *c;
+  gfc_case *cp;
+  tree tmp;
+  tree cond;
+  tree low;
+  tree sexpr;
+  tree rank;
+  tree rank_minus_one;
+  tree minus_one;
+  gfc_se se;
+  gfc_se cse;
+  stmtblock_t block;
+  stmtblock_t body;
+  bool def = false;
+
+  gfc_start_block (&block);
+
+  /* Calculate the switch expression.  */
+  gfc_init_se (&se, NULL);
+  gfc_conv_expr_descriptor (&se, code->expr1);
+  rank = gfc_conv_descriptor_rank (se.expr);
+  rank = gfc_evaluate_now (rank, &block);
+  minus_one = build_int_cst (TREE_TYPE (rank), -1);
+  tmp = fold_build2_loc (input_location, MINUS_EXPR,
+			 gfc_array_index_type,
+			 fold_convert (gfc_array_index_type, rank),
+			 build_int_cst (gfc_array_index_type, 1));
+  rank_minus_one = gfc_evaluate_now (tmp, &block);
+  tmp = gfc_conv_descriptor_ubound_get (se.expr, rank_minus_one);
+  cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
+			  tmp, build_int_cst (TREE_TYPE (tmp), -1));
+  tmp = fold_build3_loc (input_location, COND_EXPR,
+			 TREE_TYPE (rank), cond,
+			 rank, minus_one);
+  cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
+			  rank, build_int_cst (TREE_TYPE (rank), 0));
+  sexpr = fold_build3_loc (input_location, COND_EXPR,
+			   TREE_TYPE (rank), cond,
+			   rank, tmp);
+  sexpr = gfc_evaluate_now (sexpr, &block);
+  TREE_USED (code->exit_label) = 0;
+
+repeat:
+  for (c = code->block; c; c = c->block)
+    {
+      cp = c->ext.block.case_list;
+
+      /* Assume it's the default case.  */
+      low = NULL_TREE;
+      tmp = NULL_TREE;
+
+      /* Put the default case at the end.  */
+      if ((!def && !cp->low) || (def && cp->low))
+	continue;
+
+      if (cp->low)
+	{
+	  gfc_init_se (&cse, NULL);
+	  gfc_conv_expr_val (&cse, cp->low);
+	  gfc_add_block_to_block (&block, &cse.pre);
+	  low = cse.expr;
+	}
+
+      gfc_init_block (&body);
+
+      /* Add the statements for this case.  */
+      tmp = gfc_trans_code (c->next);
+      gfc_add_expr_to_block (&body, tmp);
+
+      /* Break to the end of the SELECT RANK construct.  The default
+	 case just falls through.  */
+      if (!def)
+	{
+	  TREE_USED (code->exit_label) = 1;
+	  tmp = build1_v (GOTO_EXPR, code->exit_label);
+	  gfc_add_expr_to_block (&body, tmp);
+	}
+
+      tmp = gfc_finish_block (&body);
+
+      if (low != NULL_TREE)
+	{
+	  cond = fold_build2_loc (input_location, EQ_EXPR,
+				  TREE_TYPE (sexpr), sexpr,
+				  fold_convert (TREE_TYPE (sexpr), low));
+	  tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
+				 cond, tmp,
+				 build_empty_stmt (input_location));
+	}
+
+      gfc_add_expr_to_block (&block, tmp);
+    }
+
+  if (!def)
+    {
+      def = true;
+      goto repeat;
+    }
+
+  return gfc_finish_block (&block);
+}
+
+
+tree
+gfc_trans_select_rank (gfc_code * code)
+{
+  stmtblock_t block;
+  tree body;
+  tree exit_label;
+
+  gcc_assert (code && code->expr1);
+  gfc_init_block (&block);
+
+  /* Build the exit label and hang it in.  */
+  exit_label = gfc_build_label_decl (NULL_TREE);
+  code->exit_label = exit_label;
+
+  /* Empty SELECT constructs are legal.  */
+  if (code->block == NULL)
+    body = build_empty_stmt (input_location);
+  else
+    body = gfc_trans_select_rank_cases (code);
+
+  /* Build everything together.  */
+  gfc_add_expr_to_block (&block, body);
+
+  if (TREE_USED (exit_label))
+    gfc_add_expr_to_block (&block, build1_v (LABEL_EXPR, exit_label));
+
+  return gfc_finish_block (&block);
+}
+
+
 /* Traversal function to substitute a replacement symtree if the symbol
    in the expression is the same as that passed.  f == 2 signals that
    that variable itself is not to be checked - only the references.