re PR fortran/48820 (TR 29113: Implement parts needed for MPI 3)

2012-03-03  Tobias Burnus  <burnus@net-b.de>

        PR fortran/48820
        * decl.c (gfc_match_decl_type_spec): Support type(*).
        (gfc_verify_c_interop): Allow type(*).
        * dump-parse-tree.c (show_typespec): Handle type(*).
        * expr.c (gfc_copy_expr): Ditto.
        * interface.c (compare_type_rank, compare_parameter,
        compare_actual_formal, gfc_procedure_use): Ditto.
        * libgfortran.h (bt): Add BT_ASSUMED.
        * misc.c (gfc_basic_typename, gfc_typename): Handle type(*).
        * module.c (bt_types): Ditto.
        * resolve.c (assumed_type_expr_allowed): New static variable.
        (resolve_actual_arglist, resolve_variable, resolve_symbol):
        Handle type(*). 
        * trans-expr.c (gfc_conv_procedure_call): Ditto.
        * trans-types.c (gfc_typenode_for_spec, gfc_get_dtype): Ditto.

2012-03-03  Tobias Burnus  <burnus@net-b.de>

        PR fortran/48820
        * gfortran.dg/assumed_type_1.f90: New.
        * gfortran.dg/assumed_type_2.f90: New.
        * gfortran.dg/assumed_type_3.f90: New.
        * gfortran.dg/assumed_type_4.f90: New.

From-SVN: r184852

gcc/fortran/ChangeLog

+2012-03-03  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/48820
+	* decl.c (gfc_match_decl_type_spec): Support type(*).
+	(gfc_verify_c_interop): Allow type(*).
+	* dump-parse-tree.c (show_typespec): Handle type(*).
+	* expr.c (gfc_copy_expr): Ditto.
+	* interface.c (compare_type_rank, compare_parameter,
+	compare_actual_formal, gfc_procedure_use): Ditto.
+	* libgfortran.h (bt): Add BT_ASSUMED.
+	* misc.c (gfc_basic_typename, gfc_typename): Handle type(*).
+	* module.c (bt_types): Ditto.
+	* resolve.c (assumed_type_expr_allowed): New static variable.
+	(resolve_actual_arglist, resolve_variable, resolve_symbol):
+	Handle type(*). 
+	* trans-expr.c (gfc_conv_procedure_call): Ditto.
+	* trans-types.c (gfc_typenode_for_spec, gfc_get_dtype): Ditto.
+
 2012-03-02  Tobias Burnus  <burnus@net-b.de>
 
 	PR fortran/52325

gcc/fortran/decl.c

@@ -2600,9 +2600,31 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag)
     }
 
 
-  m = gfc_match (" type ( %n", name);
+  m = gfc_match (" type (");
   matched_type = (m == MATCH_YES);
-  
+  if (matched_type)
+    {
+      gfc_gobble_whitespace ();
+      if (gfc_peek_ascii_char () == '*')
+	{
+	  if ((m = gfc_match ("*)")) != MATCH_YES)
+	    return m;
+	  if (gfc_current_state () == COMP_DERIVED)
+	    {
+	      gfc_error ("Assumed type at %C is not allowed for components");
+	      return MATCH_ERROR;
+	    }
+	  if (gfc_notify_std (GFC_STD_F2008_TS, "TS 29113: Assumed type "
+			  "at %C") == FAILURE)
+	    return MATCH_ERROR;
+	  ts->type = BT_ASSUMED;
+	  return MATCH_YES;
+	}
+
+      m = gfc_match ("%n", name);
+      matched_type = (m == MATCH_YES);
+    }
+
   if ((matched_type && strcmp ("integer", name) == 0)
       || (!matched_type && gfc_match (" integer") == MATCH_YES))
     {
@@ -3854,9 +3876,9 @@ gfc_verify_c_interop (gfc_typespec *ts)
 	   ? SUCCESS : FAILURE;
   else if (ts->type == BT_CLASS)
     return FAILURE;
-  else if (ts->is_c_interop != 1)
+  else if (ts->is_c_interop != 1 && ts->type != BT_ASSUMED)
     return FAILURE;
-  
+
   return SUCCESS;
 }
 

