re PR fortran/45424 ([F08] Add IS_CONTIGUOUS intrinsic)

2019-01-07  Thomas Koenig  <tkoenig@gcc.gnu.org>
	Harald Anlauf <anlauf@gmx.de>
	Tobias Burnus <burnus@gcc.gnu.org>

	PR fortran/45424
	* check.c (gfc_check_is_contiguous): New function.
	* expr.c (gfc_is_not_contiguous): New function.
	* gfortran.h (gfc_isym_id): Add GFC_ISYM_IS_CONTIGUOUS.
	Add prototype for gfc_is_not_contiguous.
	* intrinsic.c (do_ts29113_check): Add GFC_ISYM_IS_CONTIGUOUS.
	(add_function): Add is_contiguous.
	* intrinsic.h: Add prototypes for gfc_check_is_contiguous,
	gfc_simplify_is_contiguous and gfc_resolve_is_contiguous.
	* intrinsic.texi: Add IS_CONTIGUOUS.
	* iresolve.c (gfc_resolve_is_contiguous): New function.
	* simplify.c (gfc_simplify_is_contiguous): New function.
	* trans-decl.c (gfor_fncecl_is_contiguous0): New variable.
	(gfc_build_intrinsic_function_decl): Add it.
	* trans-intrinsic.c (gfc_conv_intrinsic_is_contiguous): New
	function.
	(gfc_conv_intrinsic_function): Handle GFC_ISYM_IS_CONTIGUOUS.

2019-01-07  Thomas Koenig  <tkoenig@gcc.gnu.org>
	Harald Anlauf <anlauf@gmx.de>
	Tobias Burnus <burnus@gcc.gnu.org>

	PR fortran/45424
	* Makefile.am: Add intrinsics/is_contiguous.c.
	* Makefile.in: Regenerated.
	* gfortran.map: Add _gfortran_is_contiguous0.
	* intrinsics/is_contiguous.c: New file.
	* libgfortran.h: Add prototype for is_contiguous0.

2019-01-07  Thomas Koenig  <tkoenig@gcc.gnu.org>
	Harald Anlauf <anlauf@gmx.de>
	Tobias Burnus <burnus@gcc.gnu.org>

	* gfortran.dg/is_contiguous_1.f90: New test.
	* gfortran.dg/is_contiguous_2.f90: New test.
	* gfortran.dg/is_contiguous_3.f90: New test.


Co-Authored-By: Harald Anlauf <anlauf@gmx.de>
Co-Authored-By: Tobias Burnus <burnus@gcc.gnu.org>

From-SVN: r267657

1 files changed, 77 insertions, 0 deletions

diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index 96a749e..b997ae5 100644
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -2828,6 +2828,79 @@ gfc_conv_intrinsic_rank (gfc_se *se, gfc_expr *expr)
 }
 
 
+static void
+gfc_conv_intrinsic_is_contiguous (gfc_se * se, gfc_expr * expr)
+{
+  gfc_expr *arg;
+  gfc_ss *ss;
+  gfc_se argse;
+  tree desc, tmp, stride, extent, cond;
+  int i;
+  tree fncall0;
+  gfc_array_spec *as;
+
+  arg = expr->value.function.actual->expr;
+
+  if (arg->ts.type == BT_CLASS)
+    gfc_add_class_array_ref (arg);
+
+  ss = gfc_walk_expr (arg);
+  gcc_assert (ss != gfc_ss_terminator);
+  gfc_init_se (&argse, NULL);
+  argse.data_not_needed = 1;
+  gfc_conv_expr_descriptor (&argse, arg);
+
+  as = gfc_get_full_arrayspec_from_expr (arg);
+
+  /* Create:  stride[0] == 1 && stride[1] == extend[0]*stride[0] && ...
+     Note in addition that zero-sized arrays don't count as contiguous.  */
+
+  if (as && as->type == AS_ASSUMED_RANK)
+    {
+      /* Build the call to is_contiguous0.  */
+      argse.want_pointer = 1;
+      gfc_conv_expr_descriptor (&argse, arg);
+      gfc_add_block_to_block (&se->pre, &argse.pre);
+      gfc_add_block_to_block (&se->post, &argse.post);
+      desc = gfc_evaluate_now (argse.expr, &se->pre);
+      fncall0 = build_call_expr_loc (input_location,
+				     gfor_fndecl_is_contiguous0, 1, desc);
+      se->expr = fncall0;
+      se->expr = convert (logical_type_node, se->expr);
+    }
+  else
+    {
+      gfc_add_block_to_block (&se->pre, &argse.pre);
+      gfc_add_block_to_block (&se->post, &argse.post);
+      desc = gfc_evaluate_now (argse.expr, &se->pre);
+  
+      stride = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[0]);
+      cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
+			      stride, build_int_cst (TREE_TYPE (stride), 1));
+
+      for (i = 0; i < expr->value.function.actual->expr->rank - 1; i++)
+	{
+	  tmp = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]);
+	  extent = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[i]);
+	  extent = fold_build2_loc (input_location, MINUS_EXPR,
+				    gfc_array_index_type, extent, tmp);
+	  extent = fold_build2_loc (input_location, PLUS_EXPR,
+				    gfc_array_index_type, extent,
+				    gfc_index_one_node);
+	  tmp = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[i]);
+	  tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
+				 tmp, extent);
+	  stride = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[i+1]);
+	  tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
+				 stride, tmp);
+	  cond = fold_build2_loc (input_location, TRUTH_AND_EXPR,
+				  boolean_type_node, cond, tmp);
+	}
+      se->expr = convert (gfc_typenode_for_spec (&expr->ts), cond);
+    }
+}
+
+
 /* Evaluate a single upper or lower bound.  */
 /* TODO: bound intrinsic generates way too much unnecessary code.  */
 
@@ -9731,6 +9804,10 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
       gfc_conv_has_intvalue (se, expr, LIBERROR_EOR);
       break;
 
+    case GFC_ISYM_IS_CONTIGUOUS:
+      gfc_conv_intrinsic_is_contiguous (se, expr);
+      break;
+
     case GFC_ISYM_ISNAN:
       gfc_conv_intrinsic_isnan (se, expr);
       break;