From 8f75db9fd35e5bd43305c37896d143b7947455a5 Mon Sep 17 00:00:00 2001 From: Paul Thomas Date: Sat, 5 May 2012 08:49:43 +0000 Subject: re PR fortran/41600 ([OOP] SELECT TYPE with associate-name => exp: Arrays not supported) 2012-05-05 Paul Thomas PR fortran/41600 * trans-array.c (build_array_ref): New static function. (gfc_conv_array_ref, gfc_get_dataptr_offset): Call it. * trans-expr.c (gfc_get_vptr_from_expr): New function. (gfc_conv_derived_to_class): Add a new argument for a caller supplied vptr and use it if it is not NULL. (gfc_conv_procedure_call): Add NULL to call to above. symbol.c (gfc_is_associate_pointer): Return true if symbol is a class object. * trans-stmt.c (trans_associate_var): Handle class associate- names. * expr.c (gfc_get_variable_expr): Supply the array-spec if possible. * trans-types.c (gfc_typenode_for_spec): Set GFC_CLASS_TYPE_P for class types. * trans.h : Add prototypes for gfc_get_vptr_from_expr and gfc_conv_derived_to_class. Define GFC_CLASS_TYPE_P. * resolve.c (resolve_variable): For class arrays, ensure that the target expression has all the necessary _data references. (resolve_assoc_var): Throw a "not yet implemented" error for class array selectors that need a temporary. * match.c (copy_ts_from_selector_to_associate, select_derived_set_tmp, select_class_set_tmp): New functions. (select_type_set_tmp): Call one of last two new functions. (gfc_match_select_type): Copy_ts_from_selector_to_associate is called if associate-name is typed. PR fortran/53191 * resolve.c (resolve_ref): C614 applied to class expressions. 2012-05-05 Paul Thomas PR fortran/41600 * gfortran.dg/select_type_26.f03 : New test. * gfortran.dg/select_type_27.f03 : New test. PR fortran/53191 * gfortran.dg/select_type_28.f03 : New test. From-SVN: r187192 --- gcc/fortran/resolve.c | 42 +++++++++++++++++++++++++++++++++++------- 1 file changed, 35 insertions(+), 7 deletions(-) (limited to 'gcc/fortran/resolve.c') diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index e15d6e1..e5a49bc 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -4904,14 +4904,19 @@ resolve_ref (gfc_expr *expr) { /* F03:C614. */ if (ref->u.c.component->attr.pointer - || ref->u.c.component->attr.proc_pointer) + || ref->u.c.component->attr.proc_pointer + || (ref->u.c.component->ts.type == BT_CLASS + && CLASS_DATA (ref->u.c.component)->attr.pointer)) { gfc_error ("Component to the right of a part reference " "with nonzero rank must not have the POINTER " "attribute at %L", &expr->where); return FAILURE; } - else if (ref->u.c.component->attr.allocatable) + else if (ref->u.c.component->attr.allocatable + || (ref->u.c.component->ts.type == BT_CLASS + && CLASS_DATA (ref->u.c.component)->attr.allocatable)) + { gfc_error ("Component to the right of a part reference " "with nonzero rank must not have the ALLOCATABLE " @@ -5081,9 +5086,15 @@ resolve_variable (gfc_expr *e) } /* 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) - return FAILURE; + in error even though the target is scalar. Fail directly in this case. + TODO Understand why class scalar expressions must be excluded. */ + if (sym->assoc && !(sym->ts.type == BT_CLASS && e->rank == 0)) + { + if (sym->ts.type == BT_CLASS) + gfc_fix_class_refs (e); + if (!sym->attr.dimension && e->ref && e->ref->type == REF_ARRAY) + return FAILURE; + } if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.generic) sym->ts.u.derived = gfc_find_dt_in_generic (sym->ts.u.derived); @@ -7941,7 +7952,7 @@ gfc_type_is_extensible (gfc_symbol *sym) } -/* Resolve an associate name: Resolve target and ensure the type-spec is +/* Resolve an associate-name: Resolve target and ensure the type-spec is correct as well as possibly the array-spec. */ static void @@ -7997,8 +8008,25 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target) sym->attr.dimension = 0; return; } - if (target->rank > 0) + + /* We cannot deal with class selectors that need temporaries. */ + if (target->ts.type == BT_CLASS + && gfc_ref_needs_temporary_p (target->ref)) + { + gfc_error ("CLASS selector at %L needs a temporary which is not " + "yet implemented", &target->where); + return; + } + + if (target->ts.type != BT_CLASS && target->rank > 0) sym->attr.dimension = 1; + else if (target->ts.type == BT_CLASS) + gfc_fix_class_refs (target); + + /* The associate-name will have a correct type by now. Make absolutely + sure that it has not picked up a dimension attribute. */ + if (sym->ts.type == BT_CLASS) + sym->attr.dimension = 0; if (sym->attr.dimension) { -- cgit v1.1