Fortran: Assumed and explicit size class arrays [PR46691/99819].

2021-05-06  Paul Thomas  <pault@gcc.gnu.org>

gcc/fortran/ChangeLog

	PR fortran/46691
	PR fortran/99819
	* class.c (gfc_build_class_symbol): Remove the error that
	disables assumed size class arrays. Class array types that are
	not deferred shape or assumed rank are given a unique name and
	placed in the procedure namespace.
	* trans-array.c (gfc_trans_g77_array): Obtain the data pointer
	for class arrays.
	(gfc_trans_dummy_array_bias): Suppress the runtime error for
	extent violations in explicit shape class arrays because it
	always fails.
	* trans-expr.c (gfc_conv_procedure_call): Handle assumed size
	class actual arguments passed to non-descriptor formal args by
	using the data pointer, stored as the symbol's backend decl.

gcc/testsuite/ChangeLog

	PR fortran/46691
	PR fortran/99819
	* gfortran.dg/class_dummy_6.f90: New test.
	* gfortran.dg/class_dummy_7.f90: New test.

5 files changed, 169 insertions, 10 deletions

diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c
index 8935321..93118ad 100644
--- a/gcc/fortran/class.c
+++ b/gcc/fortran/class.c
@@ -630,6 +630,7 @@ gfc_get_len_component (gfc_expr *e, int k)
    component '_vptr' which determines the dynamic type.  When this CLASS
    entity is unlimited polymorphic, then also add a component '_len' to
    store the length of string when that is stored in it.  */
+static int ctr = 0;
 
 bool
 gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
@@ -645,13 +646,6 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
 
   gcc_assert (as);
 
-  if (*as && (*as)->type == AS_ASSUMED_SIZE)
-    {
-      gfc_error ("Assumed size polymorphic objects or components, such "
-		 "as that at %C, have not yet been implemented");
-      return false;
-    }
-
   if (attr->class_ok)
     /* Class container has already been built.  */
     return true;
@@ -693,7 +687,30 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
   else
     ns = ts->u.derived->ns;
 
-  gfc_find_symbol (name, ns, 0, &fclass);
+  /* Although this might seem to be counterintuitive, we can build separate
+     class types with different array specs because the TKR interface checks
+     work on the declared type. All array type other than deferred shape or
+     assumed rank are added to the function namespace to ensure that they
+     are properly distinguished.  */
+  if (attr->dummy && !attr->codimension && (*as)
+      && !((*as)->type == AS_DEFERRED || (*as)->type == AS_ASSUMED_RANK))
+    {
+      char *sname;
+      ns = gfc_current_ns;
+      gfc_find_symbol (name, ns, 0, &fclass);
+      /* If a local class type with this name already exists, update the
+	 name with an index.  */
+      if (fclass)
+	{
+	  fclass = NULL;
+	  sname = xasprintf ("%s_%d", name, ++ctr);
+	  free (name);
+	  name = sname;
+	}
+    }
+  else
+    gfc_find_symbol (name, ns, 0, &fclass);
+
   if (fclass == NULL)
     {
       gfc_symtree *st;
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index e99980f..6d38ea7 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -6524,7 +6524,14 @@ gfc_trans_g77_array (gfc_symbol * sym, gfc_wrapped_block * block)
   /* Set the pointer itself if we aren't using the parameter directly.  */
   if (TREE_CODE (parm) != PARM_DECL)
     {
-      tmp = convert (TREE_TYPE (parm), GFC_DECL_SAVED_DESCRIPTOR (parm));
+      tmp = GFC_DECL_SAVED_DESCRIPTOR (parm);
+      if (sym->ts.type == BT_CLASS)
+	{
+	  tmp = build_fold_indirect_ref_loc (input_location, tmp);
+	  tmp = gfc_class_data_get (tmp);
+	  tmp = gfc_conv_descriptor_data_get (tmp);
+	}
+      tmp = convert (TREE_TYPE (parm), tmp);
       gfc_add_modify (&init, parm, tmp);
     }
   stmt = gfc_finish_block (&init);
@@ -6626,7 +6633,8 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc,
       && VAR_P (sym->ts.u.cl->backend_decl))
     gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
 
-  checkparm = (as->type == AS_EXPLICIT
+  /* TODO: Fix the exclusion of class arrays from extent checking.  */
+  checkparm = (as->type == AS_EXPLICIT && !is_classarray
 	       && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS));
 
   no_repack = !(GFC_DECL_PACKED_ARRAY (tmpdesc)
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 9389a45..7e3de41 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -6418,6 +6418,15 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 				fsym ? fsym->attr.intent : INTENT_INOUT,
 				fsym && fsym->attr.pointer);
 
