diff mbox

[Fortran] Pointer remapping

Message ID 4C6D3FAB.9090901@domob.eu
State New
Headers show

Commit Message

Daniel Kraft Aug. 19, 2010, 2:28 p.m. UTC
Tobias Burnus wrote:
>  On 08/19/2010 01:00 PM, Daniel Kraft wrote:,
>> the attached patch implements pointer bounds remapping (F2003, see PR 
>> 45016) and pointer rank remapping (F2003 and generalized in F2008, see 
>> PR 29785).  To my knowledge, these two new features should be fully 
>> supported with it.
> 
> Thanks for the patch. I have not looked at it but just tried the 
> following minutely-extended example from The Fortran 2003 Handbook and 
> it fails with an ICE. (It compiles with crayftn.)
> 
> rem.f90:1:0: error: type mismatch in binary expression
> rem.f90:1:0: internal compiler error: verify_gimple failed
> 
> REAL, TARGET :: DATA(1000)
> REAL, POINTER :: DP(:), DQ(:), DR(:)
> integer :: FIRST, LAST
> !. . .
> DP(FIRST:LAST) => DATA(FIRST:LAST)
> DQ => DATA(FIRST:LAST)
> DR(0:) => DATA(FIRST:LAST)
> end

Good catch!  The attached patch fixes this by adding fold_convert's as 
appropriate (for the declared bounds of the LHS) and changes some error 
messages as discussed on IRC.

I'll retest now, but suppose there are no failures as the last test 
finished successfully.

Ok?

Cheers,
Daniel

Comments

Tobias Burnus Aug. 19, 2010, 3:45 p.m. UTC | #1
On 08/19/2010 04:28 PM, Daniel Kraft wrote:
> I'll retest now, but suppose there are no failures as the last test 
> finished successfully.
> Ok?

OK and thanks for the patch! Nit:

+	  /* If we are rank-remapping, just get the RHS's decriptor and

Typo: de(s)criptor misses an "s".


Tobias
Daniel Kraft Aug. 19, 2010, 4:08 p.m. UTC | #2
Tobias Burnus wrote:
>  On 08/19/2010 04:28 PM, Daniel Kraft wrote:
>> I'll retest now, but suppose there are no failures as the last test 
>> finished successfully.
>> Ok?
> 
> OK and thanks for the patch! Nit:
> 
> +      /* If we are rank-remapping, just get the RHS's decriptor and
> 
> Typo: de(s)criptor misses an "s".

Fixed and committed as rev. 163377.  Thanks again for the fast review! 
I'll update the wiki "status" pages and close the PRs now.

Yours,
Daniel
diff mbox

Patch

Index: gcc/fortran/trans-expr.c
===================================================================
--- gcc/fortran/trans-expr.c	(revision 163310)
+++ gcc/fortran/trans-expr.c	(working copy)
@@ -4762,21 +4762,46 @@  gfc_trans_pointer_assignment (gfc_expr *
     }
   else
     {
+      gfc_ref* remap;
+      bool rank_remap;
       tree strlen_lhs;
       tree strlen_rhs = NULL_TREE;
 
-      /* Array pointer.  */
+      /* Array pointer.  Find the last reference on the LHS and if it is an
+	 array section ref, we're dealing with bounds remapping.  In this case,
+	 set it to AR_FULL so that gfc_conv_expr_descriptor does
+	 not see it and process the bounds remapping afterwards explicitely.  */
+      for (remap = expr1->ref; remap; remap = remap->next)
+	if (!remap->next && remap->type == REF_ARRAY
+	    && remap->u.ar.type == AR_SECTION)
+	  {  
+	    remap->u.ar.type = AR_FULL;
+	    break;
+	  }
+      rank_remap = (remap && remap->u.ar.end[0]);
+
       gfc_conv_expr_descriptor (&lse, expr1, lss);
       strlen_lhs = lse.string_length;
