Fortran: Fix an assortment of bugs

2023-05-16  Paul Thomas  <pault@gcc.gnu.org>

gcc/fortran
	PR fortran/105152
	* interface.cc (gfc_compare_actual_formal): Emit an error if an
	unlimited polymorphic actual is not matched either to an
	unlimited or assumed type formal argument.

	PR fortran/100193
	* resolve.cc (resolve_ordinary_assign): Emit an error if the
	var expression of an ordinary assignment is a proc pointer
	component.

	PR fortran/87496
	* trans-array.cc (gfc_walk_array_ref): Provide assumed shape
	arrays coming from interface mapping with a viable arrayspec.

	PR fortran/103389
	* trans-expr.cc (gfc_conv_intrinsic_to_class): Tidy up flagging
	of unlimited polymorphic 'class_ts'.
	(gfc_conv_gfc_desc_to_cfi_desc): Assumed type is unlimited
	polymorphic and should accept any actual type.

	PR fortran/104429
	(gfc_conv_procedure_call): Replace dreadful kludge with a call
	to gfc_finalize_tree_expr. Avoid dereferencing a void pointer
	by giving it the pointer type of the actual argument.

	PR fortran/82774
	(alloc_scalar_allocatable_subcomponent): Shorten the function
	name and replace the symbol argument with the se string length.
	If a deferred length character length is either not present or
	is not a variable, give the typespec a variable and assign the
	string length to that. Use gfc_deferred_strlen to find the
	hidden string length component.
	(gfc_trans_subcomponent_assign): Convert the expression before
	the call to alloc_scalar_allocatable_subcomponent so that a
	good string length is provided.
	(gfc_trans_structure_assign): Remove the unneeded derived type
	symbol from calls to gfc_trans_subcomponent_assign.

gcc/testsuite/
	PR fortran/105152
	* gfortran.dg/pr105152.f90 : New test

	PR fortran/100193
	* gfortran.dg/pr100193.f90 : New test

	PR fortran/87946
	* gfortran.dg/pr87946.f90 : New test

	PR fortran/103389
	* gfortran.dg/pr103389.f90 : New test

	PR fortran/104429
	* gfortran.dg/pr104429.f90 : New test

	PR fortran/82774
	* gfortran.dg/pr82774.f90 : New test

10 files changed, 223 insertions, 54 deletions

diff --git a/gcc/fortran/interface.cc b/gcc/fortran/interface.cc
index 968ee193c07..ea82056e9e3 100644
--- a/gcc/fortran/interface.cc
+++ b/gcc/fortran/interface.cc
@@ -3312,6 +3312,16 @@ gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
 	    }
 	}
 
+      if (UNLIMITED_POLY (a->expr)
+	  && !(f->sym->ts.type == BT_ASSUMED || UNLIMITED_POLY (f->sym)))
+	{
+	  gfc_error ("Unlimited polymorphic actual argument at %L is not "
+		     "matched with either an unlimited polymorphic or "
+		     "assumed type dummy argument", &a->expr->where);
+	  ok = false;
+	  goto match;
+	}
+
       /* Special case for character arguments.  For allocatable, pointer
 	 and assumed-shape dummies, the string length needs to match
 	 exactly.  */
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index 58f05a3e74a..90b7fb52b51 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -11165,6 +11165,17 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
   lhs = code->expr1;
   rhs = code->expr2;
 
+  if ((lhs->symtree->n.sym->ts.type == BT_DERIVED
+       || lhs->symtree->n.sym->ts.type == BT_CLASS)
+      && !lhs->symtree->n.sym->attr.proc_pointer
+      && gfc_expr_attr (lhs).proc_pointer)
+    {
+      gfc_error ("Variable in the ordinary assignment at %L is a procedure "
+		 "pointer component",
+		 &lhs->where);
+      return false;
+    }
+
   if ((gfc_numeric_ts (&lhs->ts) || lhs->ts.type == BT_LOGICAL)
       && rhs->ts.type == BT_CHARACTER
       && (rhs->expr_type != EXPR_CONSTANT || !flag_dec_char_conversions))
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 785cf504816..fe7b7ca73dd 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -11471,6 +11471,12 @@ gfc_walk_array_ref (gfc_ss * ss, gfc_expr * expr, gfc_ref * ref)
 	  break;
 
 	case AR_FULL:
+	  /* Assumed shape arrays from interface mapping need this fix.  */
+	  if (!ar->as && expr->symtree->n.sym->as)
+	    {
+	      ar->as = gfc_get_array_spec();
+	      *ar->as = *expr->symtree->n.sym->as;
+	    }
 	  newss = gfc_get_array_ss (ss, expr, ar->as->rank, GFC_SS_SECTION);
 	  newss->info->data.array.ref = ref;
 
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index d902e8f3281..101efc3cc2c 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -996,6 +996,12 @@ gfc_conv_intrinsic_to_class (gfc_se *parmse, gfc_expr *e,
   tree var;
   tree tmp;
   int dim;
+  bool unlimited_poly;
+
+  unlimited_poly = class_ts.type == BT_CLASS
+		   && class_ts.u.derived->components->ts.type == BT_DERIVED
+		   && class_ts.u.derived->components->ts.u.derived
+						->attr.unlimited_polymorphic;
 
   /* The intrinsic type needs to be converted to a temporary
      CLASS object.  */
@@ -1067,9 +1073,7 @@ gfc_conv_intrinsic_to_class (gfc_se *parmse, gfc_expr *e,
     }
 
   gcc_assert (class_ts.type == BT_CLASS);
-  if (class_ts.u.derived->components->ts.type == BT_DERIVED
-      && class_ts.u.derived->components->ts.u.derived
-		 ->attr.unlimited_polymorphic)
+  if (unlimited_poly)
     {
       ctree = gfc_class_len_get (var);
       /* When the actual arg is a char array, then set the _len component of the
@@ -1116,10 +1120,7 @@ gfc_conv_intrinsic_to_class (gfc_se *parmse, gfc_expr *e,
 
       gfc_add_modify (&parmse->pre, ctree, fold_convert (TREE_TYPE (ctree), tmp));
     }
-  else if (class_ts.type == BT_CLASS
-	   && class_ts.u.derived->components
-	   && class_ts.u.derived->components->ts.u
-		.derived->attr.unlimited_polymorphic)
+  else if (unlimited_poly)
     {
       ctree = gfc_class_len_get (var);
       gfc_add_modify (&parmse->pre, ctree,
@@ -5650,7 +5651,7 @@ gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym)
 	  itype = CFI_type_other;  // FIXME: Or CFI_type_cptr ?
 	  break;
 	case BT_CLASS:
-	  if (UNLIMITED_POLY (e) && fsym->ts.type == BT_ASSUMED)
+	  if (fsym->ts.type == BT_ASSUMED)
 	    {
 	      // F2017: 7.3.2.2: "An entity that is declared using the TYPE(*)
 	      // type specifier is assumed-type and is an unlimited polymorphic
@@ -6682,20 +6683,11 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 			{
 			  tree zero;
 
-			  gfc_expr *var;
-
-			  /* Borrow the function symbol to make a call to
-			     gfc_add_finalizer_call and then restore it.  */
-			  tmp = e->symtree->n.sym->backend_decl;
-			  e->symtree->n.sym->backend_decl
-					= TREE_OPERAND (parmse.expr, 0);
-			  e->symtree->n.sym->attr.flavor = FL_VARIABLE;
-			  var = gfc_lval_expr_from_sym (e->symtree->n.sym);
-			  finalized = gfc_add_finalizer_call (&parmse.post,
-							      var);
-			  gfc_free_expr (var);
-			  e->symtree->n.sym->backend_decl = tmp;
-			  e->symtree->n.sym->attr.flavor = FL_PROCEDURE;
+			  /* Finalize the expression.  */
+			  gfc_finalize_tree_expr (&parmse, NULL,
+						  gfc_expr_attr (e), e->rank);
+			  gfc_add_block_to_block (&parmse.post,
+						  &parmse.finalblock);
 
 			  /* Then free the class _data.  */
 			  zero = build_int_cst (TREE_TYPE (parmse.expr), 0);
@@ -7131,7 +7123,15 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 		 types passed to class formals need the _data component.  */
 	      tmp = gfc_class_data_get (tmp);
 	      if (!CLASS_DATA (fsym)->attr.dimension)
-		tmp = build_fold_indirect_ref_loc (input_location, tmp);
+		{
+		  if (UNLIMITED_POLY (fsym))
+		    {
+		      tree type = gfc_typenode_for_spec (&e->ts);
+		      type = build_pointer_type (type);
+		      tmp = fold_convert (type, tmp);
+		    }
+		  tmp = build_fold_indirect_ref_loc (input_location, tmp);
+		}
 	    }
 
 	  if (e->expr_type == EXPR_OP
@@ -8767,11 +8767,9 @@ gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm,
 /* Allocate or reallocate scalar component, as necessary.  */
 
 static void
-alloc_scalar_allocatable_for_subcomponent_assignment (stmtblock_t *block,
-						      tree comp,
-						      gfc_component *cm,
-						      gfc_expr *expr2,
-						      gfc_symbol *sym)
+alloc_scalar_allocatable_subcomponent (stmtblock_t *block, tree comp,
+				       gfc_component *cm, gfc_expr *expr2,
+				       tree slen)
 {
   tree tmp;
   tree ptr;
@@ -8789,26 +8787,20 @@ alloc_scalar_allocatable_for_subcomponent_assignment (stmtblock_t *block,
 
   if (cm->ts.type == BT_CHARACTER && cm->ts.deferred)
     {
-      char name[GFC_MAX_SYMBOL_LEN+9];
-      gfc_component *strlen;
-      /* Use the rhs string length and the lhs element size.  */
       gcc_assert (expr2->ts.type == BT_CHARACTER);
-      if (!expr2->ts.u.cl->backend_decl)
-	{
-	  gfc_conv_string_length (expr2->ts.u.cl, expr2, block);
-	  gcc_assert (expr2->ts.u.cl->backend_decl);
-	}
+      if (!expr2->ts.u.cl->backend_decl
+	  || !VAR_P (expr2->ts.u.cl->backend_decl))
+	expr2->ts.u.cl->backend_decl = gfc_create_var (TREE_TYPE (slen),
+						       "slen");
+      gfc_add_modify (block, expr2->ts.u.cl->backend_decl, slen);
 
       size = expr2->ts.u.cl->backend_decl;
 
-      /* Ensure that cm->ts.u.cl->backend_decl is a componentref to _%s_length
-	 component.  */
-      sprintf (name, "_%s_length", cm->name);
-      strlen = gfc_find_component (sym, name, true, true, NULL);
+      gfc_deferred_strlen (cm, &tmp);
       lhs_cl_size = fold_build3_loc (input_location, COMPONENT_REF,
 				     gfc_charlen_type_node,
 				     TREE_OPERAND (comp, 0),
-				     strlen->backend_decl, NULL_TREE);
+				     tmp, NULL_TREE);
 
       tmp = TREE_TYPE (gfc_typenode_for_spec (&cm->ts));
       tmp = TYPE_SIZE_UNIT (tmp);
@@ -8881,8 +8873,8 @@ alloc_scalar_allocatable_for_subcomponent_assignment (stmtblock_t *block,
 /* Assign a single component of a derived type constructor.  */
 
 static tree
-gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr,
-			       gfc_symbol *sym, bool init)
+gfc_trans_subcomponent_assign (tree dest, gfc_component * cm,
+			       gfc_expr * expr, bool init)
 {
   gfc_se se;
   gfc_se lse;
@@ -8976,19 +8968,17 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr,
 	   || (cm->ts.type == BT_CLASS && CLASS_DATA (cm)->attr.allocatable
 	       && expr->ts.type != BT_CLASS)))
     {
+      gfc_init_se (&se, NULL);
+      gfc_conv_expr (&se, expr);
+
       /* Take care about non-array allocatable components here.  The alloc_*
 	 routine below is motivated by the alloc_scalar_allocatable_for_
 	 assignment() routine, but with the realloc portions removed and
 	 different input.  */
-      alloc_scalar_allocatable_for_subcomponent_assignment (&block,
-							    dest,
-							    cm,
-							    expr,
-							    sym);
+      alloc_scalar_allocatable_subcomponent (&block, dest, cm, expr,
+					     se.string_length);
       /* The remainder of these instructions follow the if (cm->attr.pointer)
 	 if (!cm->attr.dimension) part above.  */
-      gfc_init_se (&se, NULL);
-      gfc_conv_expr (&se, expr);
       gfc_add_block_to_block (&block, &se.pre);
 
       if (expr->symtree && expr->symtree->n.sym->attr.proc_pointer
@@ -9252,13 +9242,11 @@ gfc_trans_structure_assign (tree dest, gfc_expr * expr, bool init, bool coarray)
       if (!c->expr)
 	{
 	  gfc_expr *e = gfc_get_null_expr (NULL);
-	  tmp = gfc_trans_subcomponent_assign (tmp, cm, e, expr->ts.u.derived,
-					       init);
+	  tmp = gfc_trans_subcomponent_assign (tmp, cm, e, init);
 	  gfc_free_expr (e);
 	}
       else
-        tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr,
-                                             expr->ts.u.derived, init);
+	tmp = gfc_trans_subcomponent_assign (tmp, cm, c->expr, init);
       gfc_add_expr_to_block (&block, tmp);
     }
   return gfc_finish_block (&block);
diff --git a/gcc/testsuite/gfortran.dg/pr100193.f90 b/gcc/testsuite/gfortran.dg/pr100193.f90
new file mode 100644
index 00000000000..07a3634cb06
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr100193.f90
@@ -0,0 +1,20 @@
+! { dg-do compile }
+!
+! Contributed by Gerhard Steinmetz  <gscfq@t-online.de>
+!
+module m
+   implicit none
+   type t
+      procedure(f), pointer, nopass :: g
+   end type
+contains
+   function f()
+      character(:), allocatable :: f
+      f = 'abc'
+   end
+   subroutine s
+      type(t) :: z
+      z%g = 'x'  ! { dg-error "is a procedure pointer" }
+      if ( z%g() /= 'abc' ) stop
+   end
+end
diff --git a/gcc/testsuite/gfortran.dg/pr103389.f90 b/gcc/testsuite/gfortran.dg/pr103389.f90
new file mode 100644
index 00000000000..565551564e3
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr103389.f90
@@ -0,0 +1,23 @@
+! { dg-do run }
+!
+! Contributed by Gerhard Steinmetz  <gscfq@t-online.de>
+!
+program p
+   type t
+      integer, allocatable :: a(:)
+   end type
+   type(t) :: y
+   y%a = [1,2]
+   call s((y))
+   if (any (y%a .ne. [3,4])) stop 1
+contains
+   subroutine s(x)
+      class(*) :: x
+      select type (x)
+        type is (t)
+          x%a = x%a + 2
+        class default
+          stop 2
+      end select
+   end
+end
diff --git a/gcc/testsuite/gfortran.dg/pr104429.f90 b/gcc/testsuite/gfortran.dg/pr104429.f90
new file mode 100644
index 00000000000..39761fd59fa
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr104429.f90
@@ -0,0 +1,35 @@
+! { dg-do run }
+!
+! Contributed by Gerhard Steinmetz  <gscfq@t-online.de>
+!
+module m
+   type t
+      real :: r
+   contains
+      procedure :: op
+      procedure :: assign
+      generic :: operator(*) => op
+      generic :: assignment(=) => assign
+   end type
+contains
+   function op (x, y)
+      class(t), allocatable :: op
+      class(t), intent(in) :: x
+      real, intent(in) :: y
+      allocate (op, source = t (x%r * y))
+   end
+   subroutine assign (z, x)
+      type(t), intent(in) :: x
+      class(t), intent(out) :: z
+      z%r = x%r
+   end
+end
+program p
+   use m
+   class(t), allocatable :: x
+   real :: y = 2
+   allocate (x, source = t (2.0))
+   x = x * y
+   if (int (x%r) .ne. 4) stop 1
+   if (allocated (x)) deallocate (x)
+end
diff --git a/gcc/testsuite/gfortran.dg/pr105152.f90 b/gcc/testsuite/gfortran.dg/pr105152.f90
new file mode 100644
index 00000000000..561b2a6c75d
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr105152.f90
@@ -0,0 +1,19 @@
+! { dg-do compile }
+!
+! Contributed by Gerhard Steinmetz  <gscfq@t-online.de>
+!
+program p
+   use iso_c_binding
+   type, bind(c) :: t
+      integer(c_int) :: a
+   end type
+   interface
+      function f(x) bind(c) result(z)
+         import :: c_int, t
+         type(t) :: x(:)
+         integer(c_int) :: z
+      end
+   end interface
+   class(*), allocatable :: y(:)
+   n = f(y) ! { dg-error "either an unlimited polymorphic or assumed type" }
+end
diff --git a/gcc/testsuite/gfortran.dg/pr82774.f90 b/gcc/testsuite/gfortran.dg/pr82774.f90
new file mode 100644
index 00000000000..81c22ab3828
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr82774.f90
@@ -0,0 +1,15 @@
+! { dg-do run }
+!
+! Contributed by Steve Kargl  <kargl@gcc.gnu.org>
+!
+program main
+   implicit none
+   type stuff
+      character(:), allocatable :: key
+   end type stuff
+   type(stuff) nonsense, total
+   nonsense = stuff('Xe')
+   total = stuff(nonsense%key) ! trim nonsense%key made this work
+   if (nonsense%key /= total%key) call abort
+   if (len(total%key) /= 2) call abort
+end program main
diff --git a/gcc/testsuite/gfortran.dg/pr87946.f90 b/gcc/testsuite/gfortran.dg/pr87946.f90
new file mode 100644
index 00000000000..793d37a7f39
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr87946.f90
@@ -0,0 +1,42 @@
+! { dg-do run }
+!
+! Contributed by Gerhard Steinmetz  <gscfq@t-online.de>
+!
+module m
+   type t
+   contains
+      generic :: h => g
+      procedure, private :: g
+   end type
+contains
+   function g(x, y) result(z)
+      class(t), intent(in) :: x
+      real, intent(in) :: y(:, :)
+      real :: z(size(y, 2))
+      integer :: i
+      do i = 1, size(y, 2)
+        z(i) = i
+      end do
+   end
+end
+module m2
+   use m
+   type t2
+      class(t), allocatable :: u(:)
+   end type
+end
+   use m2
+   type(t2) :: x
+   real :: y(1,5)
+   allocate (x%u(1))
+   if (any (int(f (x, y)) .ne. [1,2,3,4,5])) stop 1
+   deallocate (x%u)
+contains
+   function f(x, y) result(z)
+      use m2
+      type(t2) :: x
+      real :: y(:, :)
+      real :: z(size(y, 2))
+      z = x%u(1)%h(y)          ! Used to segfault here
+   end
+end