+	      else if (e->ts.type == BT_CLASS && CLASS_DATA (e)->as
+		       && CLASS_DATA (e)->as->type == AS_ASSUMED_SIZE
+		       && nodesc_arg && fsym->ts.type == BT_DERIVED)
+		/* An assumed size class actual argument being passed to
+		   a 'no descriptor' formal argument just requires the
+		   data pointer to be passed. For class dummy arguments
+		   this is stored in the symbol backend decl..  */
+		parmse.expr = e->symtree->n.sym->backend_decl;
+
 	      else if (gfc_is_class_array_ref (e, NULL)
 		       && fsym && fsym->ts.type == BT_DERIVED)
 		/* The actual argument is a component reference to an
diff --git a/gcc/testsuite/gfortran.dg/class_dummy_6.f90 b/gcc/testsuite/gfortran.dg/class_dummy_6.f90
new file mode 100644
index 0000000..79f6e86
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/class_dummy_6.f90
@@ -0,0 +1,65 @@
+! { dg-do run }
+!
+! Test the fix for PR99819 - explicit shape class arrays in different
+! procedures caused an ICE.
+!
+! Contributed by Gerhard Steinmetz  <gscfq@t-online.de>
+!
+program p
+   type t
+      integer :: i
+   end type
+   class(t), allocatable :: dum1(:), dum2(:), dum3(:,:)
+
+   allocate (t :: dum1(3), dum2(10), dum3(2,5))
+   dum2%i = [1,2,3,4,5,6,7,8,9,10]
+   dum3%i = reshape ([1,2,3,4,5,6,7,8,9,10],[2,5])
+
+! Somewhat elaborated versions of the PR procedures.
+   if (f (dum1, dum2, dum3) .ne. 10) stop 1
+   if (g (dum1) .ne. 3) stop 2
+
+! Test the original versions of the procedures.
+   if (f_original (dum1, dum2) .ne. 3) stop 3
+   if (g_original (dum2) .ne. 10) stop 4
+
+contains
+   integer function f(x, y, z)
+      class(t) :: x(:)
+      class(t) :: y(size( x))
+      class(t) :: z(2,*)
+      if (size (y) .ne. 3) stop 5
+      if (size (z) .ne. 0) stop 6
+      select type (y)
+        type is (t)
+          f = 1
+          if (any (y%i .ne. [1,2,3])) stop 7
+        class default
+          f = 0
+      end select
+      select type (z)
+        type is (t)
+          f = f*10
+          if (any (z(1,1:4)%i .ne. [1,3,5,7])) stop 8
+        class default
+          f = 0
+      end select
+   end
+   integer function g(z)
+      class(t) :: z(:)
+      type(t) :: u(size(z))
+      g = size (u)
+   end
+
+   integer function f_original(x, y)
+      class(t) :: x(:)
+      class(*) :: y(size (x))
+      f_original = size (y)
+   end
+
+   integer function g_original(z)
+      class(*) :: z(:)
+      type(t) :: u(size(z))
+      g_original = size (u)
+   end
+end
diff --git a/gcc/testsuite/gfortran.dg/class_dummy_7.f90 b/gcc/testsuite/gfortran.dg/class_dummy_7.f90
new file mode 100644
index 0000000..9134268
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/class_dummy_7.f90
@@ -0,0 +1,60 @@
+! { dg-do run }
+!
+! Test the fix for PR46691 - enable class assumed size arrays
+!
+! Reported by Tobias Burnus  <burnus@gcc.gnu.org>
+! from http://j3-fortran.org/pipermail/j3/2010-December/004084.html
+! submitted by Robert Corbett.
+!
+       MODULE TYPES
+         PRIVATE
+         PUBLIC REC, REC2
+
+         TYPE REC
+           INTEGER A
+         END TYPE
+
+         TYPE, EXTENDS(REC) :: REC2
+           INTEGER B
+         END TYPE
+       END
+
+       SUBROUTINE SUB1(A, N)
+         USE TYPES
+         CLASS(REC), INTENT(IN) :: A(*)
+         INTERFACE
+           SUBROUTINE SUB2(A, N, IARRAY)
+             USE TYPES
+             TYPE(REC) A(*)
+             INTEGER :: N, IARRAY(N)
+           END
+         END INTERFACE
+
+         CALL SUB2(A, N,[1,2,2,3,3,4,4,5,5,6])
+         select type (B => A(1:N))
+             type is (REC2)
+                 call SUB2(B%REC,N,[1,2,3,4,5,6,7,8,9,10])
+         end select
+
+       END
+
+       SUBROUTINE SUB2(A, N, IARRAY)
+         USE TYPES
+         TYPE(REC) A(*)
+         INTEGER :: N, IARRAY(N)
+         if (any (A(:N)%A .ne. IARRAY(:N))) stop 1
+       END
+
+       PROGRAM MAIN
+         USE TYPES
+         CLASS(REC), ALLOCATABLE :: A(:)
+         INTERFACE
+           SUBROUTINE SUB1(A, N)
+             USE TYPES
+             CLASS(REC), INTENT(IN) :: A(*)
+           END SUBROUTINE
+         END INTERFACE
+
+         A = [ (REC2(I, I+1), I = 1, 10) ]
+         CALL SUB1(A, 10)
+       END