From 45a6932568c7c3f4aaf0e0c935a5f5d58ecf1919 Mon Sep 17 00:00:00 2001 From: Tobias Burnus Date: Sat, 3 Mar 2012 09:40:24 +0100 Subject: re PR fortran/48820 (TR 29113: Implement parts needed for MPI 3) 2012-03-03 Tobias Burnus 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 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/resolve.c | 48 ++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 48 insertions(+) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 824bc25..618c6f5 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 +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 -- cgit v1.1