re PR fortran/54613 ([F08] Add FINDLOC plus support MAXLOC/MINLOC with KIND=/BACK=)

2017-10-28  Thomas Koenig  <tkoenig@gcc.gnu.org>

	PR fortran/54613
	* gfortran.h (gfc_isym_id): Add GFC_ISYM_FINDLOC.
	(gfc_check_f): Add f6fl field.
	(gfc_simplify_f): Add f6 field.
	(gfc_resolve_f): Likewise.
	(gfc_type_letter): Add optional logical_equas_int flag.
	* check.c (intrinsic_type_check): New function.
	(gfc_check_findloc): New function.
	* intrinsics.c (gfc_type_letter): If logical_equals_int is
	set, act accordingly.
	(add_sym_5ml):  Reformat comment.
	(add_sym_6fl): New function.
	(add_functions): Add findloc.
	(check_arglist): Add sixth argument, handle it.
	(resolve_intrinsic): Likewise.
	(check_specific): Handle findloc.
	* intrinsic.h (gfc_check_findloc): Add prototype.
	(gfc_simplify_findloc): Likewise.
	(gfc_resolve_findloc): Likewise.
	(MAX_INTRINSIC_ARGS): Adjust.
	* iresolve.c (gfc_resolve_findloc): New function.
	* simplify.c (gfc_simplify_minmaxloc): Make static.
	(simplify_findloc_to_scalar): New function.
	(simplify_findloc_nodim): New function.
	(simplify_findloc_to_array): New function.
	(gfc_simplify_findloc): New function.
	(gfc_conv_intrinsic_findloc): New function.
	(gfc_conv_intrinsic_function): Handle GFC_ISYM_FINDLOC.
	(gfc_is_intrinsic_libcall): Likewise.

