Patchwork [4.8,Fortran] PR 48820 - Support TYPE(*) of TS29113

login
register
mail settings
Submitter Tobias Burnus
Date March 2, 2012, 11:28 a.m.
Message ID <4F50AEDB.2010008@net-b.de>
Download mbox | patch
Permalink /patch/144223/
State New
Headers show

Comments

Tobias Burnus - March 2, 2012, 11:28 a.m.
TYPE(*) is Fortran's equivalent to C's "void *buffer". It may only be 
used for dummy arguments and essentially might only either be passed on, 
or appear in PRESENT, LBOUND/UBOUND/SHAPE/SIZE/IS_CONTIGUOUS - and most 
useful: in C_LOC.


Note: For scalar TYPE(*) and for assumed-size dummies, only the address 
is passed on. But for dimension(:) and TS29113's new (but unimplemented) 
dimension(..) an array descriptor is passed. In that case, one might 
recover the type from the array descriptor - at least for intrinsic types.


TYPE(*) is useful for, e.g., MPI (and used in the MPI v3 draft spec): 
There, one simply takes an argument of any type and transfers some bytes 
from it - without needing to know the type. TYPE(*) avoids to create 
hundreds of useless explicit interfaces for all kind of data types (and 
missing derived types that way) - or TS29113 avoids the alternative: Not 
using explicit interfaces (causing argument checking issues and prevents 
the use of BIND(C).)


See PR (or first test case) for a usage example. For a pure Fortran use, 
one could imagine:

subroutine send(buf, size)
   use iso_c_binding, only: c_signed_char, c_size_t
   type(*) :: buf(*)
   integer(c_size_t) :: size
   integer(c_signed_char) :: ibuf(size)
   call c_f_pointer (c_loc(buf), ibuf, shape=[size])
   ! ... use ibuf ...
end

[This example currently fails as "c_loc(buf)" is rejected. Several 
BIND(C) restrictions were removed in F2008 and especially in TS29113, 
but gfortran has not yet removed them.]


For more details, see:

* TS 29113 draft: ftp://ftp.nag.co.uk/sc22wg5/N1901-N1950/N1904.pdf
(Status: Went as PDTR through one round of voting by the ISO members, 
was updated at the last J3 meeting and is now the subject of a one-month 
WG5 ballot that ends on 19 March 2012. The schedule is that it will then 
be forwarded to SC22, which initiates a DTS ballot such that the final 
version will be published in September by ISO.)

* MPIv3 draft (of 2011-12-15):
https://svn.mpi-forum.org/trac/mpi-forum-web/attachment/ticket/229/mpi-report-F2008-2011-12-15-changeonlyplustickets_majorpages.pdf

Build and regtested on x86-64-linux.
OK for the 4.8 trunk?

Tobias
Paul Richard Thomas - March 3, 2012, 7:41 a.m.
Dear Tobias,

This is certainly OK for 4.8.

I have a couple of remarks:
(i) The DTYPE_TYPE_MASK is 0x38 so that we saturated it a long time
since!  At the moment it does not cause any problems because of the
extremely limited use of the dtype 'type'.  Whilst the array
descriptor revamp will eliminate such worries, we should be mindful of
this; and
(ii) By making such substantial use of scan-tree-dump-times in the
dg-run test case, you are potentially building in instability against
future development, I suppose?  Are the runtime tests not sufficient?

Thanks for this early upgrade!

Paul

On Fri, Mar 2, 2012 at 12:28 PM, Tobias Burnus <burnus@net-b.de> wrote:
> TYPE(*) is Fortran's equivalent to C's "void *buffer". It may only be used
> for dummy arguments and essentially might only either be passed on, or
> appear in PRESENT, LBOUND/UBOUND/SHAPE/SIZE/IS_CONTIGUOUS - and most useful:
> in C_LOC.
>
>
> Note: For scalar TYPE(*) and for assumed-size dummies, only the address is
> passed on. But for dimension(:) and TS29113's new (but unimplemented)
> dimension(..) an array descriptor is passed. In that case, one might recover
> the type from the array descriptor - at least for intrinsic types.
>
>
> TYPE(*) is useful for, e.g., MPI (and used in the MPI v3 draft spec): There,
> one simply takes an argument of any type and transfers some bytes from it -
> without needing to know the type. TYPE(*) avoids to create hundreds of
> useless explicit interfaces for all kind of data types (and missing derived
> types that way) - or TS29113 avoids the alternative: Not using explicit
> interfaces (causing argument checking issues and prevents the use of
> BIND(C).)
>
>
> See PR (or first test case) for a usage example. For a pure Fortran use, one
> could imagine:
>
> subroutine send(buf, size)
>  use iso_c_binding, only: c_signed_char, c_size_t
>  type(*) :: buf(*)
>  integer(c_size_t) :: size
>  integer(c_signed_char) :: ibuf(size)
>  call c_f_pointer (c_loc(buf), ibuf, shape=[size])
>  ! ... use ibuf ...
> end
>
> [This example currently fails as "c_loc(buf)" is rejected. Several BIND(C)
> restrictions were removed in F2008 and especially in TS29113, but gfortran
> has not yet removed them.]
>
>
> For more details, see:
>
> * TS 29113 draft: ftp://ftp.nag.co.uk/sc22wg5/N1901-N1950/N1904.pdf
> (Status: Went as PDTR through one round of voting by the ISO members, was
> updated at the last J3 meeting and is now the subject of a one-month WG5
> ballot that ends on 19 March 2012. The schedule is that it will then be
> forwarded to SC22, which initiates a DTS ballot such that the final version
> will be published in September by ISO.)
>
> * MPIv3 draft (of 2011-12-15):
> https://svn.mpi-forum.org/trac/mpi-forum-web/attachment/ticket/229/mpi-report-F2008-2011-12-15-changeonlyplustickets_majorpages.pdf
>
> Build and regtested on x86-64-linux.
> OK for the 4.8 trunk?
>
> Tobias
Tobias Burnus - March 3, 2012, 10:13 a.m.
Dear Paul,

