This is the mail archive of the fortran@gcc.gnu.org mailing list for the GNU Fortran project.


Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]
Other format: [Raw text]

[Fortran-Dev] Update SIZE/SHAPE and extent handling


This patch changes the setting of the extent field. TS29113 requires that extent is >= 0; before we used ubound directly, i.e. extent = ubound - lbound+1. Thus, the extent could become negative. Actually, TS29113 also permits negative extents: For assumed-size arrays.

Now since the extent is correctly set, LBOUND/UBOUND can be simplified - making the code more readable and speeding it up. Additionally, it will make it easier to shift the internal descriptor's lower_bound to 0 for nonallocatable/nonpointer variables.

Additionally, SHAPE/SIZE have to be converted to directly generated code - before they were implemented using library calls. One tricky part is that "SIZE(array, dim)" permits that "dim" is an optional, which means that one only knows at runtime whether the variable is present or not.

Build and regtested on x86-64-gnu-linux.
I intent to commit the patch soon. However, patch reviews, comments and remarks to the patch and to the Branch in general are welcome.

* * *

TODO:
- Changing the internal descriptor's lower_bound to 0 for nonallocatable/nonpointer variables - and removing the offset field from the descriptor. (Those changes are related.)
- Fixing the remaining regressions
- Support byte strides (partially handled but parts of the code still assume element-based strides) - Fix other issues as they pop up - also by auditing the setting (and use) of elem_len, ubound/extent, stride, type, attribute, and lower_bound.

Tobias

PS: I still get the following 15 test-suite failures:

gfortran.dg/auto_char_dummy_array_1.f90
gfortran.dg/auto_char_len_3.f90
gfortran.dg/class_array_1.f03
gfortran.dg/class_array_2.f03
gfortran.dg/class_to_type_1.f03
gfortran.dg/class_to_type_2.f90
gfortran.dg/move_alloc_13.f90
gfortran.dg/mvbits_7.f90
gfortran.dg/mvbits_8.f90
gfortran.dg/proc_decl_23.f90
gfortran.dg/select_type_26.f03
gfortran.dg/select_type_27.f03
gfortran.dg/subref_array_pointer_2.f90
gfortran.dg/transfer_intrinsic_3.f90
gfortran.dg/unlimited_polymorphic_1.f03
2013-05-05  Tobias Burnus  <burnus@net-b.de>

	* trans-array.c (gfc_conv_ss_startstride, set_loop_bounds): Handle
	GFC_ISYM_SHAPE in the scalarizer.
	(gfc_array_init_size, gfc_conv_expr_descriptor): Ensure that
	extent is never negative except for assumed size arrays.
	* trans-intrinsic.c (gfc_conv_intrinsic_bound): Optimizations
	of the bounds handling.
	(gfc_conv_intrinsic_size): Handle SIZE and SHAPE directly without
	calling the library.
	(gfc_conv_intrinsic_function, gfc_add_intrinsic_ss_code,
	gfc_walk_intrinsic_bound, gfc_is_intrinsic_libcall,
	gfc_walk_intrinsic_function): Handle SHAPE.

2013-05-05  Tobias Burnus  <burnus@net-b.de>

	* gfortran.dg/assumed_rank_13.f90: New.
	* gfortran.dg/array_section_2.f90: Remove tree-dump check.
	* gfortran.dg/assign_10.f90: Update dump-times.
	* gfortran.dg/transpose_optimization_2.f90: Ditto.
	* gfortran.dg/coarray_12.f90: Update dump pattern.
	* gfortran.dg/coarray_30.f90: Ditto.
	* gfortran.dg/intrinsic_size_3.f90: Ditto.

diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 34421df..08f12aa 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -4012,6 +4012,7 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop)
 	    case GFC_ISYM_UBOUND:
 	    case GFC_ISYM_LCOBOUND:
 	    case GFC_ISYM_UCOBOUND:
+	    case GFC_ISYM_SHAPE:
 	    case GFC_ISYM_THIS_IMAGE:
 	      loop->dimen = ss->dimen;
 	      goto done;
@@ -4062,11 +4063,13 @@ done:
 	    /* Fall through to supply start and stride.  */
 	    case GFC_ISYM_LBOUND:
 	    case GFC_ISYM_UBOUND:
+	    case GFC_ISYM_SHAPE:
 	      {
 		gfc_expr *arg;
 
 		/* This is the variant without DIM=...  */
-		gcc_assert (expr->value.function.actual->next->expr == NULL);
+		gcc_assert (expr->value.function.actual->next->expr == NULL
+			    || expr->value.function.isym->id == GFC_ISYM_SHAPE);
 
 		arg = expr->value.function.actual->expr;
 		if (arg->rank == -1)
@@ -4818,10 +4821,12 @@ set_loop_bounds (gfc_loopinfo *loop)
 	      {
 		gfc_expr *expr = loopspec[n]->info->expr;
 
-		/* The {l,u}bound of an assumed rank.  */
+		/* The {l,u}bound and shape of an assumed rank.  */
 		gcc_assert ((expr->value.function.isym->id == GFC_ISYM_LBOUND
-			     || expr->value.function.isym->id == GFC_ISYM_UBOUND)
-			     && expr->value.function.actual->next->expr == NULL
+			     || expr->value.function.isym->id == GFC_ISYM_UBOUND
+			     || expr->value.function.isym->id == GFC_ISYM_SHAPE)
+			     && (expr->value.function.actual->next->expr == NULL
+				 || expr->value.function.isym->id == GFC_ISYM_SHAPE)
 			     && expr->value.function.actual->expr->rank == -1);
 
 		loop->to[n] = info->end[dim];
@@ -5153,16 +5158,22 @@ gfc_array_init_size (tree descriptor, gfc_typespec *ts,
       offset = fold_build2_loc (input_location, MINUS_EXPR,
 				gfc_array_index_type, offset, tmp);
 
-      /* Set upper bound.  */
+      /* Set extent.  */
       gfc_init_se (&se, NULL);
       gcc_assert (ubound);
       gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
       gfc_add_block_to_block (pblock, &se.pre);
-
-      gfc_conv_descriptor_ubound_set (descriptor_block, descriptor,
-				      gfc_rank_cst[n], se.expr);
       conv_ubound = se.expr;
 
+      tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+			     conv_ubound, conv_lbound);
+      tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
+			     tmp, gfc_index_one_node);
+      tmp = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
+			     tmp, gfc_index_zero_node);
+      gfc_conv_descriptor_extent_set (descriptor_block, descriptor,
+				      gfc_rank_cst[n], tmp);
+
       /* Store the stride.  */
       gfc_conv_descriptor_stride_set (descriptor_block, descriptor,
 				      gfc_rank_cst[n], stride);
@@ -6666,6 +6677,7 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
   tree elem_len;
   int full;
   bool subref_array_target = false;
+  bool assumed_size = false;
   gfc_expr *arg, *ss_expr;
 
   if (se->want_coarray)
@@ -6712,6 +6724,9 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
       if (se->force_tmp)
 	need_tmp = 1;
 
+      if (info->ref->u.ar.as->type == AS_ASSUMED_SIZE)
+	assumed_size = true;
+
       if (need_tmp)
 	full = 0;
       else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
@@ -7084,9 +7099,22 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
 	  gfc_conv_descriptor_lbound_set (&loop.pre, parm,
 					  gfc_rank_cst[dim], from);
 
-	  /* Set the new upper bound.  */
-	  gfc_conv_descriptor_ubound_set (&loop.pre, parm,
-					  gfc_rank_cst[dim], to);
+	  /* Set the new extent.  */
+	  if (assumed_size && dim == ndim - 1)
+	    tmp = build_int_cst (gfc_array_index_type, -1);
+	  else
+	    {
+	      tmp = fold_build2_loc (input_location, MINUS_EXPR,
+				     gfc_array_index_type, to, from);
+	      tmp = fold_build2_loc (input_location, PLUS_EXPR,
+				     gfc_array_index_type, tmp,
+				     gfc_index_one_node);
+	      tmp = fold_build2_loc (input_location, MAX_EXPR,
+				     gfc_array_index_type, tmp,
+				     gfc_index_zero_node);
+	    }
+	  gfc_conv_descriptor_extent_set (&loop.pre, parm,
+					  gfc_rank_cst[dim], tmp);
 
 	  /* Multiply the stride by the section stride to get the
 	     total stride.  */
diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index af88a38..42fdaf7 100644
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -1293,12 +1293,14 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
   tree type;
   tree bound;
   tree tmp;
-  tree cond, cond1, cond3, cond4;
+  tree cond;
   tree lbound;
   tree extent;
   gfc_se argse;
+  gfc_ref *ref;
+  gfc_array_ref *ar;
   gfc_array_spec * as;
-  bool assumed_rank_lb_one;
+  bool lb_one;
 
   arg = expr->value.function.actual;
   arg2 = arg->next;
@@ -1338,7 +1340,13 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
 
   desc = argse.expr;
 
