re PR fortran/29785 (Fortran 2003: POINTER Rank Remapping)

2010-08-19  Daniel Kraft  <d@domob.eu>

	PR fortran/29785
	PR fortran/45016
	* trans.h (struct gfc_se): New flag `byref_noassign'.
	* trans-array.h (gfc_conv_shift_descriptor_lbound): New method.
	(gfc_conv_array_extent_dim), (gfc_conv_descriptor_size): New methods.
	* expr.c (gfc_check_pointer_assign): Allow bounds and rank remapping
	and check for compile-time errors with those.
	* trans-decl.c (trans_associate_var): Use new routine
	`gfc_conv_shift_descriptor_lbound' instead of doing it manually.
	* trans-array.c (gfc_conv_shift_descriptor_lbound): New method.
	(gfc_conv_array_extent_dim), (gfc_conv_descriptor_size): New methods.
	(gfc_array_init_size): Use new `gfc_conv_array_extent_dim'.
	(gfc_conv_expr_descriptor): Handle new flag `byref_noassign'.
	* trans-expr.c (gfc_trans_pointer_assignment): Handle bounds and
	rank remapping for assignment.

2010-08-19  Daniel Kraft  <d@domob.eu>

	PR fortran/29785
	PR fortran/45016
	* gfortran.dg/pointer_assign_5.f90: Remove 'not implemented' error.
	* gfortran.dg/pointer_remapping_1.f90: New test.
	* gfortran.dg/pointer_remapping_2.f03: New test.
	* gfortran.dg/pointer_remapping_3.f08: New test.
	* gfortran.dg/pointer_remapping_4.f03: New test.
	* gfortran.dg/pointer_remapping_5.f08: New test.
	* gfortran.dg/pointer_remapping_6.f08: New test.

From-SVN: r163377

gcc/fortran/ChangeLog

+2010-08-19  Daniel Kraft  <d@domob.eu>
+
+	PR fortran/29785
+	PR fortran/45016
+	* trans.h (struct gfc_se): New flag `byref_noassign'.
+	* trans-array.h (gfc_conv_shift_descriptor_lbound): New method.
+	(gfc_conv_array_extent_dim), (gfc_conv_descriptor_size): New methods.
+	* expr.c (gfc_check_pointer_assign): Allow bounds and rank remapping
+	and check for compile-time errors with those.
+	* trans-decl.c (trans_associate_var): Use new routine
+	`gfc_conv_shift_descriptor_lbound' instead of doing it manually.
+	* trans-array.c (gfc_conv_shift_descriptor_lbound): New method.
+	(gfc_conv_array_extent_dim), (gfc_conv_descriptor_size): New methods.
+	(gfc_array_init_size): Use new `gfc_conv_array_extent_dim'.
+	(gfc_conv_expr_descriptor): Handle new flag `byref_noassign'.
+	* trans-expr.c (gfc_trans_pointer_assignment): Handle bounds and
+	rank remapping for assignment.
+
 2010-08-19  Tobias Burnus  <burnus@net-b.de>
 
 	* intrinsic.texi (Bessel_jn, Bessel_yn): Fix typo.

gcc/fortran/expr.c

@@ -3232,7 +3232,7 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
 {
   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 *lvalue, gfc_expr *rvalue)
   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 *lvalue, gfc_expr *rvalue)
 
       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 *lvalue, gfc_expr *rvalue)
 
 	  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 *lvalue, gfc_expr *rvalue)
       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;

gcc/fortran/trans-array.c

@@ -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, locus * where)
 }
 
 
+/* 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, locus * where)
     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, int rank, int corank, tree * poffset,
   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, int rank, int corank, tree * poffset,
   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, int rank, int corank, tree * poffset,
       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);
-
-      /* 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);
+      gfc_conv_descriptor_stride_set (pblock, descriptor,
+				      gfc_rank_cst[n], stride);
 
-      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, int rank, int corank, tree * poffset,
 	}
       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, int rank, int corank, tree * poffset,
 	  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, gfc_expr * expr, gfc_ss * ss)
 
       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, gfc_expr * expr, gfc_ss * ss)
 
       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, gfc_expr * expr, gfc_ss * ss)
       desc = parm;
     }
 
-  if (!se->direct_byref)
+  if (!se->direct_byref || se->byref_noassign)
     {
       /* Get a pointer to the new descriptor.  */
       if (se->want_pointer)

gcc/fortran/trans-array.h

@@ -139,6 +139,9 @@ void gfc_conv_descriptor_stride_set (stmtblock_t *, tree, tree, tree);
 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_constructor (gfc_expr *, tree);
 
 /* 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);

gcc/fortran/trans-decl.c

@@ -3133,42 +3133,15 @@ trans_associate_var (gfc_symbol* sym, gfc_wrapped_block* block)
 	 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.  */

gcc/fortran/trans-expr.c

@@ -4773,21 +4773,46 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
     }
   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 descriptor 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;
@@ -4806,13 +4831,11 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
 		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;
@@ -4820,10 +4843,130 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
 	  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.  */
@@ -4835,8 +4978,31 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
 				       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);
 }
 

gcc/fortran/trans.h

@@ -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;
 

gcc/testsuite/ChangeLog

+2010-08-19  Daniel Kraft  <d@domob.eu>
+
+	PR fortran/29785
+	PR fortran/45016
+	* gfortran.dg/pointer_assign_5.f90: Remove 'not implemented' error.
+	* gfortran.dg/pointer_remapping_1.f90: New test.
+	* gfortran.dg/pointer_remapping_2.f03: New test.
+	* gfortran.dg/pointer_remapping_3.f08: New test.
+	* gfortran.dg/pointer_remapping_4.f03: New test.
+	* gfortran.dg/pointer_remapping_5.f08: New test.
+	* gfortran.dg/pointer_remapping_6.f08: New test.
+
 2010-08-19  Uros Bizjak  <ubizjak@gmail.com>
 
 	PR testsuite/45324

gcc/testsuite/gfortran.dg/pointer_assign_5.f90

 ! { 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

gcc/testsuite/gfortran.dg/pointer_remapping_1.f90

+! { 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

gcc/testsuite/gfortran.dg/pointer_remapping_2.f03

+! { 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

gcc/testsuite/gfortran.dg/pointer_remapping_3.f08

+! { 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

gcc/testsuite/gfortran.dg/pointer_remapping_4.f03

+! { 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

gcc/testsuite/gfortran.dg/pointer_remapping_5.f08

+! { 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

gcc/testsuite/gfortran.dg/pointer_remapping_6.f08

+! { 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\\)" }