[fortran] PRs 89363 and 89364 - wrinkles with assumed rank

Message ID CAGkQGiK0ArftDZeDPfHbqfhEto+EqJmw4B2-A1i5cPtNmJ8Cgg@mail.gmail.com
State New
Headers show
Series
  • [fortran] PRs 89363 and 89364 - wrinkles with assumed rank
Related show

Commit Message

Paul Richard Thomas March 10, 2019, 3:27 p.m.
The attached patch implements fixes for a couple of wrinkles with assumed rank:
(i) PR89363 flagged the fact that the rank was not be set for assumed
rank entities, associated with unallocated or unassociated arrays. The
fix is straightforward, the work being done by
trans-expr.c(set_dtype_for_unallocated).
(ii) PR89364 points out that ubound and shape should be returning -1
for the final dimension and not 0, for assumed rank entities argument
associated with assumed size arrays. The fix for this is bolted on to
both intrinsics. BTW lbound seems lack a bit of fixing of intermediate
expressions - the result is often overwhelmingly complicated. Is there
some reason for this?

Bootstrapped and regtested on FC29/x86_64 - OK for trunk?

Paul

PS I scoped out the select rank construct. It looks well doable but
will have to await 10-branch opening.

2019-03-10  Paul Thomas  <pault@gcc.gnu.org>

    PR fortran/89363
    PR fortran/89364
    * trans-expr.c (set_dtype_for_unallocated): New function.
    (gfc_conv_gfc_desc_to_cfi_desc): Call it for allocatable and
    pointer arguments.
    (gfc_conv_procedure_call): Likewise. Also, set the ubound of
    the final dimension to -1 for assumed rank formal args that are
    associated with assumed size arrays.
    * trans-intrinsic.c (gfc_conv_intrinsic_bound): Return -1 for
    the final dimension of assumed rank entities that are argument
    associated with assumed size arrays.
    (gfc_conv_intrinsic_shape): Likewise return -1 for the final
    dimension of the shape intrinsic.

2019-03-10  Paul Thomas  <pault@gcc.gnu.org>

    PR fortran/89363
    * gfortran.dg/assumed_rank_16.f90: New test.

    PR fortran/89364
    * gfortran.dg/assumed_rank_17.f90: New test.

Comments

Thomas Koenig March 10, 2019, 5:22 p.m. | #1
Hi Paul,

> (ii) PR89364 points out that ubound and shape should be returning -1

> for the final dimension and not 0, for assumed rank entities argument

> associated with assumed size arrays.


What a mix of features...

> Bootstrapped and regtested on FC29/x86_64 - OK for trunk?


OK. Thanks for the patch!

Regards

	Thomas

Patch

Index: gcc/fortran/trans-expr.c
===================================================================
*** gcc/fortran/trans-expr.c	(revision 269523)
--- gcc/fortran/trans-expr.c	(working copy)
*************** expr_may_alias_variables (gfc_expr *e, b
*** 4919,4924 ****
--- 4919,4970 ----
  }
  
  
+ /* A helper function to set the dtype for unallocated or unassociated
+    entities.  */
+ 
+ static void
+ set_dtype_for_unallocated (gfc_se *parmse, gfc_expr *e)
+ {
+   tree tmp;
+   tree desc;
+   tree cond;
+   tree type;
+   stmtblock_t block;
+ 
+   /* TODO Figure out how to handle optional dummies.  */
+   if (e && e->expr_type == EXPR_VARIABLE
+       && e->symtree->n.sym->attr.optional)
+     return;
+ 
+   desc = parmse->expr;
+   if (desc == NULL_TREE)
+     return;
+ 
+   if (POINTER_TYPE_P (TREE_TYPE (desc)))
+     desc = build_fold_indirect_ref_loc (input_location, desc);
+ 
+   if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
+     return;
+ 
+   gfc_init_block (&block);
+   tmp = gfc_conv_descriptor_data_get (desc);
+   cond = fold_build2_loc (input_location, EQ_EXPR,
+ 			  logical_type_node, tmp,
+ 			  build_int_cst (TREE_TYPE (tmp), 0));
+   tmp = gfc_conv_descriptor_dtype (desc);
+   type = gfc_get_element_type (TREE_TYPE (desc));
+   tmp = fold_build2_loc (input_location, MODIFY_EXPR,
+ 			 TREE_TYPE (tmp), tmp,
+ 			 gfc_get_dtype_rank_type (e->rank, type));
+   gfc_add_expr_to_block (&block, tmp);
+   cond = build3_v (COND_EXPR, cond,
+ 		   gfc_finish_block (&block),
+ 		   build_empty_stmt (input_location));
+   gfc_add_expr_to_block (&parmse->pre, cond);
+ }
+ 
+ 
+ 
  /* Provide an interface between gfortran array descriptors and the F2018:18.4
     ISO_Fortran_binding array descriptors. */
  