-      switch (expr2->expr_type)
+      desc = lse.expr;
+
+      if (expr2->expr_type == EXPR_NULL)
 	{
-	case EXPR_NULL:
 	  /* Just set the data pointer to null.  */
 	  gfc_conv_descriptor_data_set (&lse.pre, lse.expr, null_pointer_node);
-	  break;
-
-	case EXPR_VARIABLE:
-	  /* Assign directly to the pointer's descriptor.  */
+	}
+      else if (rank_remap)
+	{
+	  /* If we are rank-remapping, just get the RHS's decriptor and
+	     process this later on.  */
+	  gfc_init_se (&rse, NULL);
+	  rse.direct_byref = 1;
+	  rse.byref_noassign = 1;
+	  gfc_conv_expr_descriptor (&rse, expr2, rss);
+	  strlen_rhs = rse.string_length;
+	}
+      else if (expr2->expr_type == EXPR_VARIABLE)
+	{
+	  /* Assign directly to the LHS's descriptor.  */
 	  lse.direct_byref = 1;
 	  gfc_conv_expr_descriptor (&lse, expr2, rss);
 	  strlen_rhs = lse.string_length;
@@ -4795,13 +4820,11 @@  gfc_trans_pointer_assignment (gfc_expr *
 		gfc_add_block_to_block (&lse.post, &rse.pre);
 	      gfc_add_modify (&lse.post, GFC_DECL_SPAN(decl), tmp);
 	    }
-
-	  break;
-
-	default:
+	}
+      else
+	{
 	  /* Assign to a temporary descriptor and then copy that
 	     temporary to the pointer.  */
-	  desc = lse.expr;
 	  tmp = gfc_create_var (TREE_TYPE (desc), "ptrtemp");
 
 	  lse.expr = tmp;
@@ -4809,10 +4832,130 @@  gfc_trans_pointer_assignment (gfc_expr *
 	  gfc_conv_expr_descriptor (&lse, expr2, rss);
 	  strlen_rhs = lse.string_length;
 	  gfc_add_modify (&lse.pre, desc, tmp);
-	  break;
 	}
 
       gfc_add_block_to_block (&block, &lse.pre);
+      if (rank_remap)
+	gfc_add_block_to_block (&block, &rse.pre);
+
+      /* If we do bounds remapping, update LHS descriptor accordingly.  */
+      if (remap)
+	{
+	  int dim;
+	  gcc_assert (remap->u.ar.dimen == expr1->rank);
+
+	  if (rank_remap)
+	    {
+	      /* Do rank remapping.  We already have the RHS's descriptor
+		 converted in rse and now have to build the correct LHS
+		 descriptor for it.  */
+
+	      tree dtype, data;
+	      tree offs, stride;
+	      tree lbound, ubound;
+
+	      /* Set dtype.  */
+	      dtype = gfc_conv_descriptor_dtype (desc);
+	      tmp = gfc_get_dtype (TREE_TYPE (desc));
+	      gfc_add_modify (&block, dtype, tmp);
+
+	      /* Copy data pointer.  */
+	      data = gfc_conv_descriptor_data_get (rse.expr);
+	      gfc_conv_descriptor_data_set (&block, desc, data);
+
+	      /* Copy offset but adjust it such that it would correspond
+		 to a lbound of zero.  */
+	      offs = gfc_conv_descriptor_offset_get (rse.expr);
+	      for (dim = 0; dim < expr2->rank; ++dim)
+		{
+		  stride = gfc_conv_descriptor_stride_get (rse.expr,
+							   gfc_rank_cst[dim]);
+		  lbound = gfc_conv_descriptor_lbound_get (rse.expr,
+							   gfc_rank_cst[dim]);
+		  tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
+				     stride, lbound);
+		  offs = fold_build2 (PLUS_EXPR, gfc_array_index_type,
+				      offs, tmp);
+		}
+	      gfc_conv_descriptor_offset_set (&block, desc, offs);
+
+	      /* Set the bounds as declared for the LHS and calculate strides as
+		 well as another offset update accordingly.  */
+	      stride = gfc_conv_descriptor_stride_get (rse.expr,
+						       gfc_rank_cst[0]);
+	      for (dim = 0; dim < expr1->rank; ++dim)
+		{
+		  gfc_se lower_se;
+		  gfc_se upper_se;
+
+		  gcc_assert (remap->u.ar.start[dim] && remap->u.ar.end[dim]);
+
+		  /* Convert declared bounds.  */
+		  gfc_init_se (&lower_se, NULL);
+		  gfc_init_se (&upper_se, NULL);
+		  gfc_conv_expr (&lower_se, remap->u.ar.start[dim]);
+		  gfc_conv_expr (&upper_se, remap->u.ar.end[dim]);
+
+		  gfc_add_block_to_block (&block, &lower_se.pre);
+		  gfc_add_block_to_block (&block, &upper_se.pre);
+
+		  lbound = fold_convert (gfc_array_index_type, lower_se.expr);
+		  ubound = fold_convert (gfc_array_index_type, upper_se.expr);
+
+		  lbound = gfc_evaluate_now (lbound, &block);
+		  ubound = gfc_evaluate_now (ubound, &block);
+
+		  gfc_add_block_to_block (&block, &lower_se.post);
+		  gfc_add_block_to_block (&block, &upper_se.post);
+
+		  /* Set bounds in descriptor.  */
+		  gfc_conv_descriptor_lbound_set (&block, desc,
+						  gfc_rank_cst[dim], lbound);
+		  gfc_conv_descriptor_ubound_set (&block, desc,
+						  gfc_rank_cst[dim], ubound);
+
+		  /* Set stride.  */
+		  stride = gfc_evaluate_now (stride, &block);
+		  gfc_conv_descriptor_stride_set (&block, desc,
+						  gfc_rank_cst[dim], stride);
+
+		  /* Update offset.  */
+		  offs = gfc_conv_descriptor_offset_get (desc);
+		  tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
+				     lbound, stride);
+		  offs = fold_build2 (MINUS_EXPR, gfc_array_index_type,
+				      offs, tmp);
+		  offs = gfc_evaluate_now (offs, &block);
+		  gfc_conv_descriptor_offset_set (&block, desc, offs);
+
+		  /* Update stride.  */
+		  tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
+		  stride = fold_build2 (MULT_EXPR, gfc_array_index_type,
+					stride, tmp);
+		}
+	    }
+	  else
+	    {
+	      /* Bounds remapping.  Just shift the lower bounds.  */
+
+	      gcc_assert (expr1->rank == expr2->rank);
+
+	      for (dim = 0; dim < remap->u.ar.dimen; ++dim)
+		{
+		  gfc_se lbound_se;
+
+		  gcc_assert (remap->u.ar.start[dim]);
+		  gcc_assert (!remap->u.ar.end[dim]);
+		  gfc_init_se (&lbound_se, NULL);
+		  gfc_conv_expr (&lbound_se, remap->u.ar.start[dim]);
+
+		  gfc_add_block_to_block (&block, &lbound_se.pre);
+		  gfc_conv_shift_descriptor_lbound (&block, desc,
+						    dim, lbound_se.expr);
+		  gfc_add_block_to_block (&block, &lbound_se.post);
+		}
+	    }
+	}
 
       /* Check string lengths if applicable.  The check is only really added
 	 to the output code if -fbounds-check is enabled.  */
