User account creation filtered due to spam.

View | Details | Raw Unified | Return to bug 29785
Collapse All | Expand All

(-)gcc/fortran/trans-expr.c (-13 / +161 lines)
Lines 4762-4782 gfc_trans_pointer_assignment (gfc_expr * Link Here
4762
    }
4762
    }
4763
  else
4763
  else
4764
    {
4764
    {
4765
      gfc_ref* remap;
4766
      bool rank_remap;
4765
      tree strlen_lhs;
4767
      tree strlen_lhs;
4766
      tree strlen_rhs = NULL_TREE;
4768
      tree strlen_rhs = NULL_TREE;
4767
4769
4768
      /* Array pointer.  */
4770
      /* Array pointer.  Find the last reference on the LHS and if it is an
4771
	 array section ref, we're dealing with bounds remapping.  In this case,
4772
	 set it to AR_FULL so that gfc_conv_expr_descriptor does
4773
	 not see it and process the bounds remapping afterwards explicitely.  */
4774
      for (remap = expr1->ref; remap; remap = remap->next)
4775
	if (!remap->next && remap->type == REF_ARRAY
4776
	    && remap->u.ar.type == AR_SECTION)
4777
	  {  
4778
	    remap->u.ar.type = AR_FULL;
4779
	    break;
4780
	  }
4781
      rank_remap = (remap && remap->u.ar.end[0]);
4782
4769
      gfc_conv_expr_descriptor (&lse, expr1, lss);
4783
      gfc_conv_expr_descriptor (&lse, expr1, lss);
4770
      strlen_lhs = lse.string_length;
4784
      strlen_lhs = lse.string_length;
4771
      switch (expr2->expr_type)
4785
      desc = lse.expr;
4786
4787
      if (expr2->expr_type == EXPR_NULL)
4772
	{
4788
	{
4773
	case EXPR_NULL:
4774
	  /* Just set the data pointer to null.  */
4789
	  /* Just set the data pointer to null.  */
4775
	  gfc_conv_descriptor_data_set (&lse.pre, lse.expr, null_pointer_node);
4790
	  gfc_conv_descriptor_data_set (&lse.pre, lse.expr, null_pointer_node);
4776
	  break;
4791
	}
4777
4792
      else if (rank_remap)
4778
	case EXPR_VARIABLE:
4793
	{
4779
	  /* Assign directly to the pointer's descriptor.  */
4794
	  /* If we are rank-remapping, just get the RHS's decriptor and
4795
	     process this later on.  */
4796
	  gfc_init_se (&rse, NULL);
4797
	  rse.direct_byref = 1;
4798
	  rse.byref_noassign = 1;
4799
	  gfc_conv_expr_descriptor (&rse, expr2, rss);
4800
	  strlen_rhs = rse.string_length;
4801
	}
4802
      else if (expr2->expr_type == EXPR_VARIABLE)
4803
	{
4804
	  /* Assign directly to the LHS's descriptor.  */
4780
	  lse.direct_byref = 1;
4805
	  lse.direct_byref = 1;
4781
	  gfc_conv_expr_descriptor (&lse, expr2, rss);
4806
	  gfc_conv_expr_descriptor (&lse, expr2, rss);
4782
	  strlen_rhs = lse.string_length;
4807
	  strlen_rhs = lse.string_length;
Lines 4795-4807 gfc_trans_pointer_assignment (gfc_expr * Link Here
4795
		gfc_add_block_to_block (&lse.post, &rse.pre);
4820
		gfc_add_block_to_block (&lse.post, &rse.pre);
4796
	      gfc_add_modify (&lse.post, GFC_DECL_SPAN(decl), tmp);
4821
	      gfc_add_modify (&lse.post, GFC_DECL_SPAN(decl), tmp);
4797
	    }
4822
	    }
4798
4823
	}
4799
	  break;
4824
      else
4800
4825
	{
4801
	default:
4802
	  /* Assign to a temporary descriptor and then copy that
4826
	  /* Assign to a temporary descriptor and then copy that
4803
	     temporary to the pointer.  */
4827
	     temporary to the pointer.  */
4804
	  desc = lse.expr;
4805
	  tmp = gfc_create_var (TREE_TYPE (desc), "ptrtemp");
4828
	  tmp = gfc_create_var (TREE_TYPE (desc), "ptrtemp");
4806
4829
4807
	  lse.expr = tmp;
4830
	  lse.expr = tmp;
Lines 4809-4818 gfc_trans_pointer_assignment (gfc_expr * Link Here
4809
	  gfc_conv_expr_descriptor (&lse, expr2, rss);
4832
	  gfc_conv_expr_descriptor (&lse, expr2, rss);
4810
	  strlen_rhs = lse.string_length;
4833
	  strlen_rhs = lse.string_length;
4811
	  gfc_add_modify (&lse.pre, desc, tmp);
4834
	  gfc_add_modify (&lse.pre, desc, tmp);
4812
	  break;
4813
	}
4835
	}
4814
4836
4815
      gfc_add_block_to_block (&block, &lse.pre);
4837
      gfc_add_block_to_block (&block, &lse.pre);
4838
      if (rank_remap)
4839
	gfc_add_block_to_block (&block, &rse.pre);
4840
4841
      /* If we do bounds remapping, update LHS descriptor accordingly.  */
4842
      if (remap)
4843
	{
4844
	  int dim;
4845
	  gcc_assert (remap->u.ar.dimen == expr1->rank);
4846
4847
	  if (rank_remap)
4848
	    {
4849
	      /* Do rank remapping.  We already have the RHS's descriptor
4850
		 converted in rse and now have to build the correct LHS
4851
		 descriptor for it.  */
4852
4853
	      tree dtype, data;
4854
	      tree offs, stride;
4855
	      tree lbound, ubound;
4856
4857
	      /* Set dtype.  */
4858
	      dtype = gfc_conv_descriptor_dtype (desc);
4859
	      tmp = gfc_get_dtype (TREE_TYPE (desc));
4860
	      gfc_add_modify (&block, dtype, tmp);
4861
4862
	      /* Copy data pointer.  */
4863
	      data = gfc_conv_descriptor_data_get (rse.expr);
4864
	      gfc_conv_descriptor_data_set (&block, desc, data);
4865
4866
	      /* Copy offset but adjust it such that it would correspond
4867
		 to a lbound of zero.  */
4868
	      offs = gfc_conv_descriptor_offset_get (rse.expr);
4869
	      for (dim = 0; dim < expr2->rank; ++dim)
4870
		{
4871
		  stride = gfc_conv_descriptor_stride_get (rse.expr,
4872
							   gfc_rank_cst[dim]);
4873
		  lbound = gfc_conv_descriptor_lbound_get (rse.expr,
4874
							   gfc_rank_cst[dim]);
4875
		  tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
4876
				     stride, lbound);
4877
		  offs = fold_build2 (PLUS_EXPR, gfc_array_index_type,
4878
				      offs, tmp);
4879
		}
4880
	      gfc_conv_descriptor_offset_set (&block, desc, offs);
4881
4882
	      /* Set the bounds as declared for the LHS and calculate strides as
4883
		 well as another offset update accordingly.  */
4884
	      for (dim = 0; dim < expr1->rank; ++dim)
4885
		{
4886
		  gfc_se lower_se, upper_se;
4887
4888
		  gcc_assert (remap->u.ar.start[dim] && remap->u.ar.end[dim]);
4889
4890
		  /* Convert declared bounds.  */
4891
		  gfc_init_se (&lower_se, NULL);
4892
		  gfc_init_se (&upper_se, NULL);
4893
		  gfc_conv_expr (&lower_se, remap->u.ar.start[dim]);
4894
		  gfc_conv_expr (&upper_se, remap->u.ar.end[dim]);
4895
4896
		  gfc_add_block_to_block (&block, &lower_se.pre);
4897
		  gfc_add_block_to_block (&block, &upper_se.pre);
4898
4899
		  /* Set bounds in descriptor.  */
4900
		  gfc_conv_descriptor_lbound_set (&block, desc,
4901
						  gfc_rank_cst[dim],
4902
						  lower_se.expr);
4903
		  gfc_conv_descriptor_ubound_set (&block, desc,
4904
						  gfc_rank_cst[dim],
4905
						  upper_se.expr);
4906
4907
		  /* Calculate stride.  */
4908
		  if (dim == 0)
4909
		    stride = gfc_conv_descriptor_stride_get (rse.expr,
4910
							     gfc_rank_cst[0]);
4911
		  else
4912
		    {
4913
		      tree last = gfc_rank_cst[dim - 1];
4914
		      stride = gfc_conv_descriptor_stride_get (desc, last);
4915
		      lbound = gfc_conv_descriptor_lbound_get (desc, last);
4916
		      ubound = gfc_conv_descriptor_ubound_get (desc, last);
4917
		      tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4918
					 ubound, lbound);
4919
		      tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
4920
					 tmp, gfc_index_one_node);
4921
		      stride = fold_build2 (MULT_EXPR, gfc_array_index_type,
4922
					    stride, tmp);
4923
		    }
4924
		  gfc_conv_descriptor_stride_set (&block, desc,
4925
						  gfc_rank_cst[dim], stride);
4926
4927
		  /* Update offset.  */
4928
		  offs = gfc_conv_descriptor_offset_get (desc);
4929
		  tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
4930
				     lower_se.expr, stride);
4931
		  offs = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4932
				      offs, tmp);
4933
		  gfc_conv_descriptor_offset_set (&block, desc, offs);
4934
4935
		  gfc_add_block_to_block (&block, &lower_se.post);
4936
		  gfc_add_block_to_block (&block, &upper_se.post);
4937
		}
4938
	    }
4939
	  if (!rank_remap)
4940
	    {
4941
	      /* Bounds remapping.  Just shift the lower bounds.  */
4942
4943
	      gcc_assert (expr1->rank == expr2->rank);
4944
4945
	      for (dim = 0; dim < remap->u.ar.dimen; ++dim)
4946
		{
4947
		  gfc_se lbound_se;
4948
4949
		  gcc_assert (remap->u.ar.start[dim]);
4950
		  gcc_assert (!remap->u.ar.end[dim]);
4951
		  gfc_init_se (&lbound_se, NULL);
4952
		  gfc_conv_expr (&lbound_se, remap->u.ar.start[dim]);
4953
4954
		  gfc_add_block_to_block (&block, &lbound_se.pre);
4955
		  gfc_conv_shift_descriptor_lbound (&block, desc,
4956
						    dim, lbound_se.expr);
4957
		  gfc_add_block_to_block (&block, &lbound_se.post);
4958
		}
4959
	    }
4960
	}
4816
4961
4817
      /* Check string lengths if applicable.  The check is only really added
4962
      /* Check string lengths if applicable.  The check is only really added
4818
	 to the output code if -fbounds-check is enabled.  */
4963
	 to the output code if -fbounds-check is enabled.  */
Lines 4825-4833 gfc_trans_pointer_assignment (gfc_expr * Link Here
4825
	}
4970
	}
4826
4971
4827
      gfc_add_block_to_block (&block, &lse.post);
4972
      gfc_add_block_to_block (&block, &lse.post);
4973
      if (rank_remap)
4974
	gfc_add_block_to_block (&block, &rse.post);
4828
    }
4975
    }
4829
  return gfc_finish_block (&block);
4976
  return gfc_finish_block (&block);
4830
}
4977
}
4978
/* XXX: Test rank-remapping with => NULL () and NULLIFY.  */
4831
4979
4832
4980
4833
/* Makes sure se is suitable for passing as a function string parameter.  */
4981
/* Makes sure se is suitable for passing as a function string parameter.  */
(-)gcc/fortran/trans-array.c (-3 / +34 lines)
Lines 382-387 gfc_build_null_descriptor (tree type) Link Here
382
}
382
}
383
383
384
384
385
/* Modify a descriptor such that the lbound of a given dimension is the value
386
   specified.  This also updates ubound and offset accordingly.  */
387
388
void
389
gfc_conv_shift_descriptor_lbound (stmtblock_t* block, tree desc,
390
				  int dim, tree new_lbound)
391
{
392
  tree offs, ubound, lbound, stride;
393
  tree diff, offs_diff;
394
395
  offs = gfc_conv_descriptor_offset_get (desc);
396
  lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]);
397
  ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]);
398
  stride = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[dim]);
399
400
  /* Get difference (new - old) by which to shift stuff.  */
401
  diff = fold_build2 (MINUS_EXPR, gfc_array_index_type, new_lbound, lbound);
402
403
  /* Shift ubound and offset accordingly.  This has to be done before
404
     updating the lbound, as they depend on the lbound expression!  */
405
  ubound = fold_build2 (PLUS_EXPR, gfc_array_index_type, ubound, diff);
406
  gfc_conv_descriptor_ubound_set (block, desc, gfc_rank_cst[dim], ubound);