*************** gfc_conv_gfc_desc_to_cfi_desc (gfc_se *p
*** 4958,4963 ****
--- 5004,5018 ----
  	parmse->expr = build_fold_indirect_ref_loc (input_location,
  						    parmse->expr);
  
+       /* Unallocated allocatable arrays and unassociated pointer arrays
+ 	 need their dtype setting if they are argument associated with
+ 	 assumed rank dummies.  */
+       if (fsym && fsym->as
+ 	  && fsym->as->type == AS_ASSUMED_RANK
+ 	  && (gfc_expr_attr (e).pointer
+ 	      || gfc_expr_attr (e).allocatable))
+ 	set_dtype_for_unallocated (parmse, e);
+ 
        /* All the temporary descriptors are marked as DECL_ARTIFICIAL. If
  	 the expression type is different from the descriptor type, then
  	 the offset must be found (eg. to a component ref or substring)
*************** gfc_conv_procedure_call (gfc_se * se, gf
*** 5953,5958 ****
--- 6008,6037 ----
  		gfc_conv_array_parameter (&parmse, e, nodesc_arg, fsym,
  					  sym->name, NULL);
  
+ 	      /* Unallocated allocatable arrays and unassociated pointer arrays
+ 		 need their dtype setting if they are argument associated with
+ 		 assumed rank dummies.  */
+ 	      if (!sym->attr.is_bind_c && e && fsym && fsym->as
+ 		  && fsym->as->type == AS_ASSUMED_RANK)
+ 		{
+ 		  if (gfc_expr_attr (e).pointer
+ 		      || gfc_expr_attr (e).allocatable)
+ 		    set_dtype_for_unallocated (&parmse, e);
+ 		  else if (e->expr_type == EXPR_VARIABLE
+ 			   && e->symtree->n.sym->attr.dummy
+ 			   && e->symtree->n.sym->as
+ 			   && e->symtree->n.sym->as->type == AS_ASSUMED_SIZE)
+ 		    {
+ 		      tree minus_one;
+ 		      tmp = build_fold_indirect_ref_loc (input_location,
+ 							 parmse.expr);
+ 		      minus_one = build_int_cst (gfc_array_index_type, -1);
+ 		      gfc_conv_descriptor_ubound_set (&parmse.pre, tmp,
+ 						      gfc_rank_cst[e->rank - 1],
+ 						      minus_one);
+  		    }
+ 		}
+ 
  	      /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
  		 allocated on entry, it must be deallocated.  */
  	      if (fsym && fsym->attr.allocatable
Index: gcc/fortran/trans-intrinsic.c
===================================================================
*** gcc/fortran/trans-intrinsic.c	(revision 269523)
--- gcc/fortran/trans-intrinsic.c	(working copy)
*************** gfc_conv_intrinsic_is_contiguous (gfc_se
*** 2873,2879 ****
        gfc_add_block_to_block (&se->pre, &argse.pre);
        gfc_add_block_to_block (&se->post, &argse.post);
        desc = gfc_evaluate_now (argse.expr, &se->pre);
!   
        stride = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[0]);
        cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
  			      stride, build_int_cst (TREE_TYPE (stride), 1));
--- 2873,2879 ----
        gfc_add_block_to_block (&se->pre, &argse.pre);
        gfc_add_block_to_block (&se->post, &argse.post);
        desc = gfc_evaluate_now (argse.expr, &se->pre);
! 
        stride = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[0]);
        cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
  			      stride, build_int_cst (TREE_TYPE (stride), 1));
