diff --git a/gcc/fortran/gfortran.texi b/gcc/fortran/gfortran.texi index 9ffe6ade661..db48a713661 100644 --- a/gcc/fortran/gfortran.texi +++ b/gcc/fortran/gfortran.texi @@ -4750,7 +4750,7 @@ remote image identified by the @var{image_index}. @item @emph{Syntax}: @code{void _gfortran_caf_send_by_ref (caf_token_t token, int image_index, gfc_descriptor_t *src, caf_reference_t *refs, int dst_kind, int src_kind, -bool may_require_tmp, bool dst_reallocatable, int *stat)} +bool may_require_tmp, bool dst_reallocatable, int *stat, int dst_type)} @item @emph{Arguments}: @multitable @columnfractions .15 .70 @@ -4774,6 +4774,9 @@ is a full array or component ref. @item @var{stat} @tab intent(out) When non-@code{NULL} give the result of the operation, i.e., zero on success and non-zero on error. When @code{NULL} and an error occurs, then an error message is printed and the program is terminated. +@item @var{dst_type} @tab intent(in) Give the type of the destination. When +the destination is not an array, than the precise type, e.g. of a component in +a derived type, is not known, but provided here. @end multitable @item @emph{NOTES} @@ -4808,7 +4811,7 @@ identified by the @var{image_index}. @item @emph{Syntax}: @code{void _gfortran_caf_get_by_ref (caf_token_t token, int image_index, caf_reference_t *refs, gfc_descriptor_t *dst, int dst_kind, int src_kind, -bool may_require_tmp, bool dst_reallocatable, int *stat)} +bool may_require_tmp, bool dst_reallocatable, int *stat, int src_type)} @item @emph{Arguments}: @multitable @columnfractions .15 .70 @@ -4833,6 +4836,9 @@ array or a component is referenced. @item @var{stat} @tab intent(out) When non-@code{NULL} give the result of the operation, i.e., zero on success and non-zero on error. When @code{NULL} and an error occurs, then an error message is printed and the program is terminated. +@item @var{src_type} @tab intent(in) Give the type of the source. When the +source is not an array, than the precise type, e.g. of a component in a +derived type, is not known, but provided here. @end multitable @item @emph{NOTES} @@ -4868,7 +4874,8 @@ identified by the @var{src_image_index} to a remote image identified by the @code{void _gfortran_caf_sendget_by_ref (caf_token_t dst_token, int dst_image_index, caf_reference_t *dst_refs, caf_token_t src_token, int src_image_index, caf_reference_t *src_refs, -int dst_kind, int src_kind, bool may_require_tmp, int *dst_stat, int *src_stat)} +int dst_kind, int src_kind, bool may_require_tmp, int *dst_stat, +int *src_stat, int dst_type, int src_type)} @item @emph{Arguments}: @multitable @columnfractions .15 .70 @@ -4899,6 +4906,12 @@ program is terminated. the get-operation, i.e., zero on success and non-zero on error. When @code{NULL} and an error occurs, then an error message is printed and the program is terminated. +@item @var{dst_type} @tab intent(in) Give the type of the destination. When +the destination is not an array, than the precise type, e.g. of a component in +a derived type, is not known, but provided here. +@item @var{src_type} @tab intent(in) Give the type of the source. When the +source is not an array, than the precise type, e.g. of a component in a +derived type, is not known, but provided here. @end multitable @item @emph{NOTES} diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index 4fc07b61c68..51de933e82d 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -3662,24 +3662,25 @@ gfc_build_builtin_function_decls (void) integer_type_node, boolean_type_node, integer_type_node); gfor_fndecl_caf_get_by_ref = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("caf_get_by_ref")), ".RWRRRRRW", void_type_node, - 9, pvoid_type_node, integer_type_node, pvoid_type_node, pvoid_type_node, - integer_type_node, integer_type_node, boolean_type_node, - boolean_type_node, pint_type); + get_identifier (PREFIX("caf_get_by_ref")), ".RWRRRRRWR", void_type_node, + 10, pvoid_type_node, integer_type_node, pvoid_type_node, + pvoid_type_node, integer_type_node, integer_type_node, + boolean_type_node, boolean_type_node, pint_type, integer_type_node); gfor_fndecl_caf_send_by_ref = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("caf_send_by_ref")), ".RRRRRRRW", void_type_node, - 9, pvoid_type_node, integer_type_node, pvoid_type_node, pvoid_type_node, - integer_type_node, integer_type_node, boolean_type_node, - boolean_type_node, pint_type); + get_identifier (PREFIX("caf_send_by_ref")), ".RRRRRRRWR", + void_type_node, 10, pvoid_type_node, integer_type_node, pvoid_type_node, + pvoid_type_node, integer_type_node, integer_type_node, + boolean_type_node, boolean_type_node, pint_type, integer_type_node); gfor_fndecl_caf_sendget_by_ref = gfc_build_library_function_decl_with_spec ( - get_identifier (PREFIX("caf_sendget_by_ref")), ".RR.RRRRRWW", - void_type_node, 11, pvoid_type_node, integer_type_node, + get_identifier (PREFIX("caf_sendget_by_ref")), ".RR.RRRRRWWRR", + void_type_node, 13, pvoid_type_node, integer_type_node, pvoid_type_node, pvoid_type_node, integer_type_node, pvoid_type_node, integer_type_node, integer_type_node, - boolean_type_node, pint_type, pint_type); + boolean_type_node, pint_type, pint_type, integer_type_node, + integer_type_node); gfor_fndecl_caf_sync_all = gfc_build_library_function_decl_with_spec ( get_identifier (PREFIX("caf_sync_all")), ".WW", void_type_node, diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index 337227d3c08..dd4921681fc 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -1709,12 +1709,13 @@ gfc_conv_intrinsic_caf_get (gfc_se *se, gfc_expr *expr, tree lhs, tree lhs_kind, gfc_add_expr_to_block (&se->pre, tmp); tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_get_by_ref, - 9, token, image_index, dst_var, + 10, token, image_index, dst_var, caf_reference, lhs_kind, kind, may_require_tmp, may_realloc ? boolean_true_node : boolean_false_node, - stat); + stat, build_int_cst (integer_type_node, + array_expr->ts.type)); gfc_add_expr_to_block (&se->pre, tmp); @@ -2100,9 +2101,11 @@ conv_caf_send (gfc_code *code) { : boolean_false_node; tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_send_by_ref, - 9, token, image_index, rhs_se.expr, + 10, token, image_index, rhs_se.expr, reference, lhs_kind, rhs_kind, - may_require_tmp, dst_realloc, src_stat); + may_require_tmp, dst_realloc, src_stat, + build_int_cst (integer_type_node, + lhs_expr->ts.type)); } else tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_send, 11, @@ -2147,11 +2150,15 @@ conv_caf_send (gfc_code *code) { lhs_reference = conv_expr_ref_to_caf_ref (&block, lhs_expr); rhs_reference = conv_expr_ref_to_caf_ref (&block, rhs_expr); tmp = build_call_expr_loc (input_location, - gfor_fndecl_caf_sendget_by_ref, 11, + gfor_fndecl_caf_sendget_by_ref, 13, token, image_index, lhs_reference, rhs_token, rhs_image_index, rhs_reference, lhs_kind, rhs_kind, may_require_tmp, - dst_stat, src_stat); + dst_stat, src_stat, + build_int_cst (integer_type_node, + lhs_expr->ts.type), + build_int_cst (integer_type_node, + rhs_expr->ts.type)); } else { diff --git a/gcc/testsuite/gfortran.dg/coarray_alloc_comp_6.f08 b/gcc/testsuite/gfortran.dg/coarray_alloc_comp_6.f08 new file mode 100644 index 00000000000..a37554ffc1b --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray_alloc_comp_6.f08 @@ -0,0 +1,55 @@ +! { dg-do run } +! { dg-options "-fcoarray=lib -lcaf_single" } +! { dg-additional-options "-latomic" { target libatomic_available } } + +! Check that type conversion during caf_get_by_ref is done for components. + +program main + + implicit none + + type :: mytype + integer :: i + integer :: i4 + integer(kind=1) :: i1 + real :: r8 + real(kind=4) :: r4 + integer :: arr_i4(4) + integer(kind=1) :: arr_i1(4) + real :: arr_r8(4) + real(kind=4) :: arr_r4(4) + end type + + type T + type(mytype), allocatable :: obj + end type T + + type(T), save :: bar[*] + integer :: i4, arr_i4(4) + integer(kind=1) :: i1, arr_i1(4) + real :: r8, arr_r8(4) + real(kind=4) :: r4, arr_r4(4) + + bar%obj = mytype(42, 4, INT(1, 1), 8.0, REAL(4.0, 4), (/ 1,2,3,4 /), & + & INT((/ 5,6,7,8 /), 1), (/ 1.2,3.4,5.6,7.8 /), REAL( & + & (/ 8.7,6.5,4.3,2.1 /), 4)) + + i1 = bar[1]%obj%r4 + if (i1 /= 4) stop 1 + i4 = bar[1]%obj%r8 + if (i4 /= 8) stop 2 + r4 = bar[1]%obj%i1 + if (abs(r4 - 1.0) > 1E-4) stop 3 + r8 = bar[1]%obj%i4 + if (abs(r8 - 4.0) > 1E-6) stop 4 + + arr_i1 = bar[1]%obj%arr_r4 + if (any(arr_i1 /= INT((/ 8,6,4,2 /), 1))) stop 5 + arr_i4 = bar[1]%obj%arr_r8 + if (any(arr_i4 /= (/ 1,3,5,7 /))) stop 6 + arr_r4 = bar[1]%obj%arr_i1 + if (any(abs(arr_r4 - REAL((/ 5,6,7,8 /), 4)) > 1E-4)) stop 7 + arr_r8 = bar[1]%obj%arr_i4 + if (any(abs(arr_r8 - (/ 1,2,3,4 /)) > 1E-6)) stop 8 +end program + diff --git a/gcc/testsuite/gfortran.dg/coarray_alloc_comp_7.f08 b/gcc/testsuite/gfortran.dg/coarray_alloc_comp_7.f08 new file mode 100644 index 00000000000..93925828da1 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray_alloc_comp_7.f08 @@ -0,0 +1,62 @@ +! { dg-do run } +! { dg-options "-fcoarray=lib -lcaf_single" } +! { dg-additional-options "-latomic" { target libatomic_available } } + +! Check that type conversion during caf_send_by_ref is done for components. + +program main + + implicit none + + type :: mytype + integer :: i + integer :: i4 + integer(kind=1) :: i1 + real :: r8 + real(kind=4) :: r4 + integer :: arr_i4(4) + integer(kind=1) :: arr_i1(4) + real :: arr_r8(4) + real(kind=4) :: arr_r4(4) + end type + + type T + type(mytype), allocatable :: obj + end type T + + type(T), save :: bar[*] + integer :: i4, arr_i4(4) + integer(kind=1) :: i1, arr_i1(4) + real :: r8, arr_r8(4) + real(kind=4) :: r4, arr_r4(4) + + allocate(bar%obj) + i1 = INT(1, 1) + i4 = 4 + r4 = REAL(4.0, 4) + r8 = 8.0 + arr_i1 = INT((/ 5,6,7,8 /), 1) + arr_i4 = (/ 1,2,3,4 /) + arr_r8 = (/ 1.2,3.4,5.6,7.8 /) + arr_r4 = REAL((/ 8.7,6.5,4.3,2.1 /), 4) + + bar[1]%obj%r4 = i1 + if (abs(bar%obj%r4 - 1.0) > 1E-4) stop 1 + bar[1]%obj%r8 = i4 + if (abs(bar%obj%r8 - 4.0) > 1E-6) stop 2 + bar[1]%obj%i1 = r4 + if (bar%obj%i1 /= 4) stop 3 + bar[1]%obj%i4 = r8 + if (bar%obj%i4 /= 8) stop 4 + + bar[1]%obj%arr_r4 = arr_i1 + print *, bar%obj%arr_r4 + if (any(abs(bar%obj%arr_r4 - REAL((/ 5,6,7,8 /), 4)) > 1E-4)) stop 5 + bar[1]%obj%arr_r8 = arr_i4 + if (any(abs(bar%obj%arr_r8 - (/ 1,2,3,4 /)) > 1E-6)) stop 6 + bar[1]%obj%arr_i1 = arr_r4 + if (any(bar%obj%arr_i1 /= INT((/ 8,6,4,2 /), 1))) stop 7 + bar[1]%obj%arr_i4 = arr_r8 + if (any(bar%obj%arr_i4 /= (/ 1,3,5,7 /))) stop 8 +end program + diff --git a/gcc/testsuite/gfortran.dg/coarray_alloc_comp_8.f08 b/gcc/testsuite/gfortran.dg/coarray_alloc_comp_8.f08 new file mode 100644 index 00000000000..679bec32902 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray_alloc_comp_8.f08 @@ -0,0 +1,59 @@ +! { dg-do run } +! { dg-options "-fcoarray=lib -lcaf_single" } +! { dg-additional-options "-latomic" { target libatomic_available } } + +! Check that type conversion during caf_sendget_by_ref is done for components. + +program main + + implicit none + + type :: mytype + integer :: i + integer :: i4 + integer(kind=1) :: i1 + real :: r8 + real(kind=4) :: r4 + integer :: arr_i4(4) + integer(kind=1) :: arr_i1(4) + real :: arr_r8(4) + real(kind=4) :: arr_r4(4) + end type + + type T + type(mytype), allocatable :: obj + end type T + + type(T), save :: bar[*] + integer :: i4, arr_i4(4) + integer(kind=1) :: i1, arr_i1(4) + real :: r8, arr_r8(4) + real(kind=4) :: r4, arr_r4(4) + + bar%obj = mytype(42, 4, INT(1, 1), 8.0, REAL(4.0, 4), (/ 1,2,3,4 /), & + & INT((/ 5,6,7,8 /), 1), (/ 1.2,3.4,5.6,7.8 /), REAL( & + & (/ 8.7,6.5,4.3,2.1 /), 4)) + + bar[1]%obj%i1 = bar[1]%obj%r4 + if (bar%obj%i1 /= 4) stop 1 + bar[1]%obj%i4 = bar[1]%obj%r8 + if (bar%obj%i4 /= 8) stop 2 + bar[1]%obj%arr_i1 = bar[1]%obj%arr_r4 + if (any(bar%obj%arr_i1 /= (/ 8,6,4,2 /))) stop 3 + bar[1]%obj%arr_i4 = bar[1]%obj%arr_r8 + if (any(bar%obj%arr_i4 /= (/ 1,3,5,7 /))) stop 4 + + bar%obj%i1 = INT(1, 1) + bar%obj%i4 = 4 + bar%obj%arr_i1 = INT((/ 5,6,7,8 /), 1) + bar%obj%arr_i4 = (/ 1,2,3,4 /) + bar[1]%obj%r4 = bar[1]%obj%i1 + if (abs(bar%obj%r4 - 1.0) > 1E-4) stop 5 + bar[1]%obj%r8 = bar[1]%obj%i4 + if (abs(bar%obj%r8 - 4.0) > 1E-6) stop 6 + bar[1]%obj%arr_r4 = bar[1]%obj%arr_i1 + if (any(abs(bar%obj%arr_r4 - REAL((/ 5,6,7,8 /), 4)) > 1E-4)) stop 7 + bar[1]%obj%arr_r8 = bar[1]%obj%arr_i4 + if (any(abs(bar%obj%arr_r8 - (/ 1,2,3,4 /)) > 1E-6)) stop 8 +end program + diff --git a/libgfortran/caf/libcaf.h b/libgfortran/caf/libcaf.h index 12c73de8479..f3428a63fae 100644 --- a/libgfortran/caf/libcaf.h +++ b/libgfortran/caf/libcaf.h @@ -226,15 +226,17 @@ void _gfortran_caf_sendget (caf_token_t, size_t, int, gfc_descriptor_t *, void _gfortran_caf_get_by_ref (caf_token_t token, int image_idx, gfc_descriptor_t *dst, caf_reference_t *refs, int dst_kind, - int src_kind, bool may_require_tmp, bool dst_reallocatable, int *stat); + int src_kind, bool may_require_tmp, bool dst_reallocatable, int *stat, + int src_type); void _gfortran_caf_send_by_ref (caf_token_t token, int image_index, gfc_descriptor_t *src, caf_reference_t *refs, int dst_kind, - int src_kind, bool may_require_tmp, bool dst_reallocatable, int *stat); + int src_kind, bool may_require_tmp, bool dst_reallocatable, int *stat, + int dst_type); void _gfortran_caf_sendget_by_ref ( caf_token_t dst_token, int dst_image_index, caf_reference_t *dst_refs, caf_token_t src_token, int src_image_index, caf_reference_t *src_refs, int dst_kind, int src_kind, bool may_require_tmp, int *dst_stat, - int *src_stat); + int *src_stat, int dst_type, int src_type); void _gfortran_caf_atomic_define (caf_token_t, size_t, int, void *, int *, int, int); diff --git a/libgfortran/caf/single.c b/libgfortran/caf/single.c index bead09a386f..18906e99a94 100644 --- a/libgfortran/caf/single.c +++ b/libgfortran/caf/single.c @@ -1194,7 +1194,7 @@ get_for_ref (caf_reference_t *ref, size_t *i, size_t *dst_index, caf_single_token_t single_token, gfc_descriptor_t *dst, gfc_descriptor_t *src, void *ds, void *sr, int dst_kind, int src_kind, size_t dst_dim, size_t src_dim, - size_t num, int *stat) + size_t num, int *stat, int src_type) { ptrdiff_t extent_src = 1, array_offset_src = 0, stride_src; size_t next_dst_dim; @@ -1209,25 +1209,24 @@ get_for_ref (caf_reference_t *ref, size_t *i, size_t *dst_index, size_t dst_size = GFC_DESCRIPTOR_SIZE (dst); ptrdiff_t array_offset_dst = 0;; size_t dst_rank = GFC_DESCRIPTOR_RANK (dst); - int src_type = -1; switch (ref->type) { case CAF_REF_COMPONENT: /* Because the token is always registered after the component, its - offset is always greater zeor. */ + offset is always greater zero. */ if (ref->u.c.caf_token_offset > 0) + /* Note, that sr is dereffed here. */ copy_data (ds, *(void **)(sr + ref->u.c.offset), - GFC_DESCRIPTOR_TYPE (dst), GFC_DESCRIPTOR_TYPE (dst), + GFC_DESCRIPTOR_TYPE (dst), src_type, dst_kind, src_kind, dst_size, ref->item_size, 1, stat); else copy_data (ds, sr + ref->u.c.offset, - GFC_DESCRIPTOR_TYPE (dst), GFC_DESCRIPTOR_TYPE (src), + GFC_DESCRIPTOR_TYPE (dst), src_type, dst_kind, src_kind, dst_size, ref->item_size, 1, stat); ++(*i); return; case CAF_REF_STATIC_ARRAY: - src_type = ref->u.a.static_array_type; /* Intentionally fall through. */ case CAF_REF_ARRAY: if (ref->u.a.mode[src_dim] == CAF_ARR_REF_NONE) @@ -1235,8 +1234,7 @@ get_for_ref (caf_reference_t *ref, size_t *i, size_t *dst_index, for (size_t d = 0; d < dst_rank; ++d) array_offset_dst += dst_index[d]; copy_data (ds + array_offset_dst * dst_size, sr, - GFC_DESCRIPTOR_TYPE (dst), - src_type == -1 ? GFC_DESCRIPTOR_TYPE (src) : src_type, + GFC_DESCRIPTOR_TYPE (dst), src_type, dst_kind, src_kind, dst_size, ref->item_size, num, stat); *i += num; @@ -1252,23 +1250,39 @@ get_for_ref (caf_reference_t *ref, size_t *i, size_t *dst_index, { case CAF_REF_COMPONENT: if (ref->u.c.caf_token_offset > 0) - get_for_ref (ref->next, i, dst_index, - *(caf_single_token_t*)(sr + ref->u.c.caf_token_offset), dst, - (*(caf_single_token_t*)(sr + ref->u.c.caf_token_offset))->desc, - ds, sr + ref->u.c.offset, dst_kind, src_kind, dst_dim, 0, - 1, stat); + { + single_token = *(caf_single_token_t*)(sr + ref->u.c.caf_token_offset); + + if (ref->next && ref->next->type == CAF_REF_ARRAY) + src = single_token->desc; + else + src = NULL; + + if (ref->next && ref->next->type == CAF_REF_COMPONENT) + /* The currently ref'ed component was allocatabe (caf_token_offset + > 0) and the next ref is a component, too, then the new sr has to + be dereffed. (static arrays can not be allocatable or they + become an array with descriptor. */ + sr = *(void **)(sr + ref->u.c.offset); + else + sr += ref->u.c.offset; + + get_for_ref (ref->next, i, dst_index, single_token, dst, src, + ds, sr, dst_kind, src_kind, dst_dim, 0, + 1, stat, src_type); + } else get_for_ref (ref->next, i, dst_index, single_token, dst, (gfc_descriptor_t *)(sr + ref->u.c.offset), ds, sr + ref->u.c.offset, dst_kind, src_kind, dst_dim, 0, 1, - stat); + stat, src_type); return; case CAF_REF_ARRAY: if (ref->u.a.mode[src_dim] == CAF_ARR_REF_NONE) { get_for_ref (ref->next, i, dst_index, single_token, dst, src, ds, sr, dst_kind, src_kind, - dst_dim, 0, 1, stat); + dst_dim, 0, 1, stat, src_type); return; } /* Only when on the left most index switch the data pointer to @@ -1311,7 +1325,7 @@ get_for_ref (caf_reference_t *ref, size_t *i, size_t *dst_index, get_for_ref (ref, i, dst_index, single_token, dst, src, ds, sr + array_offset_src * ref->item_size, dst_kind, src_kind, dst_dim + 1, src_dim + 1, - 1, stat); + 1, stat, src_type); dst_index[dst_dim] += GFC_DIMENSION_STRIDE (dst->dim[dst_dim]); } @@ -1331,7 +1345,7 @@ get_for_ref (caf_reference_t *ref, size_t *i, size_t *dst_index, get_for_ref (ref, i, dst_index, single_token, dst, src, ds, sr + array_offset_src * ref->item_size, dst_kind, src_kind, dst_dim + 1, src_dim + 1, - 1, stat); + 1, stat, src_type); dst_index[dst_dim] += GFC_DIMENSION_STRIDE (dst->dim[dst_dim]); } @@ -1358,7 +1372,7 @@ get_for_ref (caf_reference_t *ref, size_t *i, size_t *dst_index, get_for_ref (ref, i, dst_index, single_token, dst, src, ds, sr + array_offset_src * ref->item_size, dst_kind, src_kind, next_dst_dim, src_dim + 1, - 1, stat); + 1, stat, src_type); dst_index[dst_dim] += GFC_DIMENSION_STRIDE (dst->dim[dst_dim]); array_offset_src += stride_src; @@ -1372,7 +1386,7 @@ get_for_ref (caf_reference_t *ref, size_t *i, size_t *dst_index, get_for_ref (ref, i, dst_index, single_token, dst, src, ds, sr + array_offset_src * ref->item_size, dst_kind, src_kind, dst_dim, src_dim + 1, 1, - stat); + stat, src_type); return; case CAF_ARR_REF_OPEN_END: COMPUTE_NUM_ITEMS (extent_src, @@ -1390,7 +1404,7 @@ get_for_ref (caf_reference_t *ref, size_t *i, size_t *dst_index, get_for_ref (ref, i, dst_index, single_token, dst, src, ds, sr + array_offset_src * ref->item_size, dst_kind, src_kind, dst_dim + 1, src_dim + 1, - 1, stat); + 1, stat, src_type); dst_index[dst_dim] += GFC_DIMENSION_STRIDE (dst->dim[dst_dim]); array_offset_src += stride_src; @@ -1410,7 +1424,7 @@ get_for_ref (caf_reference_t *ref, size_t *i, size_t *dst_index, get_for_ref (ref, i, dst_index, single_token, dst, src, ds, sr + array_offset_src * ref->item_size, dst_kind, src_kind, dst_dim + 1, src_dim + 1, - 1, stat); + 1, stat, src_type); dst_index[dst_dim] += GFC_DIMENSION_STRIDE (dst->dim[dst_dim]); array_offset_src += stride_src; @@ -1425,7 +1439,7 @@ get_for_ref (caf_reference_t *ref, size_t *i, size_t *dst_index, { get_for_ref (ref->next, i, dst_index, single_token, dst, NULL, ds, sr, dst_kind, src_kind, - dst_dim, 0, 1, stat); + dst_dim, 0, 1, stat, src_type); return; } switch (ref->u.a.mode[src_dim]) @@ -1460,7 +1474,7 @@ get_for_ref (caf_reference_t *ref, size_t *i, size_t *dst_index, get_for_ref (ref, i, dst_index, single_token, dst, NULL, ds, sr + array_offset_src * ref->item_size, dst_kind, src_kind, dst_dim + 1, src_dim + 1, - 1, stat); + 1, stat, src_type); dst_index[dst_dim] += GFC_DIMENSION_STRIDE (dst->dim[dst_dim]); } @@ -1474,7 +1488,7 @@ get_for_ref (caf_reference_t *ref, size_t *i, size_t *dst_index, get_for_ref (ref, i, dst_index, single_token, dst, NULL, ds, sr + array_offset_src * ref->item_size, dst_kind, src_kind, dst_dim + 1, src_dim + 1, - 1, stat); + 1, stat, src_type); dst_index[dst_dim] += GFC_DIMENSION_STRIDE (dst->dim[dst_dim]); } @@ -1491,7 +1505,7 @@ get_for_ref (caf_reference_t *ref, size_t *i, size_t *dst_index, get_for_ref (ref, i, dst_index, single_token, dst, NULL, ds, sr + array_offset_src * ref->item_size, dst_kind, src_kind, dst_dim + 1, src_dim + 1, - 1, stat); + 1, stat, src_type); dst_index[dst_dim] += GFC_DIMENSION_STRIDE (dst->dim[dst_dim]); array_offset_src += ref->u.a.dim[src_dim].s.stride; @@ -1502,7 +1516,7 @@ get_for_ref (caf_reference_t *ref, size_t *i, size_t *dst_index, get_for_ref (ref, i, dst_index, single_token, dst, NULL, ds, sr + array_offset_src * ref->item_size, dst_kind, src_kind, dst_dim, src_dim + 1, 1, - stat); + stat, src_type); return; /* The OPEN_* are mapped to a RANGE and therefore can not occur. */ case CAF_ARR_REF_OPEN_END: @@ -1523,7 +1537,8 @@ _gfortran_caf_get_by_ref (caf_token_t token, gfc_descriptor_t *dst, caf_reference_t *refs, int dst_kind, int src_kind, bool may_require_tmp __attribute__ ((unused)), - bool dst_reallocatable, int *stat) + bool dst_reallocatable, int *stat, + int src_type) { const char vecrefunknownkind[] = "libcaf_single::caf_get_by_ref(): " "unknown kind in vector-ref.\n"; @@ -1585,7 +1600,13 @@ _gfortran_caf_get_by_ref (caf_token_t token, else { memptr += riter->u.c.offset; - src = (gfc_descriptor_t *)memptr; + /* When the next ref is an array ref, assume there is an + array descriptor at memptr. Note, static arrays do not have + a descriptor. */ + if (riter->next && riter->next->type == CAF_REF_ARRAY) + src = (gfc_descriptor_t *)memptr; + else + src = NULL; } break; case CAF_REF_ARRAY: @@ -1677,6 +1698,13 @@ _gfortran_caf_get_by_ref (caf_token_t token, caf_internal_error (extentoutofrange, stat, NULL, 0); return; } + /* Special mode when called by __caf_sendget_by_ref (). */ + if (dst_rank == -1 && GFC_DESCRIPTOR_DATA (dst) == NULL) + { + dst_rank = dst_cur_dim + 1; + GFC_DESCRIPTOR_RANK (dst) = dst_rank; + GFC_DESCRIPTOR_SIZE (dst) = dst_kind; + } /* When dst is an array. */ if (dst_rank > 0) { @@ -1845,6 +1873,13 @@ _gfortran_caf_get_by_ref (caf_token_t token, caf_internal_error (extentoutofrange, stat, NULL, 0); return; } + /* Special mode when called by __caf_sendget_by_ref (). */ + if (dst_rank == -1 && GFC_DESCRIPTOR_DATA (dst) == NULL) + { + dst_rank = dst_cur_dim + 1; + GFC_DESCRIPTOR_RANK (dst) = dst_rank; + GFC_DESCRIPTOR_SIZE (dst) = dst_kind; + } /* When dst is an array. */ if (dst_rank > 0) { @@ -1946,6 +1981,13 @@ _gfortran_caf_get_by_ref (caf_token_t token, if (!array_extent_fixed) { assert (size == 1); + /* Special mode when called by __caf_sendget_by_ref (). */ + if (dst_rank == -1 && GFC_DESCRIPTOR_DATA (dst) == NULL) + { + dst_rank = dst_cur_dim + 1; + GFC_DESCRIPTOR_RANK (dst) = dst_rank; + GFC_DESCRIPTOR_SIZE (dst) = dst_kind; + } /* This can happen only, when the result is scalar. */ for (dst_cur_dim = 0; dst_cur_dim < dst_rank; ++dst_cur_dim) GFC_DIMENSION_SET (dst->dim[dst_cur_dim], 1, 1, 1); @@ -1967,7 +2009,7 @@ _gfortran_caf_get_by_ref (caf_token_t token, i = 0; get_for_ref (refs, &i, dst_index, single_token, dst, src, GFC_DESCRIPTOR_DATA (dst), memptr, dst_kind, src_kind, 0, 0, - 1, stat); + 1, stat, src_type); } @@ -1976,7 +2018,7 @@ send_by_ref (caf_reference_t *ref, size_t *i, size_t *src_index, caf_single_token_t single_token, gfc_descriptor_t *dst, gfc_descriptor_t *src, void *ds, void *sr, int dst_kind, int src_kind, size_t dst_dim, size_t src_dim, - size_t num, size_t size, int *stat) + size_t num, size_t size, int *stat, int dst_type) { const char vecrefunknownkind[] = "libcaf_single::caf_send_by_ref(): " "unknown kind in vector-ref.\n"; @@ -1992,7 +2034,6 @@ send_by_ref (caf_reference_t *ref, size_t *i, size_t *src_index, { size_t src_size = GFC_DESCRIPTOR_SIZE (src); ptrdiff_t array_offset_src = 0;; - int dst_type = -1; switch (ref->type) { @@ -2036,26 +2077,18 @@ send_by_ref (caf_reference_t *ref, size_t *i, size_t *src_index, dst_type = GFC_DESCRIPTOR_TYPE (dst); } else - { - /* When no destination descriptor is present, assume that - source and dest type are identical. */ - dst_type = GFC_DESCRIPTOR_TYPE (src); - ds = *(void **)(ds + ref->u.c.offset); - } + ds = *(void **)(ds + ref->u.c.offset); } copy_data (ds, sr, dst_type, GFC_DESCRIPTOR_TYPE (src), dst_kind, src_kind, ref->item_size, src_size, 1, stat); } else - copy_data (ds + ref->u.c.offset, sr, - dst != NULL ? GFC_DESCRIPTOR_TYPE (dst) - : GFC_DESCRIPTOR_TYPE (src), + copy_data (ds + ref->u.c.offset, sr, dst_type, GFC_DESCRIPTOR_TYPE (src), dst_kind, src_kind, ref->item_size, src_size, 1, stat); ++(*i); return; case CAF_REF_STATIC_ARRAY: - dst_type = ref->u.a.static_array_type; /* Intentionally fall through. */ case CAF_REF_ARRAY: if (ref->u.a.mode[dst_dim] == CAF_ARR_REF_NONE) @@ -2064,18 +2097,14 @@ send_by_ref (caf_reference_t *ref, size_t *i, size_t *src_index, { for (size_t d = 0; d < src_rank; ++d) array_offset_src += src_index[d]; - copy_data (ds, sr + array_offset_src * ref->item_size, - dst_type == -1 ? GFC_DESCRIPTOR_TYPE (dst) - : dst_type, - GFC_DESCRIPTOR_TYPE (src), dst_kind, src_kind, - ref->item_size, src_size, num, stat); + copy_data (ds, sr + array_offset_src * src_size, + dst_type, GFC_DESCRIPTOR_TYPE (src), dst_kind, + src_kind, ref->item_size, src_size, num, stat); } else - copy_data (ds, sr, - dst_type == -1 ? GFC_DESCRIPTOR_TYPE (dst) - : dst_type, - GFC_DESCRIPTOR_TYPE (src), dst_kind, src_kind, - ref->item_size, src_size, num, stat); + copy_data (ds, sr, dst_type, GFC_DESCRIPTOR_TYPE (src), + dst_kind, src_kind, ref->item_size, src_size, num, + stat); *i += num; return; } @@ -2123,22 +2152,30 @@ send_by_ref (caf_reference_t *ref, size_t *i, size_t *src_index, return; } single_token = *(caf_single_token_t*)(ds + ref->u.c.caf_token_offset); + /* When a component is allocatable (caf_token_offset != 0) and not an + array (ref->next->type == CAF_REF_COMPONENT), then ds has to be + dereffed. */ + if (ref->next && ref->next->type == CAF_REF_COMPONENT) + ds = *(void **)(ds + ref->u.c.offset); + else + ds += ref->u.c.offset; + send_by_ref (ref->next, i, src_index, single_token, - single_token->desc, src, ds + ref->u.c.offset, sr, - dst_kind, src_kind, 0, src_dim, 1, size, stat); + single_token->desc, src, ds, sr, + dst_kind, src_kind, 0, src_dim, 1, size, stat, dst_type); } else send_by_ref (ref->next, i, src_index, single_token, (gfc_descriptor_t *)(ds + ref->u.c.offset), src, ds + ref->u.c.offset, sr, dst_kind, src_kind, 0, src_dim, - 1, size, stat); + 1, size, stat, dst_type); return; case CAF_REF_ARRAY: if (ref->u.a.mode[dst_dim] == CAF_ARR_REF_NONE) { send_by_ref (ref->next, i, src_index, single_token, (gfc_descriptor_t *)ds, src, ds, sr, dst_kind, src_kind, - 0, src_dim, 1, size, stat); + 0, src_dim, 1, size, stat, dst_type); return; } /* Only when on the left most index switch the data pointer to @@ -2180,7 +2217,7 @@ send_by_ref (caf_reference_t *ref, size_t *i, size_t *src_index, send_by_ref (ref, i, src_index, single_token, dst, src, ds + array_offset_dst * ref->item_size, sr, dst_kind, src_kind, dst_dim + 1, src_dim + 1, - 1, size, stat); + 1, size, stat, dst_type); if (src_rank > 0) src_index[src_dim] += GFC_DIMENSION_STRIDE (src->dim[src_dim]); @@ -2201,7 +2238,7 @@ send_by_ref (caf_reference_t *ref, size_t *i, size_t *src_index, send_by_ref (ref, i, src_index, single_token, dst, src, ds + array_offset_dst * ref->item_size, sr, dst_kind, src_kind, dst_dim + 1, src_dim + 1, - 1, size, stat); + 1, size, stat, dst_type); if (src_rank > 0) src_index[src_dim] += GFC_DIMENSION_STRIDE (src->dim[src_dim]); @@ -2222,7 +2259,7 @@ send_by_ref (caf_reference_t *ref, size_t *i, size_t *src_index, send_by_ref (ref, i, src_index, single_token, dst, src, ds + array_offset_dst * ref->item_size, sr, dst_kind, src_kind, dst_dim + 1, src_dim + 1, - 1, size, stat); + 1, size, stat, dst_type); if (src_rank > 0) src_index[src_dim] += GFC_DIMENSION_STRIDE (src->dim[src_dim]); @@ -2236,7 +2273,7 @@ send_by_ref (caf_reference_t *ref, size_t *i, size_t *src_index, send_by_ref (ref, i, src_index, single_token, dst, src, ds + array_offset_dst * ref->item_size, sr, dst_kind, src_kind, dst_dim + 1, src_dim, 1, - size, stat); + size, stat, dst_type); return; case CAF_ARR_REF_OPEN_END: COMPUTE_NUM_ITEMS (extent_dst, @@ -2253,7 +2290,7 @@ send_by_ref (caf_reference_t *ref, size_t *i, size_t *src_index, send_by_ref (ref, i, src_index, single_token, dst, src, ds + array_offset_dst * ref->item_size, sr, dst_kind, src_kind, dst_dim + 1, src_dim + 1, - 1, size, stat); + 1, size, stat, dst_type); if (src_rank > 0) src_index[src_dim] += GFC_DIMENSION_STRIDE (src->dim[src_dim]); @@ -2274,7 +2311,7 @@ send_by_ref (caf_reference_t *ref, size_t *i, size_t *src_index, send_by_ref (ref, i, src_index, single_token, dst, src, ds + array_offset_dst * ref->item_size, sr, dst_kind, src_kind, dst_dim + 1, src_dim + 1, - 1, size, stat); + 1, size, stat, dst_type); if (src_rank > 0) src_index[src_dim] += GFC_DIMENSION_STRIDE (src->dim[src_dim]); @@ -2290,7 +2327,7 @@ send_by_ref (caf_reference_t *ref, size_t *i, size_t *src_index, { send_by_ref (ref->next, i, src_index, single_token, NULL, src, ds, sr, dst_kind, src_kind, - 0, src_dim, 1, size, stat); + 0, src_dim, 1, size, stat, dst_type); return; } switch (ref->u.a.mode[dst_dim]) @@ -2325,7 +2362,7 @@ send_by_ref (caf_reference_t *ref, size_t *i, size_t *src_index, send_by_ref (ref, i, src_index, single_token, NULL, src, ds + array_offset_dst * ref->item_size, sr, dst_kind, src_kind, dst_dim + 1, src_dim + 1, - 1, size, stat); + 1, size, stat, dst_type); src_index[src_dim] += GFC_DIMENSION_STRIDE (src->dim[src_dim]); } @@ -2339,7 +2376,7 @@ send_by_ref (caf_reference_t *ref, size_t *i, size_t *src_index, send_by_ref (ref, i, src_index, single_token, NULL, src, ds + array_offset_dst * ref->item_size, sr, dst_kind, src_kind, dst_dim + 1, src_dim + 1, - 1, size, stat); + 1, size, stat, dst_type); if (src_rank > 0) src_index[src_dim] += GFC_DIMENSION_STRIDE (src->dim[src_dim]); @@ -2357,7 +2394,7 @@ send_by_ref (caf_reference_t *ref, size_t *i, size_t *src_index, send_by_ref (ref, i, src_index, single_token, NULL, src, ds + array_offset_dst * ref->item_size, sr, dst_kind, src_kind, dst_dim + 1, src_dim + 1, - 1, size, stat); + 1, size, stat, dst_type); if (src_rank > 0) src_index[src_dim] += GFC_DIMENSION_STRIDE (src->dim[src_dim]); @@ -2369,7 +2406,7 @@ send_by_ref (caf_reference_t *ref, size_t *i, size_t *src_index, send_by_ref (ref, i, src_index, single_token, NULL, src, ds + array_offset_dst * ref->item_size, sr, dst_kind, src_kind, dst_dim + 1, src_dim, 1, - size, stat); + size, stat, dst_type); return; /* The OPEN_* are mapped to a RANGE and therefore can not occur. */ case CAF_ARR_REF_OPEN_END: @@ -2390,7 +2427,7 @@ _gfortran_caf_send_by_ref (caf_token_t token, gfc_descriptor_t *src, caf_reference_t *refs, int dst_kind, int src_kind, bool may_require_tmp __attribute__ ((unused)), - bool dst_reallocatable, int *stat) + bool dst_reallocatable, int *stat, int dst_type) { const char vecrefunknownkind[] = "libcaf_single::caf_get_by_ref(): " "unknown kind in vector-ref.\n"; @@ -2748,7 +2785,7 @@ _gfortran_caf_send_by_ref (caf_token_t token, i = 0; send_by_ref (refs, &i, dst_index, single_token, dst, src, memptr, GFC_DESCRIPTOR_DATA (src), dst_kind, src_kind, 0, 0, - 1, size, stat); + 1, size, stat, dst_type); assert (i == size); } @@ -2759,20 +2796,23 @@ _gfortran_caf_sendget_by_ref (caf_token_t dst_token, int dst_image_index, int src_image_index, caf_reference_t *src_refs, int dst_kind, int src_kind, bool may_require_tmp, int *dst_stat, - int *src_stat) + int *src_stat, int dst_type, int src_type) { - gfc_array_void temp; + GFC_FULL_ARRAY_DESCRIPTOR (GFC_MAX_DIMENSIONS, void) temp; + GFC_DESCRIPTOR_DATA (&temp) = NULL; + GFC_DESCRIPTOR_RANK (&temp) = -1; + GFC_DESCRIPTOR_TYPE (&temp) = dst_type; _gfortran_caf_get_by_ref (src_token, src_image_index, &temp, src_refs, dst_kind, src_kind, may_require_tmp, true, - src_stat); + src_stat, src_type); if (src_stat && *src_stat != 0) return; _gfortran_caf_send_by_ref (dst_token, dst_image_index, &temp, dst_refs, - dst_kind, src_kind, may_require_tmp, true, - dst_stat); + dst_kind, dst_kind, may_require_tmp, true, + dst_stat, dst_type); if (GFC_DESCRIPTOR_DATA (&temp)) free (GFC_DESCRIPTOR_DATA (&temp)); }