407
  offs_diff = fold_build2 (MULT_EXPR, gfc_array_index_type, diff, stride);
408
  offs = fold_build2 (MINUS_EXPR, gfc_array_index_type, offs, offs_diff);
409
  gfc_conv_descriptor_offset_set (block, desc, offs);
410
411
  /* Finally set lbound to value we want.  */
412
  gfc_conv_descriptor_lbound_set (block, desc, gfc_rank_cst[dim], new_lbound);
413
}
414
415
385
/* Cleanup those #defines.  */
416
/* Cleanup those #defines.  */
386
417
387
#undef DATA_FIELD
418
#undef DATA_FIELD
Lines 5064-5070 gfc_conv_expr_descriptor (gfc_se * se, g Link Here
5064
5095
5065
      if (full)
5096
      if (full)
5066
	{
5097
	{
5067
	  if (se->direct_byref)
5098
	  if (se->direct_byref && !se->byref_noassign)
5068
	    {
5099
	    {
5069
	      /* Copy the descriptor for pointer assignments.  */
5100
	      /* Copy the descriptor for pointer assignments.  */
5070
	      gfc_add_modify (&se->pre, se->expr, desc);
5101
	      gfc_add_modify (&se->pre, se->expr, desc);
Lines 5269-5275 gfc_conv_expr_descriptor (gfc_se * se, g Link Here
5269
5300
5270
      desc = info->descriptor;
5301
      desc = info->descriptor;
5271
      gcc_assert (secss && secss != gfc_ss_terminator);
5302
      gcc_assert (secss && secss != gfc_ss_terminator);
5272
      if (se->direct_byref)
5303
      if (se->direct_byref && !se->byref_noassign)
5273
	{
5304
	{
5274
	  /* For pointer assignments we fill in the destination.  */
5305
	  /* For pointer assignments we fill in the destination.  */
5275
	  parm = se->expr;
5306
	  parm = se->expr;
Lines 5427-5433 gfc_conv_expr_descriptor (gfc_se * se, g Link Here
5427
      desc = parm;
5458
      desc = parm;
5428
    }
5459
    }
5429
5460
5430
  if (!se->direct_byref)
5461
  if (!se->direct_byref || se->byref_noassign)
5431
    {
5462
    {
5432
      /* Get a pointer to the new descriptor.  */
5463
      /* Get a pointer to the new descriptor.  */
5433
      if (se->want_pointer)
5464
      if (se->want_pointer)
(-)gcc/fortran/trans-array.h (+3 lines)
Lines 139-144 void gfc_conv_descriptor_stride_set (stm Link Here
139
void gfc_conv_descriptor_lbound_set (stmtblock_t *, tree, tree, tree);
139
void gfc_conv_descriptor_lbound_set (stmtblock_t *, tree, tree, tree);
140
void gfc_conv_descriptor_ubound_set (stmtblock_t *, tree, tree, tree);
140
void gfc_conv_descriptor_ubound_set (stmtblock_t *, tree, tree, tree);
141
141
142
/* Shift lower bound of descriptor, updating ubound and offset.  */
143
void gfc_conv_shift_descriptor_lbound (stmtblock_t*, tree, int, tree);
144
142
/* Add pre-loop scalarization code for intrinsic functions which require
145
/* Add pre-loop scalarization code for intrinsic functions which require
143
   special handling.  */
146
   special handling.  */
144
void gfc_add_intrinsic_ss_code (gfc_loopinfo *, gfc_ss *);
147
void gfc_add_intrinsic_ss_code (gfc_loopinfo *, gfc_ss *);
(-)gcc/fortran/expr.c (-12 / +59 lines)
Lines 3232-3238 gfc_check_pointer_assign (gfc_expr *lval Link Here
3232
{
3232
{
3233
  symbol_attribute attr;
3233
  symbol_attribute attr;
3234
  gfc_ref *ref;
3234
  gfc_ref *ref;
3235
  int is_pure;
3235
  bool is_pure, rank_remap;
3236
  int pointer, check_intent_in, proc_pointer;
3236
  int pointer, check_intent_in, proc_pointer;
3237
3237
3238
  if (lvalue->symtree->n.sym->ts.type == BT_UNKNOWN
3238
  if (lvalue->symtree->n.sym->ts.type == BT_UNKNOWN
Lines 3260-3265 gfc_check_pointer_assign (gfc_expr *lval Link Here
3260
  pointer = lvalue->symtree->n.sym->attr.pointer;
3260
  pointer = lvalue->symtree->n.sym->attr.pointer;
3261
  proc_pointer = lvalue->symtree->n.sym->attr.proc_pointer;
3261
  proc_pointer = lvalue->symtree->n.sym->attr.proc_pointer;
3262
3262
3263
  rank_remap = false;
3263
  for (ref = lvalue->ref; ref; ref = ref->next)
3264
  for (ref = lvalue->ref; ref; ref = ref->next)
3264
    {
3265
    {
3265
      if (pointer)
3266
      if (pointer)
Lines 3273-3278 gfc_check_pointer_assign (gfc_expr *lval Link Here
3273
3274
3274
      if (ref->type == REF_ARRAY && ref->next == NULL)
3275
      if (ref->type == REF_ARRAY && ref->next == NULL)
3275
	{
3276
	{
3277
	  int dim;
3278
3276
	  if (ref->u.ar.type == AR_FULL)
3279
	  if (ref->u.ar.type == AR_FULL)
3277
	    break;
3280
	    break;
3278
3281
Lines 3285-3303 gfc_check_pointer_assign (gfc_expr *lval Link Here
3285
3288
3286
	  if (gfc_notify_std (GFC_STD_F2003,"Fortran 2003: Bounds "
3289
	  if (gfc_notify_std (GFC_STD_F2003,"Fortran 2003: Bounds "
3287
			      "specification for '%s' in pointer assignment "
3290
			      "specification for '%s' in pointer assignment "
3288
                              "at %L", lvalue->symtree->n.sym->name,
3291
			      "at %L", lvalue->symtree->n.sym->name,
3289
			      &lvalue->where) == FAILURE)
3292
			      &lvalue->where) == FAILURE)
3290
            return FAILURE;
3293
	    return FAILURE;
3291
3294
3292
	  gfc_error ("Pointer bounds remapping at %L is not yet implemented "
3295
	  /* When bounds are given, all lbounds are necessary and either all
3293
		     "in gfortran", &lvalue->where);
3296
	     or none of the upper bounds; no strides are allowed.  If the
3294
	  /* TODO: See PR 29785. Add checks that all lbounds are specified and
3297
	     upper bounds are present, we may do rank remapping.  */
3295
	     either never or always the upper-bound; strides shall not be
3298
	  /* XXX: What about co-dimen?  */
3296
	     present.  */
3299
	  for (dim = 0; dim < ref->u.ar.dimen; ++dim)
3297
	  return FAILURE;
3300
	    {
3301
	      if (!ref->u.ar.start[dim])
3302
		{
3303
		  gfc_error ("Lower bound has to be present for bounds"
3304
			     " remapping at %L", &lvalue->where);
3305
		  return FAILURE;
3306
		}
3307
	      if (ref->u.ar.stride[dim])
3308
		{
3309
		  gfc_error ("Stride must not be present for bounds"
3310
			     " remapping at %L", &lvalue->where);
3311
		  return FAILURE;
3312
		}
3313
3314
	      if (dim == 0)
3315
		rank_remap = (ref->u.ar.end[dim] != NULL);
3316
	      else
3317
		{
3318
		  if ((rank_remap && !ref->u.ar.end[dim])
3319
		      || (!rank_remap && ref->u.ar.end[dim]))
3320
		    {
3321
		      gfc_error ("Either all or none of the upper bounds"
3322
				 " must be specified for bounds remapping"
3323
				 " at %L", &lvalue->where);
3324
		      return FAILURE;
3325
		    }
3326
		}
3327
	    }
3298
	}
3328
	}
3299
    }
3329
    }
3300
3330
3331
  /* XXX: Check size matches.  */
3332
3301
  if (check_intent_in && lvalue->symtree->n.sym->attr.intent == INTENT_IN)
3333
  if (check_intent_in && lvalue->symtree->n.sym->attr.intent == INTENT_IN)
3302
    {
3334
    {
3303
      gfc_error ("Cannot assign to INTENT(IN) variable '%s' at %L",
3335
      gfc_error ("Cannot assign to INTENT(IN) variable '%s' at %L",
Lines 3456-3468 gfc_check_pointer_assign (gfc_expr *lval Link Here
3456
      return FAILURE;
3488
      return FAILURE;
3457
    }
3489
    }
3458
3490
3459
  if (lvalue->rank != rvalue->rank)
3491
  if (lvalue->rank != rvalue->rank && !rank_remap)
3460
    {
3492
    {
3461
      gfc_error ("Different ranks in pointer assignment at %L",
3493
      gfc_error ("Different ranks in pointer assignment at %L", &lvalue->where);
3462
		 &lvalue->where);
3463
      return FAILURE;
3494
      return FAILURE;
3464
    }
3495
    }
3465
3496
3497
  /* Check rank-remapping.  rvalue must be either rank one or it must
3498
     be simply-contiguous and F2008 must be allowed.  */
3499
  if (rank_remap && rvalue->rank != 1)
3500
    {
3501
      if (!gfc_is_simply_contiguous (rvalue, true))
3502
	{
3503
	  gfc_error ("Rank-remapping target with rank not one must be"
3504
		     " simply-contiguous at %L", &rvalue->where);
3505
	  return FAILURE;
3506
	}
3507
      if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Rank-remapping with"
3508
			  " target of rank not one at %L", &rvalue->where)
3509
	    == FAILURE)
3510
	return FAILURE;
3511
    }
3512
3466
  /* Now punt if we are dealing with a NULLIFY(X) or X = NULL(X).  */
3513
  /* Now punt if we are dealing with a NULLIFY(X) or X = NULL(X).  */
3467
  if (rvalue->expr_type == EXPR_NULL)
3514
  if (rvalue->expr_type == EXPR_NULL)
3468
    return SUCCESS;
3515
    return SUCCESS;
(-)gcc/fortran/trans.h (+7 lines)
Lines 64-69 typedef struct gfc_se Link Here
64
     pointer assignments.  */
64
     pointer assignments.  */
65
  unsigned direct_byref:1;
65
  unsigned direct_byref:1;
66
66
67
  /* If direct_byref is set, do work out the descriptor as in that case but
68
     do still create a new descriptor variable instead of using an
69
     existing one.  This is useful for special pointer assignments like
70
     rank remapping where we have to process the descriptor before
71
     assigning to final one.  */
72
  unsigned byref_noassign:1;
73
67
  /* Ignore absent optional arguments.  Used for some intrinsics.  */
74
  /* Ignore absent optional arguments.  Used for some intrinsics.  */
68
  unsigned ignore_optional:1;
75
  unsigned ignore_optional:1;
69
76
(-)gcc/fortran/trans-decl.c (-30 / +3 lines)
Lines 3133-3174 trans_associate_var (gfc_symbol* sym, gf Link Here
3133
	 descriptor to the one generated for the temporary.  */
3133
	 descriptor to the one generated for the temporary.  */
3134
      if (!sym->assoc->variable)
3134
      if (!sym->assoc->variable)
3135
	{
3135
	{
3136
	  tree offs;
3137
	  int dim;
3136
	  int dim;
3138
3137
3139
	  gfc_add_modify (&se.pre, desc, se.expr);
3138
	  gfc_add_modify (&se.pre, desc, se.expr);
3140
3139
3141
	  /* The generated descriptor has lower bound zero (as array
3140
	  /* The generated descriptor has lower bound zero (as array
3142
	     temporary), shift bounds so we get lower bounds of 1 all the time.
3141
	     temporary), shift bounds so we get lower bounds of 1.  */
3143
	     The offset has to be corrected as well.
3144
	     Because the ubound shift and offset depends on the lower bounds, we
3145
	     first calculate those and set the lbound to one last.  */
3146
3147
	  offs = gfc_conv_descriptor_offset_get (desc);
3148
	  for (dim = 0; dim < e->rank; ++dim)
3149
	    {
3150
	      tree from, to;
3151
	      tree stride;
3152
3153
	      from = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]);
3154
	      to = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]);
3155
	      stride = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[dim]);
3156
3157
	      tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3158
				 gfc_index_one_node, from);
3159
	      to = fold_build2 (PLUS_EXPR, gfc_array_index_type, to, tmp);
3160
3161
	      tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, tmp, stride);
3162
	      offs = fold_build2 (MINUS_EXPR, gfc_array_index_type, offs, tmp);
3163
3164
	      gfc_conv_descriptor_ubound_set (&se.pre, desc,
3165
					      gfc_rank_cst[dim], to);
3166
	    }
3167
	  gfc_conv_descriptor_offset_set (&se.pre, desc, offs);
3168
3169
	  for (dim = 0; dim < e->rank; ++dim)
3142
	  for (dim = 0; dim < e->rank; ++dim)
3170
	    gfc_conv_descriptor_lbound_set (&se.pre, desc, gfc_rank_cst[dim],
3143
	    gfc_conv_shift_descriptor_lbound (&se.pre, desc,
3171
					    gfc_index_one_node);
3144
					      dim, gfc_index_one_node);
3172
	}
3145
	}
3173
3146
3174
      /* Done, register stuff as init / cleanup code.  */
3147
      /* Done, register stuff as init / cleanup code.  */
(-)gcc/testsuite/gfortran.dg/pointer_remapping_2.f03 (+20 lines)
Line 0 Link Here
1
! { dg-do compile }
2
! { dg-options "-std=f2003" }
3
4
! PR fortran/29785
5
! Check for F2008 rejection of rank remapping to rank-two base array.
6
7
! Contributed by Daniel Kraft, d@domob.eu.
8
9
PROGRAM main
10
  IMPLICIT NONE
11
  INTEGER, TARGET :: arr(12), basem(3, 4)
12
  INTEGER, POINTER :: vec(:), mat(:, :)
13
14
  ! These are ok.
15
  vec => arr
16
  vec(2:) => arr
17
  mat(1:2, 1:6) => arr
18
19
  vec(1:12) => basem ! { dg-error "Fortran 2008" }
20
END PROGRAM main
(-)gcc/testsuite/gfortran.dg/pointer_remapping_4.f03 (+32 lines)
Line 0 Link Here
1
! { dg-do run }
2
! { dg-options "-std=f2003 -fall-intrinsics" }
3
4
! PR fortran/45016
5
! Check pointer bounds remapping at runtime.
6
7
! Contributed by Daniel Kraft, d@domob.eu.
8
9
PROGRAM main
10
  IMPLICIT NONE
11
  INTEGER, TARGET :: arr(2:5), basem(-2:-1, 3:4)
12
  INTEGER, POINTER :: vec(:), vec2(:), mat(:, :)
13
14
  arr = (/ 1, 2, 3, 4 /)
15
  basem = RESHAPE (arr, SHAPE (basem))
16
17
  vec(0:) => arr
18
  IF (LBOUND (vec, 1) /= 0 .OR. UBOUND (vec, 1) /= 3) CALL abort ()
19
  IF (ANY (vec /= arr)) CALL abort ()
20
  IF (vec(0) /= 1 .OR. vec(2) /= 3) CALL abort ()
21
22
  vec2(-5:) => vec
23
  IF (LBOUND (vec2, 1) /= -5 .OR. UBOUND (vec2, 1) /= -2) CALL abort ()
24
  IF (ANY (vec2 /= arr)) CALL abort ()
25
  IF (vec2(-5) /= 1 .OR. vec2(-3) /= 3) CALL abort ()
26
27
  mat(1:, 2:) => basem
28
  IF (ANY (LBOUND (mat) /= (/ 1, 2 /) .OR. UBOUND (mat) /= (/ 2, 3 /))) &
29
    CALL abort ()
30
  IF (ANY (mat /= basem)) CALL abort ()
31
  IF (mat(1, 2) /= 1 .OR. mat(1, 3) /= 3 .OR. mat(2, 3) /= 4) CALL abort ()
32
END PROGRAM main
(-)gcc/testsuite/gfortran.dg/pointer_assign_5.f90 (-2 / +3 lines)
Lines 1-9 Link Here
1
! { dg-do compile }
1
! { dg-do compile }
2
! PR fortran/37580
2
! PR fortran/37580
3
!
3
4
! See also the pointer_remapping_* tests.
5
4
program test
6
program test
5
implicit none
7
implicit none
6
real, pointer :: ptr1(:), ptr2(:)
8
real, pointer :: ptr1(:), ptr2(:)
7
ptr1(1) => ptr2 ! { dg-error "Expected bounds specification" }
9
ptr1(1) => ptr2 ! { dg-error "Expected bounds specification" }
8
ptr1(1:) => ptr2 ! { dg-error "not yet implemented in gfortran" }
9
end program test
10
end program test
(-)gcc/testsuite/gfortran.dg/pointer_remapping_3.f08 (+31 lines)
Line 0 Link Here
1
! { dg-do compile }
2
! { dg-options "-std=f2008" }
3
4
! PR fortran/29785
5
! PR fortran/45016
6
! Check for pointer remapping compile-time errors.
7
8
! Contributed by Daniel Kraft, d@domob.eu.
9
10
PROGRAM main
11
  IMPLICIT NONE
12
  INTEGER, TARGET :: arr(12), basem(3, 4)
13
  INTEGER, POINTER :: vec(:), mat(:, :)
14
15
  ! XXX: Check for size mismatch.
16
17
  ! Existence of reference elements.
18
  vec(:) => arr ! { dg-error "Lower bound has to be present" }
19
  vec(5:7:1) => arr ! { dg-error "Stride must not be present" }
20
  mat(1:, 2:5) => arr ! { dg-error "Either all or none of the upper bounds" }
21
  mat(2, 6) => arr ! { dg-error "Expected bounds specification" }
22
23
  ! This is bound remapping not rank remapping!
24
  mat(1:, 3:) => arr ! { dg-error "Different ranks" }
25
26
  ! Invalid remapping target; for non-rank one we already check the F2008
27
  ! error elsewhere.  Here, test that not-contiguous target is disallowed
28
  ! with rank > 1.
29
  mat(1:2, 1:3) => arr(1:12:2) ! This is ok, rank one target.
30
  vec(1:8) => basem(1:3:2, :) ! { dg-error "must be simply-contiguous" }
31
END PROGRAM main
(-)gcc/testsuite/gfortran.dg/pointer_remapping_1.f90 (+19 lines)
Line 0 Link Here
1
! { dg-do compile }
2
! { dg-options "-std=f95" }
3
4
! PR fortran/29785
5
! PR fortran/45016
6
! Check for F2003 rejection of pointer remappings.
7
8
! Contributed by Daniel Kraft, d@domob.eu.
9
10
PROGRAM main
11
  IMPLICIT NONE
12
  INTEGER, TARGET :: arr(12)
13
  INTEGER, POINTER :: vec(:), mat(:, :)
14
15
  vec => arr ! This is ok.
16
17
  vec(2:) => arr ! { dg-error "Fortran 2003" }
18
  mat(1:2, 1:6) => arr ! { dg-error "Fortran 2003" }
19
END PROGRAM main
(-)gcc/testsuite/gfortran.dg/pointer_remapping_5.f08 (+37 lines)
Line 0 Link Here
1
! { dg-do run }
2
! { dg-options "-std=f2008 -fall-intrinsics" }
3
4
! PR fortran/29785
5
! Check pointer rank remapping at runtime.
6
7
! Contributed by Daniel Kraft, d@domob.eu.
8
9
PROGRAM main
10
  IMPLICIT NONE
11
  INTEGER, TARGET :: arr(12), basem(3, 4)
12
  INTEGER, POINTER :: vec(:), mat(:, :)
13
  INTEGER :: i
14
15
  arr = (/ (i, i = 1, 12) /)
16
  basem = RESHAPE (arr, SHAPE (basem))
17
18
  ! We need not necessarily change the rank...
19
  vec(2:5) => arr(1:12:2)
20
  IF (LBOUND (vec, 1) /= 2 .OR. UBOUND (vec, 1) /= 5) CALL abort ()
21
  IF (ANY (vec /= (/ 1, 3, 5, 7 /))) CALL abort ()
22
  IF (vec(2) /= 1 .OR. vec(5) /= 7) CALL abort ()
23
24
  ! ...but it is of course the more interesting.  Also try remapping a pointer.
25
  vec => arr(1:12:2)
26
  mat(1:3, 1:2) => vec
27
  IF (ANY (LBOUND (mat) /= (/ 1, 1 /) .OR. UBOUND (mat) /= (/ 3, 2 /))) &
28
    CALL abort ()
29
  IF (ANY (mat /= RESHAPE (arr(1:12:2), SHAPE (mat)))) CALL abort ()
30
  IF (mat(1, 1) /= 1 .OR. mat(1, 2) /= 7) CALL abort ()
31
32
  ! Remap with target of rank > 1.
33
  vec(1:12) => basem
34
  IF (LBOUND (vec, 1) /= 1 .OR. UBOUND (vec, 1) /= 12) CALL abort ()
35
  IF (ANY (vec /= arr)) CALL abort ()
36
  IF (vec(1) /= 1 .OR. vec(5) /= 5 .OR. vec(12) /= 12) CALL abort ()
37
END PROGRAM main

Return to bug 29785