*************** gfc_conv_intrinsic_bound (gfc_se * se, g
*** 3103,3108 ****
--- 3103,3131 ----
  	se->expr = gfc_index_one_node;
      }
  
+   /* According to F2018 16.9.172, para 5, an assumed rank object, argument
+      associated with and assumed size array, has the ubound of the final
+      dimension set to -1 and UBOUND must return this.  */
+   if (upper && as && as->type == AS_ASSUMED_RANK)
+     {
+       tree minus_one = build_int_cst (gfc_array_index_type, -1);
+       tree rank = fold_convert (gfc_array_index_type,
+ 				gfc_conv_descriptor_rank (desc));
+       rank = fold_build2_loc (input_location, PLUS_EXPR,
+ 			      gfc_array_index_type, rank, minus_one);
+       /* Fix the expression to stop it from becoming even more complicated.  */
+       se->expr = gfc_evaluate_now (se->expr, &se->pre);
+       cond = fold_build2_loc (input_location, NE_EXPR,
+ 			     logical_type_node, bound, rank);
+       cond1 = fold_build2_loc (input_location, NE_EXPR,
+ 			       logical_type_node, ubound, minus_one);
+       cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
+ 			      logical_type_node, cond, cond1);
+       se->expr = fold_build3_loc (input_location, COND_EXPR,
+ 				  gfc_array_index_type, cond,
+ 				  se->expr, minus_one);
+     }
+ 
    type = gfc_typenode_for_spec (&expr->ts);
    se->expr = convert (type, se->expr);
  }
*************** gfc_conv_intrinsic_shape (gfc_se *se, gf
*** 6243,6248 ****
--- 6266,6273 ----
  {
    gfc_actual_arglist *s, *k;
    gfc_expr *e;
+   gfc_array_spec *as;
+   gfc_ss *ss;
  
    /* Remove the KIND argument, if present. */
    s = expr->value.function.actual;
*************** gfc_conv_intrinsic_shape (gfc_se *se, gf
*** 6252,6257 ****
--- 6277,6335 ----
    k->expr = NULL;
  
    gfc_conv_intrinsic_funcall (se, expr);
+ 
+   as = gfc_get_full_arrayspec_from_expr (s->expr);;
+   ss = gfc_walk_expr (s->expr);
+ 
+   /* According to F2018 16.9.172, para 5, an assumed rank entity, argument
+      associated with an assumed size array, has the ubound of the final
+      dimension set to -1 and SHAPE must return this.  */
+   if (as && as->type == AS_ASSUMED_RANK
+       && se->expr && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se->expr))
+       && ss && ss->info->type == GFC_SS_SECTION)
+     {
+       tree desc, rank, minus_one, cond, ubound, tmp;
+       stmtblock_t block;
+       gfc_se ase;
+ 
+       minus_one = build_int_cst (gfc_array_index_type, -1);
+ 
+       /* Recover the descriptor for the array.  */
+       gfc_init_se (&ase, NULL);
+       ase.descriptor_only = 1;
+       gfc_conv_expr_lhs (&ase, ss->info->expr);
+ 
+       /* Obtain rank-1 so that we can address both descriptors.  */
+       rank = gfc_conv_descriptor_rank (ase.expr);
+       rank = fold_convert (gfc_array_index_type, rank);
+       rank = fold_build2_loc (input_location, PLUS_EXPR,
+ 			      gfc_array_index_type,
+ 			      rank, minus_one);
+       rank = gfc_evaluate_now (rank, &se->pre);
+ 
+       /* The ubound for the final dimension will be tested for being -1.  */
+       ubound = gfc_conv_descriptor_ubound_get (ase.expr, rank);
+       ubound = gfc_evaluate_now (ubound, &se->pre);
+       cond = fold_build2_loc (input_location, EQ_EXPR,
+ 			     logical_type_node,
+ 			     ubound, minus_one);
+ 
+       /* Obtain the last element of the result from the library shape
+ 	 intrinsic and set it to -1 if that is the value of ubound.  */
+       desc = se->expr;
+       tmp = gfc_conv_array_data (desc);
+       tmp = build_fold_indirect_ref_loc (input_location, tmp);
+       tmp = gfc_build_array_ref (tmp, rank, NULL, NULL);
+ 
+       gfc_init_block (&block);
+       gfc_add_modify (&block, tmp, build_int_cst (TREE_TYPE (tmp), -1));
+ 
+       cond = build3_v (COND_EXPR, cond,
+ 		       gfc_finish_block (&block),
+ 		       build_empty_stmt (input_location));
+       gfc_add_expr_to_block (&se->pre, cond);
+     }
+ 
  }
  
  static void