gcc/fortran/dump-parse-tree.c

@@ -94,6 +94,12 @@ show_indent (void)
 static void
 show_typespec (gfc_typespec *ts)
 {
+  if (ts->type == BT_ASSUMED)
+    {
+      fputs ("(TYPE(*))", dumpfile);
+      return;
+    }
+
   fprintf (dumpfile, "(%s ", gfc_basic_typename (ts->type));
 
   switch (ts->type)

gcc/fortran/expr.c

@@ -336,6 +336,7 @@ gfc_copy_expr (gfc_expr *p)
 	case BT_LOGICAL:
 	case BT_DERIVED:
 	case BT_CLASS:
+	case BT_ASSUMED:
 	  break;		/* Already done.  */
 
 	case BT_PROCEDURE:

gcc/fortran/interface.c

@@ -514,7 +514,8 @@ compare_type_rank (gfc_symbol *s1, gfc_symbol *s2)
   if (r1 != r2)
     return 0;			/* Ranks differ.  */
 
-  return gfc_compare_types (&s1->ts, &s2->ts);
+  return gfc_compare_types (&s1->ts, &s2->ts)
+	 || s1->ts.type == BT_ASSUMED || s2->ts.type == BT_ASSUMED; 
 }
 
 
@@ -1697,6 +1698,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
 
   if ((actual->expr_type != EXPR_NULL || actual->ts.type != BT_UNKNOWN)
       && actual->ts.type != BT_HOLLERITH
+      && formal->ts.type != BT_ASSUMED
       && !gfc_compare_types (&formal->ts, &actual->ts)
       && !(formal->ts.type == BT_DERIVED && actual->ts.type == BT_CLASS
 	   && gfc_compare_derived_types (formal->ts.u.derived, 
@@ -2274,6 +2276,27 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
 			      is_elemental, where))
 	return 0;
 
+      /* TS 29113, 6.3p2.  */
+      if (f->sym->ts.type == BT_ASSUMED
+	  && (a->expr->ts.type == BT_DERIVED
+	      || (a->expr->ts.type == BT_CLASS && CLASS_DATA (a->expr))))
+	{
+	  gfc_namespace *f2k_derived;
+
+	  f2k_derived = a->expr->ts.type == BT_DERIVED
+			? a->expr->ts.u.derived->f2k_derived
+			: CLASS_DATA (a->expr)->ts.u.derived->f2k_derived;
+
+	  if (f2k_derived
+	      && (f2k_derived->finalizers || f2k_derived->tb_sym_root))
+	    {
+	      gfc_error ("Actual argument at %L to assumed-type dummy is of "
+			 "derived type with type-bound or FINAL procedures",
+			 &a->expr->where);
+	      return FAILURE;
+	    }
+	}
+
       /* Special case for character arguments.  For allocatable, pointer
 	 and assumed-shape dummies, the string length needs to match
 	 exactly.  */
@@ -2885,7 +2908,6 @@ check_intents (gfc_formal_arglist *f, gfc_actual_arglist *a)
 void
 gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where)
 {
-
   /* Warn about calls with an implicit interface.  Special case
      for calling a ISO_C_BINDING becase c_loc and c_funloc
      are pseudo-unknown.  Additionally, warn about procedures not
@@ -2938,6 +2960,16 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where)
 	      break;
 	    }
 
+	  /* TS 29113, 6.2.  */
+	  if (a->expr && a->expr->ts.type == BT_ASSUMED
+	      && sym->intmod_sym_id != ISOCBINDING_LOC)
+	    {
+	      gfc_error ("Assumed-type argument %s at %L requires an explicit "
+			 "interface", a->expr->symtree->n.sym->name,
+			 &a->expr->where);
+	      break;
+	    }
+
 	  /* F2008, C1303 and C1304.  */
 	  if (a->expr
 	      && (a->expr->ts.type == BT_DERIVED || a->expr->ts.type == BT_CLASS)

gcc/fortran/libgfortran.h

@@ -129,6 +129,7 @@ libgfortran_stat_codes;
    used in the run-time library for IO.  */
 typedef enum
 { BT_UNKNOWN = 0, BT_INTEGER, BT_LOGICAL, BT_REAL, BT_COMPLEX,
-  BT_DERIVED, BT_CHARACTER, BT_CLASS, BT_PROCEDURE, BT_HOLLERITH, BT_VOID
+  BT_DERIVED, BT_CHARACTER, BT_CLASS, BT_PROCEDURE, BT_HOLLERITH, BT_VOID,
+  BT_ASSUMED
 }
 bt;

gcc/fortran/misc.c

@@ -107,6 +107,9 @@ gfc_basic_typename (bt type)
     case BT_UNKNOWN:
       p = "UNKNOWN";
       break;
+    case BT_ASSUMED:
+      p = "TYPE(*)";
+      break;
     default:
       gfc_internal_error ("gfc_basic_typename(): Undefined type");
     }
@@ -157,6 +160,9 @@ gfc_typename (gfc_typespec *ts)
       sprintf (buffer, "CLASS(%s)",
 	       ts->u.derived->components->ts.u.derived->name);
       break;
+    case BT_ASSUMED:
+      sprintf (buffer, "TYPE(*)");
+      break;
     case BT_PROCEDURE:
       strcpy (buffer, "PROCEDURE");
       break;

gcc/fortran/module.c

@@ -2244,6 +2244,7 @@ static const mstring bt_types[] = {
     minit ("PROCEDURE", BT_PROCEDURE),
     minit ("UNKNOWN", BT_UNKNOWN),
     minit ("VOID", BT_VOID),
+    minit ("ASSUMED", BT_ASSUMED),
     minit (NULL, -1)
 };
 

gcc/fortran/resolve.c

@@ -63,6 +63,8 @@ static code_stack *cs_base = NULL;
 static int forall_flag;
 static int do_concurrent_flag;
 
+static bool assumed_type_expr_allowed = false;
+
 /* Nonzero if we're inside a OpenMP WORKSHARE or PARALLEL WORKSHARE block.  */
 
 static int omp_workshare_flag;
@@ -1597,6 +1599,8 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
   gfc_expr *e;
   int save_need_full_assumed_size;
 
+  assumed_type_expr_allowed = true;
+
   for (; arg; arg = arg->next)
     {
       e = arg->expr;
@@ -1829,6 +1833,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
           return FAILURE;
         }
     }