2017-10-28  Thomas Koenig  <tkoenig@gcc.gnu.org>

	PR fortran/54613
	* Makefile.am: Add files for findloc.
	* Makefile.in: Regenerated.
	* libgfortran.h (gfc_array_index_type): Add.
	(gfc_array_s1): Add using GFC_UINTEGER_1.
	(gfc_array_s4): Likewise.
	Replace unnecessary comment.
	(HAVE_GFC_UINTEGER_1): Define.
	(HAVE_GFC_UINTEGER_4): Define.
	* m4/findloc0.m4: New file.
	* m4/findloc0s.m4: New file.
	* m4/findloc1.m4: New file.
	* m4/findloc1s.m4: New file.
	* m4/findloc2s.m4: New file.
	* m4/ifindloc0.m4: New file.
	* m4/ifindloc1.m4: New file.
	* m4/ifindloc2.m4: New file.
	* m4/iparm.m4: Use unsigned integer for characters.
        * generated/findloc0_c16.c: New file.
        * generated/findloc0_c4.c: New file.
        * generated/findloc0_c8.c: New file.
        * generated/findloc0_i1.c: New file.
        * generated/findloc0_i16.c: New file.
        * generated/findloc0_i2.c: New file.
        * generated/findloc0_i4.c: New file.
        * generated/findloc0_i8.c: New file.
        * generated/findloc0_r16.c: New file.
        * generated/findloc0_r4.c: New file.
        * generated/findloc0_r8.c: New file.
        * generated/findloc0_s1.c: New file.
        * generated/findloc0_s4.c: New file.
        * generated/findloc1_c16.c: New file.
        * generated/findloc1_c4.c: New file.
        * generated/findloc1_c8.c: New file.
        * generated/findloc1_i1.c: New file.
        * generated/findloc1_i16.c: New file.
        * generated/findloc1_i2.c: New file.
        * generated/findloc1_i4.c: New file.
        * generated/findloc1_i8.c: New file.
        * generated/findloc1_r16.c: New file.
        * generated/findloc1_r4.c: New file.
        * generated/findloc1_r8.c: New file.
        * generated/findloc1_s1.c: New file.
        * generated/findloc1_s4.c: New file.
        * generated/findloc2_s1.c: New file.
        * generated/findloc2_s4.c: New file.
        * generated/maxloc0_16_s1.c: Regenerated.
        * generated/maxloc0_16_s4.c: Regenerated.
        * generated/maxloc0_4_s1.c: Regenerated.
        * generated/maxloc0_4_s4.c: Regenerated.
        * generated/maxloc0_8_s1.c: Regenerated.
        * generated/maxloc0_8_s4.c: Regenerated.
        * generated/maxloc1_16_s1.c: Regenerated.
        * generated/maxloc1_16_s4.c: Regenerated.
        * generated/maxloc1_4_s1.c: Regenerated.
        * generated/maxloc1_4_s4.c: Regenerated.
        * generated/maxloc1_8_s1.c: Regenerated.
        * generated/maxloc1_8_s4.c: Regenerated.
        * generated/maxloc2_16_s1.c: Regenerated.
        * generated/maxloc2_16_s4.c: Regenerated.
        * generated/maxloc2_4_s1.c: Regenerated.
        * generated/maxloc2_4_s4.c: Regenerated.
        * generated/maxloc2_8_s1.c: Regenerated.
        * generated/maxloc2_8_s4.c: Regenerated.
        * generated/maxval0_s1.c: Regenerated.
        * generated/maxval0_s4.c: Regenerated.
        * generated/maxval1_s1.c: Regenerated.
        * generated/maxval1_s4.c: Regenerated.
        * generated/minloc0_16_s1.c: Regenerated.
        * generated/minloc0_16_s4.c: Regenerated.
        * generated/minloc0_4_s1.c: Regenerated.
        * generated/minloc0_4_s4.c: Regenerated.
        * generated/minloc0_8_s1.c: Regenerated.
        * generated/minloc0_8_s4.c: Regenerated.
        * generated/minloc1_16_s1.c: Regenerated.
        * generated/minloc1_16_s4.c: Regenerated.
        * generated/minloc1_4_s1.c: Regenerated.
        * generated/minloc1_4_s4.c: Regenerated.
        * generated/minloc1_8_s1.c: Regenerated.
        * generated/minloc1_8_s4.c: Regenerated.
        * generated/minloc2_16_s1.c: Regenerated.
        * generated/minloc2_16_s4.c: Regenerated.
        * generated/minloc2_4_s1.c: Regenerated.
        * generated/minloc2_4_s4.c: Regenerated.
        * generated/minloc2_8_s1.c: Regenerated.
        * generated/minloc2_8_s4.c: Regenerated.
        * generated/minval0_s1.c: Regenerated.
        * generated/minval0_s4.c: Regenerated.
        * generated/minval1_s1.c: Regenerated.
        * generated/minval1_s4.c: Regenerated.

2017-10-28  Thomas Koenig  <tkoenig@gcc.gnu.org>

	PR fortran/54613
	* gfortran.dg/findloc_1.f90: New test.
	* gfortran.dg/findloc_2.f90: New test.
	* gfortran.dg/findloc_3.f90: New test.
	* gfortran.dg/findloc_4.f90: New test.
	* gfortran.dg/findloc_5.f90: New test.
	* gfortran.dg/findloc_6.f90: New test.

From-SVN: r265570

1 files changed, 222 insertions, 0 deletions

diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index 3bb32b5..4ae2b32 100644
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -5177,6 +5177,219 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op)
   se->expr = convert (type, pos);
 }
 
