[Patch, fortran] PR103366 - [9/10/11/12 Regression] ICE in gfc_conv_gfc_desc_to_cfi_desc, at fortran/trans-expr.c:5647

[Paul Richard Thomas via Gcc-patches]

I doubt that this is a regression on 9-11 branches since the testcase
compiles correctly on each of my copies of these branches. IMHO it is
rather more likely to have been caused by
64f9623765da3306b0ab6a47997dc5d62c2ea261, which introduced this new form of
gfc_conv_gfc_desc_to_cfi_desc.

The patch is self-explanatory. OK for mainline?

Paul

Fortran: Match unlimited polymorphic argument to assumed type [PR103366].

2022-01-07  Paul Thomas  <pa...@gcc.gnu.org>

gcc/fortran
PR fortran/103366
* trans-expr.c (gfc_conv_gfc_desc_to_cfi_desc): Allow unlimited
polymorphic actual argument passed to assumed type formal.

gcc/testsuite/
PR fortran/103366
* gfortran.dg/pr103366.f90: New test.

diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 381915e2a76..2e15a7e874c 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -50,10 +50,10 @@ static tree
 gfc_get_character_len (tree type)
 {
   tree len;
-  
+
   gcc_assert (type && TREE_CODE (type) == ARRAY_TYPE
 	      && TYPE_STRING_FLAG (type));
-  
+
   len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
   len = (len) ? (len) : (integer_zero_node);
   return fold_convert (gfc_charlen_type_node, len);
@@ -67,10 +67,10 @@ tree
 gfc_get_character_len_in_bytes (tree type)
 {
   tree tmp, len;
-  
+
   gcc_assert (type && TREE_CODE (type) == ARRAY_TYPE
 	      && TYPE_STRING_FLAG (type));
-  
+
   tmp = TYPE_SIZE_UNIT (TREE_TYPE (type));
   tmp = (tmp && !integer_zerop (tmp))
     ? (fold_convert (gfc_charlen_type_node, tmp)) : (NULL_TREE);
@@ -5630,6 +5630,16 @@ 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)
+	    {
+	      // F2017: 7.3.2.2: "An entity that is declared using the TYPE(*)
+	      // type specifier is assumed-type and is an unlimited polymorphic
+	      //  entity." The actual argument _data component is passed.
+	      itype = CFI_type_other;  // FIXME: Or CFI_type_cptr ?
+	      break;
+	    }
+	  else
+	    gcc_unreachable ();
 	case BT_PROCEDURE:
 	case BT_HOLLERITH:
 	case BT_UNION:

! { dg-do compile }
!
! Test the fix for PR103366.
!
! Contributed by Gerhardt Steinmetz  <gs...@t-online.de>
!
program p
  call u([1])
contains
   subroutine s(x) bind(c)
      type(*) :: x(..)
   end
   subroutine u(x)
      class(*) :: x(..)
      call s(x)         ! Used to ICE here
   end
end