+  assumed_type_expr_allowed = true;
 
   return SUCCESS;
 }
@@ -5057,6 +5062,24 @@ resolve_variable (gfc_expr *e)
     return FAILURE;
   sym = e->symtree->n.sym;
 
+  /* TS 29113, 407b.  */
+  if (e->ts.type == BT_ASSUMED && !assumed_type_expr_allowed)
+    {
+      gfc_error ("Invalid expression with assumed-type variable %s at %L",
+		 sym->name, &e->where);
+      return FAILURE;
+    }
+
+  /* TS 29113, 407b.  */
+  if (e->ts.type == BT_ASSUMED && e->ref
+      && !(e->ref->type == REF_ARRAY && e->ref->u.ar.type == AR_FULL
+           && e->ref->next == NULL))
+    {
+      gfc_error ("Assumed-type variable %s with designator at %L",
+                 sym->name, &e->ref->u.ar.where);
+      return FAILURE;
+    }
+
   /* If this is an associate-name, it may be parsed with an array reference
      in error even though the target is scalar.  Fail directly in this case.  */
   if (sym->assoc && !sym->attr.dimension && e->ref && e->ref->type == REF_ARRAY)
@@ -12435,6 +12458,31 @@ resolve_symbol (gfc_symbol *sym)
 	}
     }
 