-  as = gfc_get_full_arrayspec_from_expr (arg->expr);
+  for (ref = arg->expr->ref; ref; ref = ref->next)
+    if (ref->type == REF_ARRAY
+        && (ref->u.ar.type == AR_FULL || ref->u.ar.type == AR_SECTION))
+      break;
+
+  ar = ref ? &ref->u.ar : NULL;
+  as = ar ? ar->as : NULL;
 
   if (INTEGER_CST_P (bound))
     {
@@ -1376,18 +1384,22 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
     }
 
   /* Take care of the lbound shift for assumed-rank arrays, which are
-     nonallocatable and nonpointers. Those has a lbound of 1.  */
-  assumed_rank_lb_one = as && as->type == AS_ASSUMED_RANK
-			&& ((arg->expr->ts.type != BT_CLASS
-			     && !arg->expr->symtree->n.sym->attr.allocatable
-			     && !arg->expr->symtree->n.sym->attr.pointer)
-			    || (arg->expr->ts.type == BT_CLASS
-			     && !CLASS_DATA (arg->expr)->attr.allocatable
-			     && !CLASS_DATA (arg->expr)->attr.class_pointer));
+     nonallocatable and nonpointers. Those have a lbound of 1.  */
+  lb_one = as && as->type == AS_ASSUMED_RANK
+	   && ((arg->expr->ts.type != BT_CLASS
+		&& !arg->expr->symtree->n.sym->attr.allocatable
+		&& !arg->expr->symtree->n.sym->attr.pointer)
+	       || (arg->expr->ts.type == BT_CLASS
+		   && !CLASS_DATA (arg->expr)->attr.allocatable
+		   && !CLASS_DATA (arg->expr)->attr.class_pointer));
+  lb_one = lb_one || ar == NULL || ar->type != AR_FULL;
+
+  if (ref && ref->next)
+    lb_one = true;
 
   lbound = gfc_conv_descriptor_lbound_get (desc, bound);
   extent = gfc_conv_descriptor_extent_get (desc, bound);
-  
+
   /* 13.14.53: Result value for LBOUND
 
      Case (i): For an array section or for an array expression other than a
@@ -1409,76 +1421,44 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
                not have size zero and has value zero if dimension DIM has
                size zero.  */
 
-  if (!upper && assumed_rank_lb_one)
+  if (!upper && lb_one)
     se->expr = gfc_index_one_node;
-  else if (as)
+  else if (lb_one)
+    se->expr = extent;
+  else
     {
-      tree stride = gfc_conv_descriptor_stride_get (desc, bound);
-
-      cond1 = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
-			       extent, gfc_index_zero_node);
-      cond3 = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
-			       stride, gfc_index_zero_node);
-      cond3 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
-			       boolean_type_node, cond3, cond1);
-      cond4 = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
-			       stride, gfc_index_zero_node);
-
-      if (upper)
+      cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
+			      extent, gfc_index_zero_node);
+      if (!upper)
 	{
-	  tree cond5;
-	  cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
-				  boolean_type_node, cond3, cond4);
-	  cond5 = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
-				   gfc_index_one_node, lbound);
-	  cond5 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
-				   boolean_type_node, cond4, cond5);
-
-	  cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
-				  boolean_type_node, cond, cond5);
+	  tree cond2;
 
-	  if (assumed_rank_lb_one)
-            tmp = extent;
+          if (as->type == AS_ASSUMED_SIZE)
+	    cond2 = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
+				     bound,
+				     build_int_cst (TREE_TYPE (bound),
+						    arg->expr->rank - 1));
 	  else
-	    {
-	      tmp = fold_build2_loc (input_location, PLUS_EXPR,
-			       gfc_array_index_type, extent, lbound);
-	      tmp = fold_build2_loc (input_location, MINUS_EXPR,
-			       gfc_array_index_type, tmp, gfc_index_one_node);
-	    }
+	    cond2 = boolean_false_node;
+
+	  cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
+				  boolean_type_node, cond, cond2);
 
 	  se->expr = fold_build3_loc (input_location, COND_EXPR,
 				      gfc_array_index_type, cond,
-				      tmp, gfc_index_zero_node);
+				      lbound, gfc_index_one_node);
 	}
       else
 	{
-	  if (as->type == AS_ASSUMED_SIZE)
-	    cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
-				    bound, build_int_cst (TREE_TYPE (bound),
-							  arg->expr->rank - 1));
-	  else
-	    cond = boolean_false_node;
-
-	  cond1 = fold_build2_loc (input_location, TRUTH_OR_EXPR,
-				   boolean_type_node, cond3, cond4);
-	  cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
-				  boolean_type_node, cond, cond1);
-
+	  tmp = fold_build2_loc (input_location, PLUS_EXPR,
+				 gfc_array_index_type, extent, lbound);
+	  tmp = fold_build2_loc (input_location, MINUS_EXPR,
+				 gfc_array_index_type, tmp, gfc_index_one_node);
 	  se->expr = fold_build3_loc (input_location, COND_EXPR,
 				      gfc_array_index_type, cond,
-				      lbound, gfc_index_one_node);
+				      tmp, gfc_index_zero_node);
 	}
     }