+/* Emit code for findloc.  */
+
+static void
+gfc_conv_intrinsic_findloc (gfc_se *se, gfc_expr *expr)
+{
+  gfc_actual_arglist *array_arg, *value_arg, *dim_arg, *mask_arg,
+    *kind_arg, *back_arg;
+  gfc_expr *value_expr;
+  int ikind;
+  tree resvar;
+  stmtblock_t block;
+  stmtblock_t body;
+  stmtblock_t loopblock;
+  tree type;
+  tree tmp;
+  tree found;
+  tree forward_branch;
+  tree back_branch;
+  gfc_loopinfo loop;
+  gfc_ss *arrayss;
+  gfc_ss *maskss;
+  gfc_se arrayse;
+  gfc_se valuese;
+  gfc_se maskse;
+  gfc_se backse;
+  tree exit_label;
+  gfc_expr *maskexpr;
+  tree offset;
+  int i;
+
+  array_arg = expr->value.function.actual;
+  value_arg = array_arg->next;
+  dim_arg   = value_arg->next;
+  mask_arg  = dim_arg->next;
+  kind_arg  = mask_arg->next;
+  back_arg  = kind_arg->next;
+
+  /* Remove kind and set ikind.  */
+  if (kind_arg->expr)
+    {
+      ikind = mpz_get_si (kind_arg->expr->value.integer);
+      gfc_free_expr (kind_arg->expr);
+      kind_arg->expr = NULL;
+    }
+  else
+    ikind = gfc_default_integer_kind;
+
+  value_expr = value_arg->expr;
+
+  /* Unless it's a string, pass VALUE by value.  */
+  if (value_expr->ts.type != BT_CHARACTER)
+    value_arg->name = "%VAL";
+
+  /* Pass BACK argument by value.  */
+  back_arg->name = "%VAL";
+
+  /* Call the library if we have a character function or if
+     rank > 0.  */
+  if (se->ss || array_arg->expr->ts.type == BT_CHARACTER)
+    {
+      se->ignore_optional = 1;
+      if (expr->rank == 0)
+	{
+	  /* Remove dim argument.  */
+	  gfc_free_expr (dim_arg->expr);
+	  dim_arg->expr = NULL;
+	}
+      gfc_conv_intrinsic_funcall (se, expr);
+      return;
+    }
+
+  type = gfc_get_int_type (ikind);
+
+  /* Initialize the result.  */
+  resvar = gfc_create_var (gfc_array_index_type, "pos");
+  gfc_add_modify (&se->pre, resvar, build_int_cst (gfc_array_index_type, 0));
+  offset = gfc_create_var (gfc_array_index_type, "offset");
+
+  maskexpr = mask_arg->expr;
+
+  /*  Generate two loops, one for BACK=.true. and one for BACK=.false.  */
+
+  for (i = 0 ; i < 2; i++)
+    {
+      /* Walk the arguments.  */
+      arrayss = gfc_walk_expr (array_arg->expr);
+      gcc_assert (arrayss != gfc_ss_terminator);
+
+      if (maskexpr && maskexpr->rank != 0)
+	{
+	  maskss = gfc_walk_expr (maskexpr);
+	  gcc_assert (maskss != gfc_ss_terminator);
+	}
+      else
+	maskss = NULL;
+
+      /* Initialize the scalarizer.  */
+      gfc_init_loopinfo (&loop);
+      exit_label = gfc_build_label_decl (NULL_TREE);
+      TREE_USED (exit_label) = 1;
+      gfc_add_ss_to_loop (&loop, arrayss);
+      if (maskss)
+	gfc_add_ss_to_loop (&loop, maskss);
+
+      /* Initialize the loop.  */
+      gfc_conv_ss_startstride (&loop);
+      gfc_conv_loop_setup (&loop, &expr->where);
+
+      /* Calculate the offset.  */
+      tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+			     gfc_index_one_node, loop.from[0]);
+      gfc_add_modify (&loop.pre, offset, tmp);
+
+      gfc_mark_ss_chain_used (arrayss, 1);
+      if (maskss)
+	gfc_mark_ss_chain_used (maskss, 1);
+
+      /* The first loop is for BACK=.true.  */
+      if (i == 0)
+	loop.reverse[0] = GFC_REVERSE_SET;
+
+      /* Generate the loop body.  */
+      gfc_start_scalarized_body (&loop, &body);
+
+      /* If we have an array mask, only add the element if it is
+	 set.  */
+      if (maskss)
+	{
+	  gfc_init_se (&maskse, NULL);
+	  gfc_copy_loopinfo_to_se (&maskse, &loop);
+	  maskse.ss = maskss;
+	  gfc_conv_expr_val (&maskse, maskexpr);
+	  gfc_add_block_to_block (&body, &maskse.pre);
+	}
+
+      /* If the condition matches then set the return value.  */
+      gfc_start_block (&block);
+
+      /* Add the offset.  */
+      tmp = fold_build2_loc (input_location, PLUS_EXPR,
+			     TREE_TYPE (resvar),
+			     loop.loopvar[0], offset);
+      gfc_add_modify (&block, resvar, tmp);
+      /* And break out of the loop.  */
+      tmp = build1_v (GOTO_EXPR, exit_label);
+      gfc_add_expr_to_block (&block, tmp);
+
+      found = gfc_finish_block (&block);
+
+      /* Check this element.  */
+      gfc_init_se (&arrayse, NULL);
+      gfc_copy_loopinfo_to_se (&arrayse, &loop);
+      arrayse.ss = arrayss;
+      gfc_conv_expr_val (&arrayse, array_arg->expr);
+      gfc_add_block_to_block (&body, &arrayse.pre);
+
+      gfc_init_se (&valuese, NULL);
+      gfc_conv_expr_val (&valuese, value_arg->expr);
+      gfc_add_block_to_block (&body, &valuese.pre);
+
+      tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
+			     arrayse.expr, valuese.expr);
+
+      tmp = build3_v (COND_EXPR, tmp, found, build_empty_stmt (input_location));
+      if (maskss)
+	tmp = build3_v (COND_EXPR, maskse.expr, tmp,
+			build_empty_stmt (input_location));
+
+      gfc_add_expr_to_block (&body, tmp);
+      gfc_add_block_to_block (&body, &arrayse.post);
+
+      gfc_trans_scalarizing_loops (&loop, &body);
+
+      /* Add the exit label.  */
+      tmp = build1_v (LABEL_EXPR, exit_label);
+      gfc_add_expr_to_block (&loop.pre, tmp);
+      gfc_start_block (&loopblock);
+      gfc_add_block_to_block (&loopblock, &loop.pre);
+      gfc_add_block_to_block (&loopblock, &loop.post);
+      if (i == 0)
+	forward_branch = gfc_finish_block (&loopblock);
+      else
+	back_branch = gfc_finish_block (&loopblock);
+
+      gfc_cleanup_loop (&loop);
+    }
+
+  /* Enclose the two loops in an IF statement.  */
+
+  gfc_init_se (&backse, NULL);
+  gfc_conv_expr_val (&backse, back_arg->expr);
+  gfc_add_block_to_block (&se->pre, &backse.pre);
+  tmp = build3_v (COND_EXPR, backse.expr, forward_branch, back_branch);
+
+  /* For a scalar mask, enclose the loop in an if statement.  */
+  if (maskexpr && maskss == NULL)
+    {
+      tree if_stmt;
+      gfc_init_se (&maskse, NULL);
+      gfc_conv_expr_val (&maskse, maskexpr);
+      gfc_init_block (&block);
+      gfc_add_expr_to_block (&block, maskse.expr);
+      if_stmt = build3_v (COND_EXPR, maskse.expr, tmp,
+			  build_empty_stmt (input_location));
+      gfc_add_expr_to_block (&block, if_stmt);
+      tmp = gfc_finish_block (&block);
+    }
+
+  gfc_add_expr_to_block (&se->pre, tmp);
+  se->expr = convert (type, resvar);
+
+}
+
 /* Emit code for minval or maxval intrinsic.  There are many different cases
    we need to handle.  For performance reasons we sometimes create two
    loops instead of one, where the second one is much simpler.
@@ -9015,6 +9228,10 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
 	      conv_generic_with_optional_char_arg (se, expr, 1, 3);
 	      break;
 
+	    case GFC_ISYM_FINDLOC:
+	      gfc_conv_intrinsic_findloc (se, expr);
+	      break;
+
 	    case GFC_ISYM_MINLOC:
 	      gfc_conv_intrinsic_minmaxloc (se, expr, LT_EXPR);
 	      break;
@@ -9454,6 +9671,10 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
       gfc_conv_intrinsic_minmaxloc (se, expr, GT_EXPR);
       break;
 
+    case GFC_ISYM_FINDLOC:
+      gfc_conv_intrinsic_findloc (se, expr);
+      break;
+
     case GFC_ISYM_MAXVAL:
       gfc_conv_intrinsic_minmaxval (se, expr, GT_EXPR);
       break;
@@ -9933,6 +10154,7 @@ gfc_is_intrinsic_libcall (gfc_expr * expr)
     case GFC_ISYM_ALL:
     case GFC_ISYM_ANY:
     case GFC_ISYM_COUNT:
+    case GFC_ISYM_FINDLOC:
     case GFC_ISYM_JN2:
     case GFC_ISYM_IANY:
     case GFC_ISYM_IALL: