Patch and ChangeLogs for PR93581

gcc/fortran/ChangeLog

+2020-03-08  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/93581
+	* resolve.c (gfc_resolve_ref): Modify array refs to be elements
+	if the ref chain ends in INQUIRY_LEN.
+	* trans-array.c (gfc_get_dataptr_offset): Provide the offsets
+	for INQUIRY_RE and INQUIRY_IM.
+
 2020-03-05 Steven G. Kargl  <kargl@gcc.gnu.org>
 
 	PR fortran/93792

gcc/fortran/resolve.c

@@ -5199,8 +5199,8 @@ gfc_resolve_substring_charlen (gfc_expr *e)
 bool
 gfc_resolve_ref (gfc_expr *expr)
 {
-  int current_part_dimension, n_components, seen_part_dimension;
-  gfc_ref *ref, **prev;
+  int current_part_dimension, n_components, seen_part_dimension, dim;
+  gfc_ref *ref, **prev, *array_ref;
   bool equal_length;
 
   for (ref = expr->ref; ref; ref = ref->next)
@@ -5246,12 +5246,14 @@ gfc_resolve_ref (gfc_expr *expr)
   current_part_dimension = 0;
   seen_part_dimension = 0;
   n_components = 0;
+  array_ref = NULL;
 
   for (ref = expr->ref; ref; ref = ref->next)
     {
       switch (ref->type)
 	{
 	case REF_ARRAY:
+	  array_ref = ref;
 	  switch (ref->u.ar.type)
 	    {
 	    case AR_FULL:
@@ -5267,6 +5269,7 @@ gfc_resolve_ref (gfc_expr *expr)
 	      break;
 
 	    case AR_ELEMENT:
+	      array_ref = NULL;
 	      current_part_dimension = 0;
 	      break;
 
@@ -5306,7 +5309,33 @@ gfc_resolve_ref (gfc_expr *expr)
 	  break;
 
 	case REF_SUBSTRING:
+	  break;
+
 	case REF_INQUIRY:
+	  /* Implement requirement in note 9.7 of F2018 that the result of the
+	     LEN inquiry be a scalar.  */
+	  if (ref->u.i == INQUIRY_LEN && array_ref)
+	    {
+	      array_ref->u.ar.type = AR_ELEMENT;
+	      expr->rank = 0;
+	      /* INQUIRY_LEN is not evaluated from the the rest of the expr
+		 but directly from the string length. This means that setting
+		 the array indices to one does not matter but might trigger
+		 a runtime bounds error. Suppress the check.  */
+	      expr->no_bounds_check = 1;
+	      for (dim = 0; dim < array_ref->u.ar.dimen; dim++)
+		{
+		  array_ref->u.ar.dimen_type[dim] = DIMEN_ELEMENT;
+		  if (array_ref->u.ar.start[dim])
+		    gfc_free_expr (array_ref->u.ar.start[dim]);
+		  array_ref->u.ar.start[dim]
+			= gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
+		  if (array_ref->u.ar.end[dim])
+		    gfc_free_expr (array_ref->u.ar.end[dim]);
+		  if (array_ref->u.ar.stride[dim])
+		    gfc_free_expr (array_ref->u.ar.stride[dim]);
+		}
+	    }
 	  break;
 	}
 

gcc/fortran/trans-array.c

@@ -6947,6 +6947,24 @@ gfc_get_dataptr_offset (stmtblock_t *block, tree parm, tree desc, tree offset,
 	      tmp = gfc_build_array_ref (tmp, index, NULL);
 	      break;
 
+	    case REF_INQUIRY:
+	      switch (ref->u.i)
+		{
+		case INQUIRY_RE:
+		  tmp = fold_build1_loc (input_location, REALPART_EXPR,
+					 TREE_TYPE (TREE_TYPE (tmp)), tmp);
+		  break;
+
+		case INQUIRY_IM:
+		  tmp = fold_build1_loc (input_location, IMAGPART_EXPR,
+					 TREE_TYPE (TREE_TYPE (tmp)), tmp);
+		  break;
+
+		default:
+		  break;
+		}
+	      break;
+
 	    default:
 	      gcc_unreachable ();
 	      break;

gcc/testsuite/ChangeLog

+2020-03-08  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/93581
+	* gfortran.dg/inquiry_type_ref_6.f90 : New test.
+
 2020-03-08  Patrick Palka  <ppalka@redhat.com>
 
 	PR c++/93729
@@ -20,7 +25,7 @@
 
 2020-03-06  Wilco Dijkstra  <wdijkstr@arm.com>
 
-	* gcc.target/aarch64/fmla_intrinsic_1.c: Check for correct lane syntax.	
+	* gcc.target/aarch64/fmla_intrinsic_1.c: Check for correct lane syntax.
 	* gcc.target/aarch64/fmls_intrinsic_1.c: Likewise.
 	* gcc.target/aarch64/mla_intrinsic_1.c: Likewise.
 	* gcc.target/aarch64/mls_intrinsic_1.c: Likewise.

gcc/testsuite/gfortran.dg/inquiry_type_ref_6.f90

+! { dg-do run }
+! { dg-options "-fcheck=all" }
+!
+! Test the fix for PR93581 and the implementation of note 9.7 of F2018.
+! The latter requires that the result of the LEN inquiry be a scalar
+! even for array expressions.
+!
+! Contributed by Gerhard Steinmetz  <gscfq@t-online.de>
+!
+program p
+   complex, target :: z(2) = [(1.0, 2.0),(3.0, 4.0)]
+   character(:), allocatable, target :: c(:)
+   real, pointer :: r(:)
+   character(:), pointer :: s(:)
+
+   r => z%re
+   if (any (r .ne. real (z))) stop 1
+   r => z%im
+   if (any (r .ne. imag (z))) stop 2
+
+   allocate (c, source = ['abc','def'])
+   s(-2:-1) => c(1:2)
+   if (s%len .ne. len (c)) stop 3
+end