-  else
-    {
-      if (upper)
-	se->expr = fold_build2_loc (input_location, MAX_EXPR,
-				    gfc_array_index_type, extent,
-				    gfc_index_zero_node);
-      else
-	se->expr = gfc_index_one_node;
-    }
 
   type = gfc_typenode_for_spec (&expr->ts);
   se->expr = convert (type, se->expr);
@@ -5049,91 +5029,188 @@ gfc_conv_intrinsic_set_exponent (gfc_se * se, gfc_expr * expr)
 
 
 static void
-gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr)
+gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr, bool shape)
 {
-  gfc_actual_arglist *actual;
-  tree arg1;
+  gfc_actual_arglist *arg;
+  gfc_actual_arglist *arg2;
+  tree desc;
   tree type;
-  tree fncall0;
-  tree fncall1;
+  tree exit_label, tmp, cond, extent, size;
+  tree arg2_var = NULL_TREE, present = NULL_TREE, bound = NULL_TREE;
   gfc_se argse;
+  gfc_array_spec * as;
+  stmtblock_t loop;
+  bool optional;
 
-  gfc_init_se (&argse, NULL);
-  actual = expr->value.function.actual;
+  arg = expr->value.function.actual;
+  arg2 = arg->next;
 
-  if (actual->expr->ts.type == BT_CLASS)
-    gfc_add_class_array_ref (actual->expr);
+  optional = !shape && arg2->expr && arg2->expr->expr_type == EXPR_VARIABLE
+	     && arg2->expr->symtree->n.sym->attr.optional && !arg2->expr->ref;
 
-  argse.want_pointer = 1;
-  argse.data_not_needed = 1;
-  gfc_conv_expr_descriptor (&argse, actual->expr);
+  /* For SIZE, the dim= variable can be an optional, which requires special
+     handling.  */
+
+  if (se->ss)
+    {
+      /* Create an implicit second parameter from the loop variable.  */
+      gcc_assert (shape);
+      gcc_assert (se->loop->dimen == 1);
+      gcc_assert (se->ss->info->expr == expr);
+      gfc_advance_se_ss_chain (se);
+      bound = se->loop->loopvar[0];
+      bound = fold_build2_loc (input_location, MINUS_EXPR,
+			       gfc_array_index_type, bound,
+			       se->loop->from[0]);
+    }
+  else if (arg2->expr)
+    {
+      /* use the passed argument.  */
+      gcc_assert (!shape);
+      gfc_init_se (&argse, NULL);
+      gfc_conv_expr_type (&argse, arg2->expr, gfc_array_index_type);
+      gfc_add_block_to_block (&se->pre, &argse.pre);
+      arg2_var = argse.expr;
+      /* Convert from one based to zero based.  */
+      if (!optional)
+	bound = fold_build2_loc (input_location, MINUS_EXPR,
+				 gfc_array_index_type, arg2_var,
+				 gfc_index_one_node);
+    }
+
+  if (!se->ss && (!arg2->expr || optional))
+    {
+      /* SIZE without dim= - or with optional dim.  */
+      gcc_assert (!shape);
+      bound = gfc_create_var (integer_type_node, NULL);
+
+      if (optional)
+	present = gfc_conv_expr_present (arg2->expr->symtree->n.sym);
+    }
+
+  /* TODO: don't re-evaluate the descriptor on each iteration.  */
+  /* Get a descriptor for the first parameter.  */
+  gfc_init_se (&argse, NULL);
+  gfc_conv_expr_descriptor (&argse, arg->expr);
   gfc_add_block_to_block (&se->pre, &argse.pre);
   gfc_add_block_to_block (&se->post, &argse.post);
-  arg1 = gfc_evaluate_now (argse.expr, &se->pre);
 
-  /* Build the call to size0.  */
-  fncall0 = build_call_expr_loc (input_location,
-			     gfor_fndecl_size0, 1, arg1);
+  desc = argse.expr;
 
-  actual = actual->next;
+  as = gfc_get_full_arrayspec_from_expr (arg->expr);
 
-  if (actual->expr)
+  if (arg2_var != NULL_TREE && INTEGER_CST_P (arg2_var))
     {
-      gfc_init_se (&argse, NULL);
-      gfc_conv_expr_type (&argse, actual->expr,
-			  gfc_array_index_type);
-      gfc_add_block_to_block (&se->pre, &argse.pre);
+      int hi, low;
 
-      /* Unusually, for an intrinsic, size does not exclude
-	 an optional arg2, so we must test for it.  */  
-      if (actual->expr->expr_type == EXPR_VARIABLE
-	    && actual->expr->symtree->n.sym->attr.dummy
-	    && actual->expr->symtree->n.sym->attr.optional)
-	{
-	  tree tmp;
-	  /* Build the call to size1.  */
-	  fncall1 = build_call_expr_loc (input_location,
-				     gfor_fndecl_size1, 2,
-				     arg1, argse.expr);
-
-	  gfc_init_se (&argse, NULL);
-	  argse.want_pointer = 1;
-	  argse.data_not_needed = 1;
-	  gfc_conv_expr (&argse, actual->expr);
-	  gfc_add_block_to_block (&se->pre, &argse.pre);
-	  tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
-				 argse.expr, null_pointer_node);
-	  tmp = gfc_evaluate_now (tmp, &se->pre);
-	  se->expr = fold_build3_loc (input_location, COND_EXPR,
-				      pvoid_type_node, tmp, fncall1, fncall0);
-	}
-      else
-	{
-	  se->expr = NULL_TREE;
-	  argse.expr = fold_build2_loc (input_location, MINUS_EXPR,
-					gfc_array_index_type,
-					argse.expr, gfc_index_one_node);
-	}
+      hi = TREE_INT_CST_HIGH (arg2_var);
+      low = TREE_INT_CST_LOW (arg2_var);
+      if (hi || low < 0
+	  || ((!as || as->type != AS_ASSUMED_RANK)
+	      && low > GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc)))
+	  || low > GFC_MAX_DIMENSIONS)
+	gfc_error ("'dim' argument of SIZE intrinsic at %L is not a valid "
+		   "dimension index", &expr->where);
     }