@@ -4824,8 +4967,31 @@  gfc_trans_pointer_assignment (gfc_expr *
 				       strlen_lhs, strlen_rhs, &block);
 	}
 
+      /* If rank remapping was done, check with -fcheck=bounds that
+	 the target is at least as large as the pointer.  */
+      if (rank_remap && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
+	{
+	  tree lsize, rsize;
+	  tree fault;
+	  const char* msg;
+
+	  lsize = gfc_conv_descriptor_size (lse.expr, expr1->rank);
+	  rsize = gfc_conv_descriptor_size (rse.expr, expr2->rank);
+
+	  lsize = gfc_evaluate_now (lsize, &block);
+	  rsize = gfc_evaluate_now (rsize, &block);
+	  fault = fold_build2 (LT_EXPR, boolean_type_node, rsize, lsize);
+
+	  msg = _("Target of rank remapping is too small (%ld < %ld)");
+	  gfc_trans_runtime_check (true, false, fault, &block, &expr2->where,
+				   msg, rsize, lsize);
+	}
+
       gfc_add_block_to_block (&block, &lse.post);
+      if (rank_remap)
+	gfc_add_block_to_block (&block, &rse.post);
     }
+
   return gfc_finish_block (&block);
 }
 
Index: gcc/fortran/trans-array.c
===================================================================
--- gcc/fortran/trans-array.c	(revision 163310)
+++ gcc/fortran/trans-array.c	(working copy)
@@ -382,6 +382,39 @@  gfc_build_null_descriptor (tree type)
 }
 
 
+/* Modify a descriptor such that the lbound of a given dimension is the value
+   specified.  This also updates ubound and offset accordingly.  */
+
+void
+gfc_conv_shift_descriptor_lbound (stmtblock_t* block, tree desc,
+				  int dim, tree new_lbound)
+{
+  tree offs, ubound, lbound, stride;
+  tree diff, offs_diff;
+
+  new_lbound = fold_convert (gfc_array_index_type, new_lbound);
+
+  offs = gfc_conv_descriptor_offset_get (desc);
+  lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]);
+  ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]);
+  stride = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[dim]);
+
+  /* Get difference (new - old) by which to shift stuff.  */
+  diff = fold_build2 (MINUS_EXPR, gfc_array_index_type, new_lbound, lbound);
+
+  /* Shift ubound and offset accordingly.  This has to be done before
+     updating the lbound, as they depend on the lbound expression!  */
+  ubound = fold_build2 (PLUS_EXPR, gfc_array_index_type, ubound, diff);
+  gfc_conv_descriptor_ubound_set (block, desc, gfc_rank_cst[dim], ubound);
+  offs_diff = fold_build2 (MULT_EXPR, gfc_array_index_type, diff, stride);
+  offs = fold_build2 (MINUS_EXPR, gfc_array_index_type, offs, offs_diff);
+  gfc_conv_descriptor_offset_set (block, desc, offs);
+
+  /* Finally set lbound to value we want.  */
+  gfc_conv_descriptor_lbound_set (block, desc, gfc_rank_cst[dim], new_lbound);
+}
+
+
 /* Cleanup those #defines.  */
 
 #undef DATA_FIELD
@@ -3784,6 +3817,62 @@  gfc_conv_loop_setup (gfc_loopinfo * loop
 }
 
 
+/* Calculate the size of a given array dimension from the bounds.  This
+   is simply (ubound - lbound + 1) if this expression is positive
+   or 0 if it is negative (pick either one if it is zero).  Optionally
+   (if or_expr is present) OR the (expression != 0) condition to it.  */
+
+tree
+gfc_conv_array_extent_dim (tree lbound, tree ubound, tree* or_expr)
+{
+  tree res;
+  tree cond;
+
+  /* Calculate (ubound - lbound + 1).  */
+  res = fold_build2 (MINUS_EXPR, gfc_array_index_type, ubound, lbound);
+  res = fold_build2 (PLUS_EXPR, gfc_array_index_type, res, gfc_index_one_node);
+
+  /* Check whether the size for this dimension is negative.  */
+  cond = fold_build2 (LE_EXPR, boolean_type_node, res, gfc_index_zero_node);
+  res = fold_build3 (COND_EXPR, gfc_array_index_type, cond,
+		      gfc_index_zero_node, res);
+
+  /* Build OR expression.  */
+  if (or_expr)
+    *or_expr = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, *or_expr, cond);
+
+  return res;
+}
+
+
+/* For an array descriptor, get the total number of elements.  This is just
+   the product of the extents along all dimensions.  */
+
+tree
+gfc_conv_descriptor_size (tree desc, int rank)
+{
+  tree res;
+  int dim;
+
+  res = gfc_index_one_node;
+
+  for (dim = 0; dim < rank; ++dim)
+    {
+      tree lbound;
+      tree ubound;
+      tree extent;
+
+      lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]);
+      ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]);
+
+      extent = gfc_conv_array_extent_dim (lbound, ubound, NULL);
+      res = fold_build2 (MULT_EXPR, gfc_array_index_type, res, extent);
+    }
+
+  return res;
+}
+
+
 /* Fills in an array descriptor, and returns the size of the array.  The size
    will be a simple_val, ie a variable or a constant.  Also calculates the
    offset of the base.  Returns the size of the array.
@@ -3792,13 +3881,13 @@  gfc_conv_loop_setup (gfc_loopinfo * loop
     offset = 0;
     for (n = 0; n < rank; n++)
       {
-        a.lbound[n] = specified_lower_bound;
-        offset = offset + a.lbond[n] * stride;
-        size = 1 - lbound;
-        a.ubound[n] = specified_upper_bound;
-        a.stride[n] = stride;
-        size = siz >= 0 ? ubound + size : 0; //size = ubound + 1 - lbound
-        stride = stride * size;
+	a.lbound[n] = specified_lower_bound;
+	offset = offset + a.lbond[n] * stride;
+	size = 1 - lbound;
+	a.ubound[n] = specified_upper_bound;
+	a.stride[n] = stride;
+	size = siz >= 0 ? ubound + size : 0; //size = ubound + 1 - lbound
+	stride = stride * size;
       }
     return (stride);
    }  */