+  if (sym->ts.type == BT_ASSUMED)
+    { 
+      /* TS 29113, C407a.  */
+      if (!sym->attr.dummy)
+	{
+	  gfc_error ("Assumed type of variable %s at %L is only permitted "
+		     "for dummy variables", sym->name, &sym->declared_at);
+	  return;
+	}
+      if (sym->attr.allocatable || sym->attr.codimension
+	  || sym->attr.pointer || sym->attr.value)
+    	{
+	  gfc_error ("Assumed-type variable %s at %L may not have the "
+		     "ALLOCATABLE, CODIMENSION, POINTER or VALUE attribute",
+		     sym->name, &sym->declared_at);
+	  return;
+	}
+      if (sym->attr.dimension && sym->as->type == AS_EXPLICIT)
+	{
+	  gfc_error ("Assumed-type variable %s at %L shall not be an "
+		     "explicit-shape array", sym->name, &sym->declared_at);
+	  return;
+	}
+    }
+
   /* If the symbol is marked as bind(c), verify it's type and kind.  Do not
      do this for something that was implicitly typed because that is handled
      in gfc_set_default_type.  Handle dummy arguments and procedure

gcc/fortran/trans-expr.c

@@ -3619,7 +3619,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 			&& CLASS_DATA (e)->attr.dimension)
 		    gfc_conv_class_to_class (&parmse, e, fsym->ts, false);
 
-		  if (fsym && fsym->ts.type == BT_DERIVED
+		  if (fsym && (fsym->ts.type == BT_DERIVED
+			       || fsym->ts.type == BT_ASSUMED)
 		      && e->ts.type == BT_CLASS
 		      && !CLASS_DATA (e)->attr.dimension
 		      && !CLASS_DATA (e)->attr.codimension)

gcc/fortran/trans-types.c

@@ -1118,6 +1118,7 @@ gfc_typenode_for_spec (gfc_typespec * spec)
         }
       break;
     case BT_VOID:
+    case BT_ASSUMED:
       /* This is for the second arg to c_f_pointer and c_f_procpointer
          of the iso_c_binding module, to accept any ptr type.  */
       basetype = ptr_type_node;
@@ -1416,6 +1417,10 @@ gfc_get_dtype (tree type)
       n = BT_CHARACTER;
       break;
 
+    case POINTER_TYPE:
+      n = BT_ASSUMED;
+      break;
+
     default:
       /* TODO: Don't do dtype for temporary descriptorless arrays.  */
       /* We can strange array types for temporary arrays.  */

gcc/testsuite/ChangeLog

+2012-03-03  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/48820
+	* gfortran.dg/assumed_type_1.f90: New.
+	* gfortran.dg/assumed_type_2.f90: New.
+	* gfortran.dg/assumed_type_3.f90: New.
+	* gfortran.dg/assumed_type_4.f90: New.
+
 2012-03-02  Oleg Endo  <olegendo@gcc.gnu.org>
 
 	PR target/49486

gcc/testsuite/gfortran.dg/assumed_type_1.f90