-  else if (expr->value.function.actual->expr->rank == 1)
+
+  if (arg2_var != NULL_TREE
+      && (!INTEGER_CST_P (arg2_var) || (as && as->type == AS_ASSUMED_RANK)))
     {
-      argse.expr = gfc_index_zero_node;
-      se->expr = NULL_TREE;
+      if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
+        {
+          arg2_var = gfc_evaluate_now (arg2_var, &se->pre);
+          cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
+				  arg2_var,
+				  build_int_cst (TREE_TYPE (arg2_var), 1));
+	  if (as && as->type == AS_ASSUMED_RANK)
+	    tmp = gfc_conv_descriptor_rank (desc);
+	  else
+	    tmp = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))];
+          tmp = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
+				 arg2_var,
+				 fold_convert (TREE_TYPE (arg2_var), tmp));
+          cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
+				  boolean_type_node, cond, tmp);
+	  if (optional)
+	    cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
+				    boolean_type_node, present, cond);
+          gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
+				   gfc_msg_fault);
+        }
     }
-  else
-    se->expr = fncall0;
 
-  if (se->expr == NULL_TREE)
+  extent = gfc_conv_descriptor_extent_get (desc, bound);
+  type = gfc_typenode_for_spec (&expr->ts);
+
+  if (shape || (arg2->expr && !optional))
     {
-      arg1 = build_fold_indirect_ref_loc (input_location, arg1);
-      se->expr = gfc_conv_descriptor_extent_get (arg1, argse.expr);
-      se->expr = fold_build2_loc (input_location, MAX_EXPR,
-				  gfc_array_index_type, se->expr,
-				  gfc_index_zero_node);
+      se->expr = convert (type, extent);
+      return;
     }
 
-  type = gfc_typenode_for_spec (&expr->ts);
-  se->expr = convert (type, se->expr);
+  /* bound = 0; - or: bound = present ? arg2_var - 1 : 0;
+     size = 1;
+     for (;;)
+       {
+	 if (bound >= rank) - or: if (bound >= (present ? arg2_var : rank))
+	   goto exit;
+	 size = size * extent[bound];
+	 bound++;
+       }
+     exit:  */
+
+  /* bound = 0; - or: bound = present ? arg2_var : 0;  */
+  tmp = build_int_cst (integer_type_node, 0);
+  if (optional)
+    {
+      tree tmp2 = fold_build2_loc (input_location, MINUS_EXPR,
+				   integer_type_node,
+				   fold_convert (integer_type_node, arg2_var),
+				   gfc_index_one_node);
+      tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node,
+			     present, tmp2, tmp);
+    }
+  gfc_add_modify (&se->pre, bound, tmp);
+
+  exit_label = gfc_build_label_decl (NULL_TREE);
+  TREE_USED (exit_label) = 1;
+
+  size = gfc_create_var (gfc_array_index_type, NULL);
+  gfc_add_modify (&se->pre, size, gfc_index_one_node);
+
+  gfc_init_block (&loop);
+
+  /* Exit condition:  if (bound >= rank-1) goto exit_label.  */
+  tmp = fold_convert (integer_type_node, gfc_conv_descriptor_rank (desc));
+  if (optional)
+    tmp = fold_build3_loc (input_location, COND_EXPR,
+			   integer_type_node, present,
+			   fold_convert (integer_type_node, arg2_var), tmp);
+  cond = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, bound,
+			  tmp);
+  tmp = build1_v (GOTO_EXPR, exit_label);
+  tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
+                         build_empty_stmt (input_location));
+  gfc_add_expr_to_block (&loop, tmp);
+
+  gfc_add_modify (&loop, size,
+		  fold_build2_loc (input_location, MULT_EXPR,
+				   gfc_array_index_type, size, extent));
+
+  gfc_add_modify (&loop, bound,
+                  fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
+				   bound,
+				   build_int_cst (integer_type_node, 1)));
+
+  tmp = gfc_finish_block (&loop);
+  tmp = build1_v (LOOP_EXPR, tmp);
+  gfc_add_expr_to_block (&se->pre, tmp);
+
+  /* The exit label.  */
+  tmp = build1_v (LABEL_EXPR, exit_label);
+  gfc_add_expr_to_block (&se->pre, tmp);
+
+  se->expr = convert (type, size);
 }
 
 