@@ -3814,7 +3903,6 @@  gfc_array_init_size (tree descriptor, in
   tree size;
   tree offset;
   tree stride;
-  tree cond;
   tree or_expr;
   tree thencase;
   tree elsecase;
@@ -3834,14 +3922,17 @@  gfc_array_init_size (tree descriptor, in
   tmp = gfc_conv_descriptor_dtype (descriptor);
   gfc_add_modify (pblock, tmp, gfc_get_dtype (TREE_TYPE (descriptor)));
 
-  or_expr = NULL_TREE;
+  or_expr = boolean_false_node;
 
   for (n = 0; n < rank; n++)
     {
+      tree conv_lbound;
+      tree conv_ubound;
+
       /* We have 3 possibilities for determining the size of the array:
-         lower == NULL    => lbound = 1, ubound = upper[n]
-         upper[n] = NULL  => lbound = 1, ubound = lower[n]
-         upper[n] != NULL => lbound = lower[n], ubound = upper[n]  */
+	 lower == NULL    => lbound = 1, ubound = upper[n]
+	 upper[n] = NULL  => lbound = 1, ubound = lower[n]
+	 upper[n] != NULL => lbound = lower[n], ubound = upper[n]  */
       ubound = upper[n];
 
       /* Set lower bound.  */
@@ -3851,52 +3942,41 @@  gfc_array_init_size (tree descriptor, in
       else
 	{
 	  gcc_assert (lower[n]);
-          if (ubound)
-            {
+	  if (ubound)
+	    {
 	      gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
 	      gfc_add_block_to_block (pblock, &se.pre);
-            }
-          else
-            {
-              se.expr = gfc_index_one_node;
-              ubound = lower[n];
-            }
+	    }
+	  else
+	    {
+	      se.expr = gfc_index_one_node;
+	      ubound = lower[n];
+	    }
 	}
       gfc_conv_descriptor_lbound_set (pblock, descriptor, gfc_rank_cst[n],
 				      se.expr);
+      conv_lbound = se.expr;
 
       /* Work out the offset for this component.  */
       tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, se.expr, stride);
       offset = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp);
 
-      /* Start the calculation for the size of this dimension.  */
-      size = fold_build2 (MINUS_EXPR, gfc_array_index_type,
-			  gfc_index_one_node, se.expr);
-
       /* Set upper bound.  */
       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 (pblock, descriptor, gfc_rank_cst[n], se.expr);
+      gfc_conv_descriptor_ubound_set (pblock, descriptor,
+				      gfc_rank_cst[n], se.expr);
+      conv_ubound = se.expr;
 
       /* Store the stride.  */
-      gfc_conv_descriptor_stride_set (pblock, descriptor, gfc_rank_cst[n], stride);
+      gfc_conv_descriptor_stride_set (pblock, descriptor,
+				      gfc_rank_cst[n], stride);
 
-      /* Calculate the size of this dimension.  */
-      size = fold_build2 (PLUS_EXPR, gfc_array_index_type, se.expr, size);
-
-      /* Check whether the size for this dimension is negative.  */
-      cond = fold_build2 (LE_EXPR, boolean_type_node, size,
-			  gfc_index_zero_node);
-      if (n == 0)
-	or_expr = cond;
-      else
-	or_expr = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, or_expr, cond);
-
-      size = fold_build3 (COND_EXPR, gfc_array_index_type, cond,
-			  gfc_index_zero_node, size);
+      /* Calculate size and check whether extent is negative.  */
+      size = gfc_conv_array_extent_dim (conv_lbound, conv_ubound, &or_expr);
 
       /* Multiply the stride by the number of elements in this dimension.  */
       stride = fold_build2 (MULT_EXPR, gfc_array_index_type, stride, size);
@@ -3916,16 +3996,16 @@  gfc_array_init_size (tree descriptor, in
 	}
       else
 	{
-          if (ubound || n == rank + corank - 1)
-            {
+	  if (ubound || n == rank + corank - 1)
+	    {
 	      gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
 	      gfc_add_block_to_block (pblock, &se.pre);
-            }
-          else
-            {
-              se.expr = gfc_index_one_node;
-              ubound = lower[n];
-            }
+	    }
+	  else
+	    {
+	      se.expr = gfc_index_one_node;
+	      ubound = lower[n];
+	    }
 	}
       gfc_conv_descriptor_lbound_set (pblock, descriptor, gfc_rank_cst[n],
 				      se.expr);
@@ -3936,7 +4016,8 @@  gfc_array_init_size (tree descriptor, in
 	  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 (pblock, descriptor, gfc_rank_cst[n], se.expr);
+	  gfc_conv_descriptor_ubound_set (pblock, descriptor,
+					  gfc_rank_cst[n], se.expr);
 	}
     }
 