+! { dg-do compile }
+!
+! PR fortran/48820
+!
+! Test TYPE(*)
+!
+! Based on a contributed test case by Walter Spector
+!
+module mpi_interface
+  implicit none
+
+  interface mpi_send
+    subroutine MPI_Send (buf, count, datatype, dest, tag, comm, ierr)
+      type(*), intent(in) :: buf(:)
+      integer, intent(in) :: count
+      integer, intent(in) :: datatype
+      integer, intent(in) :: dest
+      integer, intent(in) :: tag
+      integer, intent(in) :: comm
+      integer, intent(out):: ierr
+    end subroutine
+  end interface
+
+  interface mpi_send2
+    subroutine MPI_Send2 (buf, count, datatype, dest, tag, comm, ierr)
+      type(*), intent(in) :: buf(*)
+      integer, intent(in) :: count
+      integer, intent(in) :: datatype
+      integer, intent(in) :: dest
+      integer, intent(in) :: tag
+      integer, intent(in) :: comm
+      integer, intent(out):: ierr
+    end subroutine
+  end interface
+
+end module
+
+use mpi_interface
+  real :: a(3)
+  integer :: b(3)
+  call foo(a)
+  call foo(b)
+  call foo(a(1:2))
+  call foo(b(1:2))
+  call MPI_Send(a, 1, 1,1,1,j,i)
+  call MPI_Send(b, 1, 1,1,1,j,i)
+  call MPI_Send2(a, 1, 1,1,1,j,i)
+  call MPI_Send2(b, 1, 1,1,1,j,i)
+contains
+    subroutine foo(x)
+    type(*):: x(*)
+    call MPI_Send(x, 1, 1,1,1,j,i)
+    call MPI_Send2(x, 1, 1,1,1,j,i)
+  end
+end
+
+! { dg-final { cleanup-modules "mpi_interface" } }

gcc/testsuite/gfortran.dg/assumed_type_2.f90

