re PR fortran/89363 (RANK incorrect for unallocated allocatable)

2019-03-12  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-12  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.

From-SVN: r269612

gcc/fortran/ChangeLog

+2019-03-12  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-11  Jakub Jelinek  <jakub@redhat.com>
 
 	PR fortran/89651

gcc/fortran/trans-expr.c

@@ -4919,6 +4919,52 @@ expr_may_alias_variables (gfc_expr *e, bool array_may_alias)
 }
 
 
+/* 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. */
 
@@ -4958,6 +5004,15 @@ gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym)
 	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)
@@ -5953,6 +6008,30 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 		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

gcc/fortran/trans-intrinsic.c

@@ -2873,7 +2873,7 @@ gfc_conv_intrinsic_is_contiguous (gfc_se * se, gfc_expr * expr)
       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));
@@ -3103,6 +3103,29 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
 	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);
 }
@@ -6243,6 +6266,8 @@ gfc_conv_intrinsic_shape (gfc_se *se, gfc_expr *expr)
 {
   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;
@@ -6252,6 +6277,59 @@ gfc_conv_intrinsic_shape (gfc_se *se, gfc_expr *expr)
   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
@@ -10390,7 +10468,7 @@ gfc_inline_intrinsic_function_p (gfc_expr *expr)
 	  && maskexpr->symtree->n.sym->attr.dummy
 	  && maskexpr->symtree->n.sym->attr.optional)
 	return false;
-	  
+
       return true;
 
     case GFC_ISYM_TRANSPOSE:

gcc/testsuite/ChangeLog

+2019-03-12  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.
+
 2019-03-12  Jakub Jelinek  <jakub@redhat.com>
 
 	PR middle-end/89663
@@ -731,7 +739,7 @@
 2019-02-25  Dominique d'Humieres  <dominiq@gcc.gnu.org>
 
 	PR fortran/89282
-	* gfortran.dg/overload_3.f90: New test. 
+	* gfortran.dg/overload_3.f90: New test.
 
 2019-02-25  Jakub Jelinek  <jakub@redhat.com>
 
@@ -741,7 +749,7 @@
 2019-02-25  Dominique d'Humieres  <dominiq@gcc.gnu.org>
 
 	PR libfortran/89274
-	* gfortran.dg/list_directed_large.f90: New test. 
+	* gfortran.dg/list_directed_large.f90: New test.
 
 2019-02-25  Jakub Jelinek  <jakub@redhat.com>
 

gcc/testsuite/gfortran.dg/assumed_rank_16.f90

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

gcc/testsuite/gfortran.dg/assumed_rank_17.f90

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