From: Tobias Burnus Date: Fri, 4 Jul 2014 20:25:28 +0000 (+0200) Subject: resolve.c (resolve_assoc_var): Fix corank setting. X-Git-Tag: releases/gcc-5.1.0~6492 X-Git-Url: http://git.ipfire.org/?a=commitdiff_plain;h=d7463e5b31fdabbd5dea5a9d62d26049538119d5;p=thirdparty%2Fgcc.git resolve.c (resolve_assoc_var): Fix corank setting. 2014-07-04 Tobias Burnus * resolve.c (resolve_assoc_var): Fix corank setting. * trans-array.c (gfc_conv_descriptor_token): Change assert. for select-type temporaries. * trans-decl.c (generate_coarray_sym_init): Skip for attr.select_type_temporary. * trans-expr.c (gfc_conv_procedure_call): Fix for select-type temporaries. * trans-intrinsic.c (get_caf_token_offset): Ditto. (gfc_conv_intrinsic_caf_get, gfc_conv_intrinsic_caf_send): Set the correct dtype. * trans-types.h (gfc_get_dtype_rank_type): New. * trans-types.c (gfc_get_dtype_rank_type): Ditto. 2014-07-04 Tobias Burnus * gfortran.dg/coarray/coindexed_3.f90: New. From-SVN: r212299 --- diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 68e903cf0476..b3764b8ea177 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,18 @@ +2014-07-04 Tobias Burnus + + * resolve.c (resolve_assoc_var): Fix corank setting. + * trans-array.c (gfc_conv_descriptor_token): Change assert. + for select-type temporaries. + * trans-decl.c (generate_coarray_sym_init): Skip for + attr.select_type_temporary. + * trans-expr.c (gfc_conv_procedure_call): Fix for + select-type temporaries. + * trans-intrinsic.c (get_caf_token_offset): Ditto. + (gfc_conv_intrinsic_caf_get, gfc_conv_intrinsic_caf_send): Set + the correct dtype. + * trans-types.h (gfc_get_dtype_rank_type): New. + * trans-types.c (gfc_get_dtype_rank_type): Ditto. + 2014-07-03 Tobias Burnus * scanner.c (skip_free_comments): Fix indentation. diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index ca20c294243f..15d8dab0efff 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -7912,10 +7912,7 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target) sym->as = gfc_get_array_spec (); sym->as->rank = target->rank; sym->as->type = AS_DEFERRED; - - /* Target must not be coindexed, thus the associate-variable - has no corank. */ - sym->as->corank = 0; + sym->as->corank = gfc_get_corank (target); } /* Mark this as an associate variable. */ diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 5558217ab48b..0e018991c0a0 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -298,7 +298,6 @@ gfc_conv_descriptor_token (tree desc) type = TREE_TYPE (desc); gcc_assert (GFC_DESCRIPTOR_TYPE_P (type)); - gcc_assert (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE); gcc_assert (gfc_option.coarray == GFC_FCOARRAY_LIB); field = gfc_advance_chain (TYPE_FIELDS (type), CAF_TOKEN_FIELD); diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index cbcd52dc87f9..93c59b11b669 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -4670,7 +4670,8 @@ generate_coarray_sym_init (gfc_symbol *sym) tree tmp, size, decl, token; if (sym->attr.dummy || sym->attr.allocatable || !sym->attr.codimension - || sym->attr.use_assoc || !sym->attr.referenced) + || sym->attr.use_assoc || !sym->attr.referenced + || sym->attr.select_type_temporary) return; decl = sym->backend_decl; diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 7ee0206e6a0c..dba51b081f47 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -4813,7 +4813,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, caf_type = TREE_TYPE (caf_decl); if (GFC_DESCRIPTOR_TYPE_P (caf_type) - && GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_ALLOCATABLE) + && (GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_ALLOCATABLE + || GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_POINTER)) tmp = gfc_conv_descriptor_token (caf_decl); else if (DECL_LANG_SPECIFIC (caf_decl) && GFC_DECL_TOKEN (caf_decl) != NULL_TREE) diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index a1dfdfb2f836..5aa56838ae7f 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -1179,7 +1179,8 @@ get_caf_token_offset (tree *token, tree *offset, tree caf_decl, tree se_expr, /* Offset between the coarray base address and the address wanted. */ if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl)) - && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl)) == GFC_ARRAY_ALLOCATABLE) + && (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl)) == GFC_ARRAY_ALLOCATABLE + || GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl)) == GFC_ARRAY_POINTER)) *offset = build_int_cst (gfc_array_index_type, 0); else if (DECL_LANG_SPECIFIC (caf_decl) && GFC_DECL_CAF_OFFSET (caf_decl) != NULL_TREE) @@ -1285,7 +1286,10 @@ gfc_conv_intrinsic_caf_get (gfc_se *se, gfc_expr *expr, tree lhs, tree lhs_kind) ar->type = AR_FULL; } gfc_conv_expr_descriptor (&argse, array_expr); - + /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that + has the wrong type if component references are done. */ + gfc_add_modify (&argse.pre, gfc_conv_descriptor_dtype (argse.expr), + gfc_get_dtype_rank_type (array_expr->rank, type)); if (has_vector) { vec = conv_caf_vector_subscript (&argse.pre, argse.expr, ar); @@ -1387,7 +1391,12 @@ conv_caf_send (gfc_code *code) { } lhs_se.want_pointer = 1; gfc_conv_expr_descriptor (&lhs_se, lhs_expr); - lhs_type = gfc_get_element_type (TREE_TYPE (TREE_TYPE (lhs_se.expr))); + /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that + has the wrong type if component references are done. */ + lhs_type = gfc_typenode_for_spec (&lhs_expr->ts); + tmp = build_fold_indirect_ref_loc (input_location, lhs_se.expr); + gfc_add_modify (&lhs_se.pre, gfc_conv_descriptor_dtype (tmp), + gfc_get_dtype_rank_type (lhs_expr->rank, lhs_type)); if (has_vector) { vec = conv_caf_vector_subscript (&block, lhs_se.expr, ar); @@ -1440,6 +1449,7 @@ conv_caf_send (gfc_code *code) { vector bounds separately. */ gfc_array_ref *ar, ar2; bool has_vector = false; + tree tmp2; if (gfc_is_coindexed (rhs_expr) && gfc_has_vector_subscript (rhs_expr)) { @@ -1452,6 +1462,12 @@ conv_caf_send (gfc_code *code) { } rhs_se.want_pointer = 1; gfc_conv_expr_descriptor (&rhs_se, rhs_expr); + /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that + has the wrong type if component references are done. */ + tmp = build_fold_indirect_ref_loc (input_location, rhs_se.expr); + tmp2 = gfc_typenode_for_spec (&rhs_expr->ts); + gfc_add_modify (&rhs_se.pre, gfc_conv_descriptor_dtype (tmp), + gfc_get_dtype_rank_type (rhs_expr->rank, tmp2)); if (has_vector) { rhs_vec = conv_caf_vector_subscript (&block, rhs_se.expr, ar); diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c index bb930f9cdeaa..e55e2d9c1f5e 100644 --- a/gcc/fortran/trans-types.c +++ b/gcc/fortran/trans-types.c @@ -1395,23 +1395,13 @@ gfc_get_desc_dim_type (void) unknown cases abort. */ tree -gfc_get_dtype (tree type) +gfc_get_dtype_rank_type (int rank, tree etype) { tree size; int n; HOST_WIDE_INT i; tree tmp; tree dtype; - tree etype; - int rank; - - gcc_assert (GFC_DESCRIPTOR_TYPE_P (type) || GFC_ARRAY_TYPE_P (type)); - - if (GFC_TYPE_ARRAY_DTYPE (type)) - return GFC_TYPE_ARRAY_DTYPE (type); - - rank = GFC_TYPE_ARRAY_RANK (type); - etype = gfc_get_element_type (type); switch (TREE_CODE (etype)) { @@ -1477,6 +1467,26 @@ gfc_get_dtype (tree type) /* TODO: Check this is actually true, particularly when repacking assumed size parameters. */ + return dtype; +} + + +tree +gfc_get_dtype (tree type) +{ + tree dtype; + tree etype; + int rank; + + gcc_assert (GFC_DESCRIPTOR_TYPE_P (type) || GFC_ARRAY_TYPE_P (type)); + + if (GFC_TYPE_ARRAY_DTYPE (type)) + return GFC_TYPE_ARRAY_DTYPE (type); + + rank = GFC_TYPE_ARRAY_RANK (type); + etype = gfc_get_element_type (type); + dtype = gfc_get_dtype_rank_type (rank, etype); + GFC_TYPE_ARRAY_DTYPE (type) = dtype; return dtype; } diff --git a/gcc/fortran/trans-types.h b/gcc/fortran/trans-types.h index 5ed87c0bb5a7..bd3e69c2bab8 100644 --- a/gcc/fortran/trans-types.h +++ b/gcc/fortran/trans-types.h @@ -97,6 +97,7 @@ int gfc_return_by_reference (gfc_symbol *); int gfc_is_nodesc_array (gfc_symbol *); /* Return the DTYPE for an array. */ +tree gfc_get_dtype_rank_type (int, tree); tree gfc_get_dtype (tree); tree gfc_get_ppc_type (gfc_component *); diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 02e8b93d08f2..93f9d35f71a6 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,7 @@ +2014-07-04 Tobias Burnus + + * gfortran.dg/coarray/coindexed_3.f90: New. + 2014-07-04 Jakub Jelinek PR middle-end/61654 diff --git a/gcc/testsuite/gfortran.dg/coarray/coindexed_3.f90 b/gcc/testsuite/gfortran.dg/coarray/coindexed_3.f90 new file mode 100644 index 000000000000..46488f3855d0 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray/coindexed_3.f90 @@ -0,0 +1,71 @@ +! { dg-do run } +! +! Contributed by Reinhold Bader +! + +program pmup + implicit none + type t + integer :: b, a + end type t + + CLASS(*), allocatable :: a(:)[:] + integer :: ii + + !! --- ONE --- + allocate(real :: a(3)[*]) + IF (this_image() == num_images()) THEN + SELECT TYPE (a) + TYPE IS (real) + a(:)[1] = 2.0 + END SELECT + END IF + SYNC ALL + + IF (this_image() == 1) THEN + SELECT TYPE (a) + TYPE IS (real) + IF (ALL(A(:)[1] == 2.0)) THEN + !WRITE(*,*) 'OK' + ELSE + WRITE(*,*) 'FAIL' + call abort() + END IF + TYPE IS (t) + ii = a(1)[1]%a + call abort() + CLASS IS (t) + ii = a(1)[1]%a + call abort() + END SELECT + END IF + + !! --- TWO --- + deallocate(a) + allocate(t :: a(3)[*]) + IF (this_image() == num_images()) THEN + SELECT TYPE (a) + TYPE IS (t) + a(:)[1]%a = 4.0 + END SELECT + END IF + SYNC ALL + + IF (this_image() == 1) THEN + SELECT TYPE (a) + TYPE IS (real) + ii = a(1)[1] + call abort() + TYPE IS (t) + IF (ALL(A(:)[1]%a == 4.0)) THEN + !WRITE(*,*) 'OK' + ELSE + WRITE(*,*) 'FAIL' + call abort() + END IF + CLASS IS (t) + ii = a(1)[1]%a + call abort() + END SELECT + END IF +end program