*************** gfc_inline_intrinsic_function_p (gfc_exp
*** 10390,10396 ****
  	  && maskexpr->symtree->n.sym->attr.dummy
  	  && maskexpr->symtree->n.sym->attr.optional)
  	return false;
! 	  
        return true;
  
      case GFC_ISYM_TRANSPOSE:
--- 10468,10474 ----
  	  && maskexpr->symtree->n.sym->attr.dummy
  	  && maskexpr->symtree->n.sym->attr.optional)
  	return false;
! 
        return true;
  
      case GFC_ISYM_TRANSPOSE:
Index: gcc/testsuite/gfortran.dg/assumed_rank_16.f90
===================================================================
*** gcc/testsuite/gfortran.dg/assumed_rank_16.f90	(nonexistent)
--- gcc/testsuite/gfortran.dg/assumed_rank_16.f90	(working copy)
***************
*** 0 ****
--- 1,45 ----
+ ! { dg-do run }
+ !
+ ! Tests the fix for PR89363, in which the rank of unallocated or unassociated
+ ! entities, argument associated with assumed rank dummies, was not being set.
+ !
+ ! Contributed by Reinhold Bader  <Bader@lrz.de>
+ !
+ module mod_ass_rank_02
+   implicit none
+ contains
+   subroutine procr(this,flag)
+     real, allocatable :: this(..)
+     logical :: flag
+     if (rank(this) /= 2 .or. allocated(this)) then
+        write(*,*) 'FAIL procr', rank(this), allocated(this)
+        flag = .FALSE.
+      end if
+   end subroutine procr
+   subroutine procs(this,flag)
+     real, allocatable :: this(..)
+     logical :: flag
+     if (rank(this) /= 2 .or. .not. allocated(this)) then
+        write(*,*) 'FAIL procs status', rank(this), allocated(this)
+        flag = .FALSE.
+      end if
+      if (size(this,1) /= 2 .and. size(this,2) /= 5) then
+        write(*,*) 'FAIL procs shape', size(this)
+        flag = .FALSE.
+      end if
+   end subroutine procs
+ end module mod_ass_rank_02
+ program ass_rank_02
+   use mod_ass_rank_02
+   implicit none
+   real, allocatable :: x(:,:)
+   logical :: flag
+ 
+   flag = .TRUE.
+   call procr(x,flag)
+   if (.not.flag) stop 1
+   allocate(x(2,5))
+   call procs(x,flag)
+   if (.not.flag) stop 2
+   deallocate(x)
+ end program ass_rank_02
Index: gcc/testsuite/gfortran.dg/assumed_rank_17.f90
===================================================================
*** gcc/testsuite/gfortran.dg/assumed_rank_17.f90	(nonexistent)
--- gcc/testsuite/gfortran.dg/assumed_rank_17.f90	(working copy)
***************
*** 0 ****
--- 1,34 ----
+ ! { dg-do run }
+ !
+ ! Tests the fix for PR89364, in which the ubound and the last element of
+ ! shape were note returning -1 for assumed rank entities, argument
+ ! associated with assumed size dummies.
+ !
+ ! Contributed by Reinhold Bader  <Bader@lrz.de>
+ !
+ module mod_ass_rank_04
+   implicit none
+ contains
+   subroutine si(this)
+     real :: this(4, *)
+     call sa(this)
+   end subroutine si
+   subroutine sa(this)
+     real :: this(..)
+     if (rank(this) /= 2) then
+        stop 1
+     end if
+     if (maxval(abs(shape(this) - [4,-1])) > 0) then
+        stop 2
+     end if
+     if (ubound(this,2) /= lbound(this,2) - 2) then
+        stop 3
+     end if
+   end subroutine sa
+ end module mod_ass_rank_04
+ program ass_rank_04
+   use mod_ass_rank_04
+   implicit none
+   real :: y(9)
+   call si(y(2))
+ end program ass_rank_04