@@ -5185,7 +5262,7 @@ gfc_conv_intrinsic_sizeof (gfc_se *se, gfc_expr *expr)
 	se->expr = size_of_string_in_bytes (arg->ts.kind,
 					    argse.string_length);
       else
-	se->expr = fold_convert (gfc_array_index_type, size_in_bytes (type)); 
+	se->expr = fold_convert (gfc_array_index_type, size_in_bytes (type));
     }
   else
     {
@@ -5199,7 +5276,7 @@ gfc_conv_intrinsic_sizeof (gfc_se *se, gfc_expr *expr)
 	tmp = size_of_string_in_bytes (arg->ts.kind, argse.string_length);
       else
 	tmp = fold_convert (gfc_array_index_type,
-			    size_in_bytes (type)); 
+			    size_in_bytes (type));
       gfc_add_modify (&argse.pre, source_bytes, tmp);
 
       /* Obtain the size of the array in bytes.  */
@@ -7008,12 +7085,16 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
       gfc_conv_intrinsic_scale (se, expr);
       break;
 
+    case GFC_ISYM_SHAPE:
+      gfc_conv_intrinsic_size (se, expr, true);
+      break;
+
     case GFC_ISYM_SIGN:
       gfc_conv_intrinsic_sign (se, expr);
       break;
 
     case GFC_ISYM_SIZE:
-      gfc_conv_intrinsic_size (se, expr);
+      gfc_conv_intrinsic_size (se, expr, false);
       break;
 
     case GFC_ISYM_SIZEOF:
@@ -7325,6 +7406,7 @@ gfc_add_intrinsic_ss_code (gfc_loopinfo * loop ATTRIBUTE_UNUSED, gfc_ss * ss)
     case GFC_ISYM_LBOUND:
     case GFC_ISYM_UCOBOUND:
     case GFC_ISYM_LCOBOUND:
+    case GFC_ISYM_SHAPE:
     case GFC_ISYM_THIS_IMAGE:
       break;
 
@@ -7343,8 +7425,9 @@ gfc_walk_intrinsic_bound (gfc_ss * ss, gfc_expr * expr)
   if (expr->value.function.actual->expr->ts.type == BT_CLASS)
     gfc_add_class_array_ref (expr->value.function.actual->expr);
 
-  /* The two argument version returns a scalar.  */
-  if (expr->value.function.actual->next->expr)
+  /* The two argument version returns a scalar, except for SHAPE.  */
+  if (expr->value.function.isym->id != GFC_ISYM_SHAPE
+      && expr->value.function.actual->next->expr)
     return ss;
 
   return gfc_get_array_ss (ss, expr, 1, GFC_SS_INTRINSIC);
@@ -7427,7 +7510,6 @@ gfc_is_intrinsic_libcall (gfc_expr * expr)
     case GFC_ISYM_PARITY:
     case GFC_ISYM_PRODUCT:
     case GFC_ISYM_SUM:
-    case GFC_ISYM_SHAPE:
     case GFC_ISYM_SPREAD:
     case GFC_ISYM_YN2:
       /* Ignore absent optional parameters.  */
