This is the mail archive of the
fortran@gcc.gnu.org
mailing list for the GNU Fortran project.
[4.8, Fortran, Patch] PR 48820 - Support TYPE(*) of TS29113
- From: Tobias Burnus <burnus at net-b dot de>
- To: gcc patches FOR <gcc-patches at gcc dot gnu dot org>, gfortran <fortran at gcc dot gnu dot org>
- Date: Fri, 02 Mar 2012 12:28:27 +0100
- Subject: [4.8, Fortran, Patch] PR 48820 - Support TYPE(*) of TS29113
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
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