@@ -5064,7 +5145,7 @@  gfc_conv_expr_descriptor (gfc_se * se, g
 
       if (full)
 	{
-	  if (se->direct_byref)
+	  if (se->direct_byref && !se->byref_noassign)
 	    {
 	      /* Copy the descriptor for pointer assignments.  */
 	      gfc_add_modify (&se->pre, se->expr, desc);
@@ -5269,7 +5350,7 @@  gfc_conv_expr_descriptor (gfc_se * se, g
 
       desc = info->descriptor;
       gcc_assert (secss && secss != gfc_ss_terminator);
-      if (se->direct_byref)
+      if (se->direct_byref && !se->byref_noassign)
 	{
 	  /* For pointer assignments we fill in the destination.  */
 	  parm = se->expr;
@@ -5427,7 +5508,7 @@  gfc_conv_expr_descriptor (gfc_se * se, g
       desc = parm;
     }
 
-  if (!se->direct_byref)
+  if (!se->direct_byref || se->byref_noassign)
     {
       /* Get a pointer to the new descriptor.  */
       if (se->want_pointer)
Index: gcc/fortran/trans-array.h
===================================================================
--- gcc/fortran/trans-array.h	(revision 163310)
+++ gcc/fortran/trans-array.h	(working copy)
@@ -139,6 +139,9 @@  void gfc_conv_descriptor_stride_set (stm
 void gfc_conv_descriptor_lbound_set (stmtblock_t *, tree, tree, tree);
 void gfc_conv_descriptor_ubound_set (stmtblock_t *, tree, tree, tree);
 
+/* Shift lower bound of descriptor, updating ubound and offset.  */
+void gfc_conv_shift_descriptor_lbound (stmtblock_t*, tree, int, tree);
+
 /* Add pre-loop scalarization code for intrinsic functions which require
    special handling.  */
 void gfc_add_intrinsic_ss_code (gfc_loopinfo *, gfc_ss *);
@@ -149,3 +152,7 @@  tree gfc_build_constant_array_constructo
 
 /* Copy a string from src to dest.  */
 void gfc_trans_string_copy (stmtblock_t *, tree, tree, int, tree, tree, int);
+
+/* Calculate extent / size of an array.  */
+tree gfc_conv_array_extent_dim (tree, tree, tree*);
+tree gfc_conv_descriptor_size (tree, int);
Index: gcc/fortran/expr.c
===================================================================
--- gcc/fortran/expr.c	(revision 163310)
+++ gcc/fortran/expr.c	(working copy)
@@ -3232,7 +3232,7 @@  gfc_check_pointer_assign (gfc_expr *lval
 {
   symbol_attribute attr;
   gfc_ref *ref;
-  int is_pure;
+  bool is_pure, rank_remap;
   int pointer, check_intent_in, proc_pointer;
 
   if (lvalue->symtree->n.sym->ts.type == BT_UNKNOWN
@@ -3260,6 +3260,7 @@  gfc_check_pointer_assign (gfc_expr *lval
   pointer = lvalue->symtree->n.sym->attr.pointer;
   proc_pointer = lvalue->symtree->n.sym->attr.proc_pointer;
 
+  rank_remap = false;
   for (ref = lvalue->ref; ref; ref = ref->next)
     {
       if (pointer)
@@ -3273,6 +3274,8 @@  gfc_check_pointer_assign (gfc_expr *lval
 
       if (ref->type == REF_ARRAY && ref->next == NULL)
 	{
+	  int dim;
+
 	  if (ref->u.ar.type == AR_FULL)
 	    break;
 
@@ -3285,16 +3288,41 @@  gfc_check_pointer_assign (gfc_expr *lval
 
 	  if (gfc_notify_std (GFC_STD_F2003,"Fortran 2003: Bounds "
 			      "specification for '%s' in pointer assignment "
-                              "at %L", lvalue->symtree->n.sym->name,
+			      "at %L", lvalue->symtree->n.sym->name,
 			      &lvalue->where) == FAILURE)
-            return FAILURE;
+	    return FAILURE;
 
-	  gfc_error ("Pointer bounds remapping at %L is not yet implemented "
-		     "in gfortran", &lvalue->where);
-	  /* TODO: See PR 29785. Add checks that all lbounds are specified and
-	     either never or always the upper-bound; strides shall not be
-	     present.  */
-	  return FAILURE;
+	  /* When bounds are given, all lbounds are necessary and either all
+	     or none of the upper bounds; no strides are allowed.  If the
+	     upper bounds are present, we may do rank remapping.  */
+	  for (dim = 0; dim < ref->u.ar.dimen; ++dim)
+	    {
+	      if (!ref->u.ar.start[dim])
+		{
+		  gfc_error ("Lower bound has to be present at %L",
+			     &lvalue->where);
+		  return FAILURE;
+		}
+	      if (ref->u.ar.stride[dim])
+		{
+		  gfc_error ("Stride must not be present at %L",
+			     &lvalue->where);
+		  return FAILURE;
+		}
+
+	      if (dim == 0)
+		rank_remap = (ref->u.ar.end[dim] != NULL);
+	      else
+		{
+		  if ((rank_remap && !ref->u.ar.end[dim])
+		      || (!rank_remap && ref->u.ar.end[dim]))
+		    {
+		      gfc_error ("Either all or none of the upper bounds"
+				 " must be specified at %L", &lvalue->where);
+		      return FAILURE;
+		    }
+		}
+	    }
 	}
     }
 
@@ -3456,13 +3484,47 @@  gfc_check_pointer_assign (gfc_expr *lval
       return FAILURE;
     }
 
-  if (lvalue->rank != rvalue->rank)
+  if (lvalue->rank != rvalue->rank && !rank_remap)
     {
-      gfc_error ("Different ranks in pointer assignment at %L",
-		 &lvalue->where);
+      gfc_error ("Different ranks in pointer assignment at %L", &lvalue->where);
       return FAILURE;
     }
 
+  /* Check rank remapping.  */
+  if (rank_remap)
+    {
+      mpz_t lsize, rsize;
+
+      /* If this can be determined, check that the target must be at least as
+	 large as the pointer assigned to it is.  */
+      if (gfc_array_size (lvalue, &lsize) == SUCCESS
+	  && gfc_array_size (rvalue, &rsize) == SUCCESS
+	  && mpz_cmp (rsize, lsize) < 0)
+	{
+	  gfc_error ("Rank remapping target is smaller than size of the"
+		     " pointer (%ld < %ld) at %L",
+		     mpz_get_si (rsize), mpz_get_si (lsize),
+		     &lvalue->where);
+	  return FAILURE;
+	}
+
+      /* The target must be either rank one or it must be simply contiguous
+	 and F2008 must be allowed.  */
+      if (rvalue->rank != 1)
+	{
+	  if (!gfc_is_simply_contiguous (rvalue, true))
+	    {
+	      gfc_error ("Rank remapping target must be rank 1 or"
+			 " simply contiguous at %L", &rvalue->where);
+	      return FAILURE;
+	    }
+	  if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Rank remapping"
+			      " target is not rank 1 at %L", &rvalue->where)
+		== FAILURE)
+	    return FAILURE;
+	}
+    }
+
   /* Now punt if we are dealing with a NULLIFY(X) or X = NULL(X).  */
   if (rvalue->expr_type == EXPR_NULL)
     return SUCCESS;
Index: gcc/fortran/trans.h
===================================================================
--- gcc/fortran/trans.h	(revision 163310)
+++ gcc/fortran/trans.h	(working copy)
@@ -64,6 +64,13 @@  typedef struct gfc_se
      pointer assignments.  */
   unsigned direct_byref:1;
 
+  /* If direct_byref is set, do work out the descriptor as in that case but
+     do still create a new descriptor variable instead of using an
+     existing one.  This is useful for special pointer assignments like
+     rank remapping where we have to process the descriptor before
+     assigning to final one.  */
+  unsigned byref_noassign:1;
+
   /* Ignore absent optional arguments.  Used for some intrinsics.  */
   unsigned ignore_optional:1;
 
Index: gcc/fortran/trans-decl.c
===================================================================
--- gcc/fortran/trans-decl.c	(revision 163310)
+++ gcc/fortran/trans-decl.c	(working copy)
@@ -3133,42 +3133,15 @@  trans_associate_var (gfc_symbol* sym, gf
 	 descriptor to the one generated for the temporary.  */
       if (!sym->assoc->variable)
 	{
-	  tree offs;
 	  int dim;
 
 	  gfc_add_modify (&se.pre, desc, se.expr);
 
 	  /* The generated descriptor has lower bound zero (as array
-	     temporary), shift bounds so we get lower bounds of 1 all the time.
-	     The offset has to be corrected as well.
-	     Because the ubound shift and offset depends on the lower bounds, we
-	     first calculate those and set the lbound to one last.  */
-
-	  offs = gfc_conv_descriptor_offset_get (desc);
-	  for (dim = 0; dim < e->rank; ++dim)
-	    {
-	      tree from, to;
-	      tree stride;
-
-	      from = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]);
-	      to = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]);
-	      stride = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[dim]);
-
-	      tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
-				 gfc_index_one_node, from);
-	      to = fold_build2 (PLUS_EXPR, gfc_array_index_type, to, tmp);
-
-	      tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, tmp, stride);
-	      offs = fold_build2 (MINUS_EXPR, gfc_array_index_type, offs, tmp);
-
-	      gfc_conv_descriptor_ubound_set (&se.pre, desc,
-					      gfc_rank_cst[dim], to);
-	    }
-	  gfc_conv_descriptor_offset_set (&se.pre, desc, offs);
-
+	     temporary), shift bounds so we get lower bounds of 1.  */
 	  for (dim = 0; dim < e->rank; ++dim)
-	    gfc_conv_descriptor_lbound_set (&se.pre, desc, gfc_rank_cst[dim],
-					    gfc_index_one_node);
+	    gfc_conv_shift_descriptor_lbound (&se.pre, desc,
+					      dim, gfc_index_one_node);
 	}
 
       /* Done, register stuff as init / cleanup code.  */
Index: gcc/testsuite/gfortran.dg/pointer_remapping_2.f03
===================================================================
--- gcc/testsuite/gfortran.dg/pointer_remapping_2.f03	(revision 0)
+++ gcc/testsuite/gfortran.dg/pointer_remapping_2.f03	(revision 0)
@@ -0,0 +1,20 @@ 
+! { dg-do compile }
+! { dg-options "-std=f2003" }
+
+! PR fortran/29785
+! Check for F2008 rejection of rank remapping to rank-two base array.
+
+! Contributed by Daniel Kraft, d@domob.eu.
+
+PROGRAM main
+  IMPLICIT NONE
+  INTEGER, TARGET :: arr(12), basem(3, 4)
+  INTEGER, POINTER :: vec(:), mat(:, :)
+
+  ! These are ok.
+  vec => arr
+  vec(2:) => arr
+  mat(1:2, 1:6) => arr
+
+  vec(1:12) => basem ! { dg-error "Fortran 2008" }
+END PROGRAM main
Index: gcc/testsuite/gfortran.dg/pointer_remapping_4.f03
===================================================================
--- gcc/testsuite/gfortran.dg/pointer_remapping_4.f03	(revision 0)
+++ gcc/testsuite/gfortran.dg/pointer_remapping_4.f03	(revision 0)
@@ -0,0 +1,33 @@ 
+! { dg-do run }
+! { dg-options "-std=f2003 -fall-intrinsics -fcheck=bounds" }
+
+! PR fortran/45016
+! Check pointer bounds remapping at runtime.
+
+! Contributed by Daniel Kraft, d@domob.eu.
+
+PROGRAM main
+  IMPLICIT NONE
+  INTEGER, TARGET :: arr(2_2:5), basem(-2:-1, 3:4_1)
+  INTEGER, POINTER :: vec(:), vec2(:), mat(:, :)
+
+  arr = (/ 1, 2, 3, 4 /)
+  basem = RESHAPE (arr, SHAPE (basem))
+
+  vec(0:) => arr
+  IF (LBOUND (vec, 1) /= 0 .OR. UBOUND (vec, 1) /= 3) CALL abort ()
+  IF (ANY (vec /= arr)) CALL abort ()
+  IF (vec(0) /= 1 .OR. vec(2) /= 3) CALL abort ()
+
+  ! Test with bound different of index type, so conversion is necessary.
+  vec2(-5_1:) => vec
+  IF (LBOUND (vec2, 1) /= -5 .OR. UBOUND (vec2, 1) /= -2) CALL abort ()
+  IF (ANY (vec2 /= arr)) CALL abort ()
+  IF (vec2(-5) /= 1 .OR. vec2(-3) /= 3) CALL abort ()
+
+  mat(1:, 2:) => basem
+  IF (ANY (LBOUND (mat) /= (/ 1, 2 /) .OR. UBOUND (mat) /= (/ 2, 3 /))) &
+    CALL abort ()
+  IF (ANY (mat /= basem)) CALL abort ()
+  IF (mat(1, 2) /= 1 .OR. mat(1, 3) /= 3 .OR. mat(2, 3) /= 4) CALL abort ()
+END PROGRAM main
Index: gcc/testsuite/gfortran.dg/pointer_remapping_6.f08
===================================================================
--- gcc/testsuite/gfortran.dg/pointer_remapping_6.f08	(revision 0)
+++ gcc/testsuite/gfortran.dg/pointer_remapping_6.f08	(revision 0)
@@ -0,0 +1,29 @@ 
+! { dg-do run }
+! { dg-options "-std=f2008 -fcheck=bounds" }
+! { dg-shouldfail "Bounds check" }
+
+! PR fortran/29785
+! Check that -fcheck=bounds catches too small target at runtime for
+! pointer rank remapping.
+
+! Contributed by Daniel Kraft, d@domob.eu.
+
+PROGRAM main
+  IMPLICIT NONE
+  INTEGER, POINTER :: ptr(:, :)
+  INTEGER :: n
+
+  n = 10
+  BLOCK
+    INTEGER, TARGET :: arr(2*n)
+
+    ! These are ok.
+    ptr(1:5, 1:2) => arr
+    ptr(1:5, 1:2) => arr(::2)
+    ptr(-5:-1, 11:14) => arr
+
+    ! This is not.
+    ptr(1:3, 1:5) => arr(::2)
+  END BLOCK
+END PROGRAM main
+! { dg-output "At line 26 of .*\nFortran runtime error: Target of rank remapping is too small \\(10 < 15\\)" }
Index: gcc/testsuite/gfortran.dg/pointer_assign_5.f90
===================================================================
--- gcc/testsuite/gfortran.dg/pointer_assign_5.f90	(revision 163310)
+++ gcc/testsuite/gfortran.dg/pointer_assign_5.f90	(working copy)
@@ -1,9 +1,10 @@ 
 ! { dg-do compile }
 ! PR fortran/37580
-!
+
+! See also the pointer_remapping_* tests.
+
 program test
 implicit none
 real, pointer :: ptr1(:), ptr2(:)
 ptr1(1) => ptr2 ! { dg-error "Expected bounds specification" }
-ptr1(1:) => ptr2 ! { dg-error "not yet implemented in gfortran" }
 end program test
Index: gcc/testsuite/gfortran.dg/pointer_remapping_3.f08
===================================================================
--- gcc/testsuite/gfortran.dg/pointer_remapping_3.f08	(revision 0)
+++ gcc/testsuite/gfortran.dg/pointer_remapping_3.f08	(revision 0)
@@ -0,0 +1,35 @@ 
+! { dg-do compile }
+! { dg-options "-std=f2008" }
+
+! PR fortran/29785
+! PR fortran/45016
+! Check for pointer remapping compile-time errors.
+
+! Contributed by Daniel Kraft, d@domob.eu.
+
+PROGRAM main
+  IMPLICIT NONE
+  INTEGER, TARGET :: arr(12), basem(3, 4)
+  INTEGER, POINTER :: vec(:), mat(:, :)
+
+  ! Existence of reference elements.
+  vec(:) => arr ! { dg-error "Lower bound has to be present" }
+  vec(5:7:1) => arr ! { dg-error "Stride must not be present" }
+  mat(1:, 2:5) => arr ! { dg-error "Either all or none of the upper bounds" }
+  mat(2, 6) => arr ! { dg-error "Expected bounds specification" }
+
+  ! This is bound remapping not rank remapping!
+  mat(1:, 3:) => arr ! { dg-error "Different ranks" }
+
+  ! Invalid remapping target; for non-rank one we already check the F2008
+  ! error elsewhere.  Here, test that not-contiguous target is disallowed
+  ! with rank > 1.
+  mat(1:2, 1:3) => arr(1:12:2) ! This is ok, rank one target.
+  vec(1:8) => basem(1:3:2, :) ! { dg-error "rank 1 or simply contiguous" }
+
+  ! Target is smaller than pointer.
+  vec(1:20) => arr ! { dg-error "smaller than size of the pointer" }
+  vec(1:10) => arr(1:12:2) ! { dg-error "smaller than size of the pointer" }
+  vec(1:20) => basem(:, :) ! { dg-error "smaller than size of the pointer" }
+  mat(1:5, 1:5) => arr ! { dg-error "smaller than size of the pointer" }
+END PROGRAM main
Index: gcc/testsuite/gfortran.dg/pointer_remapping_1.f90
===================================================================
--- gcc/testsuite/gfortran.dg/pointer_remapping_1.f90	(revision 0)
+++ gcc/testsuite/gfortran.dg/pointer_remapping_1.f90	(revision 0)
@@ -0,0 +1,19 @@ 
+! { dg-do compile }
+! { dg-options "-std=f95" }
+
+! PR fortran/29785
+! PR fortran/45016
+! Check for F2003 rejection of pointer remappings.
+
+! Contributed by Daniel Kraft, d@domob.eu.
+
+PROGRAM main
+  IMPLICIT NONE
+  INTEGER, TARGET :: arr(12)
+  INTEGER, POINTER :: vec(:), mat(:, :)
+
+  vec => arr ! This is ok.
+
+  vec(2:) => arr ! { dg-error "Fortran 2003" }
+  mat(1:2, 1:6) => arr ! { dg-error "Fortran 2003" }
+END PROGRAM main
Index: gcc/testsuite/gfortran.dg/pointer_remapping_5.f08
===================================================================
--- gcc/testsuite/gfortran.dg/pointer_remapping_5.f08	(revision 0)
+++ gcc/testsuite/gfortran.dg/pointer_remapping_5.f08	(revision 0)
@@ -0,0 +1,37 @@ 
+! { dg-do run }
+! { dg-options "-std=f2008 -fall-intrinsics -fcheck=bounds" }
+
+! PR fortran/29785
+! Check pointer rank remapping at runtime.
+
+! Contributed by Daniel Kraft, d@domob.eu.
+
+PROGRAM main
+  IMPLICIT NONE
+  INTEGER, TARGET :: arr(12), basem(3, 4)
+  INTEGER, POINTER :: vec(:), mat(:, :)
+  INTEGER :: i
+
+  arr = (/ (i, i = 1, 12) /)
+  basem = RESHAPE (arr, SHAPE (basem))
+
+  ! We need not necessarily change the rank...
+  vec(2_1:5) => arr(1_1:12_1:2_1)
+  IF (LBOUND (vec, 1) /= 2 .OR. UBOUND (vec, 1) /= 5) CALL abort ()
+  IF (ANY (vec /= (/ 1, 3, 5, 7 /))) CALL abort ()
+  IF (vec(2) /= 1 .OR. vec(5) /= 7) CALL abort ()
+
+  ! ...but it is of course the more interesting.  Also try remapping a pointer.
+  vec => arr(1:12:2)
+  mat(1:3, 1:2) => vec
+  IF (ANY (LBOUND (mat) /= (/ 1, 1 /) .OR. UBOUND (mat) /= (/ 3, 2 /))) &
+    CALL abort ()
+  IF (ANY (mat /= RESHAPE (arr(1:12:2), SHAPE (mat)))) CALL abort ()
+  IF (mat(1, 1) /= 1 .OR. mat(1, 2) /= 7) CALL abort ()
+
+  ! Remap with target of rank > 1.
+  vec(1:12_1) => basem
+  IF (LBOUND (vec, 1) /= 1 .OR. UBOUND (vec, 1) /= 12) CALL abort ()
+  IF (ANY (vec /= arr)) CALL abort ()
+  IF (vec(1) /= 1 .OR. vec(5) /= 5 .OR. vec(12) /= 12) CALL abort ()
+END PROGRAM main