@@ -7474,6 +7556,7 @@ gfc_walk_intrinsic_function (gfc_ss * ss, gfc_expr * expr,
     case GFC_ISYM_UBOUND:
     case GFC_ISYM_UCOBOUND:
     case GFC_ISYM_THIS_IMAGE:
+    case GFC_ISYM_SHAPE:
       return gfc_walk_intrinsic_bound (ss, expr);
 
     case GFC_ISYM_TRANSFER:
diff --git a/gcc/testsuite/gfortran.dg/array_section_2.f90 b/gcc/testsuite/gfortran.dg/array_section_2.f90
index 97010b0..f50269b 100644
--- a/gcc/testsuite/gfortran.dg/array_section_2.f90
+++ b/gcc/testsuite/gfortran.dg/array_section_2.f90
@@ -1,16 +1,17 @@
 ! { dg-do compile }
-! { dg-options "-fdump-tree-original" }
 !
 ! PR38033 - size(a) was not stabilized correctly and so the expression was
 ! evaluated twice outside the loop and then within the scalarization loops.
 !
 ! Contributed by Thomas Bruel  <tmbdev@gmail.com>
 !
+! Note: With the new array descriptor, which uses extent directly and inlined
+! SIZE, this is no longer simply testable in the dump.
+! (Before, the code had a -fdump-tree-original check.)
+!
 program test
    integer, parameter :: n = 100
    real, pointer :: a(:),temp(:)  ! pointer or allocatable have the same effect
    allocate(a(n), temp(n))
    temp(1:size(a)) = a
 end program
-! { dg-final { scan-tree-dump-times "MAX_EXPR\[^\n\t\]+extent, 0" 1 "original" } }
-! { dg-final { cleanup-tree-dump "original" } }
diff --git a/gcc/testsuite/gfortran.dg/assign_10.f90 b/gcc/testsuite/gfortran.dg/assign_10.f90
index e37a414..ea91423 100644
--- a/gcc/testsuite/gfortran.dg/assign_10.f90
+++ b/gcc/testsuite/gfortran.dg/assign_10.f90
@@ -23,6 +23,6 @@ end
 ! cases will all yield a temporary, so that atmp appears 18 times.
 ! Note that it is the kind conversion that generates the temp.
 !
-! { dg-final { scan-tree-dump-times "parm" 28 "original" } }
+! { dg-final { scan-tree-dump-times "parm" 26 "original" } }
 ! { dg-final { scan-tree-dump-times "atmp" 26 "original" } }
 ! { dg-final { cleanup-tree-dump "original" } }
diff --git a/gcc/testsuite/gfortran.dg/coarray_12.f90 b/gcc/testsuite/gfortran.dg/coarray_12.f90
index bddf6a5..5ae2667 100644
--- a/gcc/testsuite/gfortran.dg/coarray_12.f90
+++ b/gcc/testsuite/gfortran.dg/coarray_12.f90
@@ -46,14 +46,14 @@ end subroutine testAlloc5
 
 
 ! { dg-final { scan-tree-dump-times "a.dim.0..lower_bound = 1;"     1 "original" } }
-! { dg-final { scan-tree-dump-times "a.dim.0..extent = .*nn - a.dim.0..lower_bound. \\+ 1;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "a.dim.0..extent = MAX_EXPR <.*nn, 0>;" 1 "original" } }
 ! { dg-final { scan-tree-dump-times "a.dim.1..lower_bound = 1;"     1 "original" } }
 ! { dg-final { scan-tree-dump-times "a.dim.1..extent = .*mm - a.dim.1..lower_bound. \\+ 1;" 1 "original" } }
 ! { dg-final { scan-tree-dump-times "a.dim.2..lower_bound = 1;"     1 "original" } }
 ! { dg-final { scan-tree-dump-times "a.dim.2..extent"          0 "original" } }
 
 ! { dg-final { scan-tree-dump-times "xxx.dim.0..lower_bound = 1;"     1 "original" } }
-! { dg-final { scan-tree-dump-times "xxx.dim.0..extent = 2 - xxx.dim.0..lower_bound;"     1 "original" } }
+! { dg-final { scan-tree-dump-times "xxx.dim.0..extent = 1;"     1 "original" } }
 ! { dg-final { scan-tree-dump-times "xxx.dim.1..lower_bound = 1;"     1 "original" } }
 ! { dg-final { scan-tree-dump-times "xxx.dim.1..extent = 8 - xxx.dim.1..lower_bound;"     1 "original" } }
 ! { dg-final { scan-tree-dump-times "xxx.dim.2..lower_bound = -5;"    1 "original" } }
@@ -64,7 +64,7 @@ end subroutine testAlloc5
 ! { dg-final { scan-tree-dump-times "xxx.dim.4..extent"          0 "original" } }
 
 ! { dg-final { scan-tree-dump-times "yyy.dim.0..lower_bound = 1;"     1 "original" } }
-! { dg-final { scan-tree-dump-times "yyy.dim.0..extent = 2 - yyy.dim.0..lower_bound;"     1 "original" } }
+! { dg-final { scan-tree-dump-times "yyy.dim.0..extent = 1;"     1 "original" } }
 ! { dg-final { scan-tree-dump-times "yyy.dim.1..lower_bound = 1;"     1 "original" } }
 ! { dg-final { scan-tree-dump-times "yyy.dim.1..extent = 8 - yyy.dim.1..lower_bound;"     1 "original" } }
 ! { dg-final { scan-tree-dump-times "yyy.dim.2..lower_bound = -5;"    1 "original" } }
diff --git a/gcc/testsuite/gfortran.dg/coarray_30.f90 b/gcc/testsuite/gfortran.dg/coarray_30.f90
index 2cfb50a..fc678a3 100644
--- a/gcc/testsuite/gfortran.dg/coarray_30.f90
+++ b/gcc/testsuite/gfortran.dg/coarray_30.f90
@@ -11,5 +11,5 @@ program main
   write(greeting,"(a)") "z"
 end
 
-! { dg-final { scan-tree-dump-times "greeting.data = \\(void . restrict\\) __builtin_malloc \\(25\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "greeting.base_addr = \\(void . restrict\\) __builtin_malloc \\(25\\);" 1 "original" } }
 ! { dg-final { cleanup-tree-dump "original" } }
diff --git a/gcc/testsuite/gfortran.dg/intrinsic_size_3.f90 b/gcc/testsuite/gfortran.dg/intrinsic_size_3.f90
index 5917db8..178233b 100644
--- a/gcc/testsuite/gfortran.dg/intrinsic_size_3.f90
+++ b/gcc/testsuite/gfortran.dg/intrinsic_size_3.f90
@@ -22,5 +22,5 @@ program bug
   stop
 end program bug
 
-! { dg-final { scan-tree-dump-times "iszs = \\(integer\\(kind=2\\)\\) MAX_EXPR <D.\[0-9\]+->dim.0..extent, 0>;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "iszs = \\(integer\\(kind=2\\)\\) a.dim.0..extent;" 1 "original" } }
 ! { dg-final { cleanup-tree-dump "original" } }
diff --git a/gcc/testsuite/gfortran.dg/transpose_optimization_2.f90 b/gcc/testsuite/gfortran.dg/transpose_optimization_2.f90
index e8efc34..3203df7 100644
--- a/gcc/testsuite/gfortran.dg/transpose_optimization_2.f90
+++ b/gcc/testsuite/gfortran.dg/transpose_optimization_2.f90
@@ -60,6 +60,6 @@ end
 !
 ! The check below for temporaries gave 14 and 33 for "parm" and "atmp".
 !
-! { dg-final { scan-tree-dump-times "parm" 102 "original" } }
+! { dg-final { scan-tree-dump-times "parm" 90 "original" } }
 ! { dg-final { scan-tree-dump-times "atmp" 16 "original" } }
 ! { dg-final { cleanup-tree-dump "original" } }
--- /dev/null	2013-05-05 14:14:45.860065772 +0200
+++ gcc/gcc/testsuite/gfortran.dg/assumed_rank_13.f90	2013-05-05 15:56:45.726331397 +0200
@@ -0,0 +1,40 @@
+! { dg-do run }
+!
+! Ensure that SIZE/SHAPE/UBOUND/LBOUND work properly with
+! assumed-rank arrays for scalars and assumed-size arrays
+!
+program main
+  implicit none
+  integer :: A(2,2)
+  integer :: B
+  call foo(A)
+  call test2(B)
+contains
+  subroutine foo(x)
+    integer :: x(2,*)
+    call bar(x)
+  end subroutine foo
+  subroutine bar(y)
+    integer :: y(..)
+!   print *, rank(y)   ! 2
+!   print *, lbound(y) ! 1 1
+!   print *, ubound(y) ! 2 -1
+!   print *, shape(y)  ! 2 -1
+!   print *, size(y)   ! -2
+    if (rank(y) /= 2) call abort ()
+    if (any (lbound(y) /= [1, 1])) call abort
+    if (any (ubound(y) /= [2,-1])) call abort
+    if (any (shape(y)  /= [2,-1])) call abort
+    if (size(y,1) /=  2) call abort
+    if (size(y,2) /= -1) call abort
+    if (size(y)   /= -2) call abort
+  end subroutine bar
+  subroutine test2(z)
+    integer :: z(..)
+    if (rank(z) /= 0) call abort() ! 1
+    if (size(lbound(z)) /= 0) call abort() ! zero-sized array
+    if (size(ubound(z)) /= 0) call abort() ! zero-sized array
+    if (size(shape(z))  /= 0) call abort() ! zero-sized array
+    if (size(z) /= 1) call abort() ! 1
+  end subroutine test2
+end program main

Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]