thanks for the review.

Paul Richard Thomas wrote:
> I have a couple of remarks:
> (i) The DTYPE_TYPE_MASK is 0x38 so that we saturated it a long time
> since!  At the moment it does not cause any problems because of the
> extremely limited use of the dtype 'type'.  Whilst the array
> descriptor revamp will eliminate such worries, we should be mindful of
> this; and

Thanks for the reminder. I kind of expected such an issue - and decided 
not to worry about it.

> (ii) By making such substantial use of scan-tree-dump-times in the
> dg-run test case, you are potentially building in instability against
> future development, I suppose?  Are the runtime tests not sufficient?

In principle, run-time tests are sufficient. But they rely on C tests - 
or at least on a working C_LOC. However, one currently cannot use 
C_LOC() on assumed-shape variables nor BIND(C) for assumed-shape 
dummies. [Which is allowed in TS29113.]  Besides, the C program needs 
then to make use of gfortran's array descriptor to really check.

I tried a bit, but it gets rather complicated so that at some point, I 
gave up, deleted the traces of the C code and surrendered. I checked the 
argument manually and added them to the scan-tree-dump-times. I tried 
carefully to use them such that they should work on all targets. 
However, if the array descriptor will change, they might break. However, 
the work to fix them once or twice might be less than writing a run-time 
test.

Tobias

Patch

2012-03-02  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/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.

diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index 43c558a..bdb8c39 100644
--- a/gcc/fortran/decl.c
+++ b/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;
 }
 
diff --git a/gcc/fortran/dump-parse-tree.c b/gcc/fortran/dump-parse-tree.c
index c715b30..7f1d28f 100644
--- a/gcc/fortran/dump-parse-tree.c
+++ b/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)
diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index 129ece3..1521318 100644
--- a/gcc/fortran/expr.c
+++ b/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:
diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index e1f0cb6..ada9ea1 100644
--- a/gcc/fortran/interface.c
+++ b/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; 
 }
 
 
@@ -1695,6 +1696,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, 
@@ -2271,6 +2273,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.  */
@@ -2882,7 +2905,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
@@ -2935,6 +2957,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)
diff --git a/gcc/fortran/libgfortran.h b/gcc/fortran/libgfortran.h
index 3f36fe8..62afc21 100644
--- a/gcc/fortran/libgfortran.h
+++ b/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;
diff --git a/gcc/fortran/misc.c b/gcc/fortran/misc.c
index 05aef9f..012364a 100644
--- a/gcc/fortran/misc.c
+++ b/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;
diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c
index 5e0f26e..36ef4f8 100644
--- a/gcc/fortran/module.c
+++ b/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)
 };
 
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 4dcf9b1..4104924 100644
--- a/gcc/fortran/resolve.c
+++ b/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 +12459,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
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 3552da3..d69399c 100644
--- a/gcc/fortran/trans-expr.c
+++ b/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)
diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c
index 2579e23..6ff1d33 100644
--- a/gcc/fortran/trans-types.c
+++ b/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.  */
--- /dev/null	2012-03-02 07:37:33.883806634 +0100
+++ gcc/gcc/testsuite/gfortran.dg/assumed_type_1.f90	2012-03-01 10:13:39.000000000 +0100
@@ -0,0 +1,57 @@ 
+! { 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" } }
--- /dev/null	2012-03-02 07:37:33.883806634 +0100
+++ gcc/gcc/testsuite/gfortran.dg/assumed_type_2.f90	2012-03-02 11:28:22.000000000 +0100
@@ -0,0 +1,181 @@ 
+! { 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" } }
--- /dev/null	2012-03-02 07:37:33.883806634 +0100
+++ gcc/gcc/testsuite/gfortran.dg/assumed_type_3.f90	2012-03-02 00:51:48.000000000 +0100
@@ -0,0 +1,119 @@ 
+! { 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
--- /dev/null	2012-03-02 07:37:33.883806634 +0100
+++ gcc/gcc/testsuite/gfortran.dg/assumed_type_4.f90	2012-03-02 00:53:21.000000000 +0100
@@ -0,0 +1,10 @@ 
+! { 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