From: burnus Date: Fri, 27 Jan 2012 13:08:52 +0000 (+0000) Subject: 2012-01-27 Tobias Burnus X-Git-Url: http://git.sourceforge.jp/view?a=commitdiff_plain;h=3a19c06377e6f28b0328663107124aa0b98f7f44;hp=cbd83bfba6047c14cfb918239de1d17663b5cd2e;p=pf3gnuchains%2Fgcc-fork.git 2012-01-27 Tobias Burnus PR fortran/51970 PR fortran/51977 * primary.c (gfc_match_varspec. gfc_match_rvalue): Set handle array spec for BT_CLASS. * expr.c (gfc_get_variable_expr, gfc_lval_expr_from_sym) * frontend-passes.c (create_var): Ditto. * resolve.c (resolve_actual_arglist, resolve_assoc_var): Ditto. * trans-decl.c (gfc_trans_deferred_vars): Use class_pointer instead of attr.pointer. (gfc_generate_function_code): Use CLASS_DATA (sym) for BT_CLASS. * trans-intrinsic.c (conv_intrinsic_move_alloc): Move assert. * trans-stmt.c (trans_associate_var): Ask for the descriptor. 2012-01-27 Tobias Burnus PR fortran/51970 PR fortran/51977 * gfortran.dg/move_alloc_13.f90: New. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@183622 138bc75d-0d04-0410-961f-82ee72b054a4 --- diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 1c709f05312..6a6b05cbedc 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,5 +1,20 @@ 2012-01-27 Tobias Burnus + PR fortran/51970 + PR fortran/51977 + * primary.c (gfc_match_varspec. gfc_match_rvalue): Set + handle array spec for BT_CLASS. + * expr.c (gfc_get_variable_expr, gfc_lval_expr_from_sym) + * frontend-passes.c (create_var): Ditto. + * resolve.c (resolve_actual_arglist, resolve_assoc_var): Ditto. + * trans-decl.c (gfc_trans_deferred_vars): Use class_pointer + instead of attr.pointer. + (gfc_generate_function_code): Use CLASS_DATA (sym) for BT_CLASS. + * trans-intrinsic.c (conv_intrinsic_move_alloc): Move assert. + * trans-stmt.c (trans_associate_var): Ask for the descriptor. + +2012-01-27 Tobias Burnus + PR fortran/51953 * match.c (gfc_match_allocate): Allow more than allocate object with SOURCE=. diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index 7cea780693d..c4013133560 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -3805,9 +3805,12 @@ gfc_get_variable_expr (gfc_symtree *var) e->symtree = var; e->ts = var->n.sym->ts; - if (var->n.sym->as != NULL) + if ((var->n.sym->as != NULL && var->n.sym->ts.type != BT_CLASS) + || (var->n.sym->ts.type == BT_CLASS && CLASS_DATA (var->n.sym) + && CLASS_DATA (var->n.sym)->as)) { - e->rank = var->n.sym->as->rank; + e->rank = var->n.sym->ts.type == BT_CLASS + ? CLASS_DATA (var->n.sym)->as->rank : var->n.sym->as->rank; e->ref = gfc_get_ref (); e->ref->type = REF_ARRAY; e->ref->u.ar.type = AR_FULL; @@ -3836,7 +3839,8 @@ gfc_lval_expr_from_sym (gfc_symbol *sym) lval->ref->u.ar.type = AR_FULL; lval->ref->u.ar.dimen = lval->rank; lval->ref->u.ar.where = sym->declared_at; - lval->ref->u.ar.as = sym->as; + lval->ref->u.ar.as = sym->ts.type == BT_CLASS + ? CLASS_DATA (sym)->as : sym->as; } return lval; diff --git a/gcc/fortran/frontend-passes.c b/gcc/fortran/frontend-passes.c index ab33a2f17a9..20f76ebfbe6 100644 --- a/gcc/fortran/frontend-passes.c +++ b/gcc/fortran/frontend-passes.c @@ -328,7 +328,8 @@ create_var (gfc_expr * e) result->ref->type = REF_ARRAY; result->ref->u.ar.type = AR_FULL; result->ref->u.ar.where = e->where; - result->ref->u.ar.as = symbol->as; + result->ref->u.ar.as = symbol->ts.type == BT_CLASS + ? CLASS_DATA (symbol)->as : symbol->as; if (gfc_option.warn_array_temp) gfc_warning ("Creating array temporary at %L", &(e->where)); } diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c index 83d9132b41f..d1d96ffa68e 100644 --- a/gcc/fortran/primary.c +++ b/gcc/fortran/primary.c @@ -1868,18 +1868,24 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag, && (CLASS_DATA (sym)->attr.dimension || CLASS_DATA (sym)->attr.codimension))) { + gfc_array_spec *as; + + tail = extend_ref (primary, tail); + tail->type = REF_ARRAY; + /* In EQUIVALENCE, we don't know yet whether we are seeing an array, character variable or array of character variables. We'll leave the decision till resolve time. */ - tail = extend_ref (primary, tail); - tail->type = REF_ARRAY; - m = gfc_match_array_ref (&tail->u.ar, equiv_flag ? NULL : sym->as, - equiv_flag, - sym->ts.type == BT_CLASS && CLASS_DATA (sym) - ? (CLASS_DATA (sym)->as - ? CLASS_DATA (sym)->as->corank : 0) - : (sym->as ? sym->as->corank : 0)); + if (equiv_flag) + as = NULL; + else if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)) + as = CLASS_DATA (sym)->as; + else + as = sym->as; + + m = gfc_match_array_ref (&tail->u.ar, as, equiv_flag, + as ? as->corank : 0); if (m != MATCH_YES) return m; @@ -2893,7 +2899,10 @@ gfc_match_rvalue (gfc_expr **result) e->value.function.actual = actual_arglist; e->where = gfc_current_locus; - if (sym->as != NULL) + if (sym->ts.type == BT_CLASS && sym->attr.class_ok + && CLASS_DATA (sym)->as) + e->rank = CLASS_DATA (sym)->as->rank; + else if (sym->as != NULL) e->rank = sym->as->rank; if (!sym->attr.function diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 9bd5c00b33b..2e510047143 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -1755,13 +1755,17 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype, got_variable: e->expr_type = EXPR_VARIABLE; e->ts = sym->ts; - if (sym->as != NULL) + if ((sym->as != NULL && sym->ts.type != BT_CLASS) + || (sym->ts.type == BT_CLASS && sym->attr.class_ok + && CLASS_DATA (sym)->as)) { - e->rank = sym->as->rank; + e->rank = sym->ts.type == BT_CLASS + ? CLASS_DATA (sym)->as->rank : sym->as->rank; e->ref = gfc_get_ref (); e->ref->type = REF_ARRAY; e->ref->u.ar.type = AR_FULL; - e->ref->u.ar.as = sym->as; + e->ref->u.ar.as = sym->ts.type == BT_CLASS + ? CLASS_DATA (sym)->as : sym->as; } /* Expressions are assigned a default ts.type of BT_PROCEDURE in @@ -7945,13 +7949,8 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target) sym->attr.asynchronous = tsym->attr.asynchronous; sym->attr.volatile_ = tsym->attr.volatile_; - if (tsym->ts.type == BT_CLASS) - sym->attr.target = tsym->attr.target || CLASS_DATA (tsym)->attr.pointer; - else - sym->attr.target = tsym->attr.target || tsym->attr.pointer; - - if (sym->ts.type == BT_DERIVED && tsym->ts.type == BT_CLASS) - target->rank = sym->as ? sym->as->rank : 0; + sym->attr.target = tsym->attr.target + || gfc_expr_attr (target).pointer; } /* Get type if this was not already set. Note that it can be @@ -7966,10 +7965,7 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target) && !gfc_has_vector_subscript (target)); /* Finally resolve if this is an array or not. */ - if (sym->attr.dimension - && (target->ts.type == BT_CLASS - ? !CLASS_DATA (target)->attr.dimension - : target->rank == 0)) + if (sym->attr.dimension && target->rank == 0) { gfc_error ("Associate-name '%s' at %L is used as array", sym->name, &sym->declared_at); diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index e8e54c77b79..8efe5a97bbc 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -3687,7 +3687,7 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block) } else if ((!sym->attr.dummy || sym->ts.deferred) && (sym->ts.type == BT_CLASS - && CLASS_DATA (sym)->attr.pointer)) + && CLASS_DATA (sym)->attr.class_pointer)) continue; else if ((!sym->attr.dummy || sym->ts.deferred) && (sym->attr.allocatable @@ -5341,7 +5341,8 @@ gfc_generate_function_code (gfc_namespace * ns) null_pointer_node)); else if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.allocatable - && sym->attr.dimension == 0 && sym->result == sym) + && CLASS_DATA (sym)->attr.dimension == 0 + && sym->result == sym) { tmp = CLASS_DATA (sym)->backend_decl; tmp = fold_build3_loc (input_location, COMPONENT_REF, diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index cb742733df8..ac9f5074035 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -7237,10 +7237,11 @@ conv_intrinsic_move_alloc (gfc_code *code) gfc_init_se (&from_se, NULL); gfc_init_se (&to_se, NULL); + gcc_assert (from_expr->ts.type != BT_CLASS + || to_expr->ts.type == BT_CLASS); + if (from_expr->rank == 0) { - gcc_assert (from_expr->ts.type != BT_CLASS - || to_expr->ts.type == BT_CLASS); if (from_expr->ts.type != BT_CLASS) from_expr2 = from_expr; else diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index 19a8e7af429..f264bf92df8 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -1175,6 +1175,7 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block) gfc_se se; gfc_init_se (&se, NULL); + se.descriptor_only = 1; gfc_conv_expr (&se, e); gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr))); diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index dae81122636..38a7cf9cf64 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,5 +1,11 @@ 2012-01-27 Tobias Burnus + PR fortran/51970 + PR fortran/51977 + * gfortran.dg/move_alloc_13.f90: New. + +2012-01-27 Tobias Burnus + PR fortran/51953 * gfortran.dg/allocate_alloc_opt_13.f90: New. * gfortran.dg/allocate_alloc_opt_4.f90: Add -std=f2003 diff --git a/gcc/testsuite/gfortran.dg/move_alloc_13.f90 b/gcc/testsuite/gfortran.dg/move_alloc_13.f90 new file mode 100644 index 00000000000..9c3e0bcd58f --- /dev/null +++ b/gcc/testsuite/gfortran.dg/move_alloc_13.f90 @@ -0,0 +1,39 @@ +! { dg-do run} +! +! PR fortran/51970 +! PR fortran/51977 +! +type t +end type t +type, extends(t) :: t2 + integer :: a +end type t2 + +class(t), allocatable :: y(:), z(:) + +allocate(y(2), source=[t2(2), t2(3)]) +call func2(y,z) + +select type(z) + type is(t2) + if (any (z(:)%a /= [2, 3])) call abort() + class default + call abort() +end select + +contains + function func(x) + class (t), allocatable :: x(:), func(:) + call move_alloc (x, func) + end function + + function func1(x) + class (t), allocatable :: x(:), func1(:) + call move_alloc (func1, x) + end function + + subroutine func2(x, y) + class (t), allocatable :: x(:), y(:) + call move_alloc (x, y) + end subroutine +end