+! { dg-do run }
+! { dg-options "-fdump-tree-original" }
+!
+! PR fortran/48820
+!
+! Test TYPE(*)
+!
+
+module mod
+  use iso_c_binding, only: c_loc, c_ptr, c_bool
+  implicit none
+  interface my_c_loc
+    function my_c_loc1(x) bind(C)
+      import c_ptr
+      type(*) :: x
+      type(c_ptr) :: my_c_loc1
+    end function
+    function my_c_loc2(x) bind(C)
+      import c_ptr
+      type(*) :: x(*)
+      type(c_ptr) :: my_c_loc2
+    end function
+  end interface my_c_loc
+contains
+  subroutine sub_scalar (arg1, presnt)
+     type(*), target, optional :: arg1
+     logical :: presnt
+     type(c_ptr) :: cpt
+     if (presnt .neqv. present (arg1)) call abort ()
+     cpt = c_loc (arg1)
+  end subroutine sub_scalar
+
+  subroutine sub_array_shape (arg2, lbounds, ubounds)
+     type(*), target :: arg2(:,:)
+     type(c_ptr) :: cpt
+     integer :: lbounds(2), ubounds(2)
+     if (any (lbound(arg2) /= lbounds)) call abort ()
+     if (any (ubound(arg2) /= ubounds)) call abort ()
+     if (any (shape(arg2) /= ubounds-lbounds+1)) call abort ()
+     if (size(arg2) /= product (ubounds-lbounds+1)) call abort ()
+     if (rank (arg2) /= 2) call abort ()
+!     if (.not. is_continuous (arg2)) call abort () !<< Not yet implemented
+!     cpt = c_loc (arg2) ! << FIXME: Valid since TS29113
+     call sub_array_assumed (arg2)
+  end subroutine sub_array_shape
+
+  subroutine sub_array_assumed (arg3)
+     type(*), target :: arg3(*)
+     type(c_ptr) :: cpt
+     cpt = c_loc (arg3)
+  end subroutine sub_array_assumed
+end module
+
+use mod
+use iso_c_binding, only: c_int, c_null_ptr
+implicit none
+type t1
+  integer :: a
+end type t1
+type :: t2
+  sequence
+  integer :: b
+end type t2
+type, bind(C) :: t3
+  integer(c_int) :: c
+end type t3
+
+integer            :: scalar_int
+real, allocatable  :: scalar_real_alloc
+character, pointer :: scalar_char_ptr
+
+integer            :: array_int(3)
+real, allocatable  :: array_real_alloc(:,:)
+character, pointer :: array_char_ptr(:,:)
+
+type(t1)              :: scalar_t1
+type(t2), allocatable :: scalar_t2_alloc
+type(t3), pointer     :: scalar_t3_ptr
+
+type(t1)              :: array_t1(4)
+type(t2), allocatable :: array_t2_alloc(:,:)
+type(t3), pointer     :: array_t3_ptr(:,:)
+
+class(t1), allocatable :: scalar_class_t1_alloc
+class(t1), pointer     :: scalar_class_t1_ptr
+
+class(t1), allocatable :: array_class_t1_alloc(:,:)
+class(t1), pointer     :: array_class_t1_ptr(:,:)
+
+scalar_char_ptr => null()
+scalar_t3_ptr => null()
+
+call sub_scalar (presnt=.false.)
+call sub_scalar (scalar_real_alloc, .false.)
+call sub_scalar (scalar_char_ptr, .false.)
+call sub_scalar (null (), .false.)
+call sub_scalar (scalar_t2_alloc, .false.)
+call sub_scalar (scalar_t3_ptr, .false.)
+
+allocate (scalar_real_alloc, scalar_char_ptr, scalar_t3_ptr)
+allocate (scalar_class_t1_alloc, scalar_class_t1_ptr, scalar_t2_alloc)
+allocate (array_real_alloc(3:5,2:4), array_char_ptr(-2:2,2))
+allocate (array_t2_alloc(3:5,2:4), array_t3_ptr(-2:2,2))
+allocate (array_class_t1_alloc(3,3), array_class_t1_ptr(4,4))
+
+call sub_scalar (scalar_int, .true.)
+call sub_scalar (scalar_real_alloc, .true.)
+call sub_scalar (scalar_char_ptr, .true.)
+call sub_scalar (array_int(2), .true.)
+call sub_scalar (array_real_alloc(3,2), .true.)
+call sub_scalar (array_char_ptr(0,1), .true.)
+call sub_scalar (scalar_t1, .true.)
+call sub_scalar (scalar_t2_alloc, .true.)
+call sub_scalar (scalar_t3_ptr, .true.)
+call sub_scalar (array_t1(2), .true.)
+call sub_scalar (array_t2_alloc(3,2), .true.)
+call sub_scalar (array_t3_ptr(0,1), .true.)
+call sub_scalar (array_class_t1_alloc(2,1), .true.)
+call sub_scalar (array_class_t1_ptr(3,3), .true.)
+
+call sub_array_assumed (array_int)
+call sub_array_assumed (array_real_alloc)
+call sub_array_assumed (array_char_ptr)
+call sub_array_assumed (array_t1)
+call sub_array_assumed (array_t2_alloc)
+call sub_array_assumed (array_t3_ptr)
+call sub_array_assumed (array_class_t1_alloc)
+call sub_array_assumed (array_class_t1_ptr)
+
+call sub_array_shape (array_real_alloc, [1,1], shape(array_real_alloc))
+call sub_array_shape (array_char_ptr, [1,1], shape(array_char_ptr))
+call sub_array_shape (array_t2_alloc, [1,1], shape(array_t2_alloc))
+call sub_array_shape (array_t3_ptr, [1,1], shape(array_t3_ptr))
+call sub_array_shape (array_class_t1_alloc, [1,1], shape(array_class_t1_alloc))
+call sub_array_shape (array_class_t1_ptr, [1,1], shape(array_class_t1_ptr))
+
+deallocate (scalar_char_ptr, scalar_class_t1_ptr, array_char_ptr)
+deallocate (array_class_t1_ptr, array_t3_ptr)
+
+end
+
+! { dg-final { cleanup-modules "mod" } }
+
+! { dg-final { scan-tree-dump-times "sub_scalar .0B,"  2 "original" } }
+! { dg-final { scan-tree-dump-times "sub_scalar .scalar_real_alloc," 2 "original" } }
+! { dg-final { scan-tree-dump-times "sub_scalar .scalar_char_ptr," 2 "original" } }
+! { dg-final { scan-tree-dump-times "sub_scalar .scalar_t2_alloc," 2 "original" } }
+! { dg-final { scan-tree-dump-times "sub_scalar .scalar_t3_ptr" 2 "original" } }
+
+! { dg-final { scan-tree-dump-times "sub_scalar .&scalar_int," 1 "original" } }
+! { dg-final { scan-tree-dump-times "sub_scalar .&scalar_t1," 1 "original" } }
+! { dg-final { scan-tree-dump-times "sub_scalar .&array_int.1.," 1 "original" } }
+! { dg-final { scan-tree-dump-times "sub_scalar .&scalar_t1," 1 "original" } }
+
+! { dg-final { scan-tree-dump-times "sub_scalar .&\\(.\\(real.kind=4..0:. . restrict\\) array_real_alloc.data" 1 "original" } }
+! { dg-final { scan-tree-dump-times "sub_scalar .&\\(.\\(character.kind=1..0:..1:1. .\\) array_char_ptr.data" 1 "original" } }
+! { dg-final { scan-tree-dump-times "sub_scalar .&\\(.\\(struct t2.0:. . restrict\\) array_t2_alloc.data" 1 "original" } }
+! { dg-final { scan-tree-dump-times "sub_scalar .&\\(.\\(struct t3.0:. .\\) array_t3_ptr.data" 1 "original" } }
+! { dg-final { scan-tree-dump-times "sub_scalar .\\(struct t1 .\\) array_class_t1_alloc._data.data" 1 "original" } }
+! { dg-final { scan-tree-dump-times "sub_scalar .\\(struct t1 .\\) array_class_t1_ptr._data.dat" 1 "original" } }a
+
+! { dg-final { scan-tree-dump-times "sub_array_assumed \\(D" 2 "original" } }
+! { dg-final { scan-tree-dump-times " = _gfortran_internal_pack \\(&parm" 1 "original" } }
+! { dg-final { scan-tree-dump-times "sub_array_assumed \\(&array_int\\)" 1 "original" } }
+! { dg-final { scan-tree-dump-times "sub_array_assumed \\(\\(real\\(kind=4\\).0:. . restrict\\) array_real_alloc.data" 1 "original" } }
+! { dg-final { scan-tree-dump-times " = _gfortran_internal_pack \\(&array_char_ptr\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "\\.data = \\(void .\\) &array_t1.0.;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "sub_array_assumed \\(\\(struct t1.0:. .\\) parm" 1 "original" } }
+! { dg-final { scan-tree-dump-times "sub_array_assumed \\(\\(struct t2.0:. . restrict\\) array_t2_alloc.data\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "sub_array_assumed \\(\\(struct t3.0:. .\\) array_t3_ptr.data\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "sub_array_assumed \\(\\(struct t1.0:. . restrict\\) array_class_t1_alloc._data.data\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "sub_array_assumed \\(\\(struct t1.0:. .\\) array_class_t1_ptr._data.data\\);" 1 "original" } }
+
+! { dg-final { scan-tree-dump-times "sub_array_shape \\(&array_real_alloc," 1 "original" } }
+! { dg-final { scan-tree-dump-times "sub_array_shape \\(&array_char_ptr," 1 "original" } }
+! { dg-final { scan-tree-dump-times "sub_array_shape \\(&array_t2_alloc," 1 "original" } }
+! { dg-final { scan-tree-dump-times "sub_array_shape \\(&array_t3_ptr," 1 "original" } }
+! { dg-final { scan-tree-dump-times "sub_array_shape \\(&array_class_t1_alloc._data," 1 "original" } }
+! { dg-final { scan-tree-dump-times "sub_array_shape \\(&array_class_t1_ptr._data," 1 "original" } }
+
+! { dg-final { cleanup-tree-dump "original" } }

gcc/testsuite/gfortran.dg/assumed_type_3.f90

+! { dg-do compile }
+! { dg-options "-fcoarray=single" }
+!
+! PR fortran/48820
+!
+! Test TYPE(*)
+
+subroutine one(a) ! { dg-error "may not have the ALLOCATABLE, CODIMENSION, POINTER or VALUE attribute" }
+  type(*), value :: a
+end subroutine one
+
+subroutine two(a) ! { dg-error "may not have the ALLOCATABLE, CODIMENSION, POINTER or VALUE attribute" }
+  type(*), pointer :: a
+end subroutine two
+
+subroutine three(a) ! { dg-error "may not have the ALLOCATABLE, CODIMENSION, POINTER or VALUE attribute" }
+  type(*), allocatable :: a
+end subroutine three
+
+subroutine four(a) ! { dg-error "may not have the ALLOCATABLE, CODIMENSION, POINTER or VALUE attribute" }
+  type(*)  :: a[*]
+end subroutine four
+
+subroutine five(a) ! { dg-error "shall not be an explicit-shape array" }
+  type(*) :: a(3)
+end subroutine five
+
+subroutine six()
+  type(*) :: nodum ! { dg-error "is only permitted for dummy variables" }
+end subroutine six
+
+subroutine seven(y)
+ type(*) :: y(:)
+ call a7(y(3:5)) ! { dg-error "Assumed-type variable y with designator" }
+contains
+ subroutine a7(x)
+   type(*) :: x(*)
+ end subroutine a7
+end subroutine seven
+
+subroutine eight()
+  type t
+    type(*) :: x ! { dg-error "is not allowed for components" }
+  end type t
+end subroutine eight
+
+subroutine nine()
+  interface one
+    subroutine okay(x)
+      type(*) :: x
+    end subroutine okay
+    subroutine okay2(x)
+      type(*) :: x(*)
+    end subroutine okay2
+    subroutine okay2(x,y)
+      integer :: x
+      type(*) :: y
+    end subroutine okay2
+  end interface
+  interface two
+    subroutine okok1(x)
+      type(*) :: x
+    end subroutine okok1
+    subroutine okok2(x)
+      integer :: x(*)
+    end subroutine okok2
+  end interface
+  interface three
+    subroutine ambig1(x)
+      type(*) :: x
+    end subroutine ambig1
+    subroutine ambig2(x)
+      integer :: x
+    end subroutine ambig2 ! { dg-error "Ambiguous interfaces 'ambig2' and 'ambig1' in generic interface 'three'" }
+  end interface
+end subroutine nine
+
+subroutine ten()
+ interface
+   subroutine bar()
+   end subroutine
+ end interface
+ type t
+ contains
+   procedure, nopass :: proc => bar
+ end type
+ type(t) :: xx
+ call sub(xx) ! { dg-error "is of derived type with type-bound or FINAL procedures" }
+contains
+  subroutine sub(a)
+    type(*) :: a
+  end subroutine sub
+end subroutine ten
+
+subroutine eleven(x)
+  external bar
+  type(*) :: x
+  call bar(x) ! { dg-error "Assumed-type argument x at .1. requires an explicit interface" }
+end subroutine eleven
+
+subroutine twelf(x)
+  type(*) :: x
+  call bar(x)
+contains
+  subroutine bar(x)
+    integer :: x ! { dg-error "Type mismatch in argument" }
+  end subroutine bar
+end subroutine twelf
+
+subroutine thirteen(x, y)
+  type(*) :: x
+  integer :: y(:)
+  print *, ubound(y, dim=x) ! { dg-error "must be INTEGER" }
+end subroutine thirteen
+
+subroutine fourteen(x)
+  type(*) :: x
+  x = x ! { dg-error "Invalid expression with assumed-type variable" }
+end subroutine fourteen

gcc/testsuite/gfortran.dg/assumed_type_4.f90

+! { dg-do compile }
+! { dg-options "-std=f2008" }
+!
+! PR fortran/48820
+!
+! Test TYPE(*)
+
+subroutine one(a) ! { dg-error "TS 29113: Assumed type" }
+  type(*)  :: a
+end subroutine one