From 7ca773e83290494fd13329947e9b5100f8f12a57 Mon Sep 17 00:00:00 2001
From: Andre Vehreschild <vehre@gcc.gnu.org>
Date: Fri, 7 Feb 2025 12:09:53 +0100
Subject: [PATCH 7/7] Fortran: Remove deprecated coarray routines [PR107635]
gcc/fortran/ChangeLog:
PR fortran/107635
* gfortran.texi: Remove deprecated functions from documentation.
* trans-decl.cc (gfc_build_builtin_function_decls): Remove
decprecated function decls.
* trans-intrinsic.cc (gfc_conv_intrinsic_exponent): Remove
deprecated/no longer needed routines.
* trans.h: Remove unused decls.
libgfortran/ChangeLog:
* caf/libcaf.h (_gfortran_caf_get): Removed because deprecated.
(_gfortran_caf_send): Same.
(_gfortran_caf_sendget): Same.
(_gfortran_caf_send_by_ref): Same.
* caf/single.c (assign_char4_from_char1): Same.
(assign_char1_from_char4): Same.
(convert_type): Same.
(defined): Same.
(_gfortran_caf_get): Same.
(_gfortran_caf_send): Same.
(_gfortran_caf_sendget): Same.
(copy_data): Same.
(get_for_ref): Same.
(_gfortran_caf_get_by_ref): Same.
(send_by_ref): Same.
(_gfortran_caf_send_by_ref): Same.
(_gfortran_caf_sendget_by_ref): Same.
---
gcc/fortran/gfortran.texi | 335 -----
gcc/fortran/trans-decl.cc | 49 -
gcc/fortran/trans-intrinsic.cc | 1100 ---------------
gcc/fortran/trans.h | 10 -
libgfortran/caf/libcaf.h | 112 --
libgfortran/caf/single.c | 2387 --------------------------------
6 files changed, 3993 deletions(-)
@@ -4204,12 +4204,6 @@ future implementation of teams. It is about to change without further notice.
* _gfortran_caf_register_accessor:: Register an accessor for remote access
* _gfortran_caf_register_accessors_finish:: Finish registering accessor functions
* _gfortran_caf_get_remote_function_index:: Get the index of an accessor
-* _gfortran_caf_is_present:: Query whether an allocatable or pointer component in a derived type coarray is allocated
-* _gfortran_caf_send:: Sending data from a local image to a remote image
-* _gfortran_caf_get:: Getting data from a remote image
-* _gfortran_caf_sendget:: Sending data between remote images
-* _gfortran_caf_send_by_ref:: Sending data from a local image to a remote image using enhanced references
-* _gfortran_caf_get_by_ref:: Getting data from a remote image using enhanced references
* _gfortran_caf_get_from_remote:: Getting data from a remote image using a remote side accessor
* _gfortran_caf_is_present_on_remote:: Check that a coarray or a part of it is allocated on the remote image
* _gfortran_caf_send_to_remote:: Send data to a remote image using a remote side accessor to store it
@@ -4648,335 +4642,6 @@ message, when the hash could not be found.
@end table
-
-@node _gfortran_caf_is_present
-@subsection @code{_gfortran_caf_is_present} --- Query whether an allocatable or pointer component in a derived type coarray is allocated
-@cindex Coarray, _gfortran_caf_is_present
-
-@table @asis
-@item @emph{Description}:
-Used to query the coarray library whether an allocatable component in a derived
-type coarray is allocated on a remote image.
-
-@item @emph{Syntax}:
-@code{void _gfortran_caf_is_present (caf_token_t token, int image_index,
-gfc_reference_t *ref)}
-
-@item @emph{Arguments}:
-@multitable @columnfractions .15 .70
-@item @var{token} @tab An opaque pointer identifying the coarray.
-@item @var{image_index} @tab The ID of the remote image; must be a positive
-number.
-@item @var{ref} @tab A chain of references to address the allocatable or
-pointer component in the derived type coarray. The object reference needs to be
-a scalar or a full array reference, respectively.
-@end multitable
-
-@end table
-
-@node _gfortran_caf_send
-@subsection @code{_gfortran_caf_send} --- Sending data from a local image to a remote image
-@cindex Coarray, _gfortran_caf_send
-
-@table @asis
-@item @emph{Description}:
-Called to send a scalar, an array section or a whole array from a local
-to a remote image identified by the image_index.
-
-@item @emph{Syntax}:
-@code{void _gfortran_caf_send (caf_token_t token, size_t offset,
-int image_index, gfc_descriptor_t *dest, caf_vector_t *dst_vector,
-gfc_descriptor_t *src, int dst_kind, int src_kind, bool may_require_tmp,
-int *stat)}
-
-@item @emph{Arguments}:
-@multitable @columnfractions .15 .70
-@item @var{token} @tab intent(in) An opaque pointer identifying the coarray.
-@item @var{offset} @tab intent(in) The number of bytes the actual data is
-shifted compared to the base address of the coarray.
-@item @var{image_index} @tab intent(in) The ID of the remote image; must be a
-positive number.
-@item @var{dest} @tab intent(in) Array descriptor for the remote image for the
-bounds and the size. The @code{base_addr} shall not be accessed.
-@item @var{dst_vector} @tab intent(in) If not NULL, it contains the vector
-subscript of the destination array; the values are relative to the dimension
-triplet of the dest argument.
-@item @var{src} @tab intent(in) Array descriptor of the local array to be
-transferred to the remote image
-@item @var{dst_kind} @tab intent(in) Kind of the destination argument
-@item @var{src_kind} @tab intent(in) Kind of the source argument
-@item @var{may_require_tmp} @tab intent(in) The variable is @code{false} when
-it is known at compile time that the @var{dest} and @var{src} either cannot
-overlap or overlap (fully or partially) such that walking @var{src} and
-@var{dest} in elementwise order (honoring the stride value) does not
-lead to wrong results. Otherwise, the value is @code{true}.
-@item @var{stat} @tab intent(out) when non-NULL give the result of the
-operation, i.e., zero on success and nonzero on error. When NULL and an error
-occurs, then an error message is printed and the program is terminated.
-@end multitable
-
-@item @emph{NOTES}
-It is permitted to have @var{image_index} equal the current image; the memory
-of the send-to and the send-from might (partially) overlap in that case. The
-implementation has to take care that it handles this case, e.g. using
-@code{memmove} which handles (partially) overlapping memory. If
-@var{may_require_tmp} is true, the library might additionally create a
-temporary variable, unless additional checks show that this is not required
-(e.g. because walking backward is possible or because both arrays are
-contiguous and @code{memmove} takes care of overlap issues).
-
-Note that the assignment of a scalar to an array is permitted. In addition,
-the library has to handle numeric type conversion, and padding
-and different character kinds for strings.
-@end table
-
-
-@node _gfortran_caf_get
-@subsection @code{_gfortran_caf_get} --- Getting data from a remote image
-@cindex Coarray, _gfortran_caf_get
-
-@table @asis
-@item @emph{Description}:
-Called to get an array section or a whole array from a remote,
-image identified by the image_index.
-
-@item @emph{Syntax}:
-@code{void _gfortran_caf_get (caf_token_t token, size_t offset,
-int image_index, gfc_descriptor_t *src, caf_vector_t *src_vector,
-gfc_descriptor_t *dest, int src_kind, int dst_kind, bool may_require_tmp,
-int *stat)}
-
-@item @emph{Arguments}:
-@multitable @columnfractions .15 .70
-@item @var{token} @tab intent(in) An opaque pointer identifying the coarray.
-@item @var{offset} @tab intent(in) The number of bytes the actual data is
-shifted compared to the base address of the coarray.
-@item @var{image_index} @tab intent(in) The ID of the remote image; must be a
-positive number.
-@item @var{dest} @tab intent(out) Array descriptor of the local array to store
-the data retrieved from the remote image
-@item @var{src} @tab intent(in) Array descriptor for the remote image for the
-bounds and the size. The @code{base_addr} shall not be accessed.
-@item @var{src_vector} @tab intent(in) If not NULL, it contains the vector
-subscript of the source array; the values are relative to the dimension
-triplet of the @var{src} argument.
-@item @var{dst_kind} @tab intent(in) Kind of the destination argument
-@item @var{src_kind} @tab intent(in) Kind of the source argument
-@item @var{may_require_tmp} @tab intent(in) The variable is @code{false} when
-it is known at compile time that the @var{dest} and @var{src} either cannot
-overlap or overlap (fully or partially) such that walking @var{src} and
-@var{dest} in elementwise order (honoring the stride value) does not
-lead to wrong results. Otherwise, the value is @code{true}.
-@item @var{stat} @tab intent(out) When non-NULL give the result of the
-operation, i.e., zero on success and nonzero on error. When NULL and an error
-occurs, then an error message is printed and the program is terminated.
-@end multitable
-
-@item @emph{NOTES}
-It is permitted to have @var{image_index} equal the current image; the memory of
-the send-to and the send-from might (partially) overlap in that case. The
-implementation has to take care that it handles this case, e.g. using
-@code{memmove} which handles (partially) overlapping memory. If
-@var{may_require_tmp} is true, the library might additionally create a
-temporary variable, unless additional checks show that this is not required
-(e.g. because walking backward is possible or because both arrays are
-contiguous and @code{memmove} takes care of overlap issues).
-
-Note that the library has to handle numeric-type conversion and for strings,
-padding and different character kinds.
-@end table
-
-
-@node _gfortran_caf_sendget
-@subsection @code{_gfortran_caf_sendget} --- Sending data between remote images
-@cindex Coarray, _gfortran_caf_sendget
-
-@table @asis
-@item @emph{Description}:
-Called to send a scalar, an array section or a whole array from a remote image
-identified by the @var{src_image_index} to a remote image identified by the
-@var{dst_image_index}.
-
-@item @emph{Syntax}:
-@code{void _gfortran_caf_sendget (caf_token_t dst_token, size_t dst_offset,
-int dst_image_index, gfc_descriptor_t *dest, caf_vector_t *dst_vector,
-caf_token_t src_token, size_t src_offset, int src_image_index,
-gfc_descriptor_t *src, caf_vector_t *src_vector, int dst_kind, int src_kind,
-bool may_require_tmp, int *stat)}
-
-@item @emph{Arguments}:
-@multitable @columnfractions .15 .70
-@item @var{dst_token} @tab intent(in) An opaque pointer identifying the
-destination coarray.
-@item @var{dst_offset} @tab intent(in) The number of bytes the actual data
-is shifted compared to the base address of the destination coarray.
-@item @var{dst_image_index} @tab intent(in) The ID of the destination remote
-image; must be a positive number.
-@item @var{dest} @tab intent(in) Array descriptor for the destination
-remote image for the bounds and the size. The @code{base_addr} shall not be
-accessed.
-@item @var{dst_vector} @tab intent(int) If not NULL, it contains the vector
-subscript of the destination array; the values are relative to the dimension
-triplet of the @var{dest} argument.
-@item @var{src_token} @tab intent(in) An opaque pointer identifying the source
-coarray.
-@item @var{src_offset} @tab intent(in) The number of bytes the actual data
-is shifted compared to the base address of the source coarray.
-@item @var{src_image_index} @tab intent(in) The ID of the source remote image;
-must be a positive number.
-@item @var{src} @tab intent(in) Array descriptor of the local array to be
-transferred to the remote image.
-@item @var{src_vector} @tab intent(in) Array descriptor of the local array to
-be transferred to the remote image
-@item @var{dst_kind} @tab intent(in) Kind of the destination argument
-@item @var{src_kind} @tab intent(in) Kind of the source argument
-@item @var{may_require_tmp} @tab intent(in) The variable is @code{false} when
-it is known at compile time that the @var{dest} and @var{src} either cannot
-overlap or overlap (fully or partially) such that walking @var{src} and
-@var{dest} in elementwise order (honoring the stride value) does not
-lead to wrong results. Otherwise, the value is @code{true}.
-@item @var{stat} @tab intent(out) when non-NULL give the result of the
-operation, i.e., zero on success and nonzero on error. When NULL and an error
-occurs, then an error message is printed and the program is terminated.
-@end multitable
-
-@item @emph{NOTES}
-It is permitted to have the same image index for both @var{src_image_index} and
-@var{dst_image_index}; the memory of the send-to and the send-from might
-(partially) overlap in that case. The implementation has to take care that it
-handles this case, e.g. using @code{memmove} which handles (partially)
-overlapping memory. If @var{may_require_tmp} is true, the library
-might additionally create a temporary variable, unless additional checks show
-that this is not required (e.g. because walking backward is possible or because
-both arrays are contiguous and @code{memmove} takes care of overlap issues).
-
-Note that the assignment of a scalar to an array is permitted. In addition,
-the library has to handle numeric-type conversion and for strings, padding and
-different character kinds.
-@end table
-
-@node _gfortran_caf_send_by_ref
-@subsection @code{_gfortran_caf_send_by_ref} --- Sending data from a local image to a remote image with enhanced referencing options
-@cindex Coarray, _gfortran_caf_send_by_ref
-
-@table @asis
-@item @emph{Description}:
-Called to send a scalar, an array section or a whole array from a local to a
-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, int dst_type)}
-
-@item @emph{Arguments}:
-@multitable @columnfractions .15 .70
-@item @var{token} @tab intent(in) An opaque pointer identifying the coarray.
-@item @var{image_index} @tab intent(in) The ID of the remote image; must be a
-positive number.
-@item @var{src} @tab intent(in) Array descriptor of the local array to be
-transferred to the remote image
-@item @var{refs} @tab intent(in) The references on the remote array to store
-the data given by src. Guaranteed to have at least one entry.
-@item @var{dst_kind} @tab intent(in) Kind of the destination argument
-@item @var{src_kind} @tab intent(in) Kind of the source argument
-@item @var{may_require_tmp} @tab intent(in) The variable is @code{false} when
-it is known at compile time that the @var{dest} and @var{src} either cannot
-overlap or overlap (fully or partially) such that walking @var{src} and
-@var{dest} in elementwise order (honoring the stride value) does not
-lead to wrong results. Otherwise, the value is @code{true}.
-@item @var{dst_reallocatable} @tab intent(in) Set when the destination is of
-allocatable or pointer type and the refs allow reallocation, i.e., the ref
-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 nonzero 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}
-It is permitted to have @var{image_index} equal the current image; the memory of
-the send-to and the send-from might (partially) overlap in that case. The
-implementation has to take care that it handles this case, e.g. using
-@code{memmove} which handles (partially) overlapping memory. If
-@var{may_require_tmp} is true, the library might additionally create a
-temporary variable, unless additional checks show that this is not required
-(e.g. because walking backward is possible or because both arrays are
-contiguous and @code{memmove} takes care of overlap issues).
-
-Note that the assignment of a scalar to an array is permitted. In addition,
-the library has to handle numeric-type conversion and for strings, padding
-and different character kinds.
-
-Because of the more complicated references possible some operations may be
-unsupported by certain libraries. The library is expected to issue a precise
-error message why the operation is not permitted.
-@end table
-
-
-@node _gfortran_caf_get_by_ref
-@subsection @code{_gfortran_caf_get_by_ref} --- Getting data from a remote image using enhanced references
-@cindex Coarray, _gfortran_caf_get_by_ref
-
-@table @asis
-@item @emph{Description}:
-Called to get a scalar, an array section or a whole array from a remote image
-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, int src_type)}
-
-@item @emph{Arguments}:
-@multitable @columnfractions .15 .70
-@item @var{token} @tab intent(in) An opaque pointer identifying the coarray.
-@item @var{image_index} @tab intent(in) The ID of the remote image; must be a
-positive number.
-@item @var{refs} @tab intent(in) The references to apply to the remote structure
-to get the data.
-@item @var{dst} @tab intent(in) Array descriptor of the local array to store
-the data transferred from the remote image. May be reallocated where needed
-and when @var{DST_REALLOCATABLE} allows it.
-@item @var{dst_kind} @tab intent(in) Kind of the destination argument
-@item @var{src_kind} @tab intent(in) Kind of the source argument
-@item @var{may_require_tmp} @tab intent(in) The variable is @code{false} when
-it is known at compile time that the @var{dest} and @var{src} either cannot
-overlap or overlap (fully or partially) such that walking @var{src} and
-@var{dest} in elementwise order (honoring the stride value) does not
-lead to wrong results. Otherwise, the value is @code{true}.
-@item @var{dst_reallocatable} @tab intent(in) Set when @var{DST} is of
-allocatable or pointer type and its refs allow reallocation, i.e., the full
-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 nonzero 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}
-It is permitted to have @code{image_index} equal the current image; the memory
-of the send-to and the send-from might (partially) overlap in that case. The
-implementation has to take care that it handles this case, e.g. using
-@code{memmove} which handles (partially) overlapping memory. If
-@var{may_require_tmp} is true, the library might additionally create a
-temporary variable, unless additional checks show that this is not required
-(e.g. because walking backward is possible or because both arrays are
-contiguous and @code{memmove} takes care of overlap issues).
-
-Note that the library has to handle numeric-type conversion and for strings,
-padding and different character kinds.
-
-Because of the more complicated references possible some operations may be
-unsupported by certain libraries. The library is expected to issue a precise
-error message why the operation is not permitted.
-@end table
-
-
@node _gfortran_caf_get_from_remote
@subsection @code{_gfortran_caf_get_from_remote} --- Getting data from a remote image using a remote side accessor
@cindex Coarray, _gfortran_caf_get_from_remote
@@ -135,22 +135,12 @@ tree gfor_fndecl_caf_this_image;
tree gfor_fndecl_caf_num_images;
tree gfor_fndecl_caf_register;
tree gfor_fndecl_caf_deregister;
-
-// Deprecate start
-tree gfor_fndecl_caf_get;
-tree gfor_fndecl_caf_send;
-tree gfor_fndecl_caf_sendget;
-tree gfor_fndecl_caf_send_by_ref;
-tree gfor_fndecl_caf_sendget_by_ref;
-// Deprecate end
-
tree gfor_fndecl_caf_register_accessor;
tree gfor_fndecl_caf_register_accessors_finish;
tree gfor_fndecl_caf_get_remote_function_index;
tree gfor_fndecl_caf_get_from_remote;
tree gfor_fndecl_caf_send_to_remote;
tree gfor_fndecl_caf_transfer_between_remotes;
-
tree gfor_fndecl_caf_sync_all;
tree gfor_fndecl_caf_sync_memory;
tree gfor_fndecl_caf_sync_images;
@@ -4075,45 +4065,6 @@ gfc_build_builtin_function_decls (void)
ppvoid_type_node, integer_type_node, pint_type, pchar_type_node,
size_type_node);
- // Deprecate start
- gfor_fndecl_caf_get = gfc_build_library_function_decl_with_spec (
- get_identifier (PREFIX("caf_get")), ". r . . r r w . . . w ",
- void_type_node, 10,
- pvoid_type_node, size_type_node, integer_type_node, pvoid_type_node,
- pvoid_type_node, pvoid_type_node, integer_type_node, integer_type_node,
- boolean_type_node, pint_type);
-
- gfor_fndecl_caf_send = gfc_build_library_function_decl_with_spec (
- get_identifier (PREFIX("caf_send")), ". r . . w r r . . . w ",
- void_type_node, 11,
- pvoid_type_node, size_type_node, integer_type_node, pvoid_type_node,
- pvoid_type_node, pvoid_type_node, integer_type_node, integer_type_node,
- boolean_type_node, pint_type, pvoid_type_node);
-
- gfor_fndecl_caf_sendget = gfc_build_library_function_decl_with_spec (
- get_identifier (PREFIX("caf_sendget")), ". r . . w r r . . r r . . . w ",
- void_type_node, 14, pvoid_type_node, size_type_node, integer_type_node,
- pvoid_type_node, pvoid_type_node, pvoid_type_node, size_type_node,
- integer_type_node, pvoid_type_node, pvoid_type_node, integer_type_node,
- integer_type_node, boolean_type_node, integer_type_node);
-
- gfor_fndecl_caf_send_by_ref = gfc_build_library_function_decl_with_spec (
- get_identifier (PREFIX("caf_send_by_ref")), ". r . r r . . . . w . ",
- 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")),
- ". r . r r . r . . . w w . . ",
- 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, integer_type_node,
- integer_type_node);
- // Deprecate end
-
gfor_fndecl_caf_register_accessor
= gfc_build_library_function_decl_with_spec (
get_identifier (PREFIX ("caf_register_accessor")), ". r r ",
@@ -1025,653 +1025,6 @@ gfc_conv_intrinsic_exponent (gfc_se *se, gfc_expr *expr)
}
-/* Fill in the following structure
- struct caf_vector_t {
- size_t nvec; // size of the vector
- union {
- struct {
- void *vector;
- int kind;
- } v;
- struct {
- ptrdiff_t lower_bound;
- ptrdiff_t upper_bound;
- ptrdiff_t stride;
- } triplet;
- } u;
- } */
-
-// static void
-// conv_caf_vector_subscript_elem (stmtblock_t *block, int i, tree desc,
-// tree lower, tree upper, tree stride,
-// tree vector, int kind, tree nvec)
-// {
-// tree field, type, tmp;
-
-// desc = gfc_build_array_ref (desc, gfc_rank_cst[i], NULL_TREE);
-// type = TREE_TYPE (desc);
-
-// field = gfc_advance_chain (TYPE_FIELDS (type), 0);
-// tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
-// desc, field, NULL_TREE);
-// gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (field), nvec));
-
-// /* Access union. */
-// field = gfc_advance_chain (TYPE_FIELDS (type), 1);
-// desc = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
-// desc, field, NULL_TREE);
-// type = TREE_TYPE (desc);
-
-// /* Access the inner struct. */
-// field = gfc_advance_chain (TYPE_FIELDS (type), vector != NULL_TREE ? 0 :
-// 1); desc = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE
-// (field),
-// desc, field, NULL_TREE);
-// type = TREE_TYPE (desc);
-
-// if (vector != NULL_TREE)
-// {
-// /* Set vector and kind. */
-// field = gfc_advance_chain (TYPE_FIELDS (type), 0);
-// tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE
-// (field),
-// desc, field, NULL_TREE);
-// gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (field), vector));
-// field = gfc_advance_chain (TYPE_FIELDS (type), 1);
-// tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE
-// (field),
-// desc, field, NULL_TREE);
-// gfc_add_modify (block, tmp, build_int_cst (integer_type_node, kind));
-// }
-// else
-// {
-// /* Set dim.lower/upper/stride. */
-// field = gfc_advance_chain (TYPE_FIELDS (type), 0);
-// tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE
-// (field),
-// desc, field, NULL_TREE);
-// gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (field), lower));
-
-// field = gfc_advance_chain (TYPE_FIELDS (type), 1);
-// tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE
-// (field),
-// desc, field, NULL_TREE);
-// gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (field), upper));
-
-// field = gfc_advance_chain (TYPE_FIELDS (type), 2);
-// tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE
-// (field),
-// desc, field, NULL_TREE);
-// gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (field), stride));
-// }
-// }
-
-// static tree
-// conv_caf_vector_subscript (stmtblock_t *block, tree desc, gfc_array_ref *ar)
-// {
-// gfc_se argse;
-// tree var, lower, upper = NULL_TREE, stride = NULL_TREE, vector, nvec;
-// tree lbound, ubound, tmp;
-// int i;
-
-// var = gfc_create_var (gfc_get_caf_vector_type (ar->dimen), "vector");
-
-// for (i = 0; i < ar->dimen; i++)
-// switch (ar->dimen_type[i])
-// {
-// case DIMEN_RANGE:
-// if (ar->end[i])
-// {
-// gfc_init_se (&argse, NULL);
-// gfc_conv_expr (&argse, ar->end[i]);
-// gfc_add_block_to_block (block, &argse.pre);
-// upper = gfc_evaluate_now (argse.expr, block);
-// }
-// else
-// upper = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[i]);
-// if (ar->stride[i])
-// {
-// gfc_init_se (&argse, NULL);
-// gfc_conv_expr (&argse, ar->stride[i]);
-// gfc_add_block_to_block (block, &argse.pre);
-// stride = gfc_evaluate_now (argse.expr, block);
-// }
-// else
-// stride = gfc_index_one_node;
-
-// /* Fall through. */
-// case DIMEN_ELEMENT:
-// if (ar->start[i])
-// {
-// gfc_init_se (&argse, NULL);
-// gfc_conv_expr (&argse, ar->start[i]);
-// gfc_add_block_to_block (block, &argse.pre);
-// lower = gfc_evaluate_now (argse.expr, block);
-// }
-// else
-// lower = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]);
-// if (ar->dimen_type[i] == DIMEN_ELEMENT)
-// {
-// upper = lower;
-// stride = gfc_index_one_node;
-// }
-// vector = NULL_TREE;
-// nvec = size_zero_node;
-// conv_caf_vector_subscript_elem (block, i, var, lower, upper, stride,
-// vector, 0, nvec);
-// break;
-
-// case DIMEN_VECTOR:
-// gfc_init_se (&argse, NULL);
-// argse.descriptor_only = 1;
-// gfc_conv_expr_descriptor (&argse, ar->start[i]);
-// gfc_add_block_to_block (block, &argse.pre);
-// vector = argse.expr;
-// lbound = gfc_conv_descriptor_lbound_get (vector, gfc_rank_cst[0]);
-// ubound = gfc_conv_descriptor_ubound_get (vector, gfc_rank_cst[0]);
-// nvec = gfc_conv_array_extent_dim (lbound, ubound, NULL);
-// tmp = gfc_conv_descriptor_stride_get (vector, gfc_rank_cst[0]);
-// nvec = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
-// TREE_TYPE (nvec), nvec, tmp);
-// lower = gfc_index_zero_node;
-// upper = gfc_index_zero_node;
-// stride = gfc_index_zero_node;
-// vector = gfc_conv_descriptor_data_get (vector);
-// conv_caf_vector_subscript_elem (block, i, var, lower, upper, stride,
-// vector, ar->start[i]->ts.kind, nvec);
-// break;
-// default:
-// gcc_unreachable();
-// }
-// return gfc_build_addr_expr (NULL_TREE, var);
-// }
-
-// static tree
-// compute_component_offset (tree field, tree type)
-// {
-// tree tmp;
-// if (DECL_FIELD_BIT_OFFSET (field) != NULL_TREE
-// && !integer_zerop (DECL_FIELD_BIT_OFFSET (field)))
-// {
-// tmp = fold_build2 (TRUNC_DIV_EXPR, type,
-// DECL_FIELD_BIT_OFFSET (field),
-// bitsize_unit_node);
-// return fold_build2 (PLUS_EXPR, type, DECL_FIELD_OFFSET (field), tmp);
-// }
-// else
-// return DECL_FIELD_OFFSET (field);
-// }
-
-// static tree
-// conv_expr_ref_to_caf_ref (stmtblock_t *block, gfc_expr *expr)
-// {
-// gfc_ref *ref = expr->ref, *last_comp_ref;
-// tree caf_ref = NULL_TREE, prev_caf_ref = NULL_TREE, reference_type, tmp,
-// tmp2,
-// field, last_type, inner_struct, mode, mode_rhs, dim_array, dim,
-// dim_type, start, end, stride, vector, nvec;
-// gfc_se se;
-// bool ref_static_array = false;
-// tree last_component_ref_tree = NULL_TREE;
-// int i, last_type_n;
-
-// if (expr->symtree)
-// {
-// last_component_ref_tree = expr->symtree->n.sym->backend_decl;
-// ref_static_array = !expr->symtree->n.sym->attr.allocatable
-// && !expr->symtree->n.sym->attr.pointer;
-// }
-
-// /* Prevent uninit-warning. */
-// reference_type = NULL_TREE;
-
-// /* Skip refs upto the first coarray-ref. */
-// last_comp_ref = NULL;
-// while (ref && (ref->type != REF_ARRAY || ref->u.ar.codimen == 0))
-// {
-// /* Remember the type of components skipped. */
-// if (ref->type == REF_COMPONENT)
-// last_comp_ref = ref;
-// ref = ref->next;
-// }
-// /* When a component was skipped, get the type information of the last
-// component ref, else get the type from the symbol. */
-// if (last_comp_ref)
-// {
-// last_type = gfc_typenode_for_spec (&last_comp_ref->u.c.component->ts);
-// last_type_n = last_comp_ref->u.c.component->ts.type;
-// }
-// else
-// {
-// last_type = gfc_typenode_for_spec (&expr->symtree->n.sym->ts);
-// last_type_n = expr->symtree->n.sym->ts.type;
-// }
-
-// while (ref)
-// {
-// if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0
-// && ref->u.ar.dimen == 0)
-// {
-// /* Skip pure coindexes. */
-// ref = ref->next;
-// continue;
-// }
-// tmp = gfc_create_var (gfc_get_caf_reference_type (), "caf_ref");
-// reference_type = TREE_TYPE (tmp);
-
-// if (caf_ref == NULL_TREE)
-// caf_ref = tmp;
-
-// /* Construct the chain of refs. */
-// if (prev_caf_ref != NULL_TREE)
-// {
-// field = gfc_advance_chain (TYPE_FIELDS (reference_type), 0);
-// tmp2 = fold_build3_loc (input_location, COMPONENT_REF,
-// TREE_TYPE (field), prev_caf_ref, field,
-// NULL_TREE);
-// gfc_add_modify (block, tmp2, gfc_build_addr_expr (TREE_TYPE (field),
-// tmp));
-// }
-// prev_caf_ref = tmp;
-
-// switch (ref->type)
-// {
-// case REF_COMPONENT:
-// last_type = gfc_typenode_for_spec (&ref->u.c.component->ts);
-// last_type_n = ref->u.c.component->ts.type;
-// /* Set the type of the ref. */
-// field = gfc_advance_chain (TYPE_FIELDS (reference_type), 1);
-// tmp = fold_build3_loc (input_location, COMPONENT_REF,
-// TREE_TYPE (field), prev_caf_ref, field,
-// NULL_TREE);
-// gfc_add_modify (block, tmp, build_int_cst (integer_type_node,
-// GFC_CAF_REF_COMPONENT));
-
-// /* Ref the c in union u. */
-// field = gfc_advance_chain (TYPE_FIELDS (reference_type), 3);
-// tmp = fold_build3_loc (input_location, COMPONENT_REF,
-// TREE_TYPE (field), prev_caf_ref, field,
-// NULL_TREE);
-// field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (field)), 0);
-// inner_struct = fold_build3_loc (input_location, COMPONENT_REF,
-// TREE_TYPE (field), tmp, field,
-// NULL_TREE);
-
-// /* Set the offset. */
-// field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct)), 0);
-// tmp = fold_build3_loc (input_location, COMPONENT_REF,
-// TREE_TYPE (field), inner_struct, field,
-// NULL_TREE);
-// /* Computing the offset is somewhat harder. The bit_offset has to be
-// taken into account. When the bit_offset in the field_decl is non-
-// null, divide it by the bitsize_unit and add it to the regular
-// offset. */
-// tmp2 = compute_component_offset (ref->u.c.component->backend_decl,
-// TREE_TYPE (tmp));
-// gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (tmp), tmp2));
-
-// /* Set caf_token_offset. */
-// field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct)), 1);
-// tmp = fold_build3_loc (input_location, COMPONENT_REF,
-// TREE_TYPE (field), inner_struct, field,
-// NULL_TREE);
-// if ((ref->u.c.component->attr.allocatable
-// || ref->u.c.component->attr.pointer)
-// && ref->u.c.component->attr.dimension)
-// {
-// tree arr_desc_token_offset;
-// /* Get the token field from the descriptor. */
-// arr_desc_token_offset = TREE_OPERAND (
-// gfc_conv_descriptor_token
-// (ref->u.c.component->backend_decl), 1); arr_desc_token_offset
-// = compute_component_offset (arr_desc_token_offset,
-// TREE_TYPE (tmp)); tmp2 = fold_build2_loc (input_location, PLUS_EXPR,
-// TREE_TYPE (tmp2), tmp2, arr_desc_token_offset);
-// }
-// else if (ref->u.c.component->caf_token)
-// tmp2 = compute_component_offset (gfc_comp_caf_token (
-// ref->u.c.component),
-// TREE_TYPE (tmp));
-// else
-// tmp2 = integer_zero_node;
-// gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (tmp), tmp2));
-
-// /* Remember whether this ref was to a non-allocatable/non-pointer
-// component so the next array ref can be tailored correctly. */
-// ref_static_array = !ref->u.c.component->attr.allocatable
-// && !ref->u.c.component->attr.pointer;
-// last_component_ref_tree = ref_static_array
-// ? ref->u.c.component->backend_decl : NULL_TREE;
-// break;
-// case REF_ARRAY:
-// if (ref_static_array && ref->u.ar.as->type == AS_DEFERRED)
-// ref_static_array = false;
-// /* Set the type of the ref. */
-// field = gfc_advance_chain (TYPE_FIELDS (reference_type), 1);
-// tmp = fold_build3_loc (input_location, COMPONENT_REF,
-// TREE_TYPE (field), prev_caf_ref, field,
-// NULL_TREE);
-// gfc_add_modify (block, tmp, build_int_cst (integer_type_node,
-// ref_static_array
-// ? GFC_CAF_REF_STATIC_ARRAY
-// : GFC_CAF_REF_ARRAY));
-
-// /* Ref the a in union u. */
-// field = gfc_advance_chain (TYPE_FIELDS (reference_type), 3);
-// tmp = fold_build3_loc (input_location, COMPONENT_REF,
-// TREE_TYPE (field), prev_caf_ref, field,
-// NULL_TREE);
-// field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (field)), 1);
-// inner_struct = fold_build3_loc (input_location, COMPONENT_REF,
-// TREE_TYPE (field), tmp, field,
-// NULL_TREE);
-
-// /* Set the static_array_type in a for static arrays. */
-// if (ref_static_array)
-// {
-// field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct)),
-// 1);
-// tmp = fold_build3_loc (input_location, COMPONENT_REF,
-// TREE_TYPE (field), inner_struct, field,
-// NULL_TREE);
-// gfc_add_modify (block, tmp, build_int_cst (TREE_TYPE (tmp),
-// last_type_n));
-// }
-// /* Ref the mode in the inner_struct. */
-// field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct)), 0);
-// mode = fold_build3_loc (input_location, COMPONENT_REF,
-// TREE_TYPE (field), inner_struct, field,
-// NULL_TREE);
-// /* Ref the dim in the inner_struct. */
-// field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct)), 2);
-// dim_array = fold_build3_loc (input_location, COMPONENT_REF,
-// TREE_TYPE (field), inner_struct, field,
-// NULL_TREE);
-// for (i = 0; i < ref->u.ar.dimen; ++i)
-// {
-// /* Ref dim i. */
-// dim = gfc_build_array_ref (dim_array, gfc_rank_cst[i], NULL_TREE);
-// dim_type = TREE_TYPE (dim);
-// mode_rhs = start = end = stride = NULL_TREE;
-// switch (ref->u.ar.dimen_type[i])
-// {
-// case DIMEN_RANGE:
-// if (ref->u.ar.end[i])
-// {
-// gfc_init_se (&se, NULL);
-// gfc_conv_expr (&se, ref->u.ar.end[i]);
-// gfc_add_block_to_block (block, &se.pre);
-// if (ref_static_array)
-// {
-// /* Make the index zero-based, when reffing a static
-// array. */
-// end = se.expr;
-// gfc_init_se (&se, NULL);
-// gfc_conv_expr (&se, ref->u.ar.as->lower[i]);
-// gfc_add_block_to_block (block, &se.pre);
-// se.expr = fold_build2 (MINUS_EXPR,
-// gfc_array_index_type,
-// end, fold_convert (
-// gfc_array_index_type,
-// se.expr));
-// }
-// end = gfc_evaluate_now (fold_convert (
-// gfc_array_index_type,
-// se.expr),
-// block);
-// }
-// else if (ref_static_array)
-// end = fold_build2 (MINUS_EXPR,
-// gfc_array_index_type,
-// gfc_conv_array_ubound (
-// last_component_ref_tree, i),
-// gfc_conv_array_lbound (
-// last_component_ref_tree, i));
-// else
-// {
-// end = NULL_TREE;
-// mode_rhs = build_int_cst (unsigned_char_type_node,
-// GFC_CAF_ARR_REF_OPEN_END);
-// }
-// if (ref->u.ar.stride[i])
-// {
-// gfc_init_se (&se, NULL);
-// gfc_conv_expr (&se, ref->u.ar.stride[i]);
-// gfc_add_block_to_block (block, &se.pre);
-// stride = gfc_evaluate_now (fold_convert (
-// gfc_array_index_type,
-// se.expr),
-// block);
-// if (ref_static_array)
-// {
-// /* Make the index zero-based, when reffing a static
-// array. */
-// stride = fold_build2 (MULT_EXPR,
-// gfc_array_index_type,
-// gfc_conv_array_stride (
-// last_component_ref_tree,
-// i),
-// stride);
-// gcc_assert (end != NULL_TREE);
-// /* Multiply with the product of array's stride and
-// the step of the ref to a virtual upper bound.
-// We cannot compute the actual upper bound here or
-// the caflib would compute the extend
-// incorrectly. */
-// end = fold_build2 (MULT_EXPR, gfc_array_index_type,
-// end, gfc_conv_array_stride (
-// last_component_ref_tree,
-// i));
-// end = gfc_evaluate_now (end, block);
-// stride = gfc_evaluate_now (stride, block);
-// }
-// }
-// else if (ref_static_array)
-// {
-// stride = gfc_conv_array_stride (last_component_ref_tree,
-// i);
-// end = fold_build2 (MULT_EXPR, gfc_array_index_type,
-// end, stride);
-// end = gfc_evaluate_now (end, block);
-// }
-// else
-// /* Always set a ref stride of one to make caflib's
-// handling easier. */
-// stride = gfc_index_one_node;
-
-// /* Fall through. */
-// case DIMEN_ELEMENT:
-// if (ref->u.ar.start[i])
-// {
-// gfc_init_se (&se, NULL);
-// gfc_conv_expr (&se, ref->u.ar.start[i]);
-// gfc_add_block_to_block (block, &se.pre);
-// if (ref_static_array)
-// {
-// /* Make the index zero-based, when reffing a static
-// array. */
-// start = fold_convert (gfc_array_index_type, se.expr);
-// gfc_init_se (&se, NULL);
-// gfc_conv_expr (&se, ref->u.ar.as->lower[i]);
-// gfc_add_block_to_block (block, &se.pre);
-// se.expr = fold_build2 (MINUS_EXPR,
-// gfc_array_index_type,
-// start, fold_convert (
-// gfc_array_index_type,
-// se.expr));
-// /* Multiply with the stride. */
-// se.expr = fold_build2 (MULT_EXPR,
-// gfc_array_index_type,
-// se.expr,
-// gfc_conv_array_stride (
-// last_component_ref_tree,
-// i));
-// }
-// start = gfc_evaluate_now (fold_convert (
-// gfc_array_index_type,
-// se.expr),
-// block);
-// if (mode_rhs == NULL_TREE)
-// mode_rhs = build_int_cst (unsigned_char_type_node,
-// ref->u.ar.dimen_type[i]
-// == DIMEN_ELEMENT
-// ? GFC_CAF_ARR_REF_SINGLE
-// : GFC_CAF_ARR_REF_RANGE);
-// }
-// else if (ref_static_array)
-// {
-// start = integer_zero_node;
-// mode_rhs = build_int_cst (unsigned_char_type_node,
-// ref->u.ar.start[i] == NULL
-// ? GFC_CAF_ARR_REF_FULL
-// : GFC_CAF_ARR_REF_RANGE);
-// }
-// else if (end == NULL_TREE)
-// mode_rhs = build_int_cst (unsigned_char_type_node,
-// GFC_CAF_ARR_REF_FULL);
-// else
-// mode_rhs = build_int_cst (unsigned_char_type_node,
-// GFC_CAF_ARR_REF_OPEN_START);
-
-// /* Ref the s in dim. */
-// field = gfc_advance_chain (TYPE_FIELDS (dim_type), 0);
-// tmp = fold_build3_loc (input_location, COMPONENT_REF,
-// TREE_TYPE (field), dim, field,
-// NULL_TREE);
-
-// /* Set start in s. */
-// if (start != NULL_TREE)
-// {
-// field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)),
-// 0);
-// tmp2 = fold_build3_loc (input_location, COMPONENT_REF,
-// TREE_TYPE (field), tmp, field,
-// NULL_TREE);
-// gfc_add_modify (block, tmp2,
-// fold_convert (TREE_TYPE (tmp2), start));
-// }
-
-// /* Set end in s. */
-// if (end != NULL_TREE)
-// {
-// field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)),
-// 1);
-// tmp2 = fold_build3_loc (input_location, COMPONENT_REF,
-// TREE_TYPE (field), tmp, field,
-// NULL_TREE);
-// gfc_add_modify (block, tmp2,
-// fold_convert (TREE_TYPE (tmp2), end));
-// }
-
-// /* Set end in s. */
-// if (stride != NULL_TREE)
-// {
-// field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)),
-// 2);
-// tmp2 = fold_build3_loc (input_location, COMPONENT_REF,
-// TREE_TYPE (field), tmp, field,
-// NULL_TREE);
-// gfc_add_modify (block, tmp2,
-// fold_convert (TREE_TYPE (tmp2), stride));
-// }
-// break;
-// case DIMEN_VECTOR:
-// /* TODO: In case of static array. */
-// gcc_assert (!ref_static_array);
-// mode_rhs = build_int_cst (unsigned_char_type_node,
-// GFC_CAF_ARR_REF_VECTOR);
-// gfc_init_se (&se, NULL);
-// se.descriptor_only = 1;
-// gfc_conv_expr_descriptor (&se, ref->u.ar.start[i]);
-// gfc_add_block_to_block (block, &se.pre);
-// vector = se.expr;
-// tmp = gfc_conv_descriptor_lbound_get (vector,
-// gfc_rank_cst[0]);
-// tmp2 = gfc_conv_descriptor_ubound_get (vector,
-// gfc_rank_cst[0]);
-// nvec = gfc_conv_array_extent_dim (tmp, tmp2, NULL);
-// tmp = gfc_conv_descriptor_stride_get (vector,
-// gfc_rank_cst[0]);
-// nvec = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
-// TREE_TYPE (nvec), nvec, tmp);
-// vector = gfc_conv_descriptor_data_get (vector);
-
-// /* Ref the v in dim. */
-// field = gfc_advance_chain (TYPE_FIELDS (dim_type), 1);
-// tmp = fold_build3_loc (input_location, COMPONENT_REF,
-// TREE_TYPE (field), dim, field,
-// NULL_TREE);
-
-// /* Set vector in v. */
-// field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)), 0);
-// tmp2 = fold_build3_loc (input_location, COMPONENT_REF,
-// TREE_TYPE (field), tmp, field,
-// NULL_TREE);
-// gfc_add_modify (block, tmp2, fold_convert (TREE_TYPE (tmp2),
-// vector));
-
-// /* Set nvec in v. */
-// field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)), 1);
-// tmp2 = fold_build3_loc (input_location, COMPONENT_REF,
-// TREE_TYPE (field), tmp, field,
-// NULL_TREE);
-// gfc_add_modify (block, tmp2, fold_convert (TREE_TYPE (tmp2),
-// nvec));
-
-// /* Set kind in v. */
-// field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)), 2);
-// tmp2 = fold_build3_loc (input_location, COMPONENT_REF,
-// TREE_TYPE (field), tmp, field,
-// NULL_TREE);
-// gfc_add_modify (block, tmp2, build_int_cst (integer_type_node,
-// ref->u.ar.start[i]->ts.kind));
-// break;
-// default:
-// gcc_unreachable ();
-// }
-// /* Set the mode for dim i. */
-// tmp = gfc_build_array_ref (mode, gfc_rank_cst[i], NULL_TREE);
-// gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (tmp),
-// mode_rhs));
-// }
-
-// /* Set the mode for dim i+1 to GFC_ARR_REF_NONE. */
-// if (i < GFC_MAX_DIMENSIONS)
-// {
-// tmp = gfc_build_array_ref (mode, gfc_rank_cst[i], NULL_TREE);
-// gfc_add_modify (block, tmp,
-// build_int_cst (unsigned_char_type_node,
-// GFC_CAF_ARR_REF_NONE));
-// }
-// break;
-// default:
-// gcc_unreachable ();
-// }
-
-// /* Set the size of the current type. */
-// field = gfc_advance_chain (TYPE_FIELDS (reference_type), 2);
-// tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE
-// (field),
-// prev_caf_ref, field, NULL_TREE);
-// gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (field),
-// TYPE_SIZE_UNIT (last_type)));
-
-// ref = ref->next;
-// }
-
-// if (prev_caf_ref != NULL_TREE)
-// {
-// field = gfc_advance_chain (TYPE_FIELDS (reference_type), 0);
-// tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE
-// (field),
-// prev_caf_ref, field, NULL_TREE);
-// gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (field),
-// null_pointer_node));
-// }
-// return caf_ref != NULL_TREE ? gfc_build_addr_expr (NULL_TREE, caf_ref)
-// : NULL_TREE;
-// }
-
static int caf_call_cnt = 0;
static tree
@@ -2202,15 +1555,6 @@ conv_caf_send_to_remote (gfc_code *code)
return gfc_finish_block (&block);
}
-// static bool
-// has_ref_after_cafref (gfc_expr *expr)
-// {
-// for (gfc_ref *ref = expr->ref; ref; ref = ref->next)
-// if (ref->type == REF_ARRAY && ref->u.ar.codimen)
-// return ref->next;
-// return false;
-// }
-
/* Send-get data to a remote coarray. */
static tree
@@ -2436,450 +1780,6 @@ conv_caf_sendget (gfc_code *code)
return gfc_finish_block (&block);
}
-// static tree
-// conv_caf_sendget (gfc_code *code)
-// {
-// gfc_expr *lhs_expr, *rhs_expr, *tmp_stat, *tmp_team;
-// gfc_se lhs_se, rhs_se;
-// stmtblock_t block;
-// tree caf_decl, token, offset, image_index, tmp, lhs_kind, rhs_kind;
-// tree may_require_tmp, src_stat, dst_stat, dst_team;
-// tree lhs_type = NULL_TREE;
-// tree vec = null_pointer_node, rhs_vec = null_pointer_node;
-// symbol_attribute lhs_caf_attr, rhs_caf_attr;
-// bool lhs_is_coindexed, rhs_is_coindexed;
-
-// gcc_assert (flag_coarray == GFC_FCOARRAY_LIB);
-
-// lhs_expr
-// = code->ext.actual->expr->expr_type == EXPR_FUNCTION
-// && code->ext.actual->expr->value.function.isym->id == GFC_ISYM_CAF_GET
-// ? code->ext.actual->expr->value.function.actual->expr
-// : code->ext.actual->expr;
-// rhs_expr = code->ext.actual->next->expr->expr_type == EXPR_FUNCTION
-// && code->ext.actual->next->expr->value.function.isym->id
-// == GFC_ISYM_CAF_GET
-// ? code->ext.actual->next->expr->value.function.actual->expr
-// : code->ext.actual->next->expr;
-// lhs_is_coindexed = gfc_is_coindexed (lhs_expr);
-// rhs_is_coindexed = gfc_is_coindexed (rhs_expr);
-// may_require_tmp = gfc_check_dependency (lhs_expr, rhs_expr, true) == 0
-// ? boolean_false_node : boolean_true_node;
-// gfc_init_block (&block);
-
-// lhs_caf_attr = gfc_caf_attr (lhs_expr);
-// rhs_caf_attr = gfc_caf_attr (rhs_expr);
-// src_stat = dst_stat = null_pointer_node;
-// dst_team = null_pointer_node;
-
-// /* LHS. */
-// gfc_init_se (&lhs_se, NULL);
-// if (lhs_expr->rank == 0)
-// {
-// if (lhs_expr->ts.type == BT_CHARACTER && lhs_expr->ts.deferred)
-// {
-// lhs_se.expr = gfc_get_tree_for_caf_expr (lhs_expr);
-// if (!POINTER_TYPE_P (TREE_TYPE (lhs_se.expr)))
-// lhs_se.expr = gfc_build_addr_expr (NULL_TREE, lhs_se.expr);
-// }
-// else
-// {
-// symbol_attribute attr;
-// gfc_clear_attr (&attr);
-// gfc_conv_expr (&lhs_se, lhs_expr);
-// lhs_type = TREE_TYPE (lhs_se.expr);
-// if (lhs_is_coindexed)
-// lhs_se.expr = gfc_conv_scalar_to_descriptor (&lhs_se, lhs_se.expr,
-// attr);
-// lhs_se.expr = gfc_build_addr_expr (NULL_TREE, lhs_se.expr);
-// }
-// }
-// else if ((lhs_caf_attr.alloc_comp || lhs_caf_attr.pointer_comp)
-// && lhs_caf_attr.codimension)
-// {
-// lhs_se.want_pointer = 1;
-// gfc_conv_expr_descriptor (&lhs_se, lhs_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 (
-// gfc_has_vector_subscript (lhs_expr)
-// ? gfc_find_array_ref (lhs_expr)->dimen
-// : lhs_expr->rank,
-// lhs_type));
-// }
-// else
-// {
-// bool has_vector = gfc_has_vector_subscript (lhs_expr);
-
-// if (lhs_is_coindexed || !has_vector)
-// {
-// /* If has_vector, pass descriptor for whole array and the
-// vector bounds separately. */
-// gfc_array_ref *ar, ar2;
-// bool has_tmp_lhs_array = false;
-// if (has_vector)
-// {
-// has_tmp_lhs_array = true;
-// ar = gfc_find_array_ref (lhs_expr);
-// ar2 = *ar;
-// memset (ar, '\0', sizeof (*ar));
-// ar->as = ar2.as;
-// ar->type = AR_FULL;
-// }
-// lhs_se.want_pointer = 1;
-// gfc_conv_expr_descriptor (&lhs_se, lhs_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 (has_vector ? ar2.dimen
-// : lhs_expr->rank,
-// lhs_type));
-// if (has_tmp_lhs_array)
-// {
-// vec = conv_caf_vector_subscript (&block, lhs_se.expr, &ar2);
-// *ar = ar2;
-// }
-// }
-// else if (rhs_is_coindexed)
-// {
-// /* Special casing for arr1 ([...]) = arr2[...], i.e. caf_get to
-// indexed array expression. This is rewritten to:
-
-// tmp_array = arr2[...]
-// arr1 ([...]) = tmp_array
-
-// because using the standard gfc_conv_expr (lhs_expr) did the
-// assignment with lhs and rhs exchanged. */
-
-// gfc_ss *lss_for_tmparray, *lss_real;
-// gfc_loopinfo loop;
-// gfc_se se;
-// stmtblock_t body;
-// tree tmparr_desc, src;
-// tree index = gfc_index_zero_node;
-// tree stride = gfc_index_zero_node;
-// int n;
-
-// /* Walk both sides of the assignment, once to get the shape of the
-// temporary array to create right. */
-// lss_for_tmparray = gfc_walk_expr (lhs_expr);
-// /* And a second time to be able to create an assignment of the
-// temporary to the lhs_expr. gfc_trans_create_temp_array replaces
-// the tree in the descriptor with the one for the temporary
-// array. */
-// lss_real = gfc_walk_expr (lhs_expr);
-// gfc_init_loopinfo (&loop);
-// gfc_add_ss_to_loop (&loop, lss_for_tmparray);
-// gfc_add_ss_to_loop (&loop, lss_real);
-// gfc_conv_ss_startstride (&loop);
-// gfc_conv_loop_setup (&loop, &lhs_expr->where);
-// lhs_type = gfc_typenode_for_spec (&lhs_expr->ts);
-// gfc_trans_create_temp_array (&lhs_se.pre, &lhs_se.post,
-// lss_for_tmparray, lhs_type, NULL_TREE,
-// false, true, false,
-// &lhs_expr->where);
-// tmparr_desc = lss_for_tmparray->info->data.array.descriptor;
-// gfc_start_scalarized_body (&loop, &body);
-// gfc_init_se (&se, NULL);
-// gfc_copy_loopinfo_to_se (&se, &loop);
-// se.ss = lss_real;
-// gfc_conv_expr (&se, lhs_expr);
-// gfc_add_block_to_block (&body, &se.pre);
-
-// /* Walk over all indexes of the loop. */
-// for (n = loop.dimen - 1; n > 0; --n)
-// {
-// tmp = loop.loopvar[n];
-// tmp = fold_build2_loc (input_location, MINUS_EXPR,
-// gfc_array_index_type, tmp, loop.from[n]);
-// tmp = fold_build2_loc (input_location, PLUS_EXPR,
-// gfc_array_index_type, tmp, index);
-
-// stride = fold_build2_loc (input_location, MINUS_EXPR,
-// gfc_array_index_type,
-// loop.to[n - 1], loop.from[n - 1]);
-// stride = fold_build2_loc (input_location, PLUS_EXPR,
-// gfc_array_index_type,
-// stride, gfc_index_one_node);
-
-// index = fold_build2_loc (input_location, MULT_EXPR,
-// gfc_array_index_type, tmp, stride);
-// }
-
-// index = fold_build2_loc (input_location, MINUS_EXPR,
-// gfc_array_index_type,
-// index, loop.from[0]);
-
-// index = fold_build2_loc (input_location, PLUS_EXPR,
-// gfc_array_index_type,
-// loop.loopvar[0], index);
-
-// src = build_fold_indirect_ref (gfc_conv_array_data (tmparr_desc));
-// src = gfc_build_array_ref (src, index, NULL);
-// /* Now create the assignment of lhs_expr = tmp_array. */
-// gfc_add_modify (&body, se.expr, src);
-// gfc_add_block_to_block (&body, &se.post);
-// lhs_se.expr = gfc_build_addr_expr (NULL_TREE, tmparr_desc);
-// gfc_trans_scalarizing_loops (&loop, &body);
-// gfc_add_block_to_block (&loop.pre, &loop.post);
-// gfc_add_expr_to_block (&lhs_se.post, gfc_finish_block (&loop.pre));
-// gfc_free_ss (lss_for_tmparray);
-// gfc_free_ss (lss_real);
-// }
-// }
-
-// lhs_kind = build_int_cst (integer_type_node, lhs_expr->ts.kind);
-
-// /* Special case: RHS is a coarray but LHS is not; this code path avoids a
-// temporary and a loop. */
-// if (!lhs_is_coindexed && rhs_is_coindexed
-// && (!lhs_caf_attr.codimension
-// || !(lhs_expr->rank > 0
-// && (lhs_caf_attr.allocatable || lhs_caf_attr.pointer))))
-// {
-// bool lhs_may_realloc = lhs_expr->rank > 0 && lhs_caf_attr.allocatable;
-// gfc_init_se (&rhs_se, NULL);
-// if (lhs_expr->rank == 0 && lhs_caf_attr.allocatable)
-// {
-// gfc_se scal_se;
-// gfc_init_se (&scal_se, NULL);
-// scal_se.want_pointer = 1;
-// gfc_conv_expr (&scal_se, lhs_expr);
-// /* Ensure scalar on lhs is allocated. */
-// gfc_add_block_to_block (&block, &scal_se.pre);
-
-// gfc_allocate_using_malloc (&scal_se.pre, scal_se.expr,
-// TYPE_SIZE_UNIT (
-// gfc_typenode_for_spec (&lhs_expr->ts)),
-// NULL_TREE);
-// tmp = fold_build2 (EQ_EXPR, logical_type_node, scal_se.expr,
-// null_pointer_node);
-// tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
-// tmp, gfc_finish_block (&scal_se.pre),
-// build_empty_stmt (input_location));
-// gfc_add_expr_to_block (&block, tmp);
-// }
-// else
-// lhs_may_realloc = lhs_may_realloc
-// && gfc_full_array_ref_p (lhs_expr->ref, NULL);
-// gfc_add_block_to_block (&block, &lhs_se.pre);
-// gfc_conv_intrinsic_caf_get (&rhs_se, code->ext.actual->next->expr,
-// lhs_se.expr, lhs_may_realloc, &rhs_caf_attr);
-// gfc_add_block_to_block (&block, &rhs_se.pre);
-// gfc_add_block_to_block (&block, &rhs_se.post);
-// gfc_add_block_to_block (&block, &lhs_se.post);
-// return gfc_finish_block (&block);
-// }
-
-// gfc_add_block_to_block (&block, &lhs_se.pre);
-
-// /* Obtain token, offset and image index for the LHS. */
-// caf_decl = gfc_get_tree_for_caf_expr (lhs_expr);
-// if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
-// caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
-// image_index = gfc_caf_get_image_index (&block, lhs_expr, caf_decl);
-// tmp = lhs_se.expr;
-// if (lhs_caf_attr.alloc_comp)
-// gfc_get_caf_token_offset (&lhs_se, &token, NULL, caf_decl, NULL_TREE,
-// NULL);
-// else
-// gfc_get_caf_token_offset (&lhs_se, &token, &offset, caf_decl, tmp,
-// lhs_expr);
-// lhs_se.expr = tmp;
-
-// /* RHS. */
-// gfc_init_se (&rhs_se, NULL);
-// if (rhs_expr->expr_type == EXPR_FUNCTION && rhs_expr->value.function.isym
-// && rhs_expr->value.function.isym->id == GFC_ISYM_CONVERSION)
-// rhs_expr = rhs_expr->value.function.actual->expr;
-// if (rhs_expr->rank == 0)
-// {
-// symbol_attribute attr;
-// gfc_clear_attr (&attr);
-// gfc_conv_expr (&rhs_se, rhs_expr);
-// rhs_se.expr = gfc_conv_scalar_to_descriptor (&rhs_se, rhs_se.expr,
-// attr); rhs_se.expr = gfc_build_addr_expr (NULL_TREE, rhs_se.expr);
-// }
-// else if ((rhs_caf_attr.alloc_comp || rhs_caf_attr.pointer_comp)
-// && rhs_caf_attr.codimension)
-// {
-// tree tmp2;
-// 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. */
-// tmp2 = gfc_typenode_for_spec (&rhs_expr->ts);
-// tmp = build_fold_indirect_ref_loc (input_location, rhs_se.expr);
-// gfc_add_modify (&rhs_se.pre, gfc_conv_descriptor_dtype (tmp),
-// gfc_get_dtype_rank_type (
-// gfc_has_vector_subscript (rhs_expr)
-// ? gfc_find_array_ref (rhs_expr)->dimen
-// : rhs_expr->rank,
-// tmp2));
-// }
-// else
-// {
-// /* If has_vector, pass descriptor for whole array and the
-// vector bounds separately. */
-// gfc_array_ref *ar, ar2;
-// bool has_vector = false;
-// tree tmp2;
-
-// if (rhs_is_coindexed && gfc_has_vector_subscript (rhs_expr))
-// {
-// has_vector = true;
-// ar = gfc_find_array_ref (rhs_expr);
-// ar2 = *ar;
-// memset (ar, '\0', sizeof (*ar));
-// ar->as = ar2.as;
-// ar->type = AR_FULL;
-// }
-// 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 (has_vector ? ar2.dimen
-// : rhs_expr->rank,
-// tmp2));
-// if (has_vector)
-// {
-// rhs_vec = conv_caf_vector_subscript (&block, rhs_se.expr, &ar2);
-// *ar = ar2;
-// }
-// }
-
-// gfc_add_block_to_block (&block, &rhs_se.pre);
-
-// rhs_kind = build_int_cst (integer_type_node, rhs_expr->ts.kind);
-
-// tmp_stat = gfc_find_stat_co (lhs_expr);
-
-// if (tmp_stat)
-// {
-// gfc_se stat_se;
-// gfc_init_se (&stat_se, NULL);
-// gfc_conv_expr_reference (&stat_se, tmp_stat);
-// dst_stat = stat_se.expr;
-// gfc_add_block_to_block (&block, &stat_se.pre);
-// gfc_add_block_to_block (&block, &stat_se.post);
-// }
-
-// tmp_team = gfc_find_team_co (lhs_expr);
-
-// if (tmp_team)
-// {
-// gfc_se team_se;
-// gfc_init_se (&team_se, NULL);
-// gfc_conv_expr_reference (&team_se, tmp_team);
-// dst_team = team_se.expr;
-// gfc_add_block_to_block (&block, &team_se.pre);
-// gfc_add_block_to_block (&block, &team_se.post);
-// }
-
-// if (!rhs_is_coindexed)
-// {
-// if (lhs_caf_attr.alloc_comp || lhs_caf_attr.pointer_comp
-// || has_ref_after_cafref (lhs_expr))
-// {
-// tree reference, dst_realloc;
-// reference = conv_expr_ref_to_caf_ref (&block, lhs_expr);
-// dst_realloc
-// = lhs_caf_attr.allocatable ? boolean_true_node : boolean_false_node;
-// tmp = build_call_expr_loc (input_location,
-// gfor_fndecl_caf_send_by_ref,
-// 10, token, image_index, rhs_se.expr,
-// reference, lhs_kind, rhs_kind,
-// 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,
-// token, offset, image_index, lhs_se.expr, vec,
-// rhs_se.expr, lhs_kind, rhs_kind,
-// may_require_tmp, src_stat, dst_team);
-// }
-// else
-// {
-// tree rhs_token, rhs_offset, rhs_image_index;
-
-// /* It guarantees memory consistency within the same segment. */
-// tmp = gfc_build_string_const (strlen ("memory") + 1, "memory");
-// tmp = build5_loc (input_location, ASM_EXPR, void_type_node,
-// gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE,
-// tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE);
-// ASM_VOLATILE_P (tmp) = 1;
-// gfc_add_expr_to_block (&block, tmp);
-
-// caf_decl = gfc_get_tree_for_caf_expr (rhs_expr);
-// if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
-// caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
-// rhs_image_index = gfc_caf_get_image_index (&block, rhs_expr, caf_decl);
-// tmp = rhs_se.expr;
-// if (rhs_caf_attr.alloc_comp || rhs_caf_attr.pointer_comp
-// || has_ref_after_cafref (lhs_expr))
-// {
-// tmp_stat = gfc_find_stat_co (lhs_expr);
-
-// if (tmp_stat)
-// {
-// gfc_se stat_se;
-// gfc_init_se (&stat_se, NULL);
-// gfc_conv_expr_reference (&stat_se, tmp_stat);
-// src_stat = stat_se.expr;
-// gfc_add_block_to_block (&block, &stat_se.pre);
-// gfc_add_block_to_block (&block, &stat_se.post);
-// }
-
-// gfc_get_caf_token_offset (&rhs_se, &rhs_token, NULL, caf_decl,
-// NULL_TREE, NULL);
-// tree lhs_reference, rhs_reference;
-// 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, 13,
-// token, image_index, lhs_reference,
-// rhs_token, rhs_image_index, rhs_reference,
-// lhs_kind, rhs_kind, may_require_tmp,
-// 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
-// {
-// gfc_get_caf_token_offset (&rhs_se, &rhs_token, &rhs_offset, caf_decl,
-// tmp, rhs_expr);
-// tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sendget,
-// 14, token, offset, image_index,
-// lhs_se.expr, vec, rhs_token, rhs_offset,
-// rhs_image_index, tmp, rhs_vec, lhs_kind,
-// rhs_kind, may_require_tmp, src_stat);
-// }
-// }
-// gfc_add_expr_to_block (&block, tmp);
-// gfc_add_block_to_block (&block, &lhs_se.post);
-// gfc_add_block_to_block (&block, &rhs_se.post);
-
-// /* It guarantees memory consistency within the same segment. */
-// tmp = gfc_build_string_const (strlen ("memory") + 1, "memory");
-// tmp = build5_loc (input_location, ASM_EXPR, void_type_node,
-// gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE,
-// tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE);
-// ASM_VOLATILE_P (tmp) = 1;
-// gfc_add_expr_to_block (&block, tmp);
-
-// return gfc_finish_block (&block);
-// }
static void
trans_this_image (gfc_se * se, gfc_expr *expr)
@@ -883,22 +883,12 @@ extern GTY(()) tree gfor_fndecl_caf_this_image;
extern GTY(()) tree gfor_fndecl_caf_num_images;
extern GTY(()) tree gfor_fndecl_caf_register;
extern GTY(()) tree gfor_fndecl_caf_deregister;
-
-// Deprecate start
-extern GTY(()) tree gfor_fndecl_caf_get;
-extern GTY(()) tree gfor_fndecl_caf_send;
-extern GTY(()) tree gfor_fndecl_caf_sendget;
-extern GTY(()) tree gfor_fndecl_caf_send_by_ref;
-extern GTY(()) tree gfor_fndecl_caf_sendget_by_ref;
-// Deprecate end
-
extern GTY(()) tree gfor_fndecl_caf_register_accessor;
extern GTY(()) tree gfor_fndecl_caf_register_accessors_finish;
extern GTY(()) tree gfor_fndecl_caf_get_remote_function_index;
extern GTY(()) tree gfor_fndecl_caf_get_from_remote;
extern GTY(()) tree gfor_fndecl_caf_send_to_remote;
extern GTY(()) tree gfor_fndecl_caf_transfer_between_remotes;
-
extern GTY(()) tree gfor_fndecl_caf_sync_all;
extern GTY(()) tree gfor_fndecl_caf_sync_memory;
extern GTY(()) tree gfor_fndecl_caf_sync_images;
@@ -89,98 +89,6 @@ typedef struct caf_static_t {
}
caf_static_t;
-/* When there is a vector subscript in this dimension, nvec == 0, otherwise,
- lower_bound, upper_bound, stride contains the bounds relative to the declared
- bounds; kind denotes the integer kind of the elements of vector[]. */
-typedef struct caf_vector_t {
- size_t nvec;
- union {
- struct {
- void *vector;
- int kind;
- } v;
- struct {
- ptrdiff_t lower_bound, upper_bound, stride;
- } triplet;
- } u;
-}
-caf_vector_t;
-
-typedef enum caf_ref_type_t {
- /* Reference a component of a derived type, either regular one or an
- allocatable or pointer type. For regular ones idx in caf_reference_t is
- set to -1. */
- CAF_REF_COMPONENT,
- /* Reference an allocatable array. */
- CAF_REF_ARRAY,
- /* Reference a non-allocatable/non-pointer array. */
- CAF_REF_STATIC_ARRAY
-} caf_ref_type_t;
-
-typedef enum caf_array_ref_t {
- /* No array ref. This terminates the array ref. */
- CAF_ARR_REF_NONE = 0,
- /* Reference array elements given by a vector. Only for this mode
- caf_reference_t.u.a.dim[i].v is valid. */
- CAF_ARR_REF_VECTOR,
- /* A full array ref (:). */
- CAF_ARR_REF_FULL,
- /* Reference a range on elements given by start, end and stride. */
- CAF_ARR_REF_RANGE,
- /* Only a single item is referenced given in the start member. */
- CAF_ARR_REF_SINGLE,
- /* An array ref of the kind (i:), where i is an arbitrary valid index in the
- array. The index i is given in the start member. */
- CAF_ARR_REF_OPEN_END,
- /* An array ref of the kind (:i), where the lower bound of the array ref
- is given by the remote side. The index i is given in the end member. */
- CAF_ARR_REF_OPEN_START
-} caf_array_ref_t;
-
-/* References to remote components of a derived type. */
-typedef struct caf_reference_t {
- /* A pointer to the next ref or NULL. */
- struct caf_reference_t *next;
- /* The type of the reference. */
- /* caf_ref_type_t, replaced by int to allow specification in fortran FE. */
- int type;
- /* The size of an item referenced in bytes. I.e. in an array ref this is
- the factor to advance the array pointer with to get to the next item.
- For component refs this gives just the size of the element referenced. */
- size_t item_size;
- union {
- struct {
- /* The offset (in bytes) of the component in the derived type. */
- ptrdiff_t offset;
- /* The offset (in bytes) to the caf_token associated with this
- component. NULL, when not allocatable/pointer ref. */
- ptrdiff_t caf_token_offset;
- } c;
- struct {
- /* The mode of the array ref. See CAF_ARR_REF_*. */
- /* caf_array_ref_t, replaced by unsigend char to allow specification in
- fortran FE. */
- unsigned char mode[GFC_MAX_DIMENSIONS];
- /* The type of a static array. Unset for array's with descriptors. */
- int static_array_type;
- /* Subscript refs (s) or vector refs (v). */
- union {
- struct {
- /* The start and end boundary of the ref and the stride. */
- index_type start, end, stride;
- } s;
- struct {
- /* nvec entries of kind giving the elements to reference. */
- void *vector;
- /* The number of entries in vector. */
- size_t nvec;
- /* The integer kind used for the elements in vector. */
- int kind;
- } v;
- } dim[GFC_MAX_DIMENSIONS];
- } a;
- } u;
-} caf_reference_t;
void _gfortran_caf_init (int *, char ***);
void _gfortran_caf_finalize (void);
@@ -213,26 +121,6 @@ void _gfortran_caf_co_max (gfc_descriptor_t *, int, int *, char *, int, size_t);
void _gfortran_caf_co_reduce (gfc_descriptor_t *, void* (*) (void *, void*),
int, int, int *, char *, int, size_t);
-void _gfortran_caf_get (caf_token_t, size_t, int, gfc_descriptor_t *,
- caf_vector_t *, gfc_descriptor_t *, int, int, bool,
- int *);
-void _gfortran_caf_send (caf_token_t, size_t, int, gfc_descriptor_t *,
- caf_vector_t *, gfc_descriptor_t *, int, int, bool,
- int *);
-void _gfortran_caf_sendget (caf_token_t, size_t, int, gfc_descriptor_t *,
- caf_vector_t *, caf_token_t, size_t, int,
- gfc_descriptor_t *, caf_vector_t *, int, int, bool);
-
-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 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 dst_type, int src_type);
-
void _gfortran_caf_register_accessor (
const int hash,
void (*accessor) (void *, const int *, void **, int32_t *, void *,
@@ -477,2393 +477,6 @@ _gfortran_caf_co_reduce (gfc_descriptor_t *a __attribute__ ((unused)),
}
-static void
-assign_char4_from_char1 (size_t dst_size, size_t src_size, uint32_t *dst,
- unsigned char *src)
-{
- size_t i, n;
- n = dst_size/4 > src_size ? src_size : dst_size/4;
- for (i = 0; i < n; ++i)
- dst[i] = (int32_t) src[i];
- for (; i < dst_size/4; ++i)
- dst[i] = (int32_t) ' ';
-}
-
-
-static void
-assign_char1_from_char4 (size_t dst_size, size_t src_size, unsigned char *dst,
- uint32_t *src)
-{
- size_t i, n;
- n = dst_size > src_size/4 ? src_size/4 : dst_size;
- for (i = 0; i < n; ++i)
- dst[i] = src[i] > UINT8_MAX ? (unsigned char) '?' : (unsigned char) src[i];
- if (dst_size > n)
- memset (&dst[n], ' ', dst_size - n);
-}
-
-
-static void
-convert_type (void *dst, int dst_type, int dst_kind, void *src, int src_type,
- int src_kind, int *stat)
-{
-#ifdef HAVE_GFC_INTEGER_16
- typedef __int128 int128t;
-#else
- typedef int64_t int128t;
-#endif
-
-#if defined(GFC_REAL_16_IS_LONG_DOUBLE)
- typedef long double real128t;
- typedef _Complex long double complex128t;
-#elif defined(HAVE_GFC_REAL_16)
- typedef _Float128 real128t;
- typedef _Complex _Float128 complex128t;
-#elif defined(HAVE_GFC_REAL_10)
- typedef long double real128t;
- typedef _Complex long double complex128t;
-#else
- typedef double real128t;
- typedef _Complex double complex128t;
-#endif
-
- int128t int_val = 0;
- real128t real_val = 0;
- complex128t cmpx_val = 0;
-
- switch (src_type)
- {
- case BT_INTEGER:
- if (src_kind == 1)
- int_val = *(int8_t*) src;
- else if (src_kind == 2)
- int_val = *(int16_t*) src;
- else if (src_kind == 4)
- int_val = *(int32_t*) src;
- else if (src_kind == 8)
- int_val = *(int64_t*) src;
-#ifdef HAVE_GFC_INTEGER_16
- else if (src_kind == 16)
- int_val = *(int128t*) src;
-#endif
- else
- goto error;
- break;
- case BT_REAL:
- if (src_kind == 4)
- real_val = *(float*) src;
- else if (src_kind == 8)
- real_val = *(double*) src;
-#ifdef HAVE_GFC_REAL_10
- else if (src_kind == 10)
- real_val = *(long double*) src;
-#endif
-#ifdef HAVE_GFC_REAL_16
- else if (src_kind == 16)
- real_val = *(real128t*) src;
-#endif
- else
- goto error;
- break;
- case BT_COMPLEX:
- if (src_kind == 4)
- cmpx_val = *(_Complex float*) src;
- else if (src_kind == 8)
- cmpx_val = *(_Complex double*) src;
-#ifdef HAVE_GFC_REAL_10
- else if (src_kind == 10)
- cmpx_val = *(_Complex long double*) src;
-#endif
-#ifdef HAVE_GFC_REAL_16
- else if (src_kind == 16)
- cmpx_val = *(complex128t*) src;
-#endif
- else
- goto error;
- break;
- default:
- goto error;
- }
-
- switch (dst_type)
- {
- case BT_INTEGER:
- if (src_type == BT_INTEGER)
- {
- if (dst_kind == 1)
- *(int8_t*) dst = (int8_t) int_val;
- else if (dst_kind == 2)
- *(int16_t*) dst = (int16_t) int_val;
- else if (dst_kind == 4)
- *(int32_t*) dst = (int32_t) int_val;
- else if (dst_kind == 8)
- *(int64_t*) dst = (int64_t) int_val;
-#ifdef HAVE_GFC_INTEGER_16
- else if (dst_kind == 16)
- *(int128t*) dst = (int128t) int_val;
-#endif
- else
- goto error;
- }
- else if (src_type == BT_REAL)
- {
- if (dst_kind == 1)
- *(int8_t*) dst = (int8_t) real_val;
- else if (dst_kind == 2)
- *(int16_t*) dst = (int16_t) real_val;
- else if (dst_kind == 4)
- *(int32_t*) dst = (int32_t) real_val;
- else if (dst_kind == 8)
- *(int64_t*) dst = (int64_t) real_val;
-#ifdef HAVE_GFC_INTEGER_16
- else if (dst_kind == 16)
- *(int128t*) dst = (int128t) real_val;
-#endif
- else
- goto error;
- }
- else if (src_type == BT_COMPLEX)
- {
- if (dst_kind == 1)
- *(int8_t*) dst = (int8_t) cmpx_val;
- else if (dst_kind == 2)
- *(int16_t*) dst = (int16_t) cmpx_val;
- else if (dst_kind == 4)
- *(int32_t*) dst = (int32_t) cmpx_val;
- else if (dst_kind == 8)
- *(int64_t*) dst = (int64_t) cmpx_val;
-#ifdef HAVE_GFC_INTEGER_16
- else if (dst_kind == 16)
- *(int128t*) dst = (int128t) cmpx_val;
-#endif
- else
- goto error;
- }
- else
- goto error;
- return;
- case BT_REAL:
- if (src_type == BT_INTEGER)
- {
- if (dst_kind == 4)
- *(float*) dst = (float) int_val;
- else if (dst_kind == 8)
- *(double*) dst = (double) int_val;
-#ifdef HAVE_GFC_REAL_10
- else if (dst_kind == 10)
- *(long double*) dst = (long double) int_val;
-#endif
-#ifdef HAVE_GFC_REAL_16
- else if (dst_kind == 16)
- *(real128t*) dst = (real128t) int_val;
-#endif
- else
- goto error;
- }
- else if (src_type == BT_REAL)
- {
- if (dst_kind == 4)
- *(float*) dst = (float) real_val;
- else if (dst_kind == 8)
- *(double*) dst = (double) real_val;
-#ifdef HAVE_GFC_REAL_10
- else if (dst_kind == 10)
- *(long double*) dst = (long double) real_val;
-#endif
-#ifdef HAVE_GFC_REAL_16
- else if (dst_kind == 16)
- *(real128t*) dst = (real128t) real_val;
-#endif
- else
- goto error;
- }
- else if (src_type == BT_COMPLEX)
- {
- if (dst_kind == 4)
- *(float*) dst = (float) cmpx_val;
- else if (dst_kind == 8)
- *(double*) dst = (double) cmpx_val;
-#ifdef HAVE_GFC_REAL_10
- else if (dst_kind == 10)
- *(long double*) dst = (long double) cmpx_val;
-#endif
-#ifdef HAVE_GFC_REAL_16
- else if (dst_kind == 16)
- *(real128t*) dst = (real128t) cmpx_val;
-#endif
- else
- goto error;
- }
- return;
- case BT_COMPLEX:
- if (src_type == BT_INTEGER)
- {
- if (dst_kind == 4)
- *(_Complex float*) dst = (_Complex float) int_val;
- else if (dst_kind == 8)
- *(_Complex double*) dst = (_Complex double) int_val;
-#ifdef HAVE_GFC_REAL_10
- else if (dst_kind == 10)
- *(_Complex long double*) dst = (_Complex long double) int_val;
-#endif
-#ifdef HAVE_GFC_REAL_16
- else if (dst_kind == 16)
- *(complex128t*) dst = (complex128t) int_val;
-#endif
- else
- goto error;
- }
- else if (src_type == BT_REAL)
- {
- if (dst_kind == 4)
- *(_Complex float*) dst = (_Complex float) real_val;
- else if (dst_kind == 8)
- *(_Complex double*) dst = (_Complex double) real_val;
-#ifdef HAVE_GFC_REAL_10
- else if (dst_kind == 10)
- *(_Complex long double*) dst = (_Complex long double) real_val;
-#endif
-#ifdef HAVE_GFC_REAL_16
- else if (dst_kind == 16)
- *(complex128t*) dst = (complex128t) real_val;
-#endif
- else
- goto error;
- }
- else if (src_type == BT_COMPLEX)
- {
- if (dst_kind == 4)
- *(_Complex float*) dst = (_Complex float) cmpx_val;
- else if (dst_kind == 8)
- *(_Complex double*) dst = (_Complex double) cmpx_val;
-#ifdef HAVE_GFC_REAL_10
- else if (dst_kind == 10)
- *(_Complex long double*) dst = (_Complex long double) cmpx_val;
-#endif
-#ifdef HAVE_GFC_REAL_16
- else if (dst_kind == 16)
- *(complex128t*) dst = (complex128t) cmpx_val;
-#endif
- else
- goto error;
- }
- else
- goto error;
- return;
- default:
- goto error;
- }
-
-error:
- fprintf (stderr, "libcaf_single RUNTIME ERROR: Cannot convert type %d kind "
- "%d to type %d kind %d\n", src_type, src_kind, dst_type, dst_kind);
- if (stat)
- *stat = 1;
- else
- abort ();
-}
-
-
-void
-_gfortran_caf_get (caf_token_t token, size_t offset,
- int image_index __attribute__ ((unused)),
- gfc_descriptor_t *src,
- caf_vector_t *src_vector __attribute__ ((unused)),
- gfc_descriptor_t *dest, int src_kind, int dst_kind,
- bool may_require_tmp, int *stat)
-{
- /* FIXME: Handle vector subscripts. */
- size_t i, k, size;
- int j;
- int rank = GFC_DESCRIPTOR_RANK (dest);
- size_t src_size = GFC_DESCRIPTOR_SIZE (src);
- size_t dst_size = GFC_DESCRIPTOR_SIZE (dest);
-
- if (stat)
- *stat = 0;
-
- if (rank == 0)
- {
- void *sr = (void *) ((char *) MEMTOK (token) + offset);
- if (GFC_DESCRIPTOR_TYPE (dest) == GFC_DESCRIPTOR_TYPE (src)
- && dst_kind == src_kind)
- {
- memmove (GFC_DESCRIPTOR_DATA (dest), sr,
- dst_size > src_size ? src_size : dst_size);
- if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_size > src_size)
- {
- if (dst_kind == 1)
- memset ((void*)(char*) GFC_DESCRIPTOR_DATA (dest) + src_size,
- ' ', dst_size - src_size);
- else /* dst_kind == 4. */
- for (i = src_size/4; i < dst_size/4; i++)
- ((int32_t*) GFC_DESCRIPTOR_DATA (dest))[i] = (int32_t) ' ';
- }
- }
- else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_kind == 1)
- assign_char1_from_char4 (dst_size, src_size, GFC_DESCRIPTOR_DATA (dest),
- sr);
- else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER)
- assign_char4_from_char1 (dst_size, src_size, GFC_DESCRIPTOR_DATA (dest),
- sr);
- else
- convert_type (GFC_DESCRIPTOR_DATA (dest), GFC_DESCRIPTOR_TYPE (dest),
- dst_kind, sr, GFC_DESCRIPTOR_TYPE (src), src_kind, stat);
- return;
- }
-
- size = 1;
- for (j = 0; j < rank; j++)
- {
- ptrdiff_t dimextent = dest->dim[j]._ubound - dest->dim[j].lower_bound + 1;
- if (dimextent < 0)
- dimextent = 0;
- size *= dimextent;
- }
-
- if (size == 0)
- return;
-
- if (may_require_tmp)
- {
- ptrdiff_t array_offset_sr, array_offset_dst;
- void *tmp = malloc (size*src_size);
-
- array_offset_dst = 0;
- for (i = 0; i < size; i++)
- {
- ptrdiff_t array_offset_sr = 0;
- ptrdiff_t stride = 1;
- ptrdiff_t extent = 1;
- for (j = 0; j < GFC_DESCRIPTOR_RANK (src)-1; j++)
- {
- array_offset_sr += ((i / (extent*stride))
- % (src->dim[j]._ubound
- - src->dim[j].lower_bound + 1))
- * src->dim[j]._stride;
- extent = (src->dim[j]._ubound - src->dim[j].lower_bound + 1);
- stride = src->dim[j]._stride;
- }
- array_offset_sr += (i / extent) * src->dim[rank-1]._stride;
- void *sr = (void *)((char *) MEMTOK (token) + offset
- + array_offset_sr*GFC_DESCRIPTOR_SIZE (src));
- memcpy ((void *) ((char *) tmp + array_offset_dst), sr, src_size);
- array_offset_dst += src_size;
- }
-
- array_offset_sr = 0;
- for (i = 0; i < size; i++)
- {
- ptrdiff_t array_offset_dst = 0;
- ptrdiff_t stride = 1;
- ptrdiff_t extent = 1;
- for (j = 0; j < rank-1; j++)
- {
- array_offset_dst += ((i / (extent*stride))
- % (dest->dim[j]._ubound
- - dest->dim[j].lower_bound + 1))
- * dest->dim[j]._stride;
- extent = (dest->dim[j]._ubound - dest->dim[j].lower_bound + 1);
- stride = dest->dim[j]._stride;
- }
- array_offset_dst += (i / extent) * dest->dim[rank-1]._stride;
- void *dst = dest->base_addr
- + array_offset_dst*GFC_DESCRIPTOR_SIZE (dest);
- void *sr = tmp + array_offset_sr;
-
- if (GFC_DESCRIPTOR_TYPE (dest) == GFC_DESCRIPTOR_TYPE (src)
- && dst_kind == src_kind)
- {
- memmove (dst, sr, dst_size > src_size ? src_size : dst_size);
- if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER
- && dst_size > src_size)
- {
- if (dst_kind == 1)
- memset ((void*)(char*) dst + src_size, ' ',
- dst_size-src_size);
- else /* dst_kind == 4. */
- for (k = src_size/4; k < dst_size/4; k++)
- ((int32_t*) dst)[k] = (int32_t) ' ';
- }
- }
- else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_kind == 1)
- assign_char1_from_char4 (dst_size, src_size, dst, sr);
- else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER)
- assign_char4_from_char1 (dst_size, src_size, dst, sr);
- else
- convert_type (dst, GFC_DESCRIPTOR_TYPE (dest), dst_kind,
- sr, GFC_DESCRIPTOR_TYPE (src), src_kind, stat);
- array_offset_sr += src_size;
- }
-
- free (tmp);
- return;
- }
-
- for (i = 0; i < size; i++)
- {
- ptrdiff_t array_offset_dst = 0;
- ptrdiff_t stride = 1;
- ptrdiff_t extent = 1;
- for (j = 0; j < rank-1; j++)
- {
- array_offset_dst += ((i / (extent*stride))
- % (dest->dim[j]._ubound
- - dest->dim[j].lower_bound + 1))
- * dest->dim[j]._stride;
- extent = (dest->dim[j]._ubound - dest->dim[j].lower_bound + 1);
- stride = dest->dim[j]._stride;
- }
- array_offset_dst += (i / extent) * dest->dim[rank-1]._stride;
- void *dst = dest->base_addr + array_offset_dst*GFC_DESCRIPTOR_SIZE (dest);
-
- ptrdiff_t array_offset_sr = 0;
- stride = 1;
- extent = 1;
- for (j = 0; j < GFC_DESCRIPTOR_RANK (src)-1; j++)
- {
- array_offset_sr += ((i / (extent*stride))
- % (src->dim[j]._ubound
- - src->dim[j].lower_bound + 1))
- * src->dim[j]._stride;
- extent = (src->dim[j]._ubound - src->dim[j].lower_bound + 1);
- stride = src->dim[j]._stride;
- }
- array_offset_sr += (i / extent) * src->dim[rank-1]._stride;
- void *sr = (void *)((char *) MEMTOK (token) + offset
- + array_offset_sr*GFC_DESCRIPTOR_SIZE (src));
-
- if (GFC_DESCRIPTOR_TYPE (dest) == GFC_DESCRIPTOR_TYPE (src)
- && dst_kind == src_kind)
- {
- memmove (dst, sr, dst_size > src_size ? src_size : dst_size);
- if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_size > src_size)
- {
- if (dst_kind == 1)
- memset ((void*)(char*) dst + src_size, ' ', dst_size-src_size);
- else /* dst_kind == 4. */
- for (k = src_size/4; k < dst_size/4; k++)
- ((int32_t*) dst)[k] = (int32_t) ' ';
- }
- }
- else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_kind == 1)
- assign_char1_from_char4 (dst_size, src_size, dst, sr);
- else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER)
- assign_char4_from_char1 (dst_size, src_size, dst, sr);
- else
- convert_type (dst, GFC_DESCRIPTOR_TYPE (dest), dst_kind,
- sr, GFC_DESCRIPTOR_TYPE (src), src_kind, stat);
- }
-}
-
-
-void
-_gfortran_caf_send (caf_token_t token, size_t offset,
- int image_index __attribute__ ((unused)),
- gfc_descriptor_t *dest,
- caf_vector_t *dst_vector __attribute__ ((unused)),
- gfc_descriptor_t *src, int dst_kind, int src_kind,
- bool may_require_tmp, int *stat)
-{
- /* FIXME: Handle vector subscripts. */
- size_t i, k, size;
- int j;
- int rank = GFC_DESCRIPTOR_RANK (dest);
- size_t src_size = GFC_DESCRIPTOR_SIZE (src);
- size_t dst_size = GFC_DESCRIPTOR_SIZE (dest);
-
- if (stat)
- *stat = 0;
-
- if (rank == 0)
- {
- void *dst = (void *) ((char *) MEMTOK (token) + offset);
- if (GFC_DESCRIPTOR_TYPE (dest) == GFC_DESCRIPTOR_TYPE (src)
- && dst_kind == src_kind)
- {
- memmove (dst, GFC_DESCRIPTOR_DATA (src),
- dst_size > src_size ? src_size : dst_size);
- if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_size > src_size)
- {
- if (dst_kind == 1)
- memset ((void*)(char*) dst + src_size, ' ', dst_size-src_size);
- else /* dst_kind == 4. */
- for (i = src_size/4; i < dst_size/4; i++)
- ((int32_t*) dst)[i] = (int32_t) ' ';
- }
- }
- else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_kind == 1)
- assign_char1_from_char4 (dst_size, src_size, dst,
- GFC_DESCRIPTOR_DATA (src));
- else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER)
- assign_char4_from_char1 (dst_size, src_size, dst,
- GFC_DESCRIPTOR_DATA (src));
- else
- convert_type (dst, GFC_DESCRIPTOR_TYPE (dest), dst_kind,
- GFC_DESCRIPTOR_DATA (src), GFC_DESCRIPTOR_TYPE (src),
- src_kind, stat);
- return;
- }
-
- size = 1;
- for (j = 0; j < rank; j++)
- {
- ptrdiff_t dimextent = dest->dim[j]._ubound - dest->dim[j].lower_bound + 1;
- if (dimextent < 0)
- dimextent = 0;
- size *= dimextent;
- }
-
- if (size == 0)
- return;
-
- if (may_require_tmp)
- {
- ptrdiff_t array_offset_sr, array_offset_dst;
- void *tmp;
-
- if (GFC_DESCRIPTOR_RANK (src) == 0)
- {
- tmp = malloc (src_size);
- memcpy (tmp, GFC_DESCRIPTOR_DATA (src), src_size);
- }
- else
- {
- tmp = malloc (size*src_size);
- array_offset_dst = 0;
- for (i = 0; i < size; i++)
- {
- ptrdiff_t array_offset_sr = 0;
- ptrdiff_t stride = 1;
- ptrdiff_t extent = 1;
- for (j = 0; j < GFC_DESCRIPTOR_RANK (src)-1; j++)
- {
- array_offset_sr += ((i / (extent*stride))
- % (src->dim[j]._ubound
- - src->dim[j].lower_bound + 1))
- * src->dim[j]._stride;
- extent = (src->dim[j]._ubound - src->dim[j].lower_bound + 1);
- stride = src->dim[j]._stride;
- }
- array_offset_sr += (i / extent) * src->dim[rank-1]._stride;
- void *sr = (void *) ((char *) src->base_addr
- + array_offset_sr*GFC_DESCRIPTOR_SIZE (src));
- memcpy ((void *) ((char *) tmp + array_offset_dst), sr, src_size);
- array_offset_dst += src_size;
- }
- }
-
- array_offset_sr = 0;
- for (i = 0; i < size; i++)
- {
- ptrdiff_t array_offset_dst = 0;
- ptrdiff_t stride = 1;
- ptrdiff_t extent = 1;
- for (j = 0; j < rank-1; j++)
- {
- array_offset_dst += ((i / (extent*stride))
- % (dest->dim[j]._ubound
- - dest->dim[j].lower_bound + 1))
- * dest->dim[j]._stride;
- extent = (dest->dim[j]._ubound - dest->dim[j].lower_bound + 1);
- stride = dest->dim[j]._stride;
- }
- array_offset_dst += (i / extent) * dest->dim[rank-1]._stride;
- void *dst = (void *)((char *) MEMTOK (token) + offset
- + array_offset_dst*GFC_DESCRIPTOR_SIZE (dest));
- void *sr = tmp + array_offset_sr;
- if (GFC_DESCRIPTOR_TYPE (dest) == GFC_DESCRIPTOR_TYPE (src)
- && dst_kind == src_kind)
- {
- memmove (dst, sr,
- dst_size > src_size ? src_size : dst_size);
- if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER
- && dst_size > src_size)
- {
- if (dst_kind == 1)
- memset ((void*)(char*) dst + src_size, ' ',
- dst_size-src_size);
- else /* dst_kind == 4. */
- for (k = src_size/4; k < dst_size/4; k++)
- ((int32_t*) dst)[k] = (int32_t) ' ';
- }
- }
- else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_kind == 1)
- assign_char1_from_char4 (dst_size, src_size, dst, sr);
- else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER)
- assign_char4_from_char1 (dst_size, src_size, dst, sr);
- else
- convert_type (dst, GFC_DESCRIPTOR_TYPE (dest), dst_kind,
- sr, GFC_DESCRIPTOR_TYPE (src), src_kind, stat);
- if (GFC_DESCRIPTOR_RANK (src))
- array_offset_sr += src_size;
- }
- free (tmp);
- return;
- }
-
- for (i = 0; i < size; i++)
- {
- ptrdiff_t array_offset_dst = 0;
- ptrdiff_t stride = 1;
- ptrdiff_t extent = 1;
- for (j = 0; j < rank-1; j++)
- {
- array_offset_dst += ((i / (extent*stride))
- % (dest->dim[j]._ubound
- - dest->dim[j].lower_bound + 1))
- * dest->dim[j]._stride;
- extent = (dest->dim[j]._ubound - dest->dim[j].lower_bound + 1);
- stride = dest->dim[j]._stride;
- }
- array_offset_dst += (i / extent) * dest->dim[rank - 1]._stride;
- void *dst = (void *) ((char *) MEMTOK (token) + offset
- + array_offset_dst * dest->span);
- void *sr;
- if (GFC_DESCRIPTOR_RANK (src) != 0)
- {
- ptrdiff_t array_offset_sr = 0;
- stride = 1;
- extent = 1;
- for (j = 0; j < GFC_DESCRIPTOR_RANK (src)-1; j++)
- {
- array_offset_sr += ((i / (extent*stride))
- % (src->dim[j]._ubound
- - src->dim[j].lower_bound + 1))
- * src->dim[j]._stride;
- extent = (src->dim[j]._ubound - src->dim[j].lower_bound + 1);
- stride = src->dim[j]._stride;
- }
- array_offset_sr += (i / extent) * src->dim[rank-1]._stride;
- sr = (void *) ((char *) src->base_addr + array_offset_sr * src->span);
- }
- else
- sr = src->base_addr;
-
- if (GFC_DESCRIPTOR_TYPE (dest) == GFC_DESCRIPTOR_TYPE (src)
- && dst_kind == src_kind)
- {
- memmove (dst, sr,
- dst_size > src_size ? src_size : dst_size);
- if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_size > src_size)
- {
- if (dst_kind == 1)
- memset ((void*)(char*) dst + src_size, ' ', dst_size-src_size);
- else /* dst_kind == 4. */
- for (k = src_size/4; k < dst_size/4; k++)
- ((int32_t*) dst)[k] = (int32_t) ' ';
- }
- }
- else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_kind == 1)
- assign_char1_from_char4 (dst_size, src_size, dst, sr);
- else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER)
- assign_char4_from_char1 (dst_size, src_size, dst, sr);
- else
- convert_type (dst, GFC_DESCRIPTOR_TYPE (dest), dst_kind,
- sr, GFC_DESCRIPTOR_TYPE (src), src_kind, stat);
- }
-}
-
-
-void
-_gfortran_caf_sendget (caf_token_t dst_token, size_t dst_offset,
- int dst_image_index, gfc_descriptor_t *dest,
- caf_vector_t *dst_vector, caf_token_t src_token,
- size_t src_offset,
- int src_image_index __attribute__ ((unused)),
- gfc_descriptor_t *src,
- caf_vector_t *src_vector __attribute__ ((unused)),
- int dst_kind, int src_kind, bool may_require_tmp)
-{
- /* FIXME: Handle vector subscript of 'src_vector'. */
- /* For a single image, src->base_addr should be the same as src_token + offset
- but to play save, we do it properly. */
- void *src_base = GFC_DESCRIPTOR_DATA (src);
- GFC_DESCRIPTOR_DATA (src) = (void *) ((char *) MEMTOK (src_token)
- + src_offset);
- _gfortran_caf_send (dst_token, dst_offset, dst_image_index, dest, dst_vector,
- src, dst_kind, src_kind, may_require_tmp, NULL);
- GFC_DESCRIPTOR_DATA (src) = src_base;
-}
-
-
-/* Emitted when a theorectically unreachable part is reached. */
-const char unreachable[] = "Fatal error: unreachable alternative found.\n";
-
-
-static void
-copy_data (void *ds, void *sr, int dst_type, int src_type,
- int dst_kind, int src_kind, size_t dst_size, size_t src_size,
- size_t num, int *stat)
-{
- size_t k;
- if (dst_type == src_type && dst_kind == src_kind)
- {
- memmove (ds, sr, (dst_size > src_size ? src_size : dst_size) * num);
- if ((dst_type == BT_CHARACTER || src_type == BT_CHARACTER)
- && dst_size > src_size)
- {
- if (dst_kind == 1)
- memset ((void*)(char*) ds + src_size, ' ', dst_size-src_size);
- else /* dst_kind == 4. */
- for (k = src_size/4; k < dst_size/4; k++)
- ((int32_t*) ds)[k] = (int32_t) ' ';
- }
- }
- else if (dst_type == BT_CHARACTER && dst_kind == 1)
- assign_char1_from_char4 (dst_size, src_size, ds, sr);
- else if (dst_type == BT_CHARACTER)
- assign_char4_from_char1 (dst_size, src_size, ds, sr);
- else
- for (k = 0; k < num; ++k)
- {
- convert_type (ds, dst_type, dst_kind, sr, src_type, src_kind, stat);
- ds += dst_size;
- sr += src_size;
- }
-}
-
-
-#define COMPUTE_NUM_ITEMS(num, stride, lb, ub) \
- do { \
- index_type abs_stride = (stride) > 0 ? (stride) : -(stride); \
- num = (stride) > 0 ? (ub) + 1 - (lb) : (lb) + 1 - (ub); \
- if (num <= 0 || abs_stride < 1) return; \
- num = (abs_stride > 1) ? (1 + (num - 1) / abs_stride) : num; \
- } while (0)
-
-
-static void
-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, int src_type)
-{
- ptrdiff_t extent_src = 1, array_offset_src = 0, stride_src;
- size_t next_dst_dim;
-
- if (unlikely (ref == NULL))
- /* May be we should issue an error here, because this case should not
- occur. */
- return;
-
- if (ref->next == NULL)
- {
- size_t dst_size = GFC_DESCRIPTOR_SIZE (dst);
- ptrdiff_t array_offset_dst = 0;;
- size_t dst_rank = GFC_DESCRIPTOR_RANK (dst);
-
- switch (ref->type)
- {
- case CAF_REF_COMPONENT:
- /* Because the token is always registered after the component, its
- 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), 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), src_type,
- dst_kind, src_kind, dst_size, ref->item_size, 1, stat);
- ++(*i);
- return;
- case CAF_REF_STATIC_ARRAY:
- /* Intentionally fall through. */
- case CAF_REF_ARRAY:
- if (ref->u.a.mode[src_dim] == CAF_ARR_REF_NONE)
- {
- 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,
- dst_kind, src_kind, dst_size, ref->item_size, num,
- stat);
- *i += num;
- return;
- }
- break;
- default:
- caf_runtime_error (unreachable);
- }
- }
-
- switch (ref->type)
- {
- case CAF_REF_COMPONENT:
- if (ref->u.c.caf_token_offset > 0)
- {
- 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 cannot 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, 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, src_type);
- return;
- }
- /* Only when on the left most index switch the data pointer to
- the array's data pointer. */
- if (src_dim == 0)
- sr = GFC_DESCRIPTOR_DATA (src);
- switch (ref->u.a.mode[src_dim])
- {
- case CAF_ARR_REF_VECTOR:
- extent_src = GFC_DIMENSION_EXTENT (src->dim[src_dim]);
- array_offset_src = 0;
- dst_index[dst_dim] = 0;
- for (size_t idx = 0; idx < ref->u.a.dim[src_dim].v.nvec;
- ++idx)
- {
-#define KINDCASE(kind, type) case kind: \
- array_offset_src = (((index_type) \
- ((type *)ref->u.a.dim[src_dim].v.vector)[idx]) \
- - GFC_DIMENSION_LBOUND (src->dim[src_dim])) \
- * GFC_DIMENSION_STRIDE (src->dim[src_dim]); \
- break
-
- switch (ref->u.a.dim[src_dim].v.kind)
- {
- KINDCASE (1, GFC_INTEGER_1);
- KINDCASE (2, GFC_INTEGER_2);
- KINDCASE (4, GFC_INTEGER_4);
-#ifdef HAVE_GFC_INTEGER_8
- KINDCASE (8, GFC_INTEGER_8);
-#endif
-#ifdef HAVE_GFC_INTEGER_16
- KINDCASE (16, GFC_INTEGER_16);
-#endif
- default:
- caf_runtime_error (unreachable);
- return;
- }
-#undef KINDCASE
-
- 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, src_type);
- dst_index[dst_dim]
- += GFC_DIMENSION_STRIDE (dst->dim[dst_dim]);
- }
- return;
- case CAF_ARR_REF_FULL:
- COMPUTE_NUM_ITEMS (extent_src,
- ref->u.a.dim[src_dim].s.stride,
- GFC_DIMENSION_LBOUND (src->dim[src_dim]),
- GFC_DIMENSION_UBOUND (src->dim[src_dim]));
- stride_src = src->dim[src_dim]._stride
- * ref->u.a.dim[src_dim].s.stride;
- array_offset_src = 0;
- dst_index[dst_dim] = 0;
- for (index_type idx = 0; idx < extent_src;
- ++idx, array_offset_src += stride_src)
- {
- 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, src_type);
- dst_index[dst_dim]
- += GFC_DIMENSION_STRIDE (dst->dim[dst_dim]);
- }
- return;
- case CAF_ARR_REF_RANGE:
- COMPUTE_NUM_ITEMS (extent_src,
- ref->u.a.dim[src_dim].s.stride,
- ref->u.a.dim[src_dim].s.start,
- ref->u.a.dim[src_dim].s.end);
- array_offset_src = (ref->u.a.dim[src_dim].s.start
- - GFC_DIMENSION_LBOUND (src->dim[src_dim]))
- * GFC_DIMENSION_STRIDE (src->dim[src_dim]);
- stride_src = GFC_DIMENSION_STRIDE (src->dim[src_dim])
- * ref->u.a.dim[src_dim].s.stride;
- dst_index[dst_dim] = 0;
- /* Increase the dst_dim only, when the src_extent is greater one
- or src and dst extent are both one. Don't increase when the scalar
- source is not present in the dst. */
- next_dst_dim = extent_src > 1
- || (GFC_DIMENSION_EXTENT (dst->dim[dst_dim]) == 1
- && extent_src == 1) ? (dst_dim + 1) : dst_dim;
- for (index_type idx = 0; idx < extent_src; ++idx)
- {
- 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, src_type);
- dst_index[dst_dim]
- += GFC_DIMENSION_STRIDE (dst->dim[dst_dim]);
- array_offset_src += stride_src;
- }
- return;
- case CAF_ARR_REF_SINGLE:
- array_offset_src = (ref->u.a.dim[src_dim].s.start
- - src->dim[src_dim].lower_bound)
- * GFC_DIMENSION_STRIDE (src->dim[src_dim]);
- dst_index[dst_dim] = 0;
- 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, src_type);
- return;
- case CAF_ARR_REF_OPEN_END:
- COMPUTE_NUM_ITEMS (extent_src,
- ref->u.a.dim[src_dim].s.stride,
- ref->u.a.dim[src_dim].s.start,
- GFC_DIMENSION_UBOUND (src->dim[src_dim]));
- stride_src = GFC_DIMENSION_STRIDE (src->dim[src_dim])
- * ref->u.a.dim[src_dim].s.stride;
- array_offset_src = (ref->u.a.dim[src_dim].s.start
- - GFC_DIMENSION_LBOUND (src->dim[src_dim]))
- * GFC_DIMENSION_STRIDE (src->dim[src_dim]);
- dst_index[dst_dim] = 0;
- for (index_type idx = 0; idx < extent_src; ++idx)
- {
- 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, src_type);
- dst_index[dst_dim]
- += GFC_DIMENSION_STRIDE (dst->dim[dst_dim]);
- array_offset_src += stride_src;
- }
- return;
- case CAF_ARR_REF_OPEN_START:
- COMPUTE_NUM_ITEMS (extent_src,
- ref->u.a.dim[src_dim].s.stride,
- GFC_DIMENSION_LBOUND (src->dim[src_dim]),
- ref->u.a.dim[src_dim].s.end);
- stride_src = GFC_DIMENSION_STRIDE (src->dim[src_dim])
- * ref->u.a.dim[src_dim].s.stride;
- array_offset_src = 0;
- dst_index[dst_dim] = 0;
- for (index_type idx = 0; idx < extent_src; ++idx)
- {
- 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, src_type);
- dst_index[dst_dim]
- += GFC_DIMENSION_STRIDE (dst->dim[dst_dim]);
- array_offset_src += stride_src;
- }
- return;
- default:
- caf_runtime_error (unreachable);
- }
- return;
- case CAF_REF_STATIC_ARRAY:
- if (ref->u.a.mode[src_dim] == CAF_ARR_REF_NONE)
- {
- get_for_ref (ref->next, i, dst_index, single_token, dst,
- NULL, ds, sr, dst_kind, src_kind,
- dst_dim, 0, 1, stat, src_type);
- return;
- }
- switch (ref->u.a.mode[src_dim])
- {
- case CAF_ARR_REF_VECTOR:
- array_offset_src = 0;
- dst_index[dst_dim] = 0;
- for (size_t idx = 0; idx < ref->u.a.dim[src_dim].v.nvec;
- ++idx)
- {
-#define KINDCASE(kind, type) case kind: \
- array_offset_src = ((type *)ref->u.a.dim[src_dim].v.vector)[idx]; \
- break
-
- switch (ref->u.a.dim[src_dim].v.kind)
- {
- KINDCASE (1, GFC_INTEGER_1);
- KINDCASE (2, GFC_INTEGER_2);
- KINDCASE (4, GFC_INTEGER_4);
-#ifdef HAVE_GFC_INTEGER_8
- KINDCASE (8, GFC_INTEGER_8);
-#endif
-#ifdef HAVE_GFC_INTEGER_16
- KINDCASE (16, GFC_INTEGER_16);
-#endif
- default:
- caf_runtime_error (unreachable);
- return;
- }
-#undef KINDCASE
-
- 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, src_type);
- dst_index[dst_dim]
- += GFC_DIMENSION_STRIDE (dst->dim[dst_dim]);
- }
- return;
- case CAF_ARR_REF_FULL:
- dst_index[dst_dim] = 0;
- for (array_offset_src = 0 ;
- array_offset_src <= ref->u.a.dim[src_dim].s.end;
- array_offset_src += ref->u.a.dim[src_dim].s.stride)
- {
- 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, src_type);
- dst_index[dst_dim]
- += GFC_DIMENSION_STRIDE (dst->dim[dst_dim]);
- }
- return;
- case CAF_ARR_REF_RANGE:
- COMPUTE_NUM_ITEMS (extent_src,
- ref->u.a.dim[src_dim].s.stride,
- ref->u.a.dim[src_dim].s.start,
- ref->u.a.dim[src_dim].s.end);
- array_offset_src = ref->u.a.dim[src_dim].s.start;
- dst_index[dst_dim] = 0;
- for (index_type idx = 0; idx < extent_src; ++idx)
- {
- 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, src_type);
- dst_index[dst_dim]
- += GFC_DIMENSION_STRIDE (dst->dim[dst_dim]);
- array_offset_src += ref->u.a.dim[src_dim].s.stride;
- }
- return;
- case CAF_ARR_REF_SINGLE:
- array_offset_src = ref->u.a.dim[src_dim].s.start;
- 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, src_type);
- return;
- /* The OPEN_* are mapped to a RANGE and therefore cannot occur. */
- case CAF_ARR_REF_OPEN_END:
- case CAF_ARR_REF_OPEN_START:
- default:
- caf_runtime_error (unreachable);
- }
- return;
- default:
- caf_runtime_error (unreachable);
- }
-}
-
-/* For internal use only. */
-static void
-_gfortran_caf_get_by_ref (caf_token_t token,
- int image_index __attribute__ ((unused)),
- 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, int src_type)
-{
- const char vecrefunknownkind[] = "libcaf_single::caf_get_by_ref(): "
- "unknown kind in vector-ref.\n";
- const char unknownreftype[] = "libcaf_single::caf_get_by_ref(): "
- "unknown reference type.\n";
- const char unknownarrreftype[] = "libcaf_single::caf_get_by_ref(): "
- "unknown array reference type.\n";
- const char rankoutofrange[] = "libcaf_single::caf_get_by_ref(): "
- "rank out of range.\n";
- const char extentoutofrange[] = "libcaf_single::caf_get_by_ref(): "
- "extent out of range.\n";
- const char cannotallocdst[] = "libcaf_single::caf_get_by_ref(): "
- "cannot allocate memory.\n";
- const char nonallocextentmismatch[] = "libcaf_single::caf_get_by_ref(): "
- "extent of non-allocatable arrays mismatch (%lu != %lu).\n";
- const char doublearrayref[] = "libcaf_single::caf_get_by_ref(): "
- "two or more array part references are not supported.\n";
- size_t size, i;
- size_t dst_index[GFC_MAX_DIMENSIONS];
- int dst_rank = GFC_DESCRIPTOR_RANK (dst);
- int dst_cur_dim = 0;
- size_t src_size = 0;
- caf_single_token_t single_token = TOKEN (token);
- void *memptr = single_token->memptr;
- gfc_descriptor_t *src = single_token->desc;
- caf_reference_t *riter = refs;
- long delta;
- /* Reallocation of dst.data is needed (e.g., array to small). */
- bool realloc_needed;
- /* Reallocation of dst.data is required, because data is not alloced at
- all. */
- bool realloc_required;
- bool extent_mismatch = false;
- /* Set when the first non-scalar array reference is encountered. */
- bool in_array_ref = false;
- bool array_extent_fixed = false;
- realloc_needed = realloc_required = GFC_DESCRIPTOR_DATA (dst) == NULL;
-
- assert (!realloc_needed || dst_reallocatable);
-
- if (stat)
- *stat = 0;
-
- /* Compute the size of the result. In the beginning size just counts the
- number of elements. */
- size = 1;
- while (riter)
- {
- switch (riter->type)
- {
- case CAF_REF_COMPONENT:
- if (riter->u.c.caf_token_offset)
- {
- single_token = *(caf_single_token_t*)
- (memptr + riter->u.c.caf_token_offset);
- memptr = single_token->memptr;
- src = single_token->desc;
- }
- else
- {
- memptr += riter->u.c.offset;
- /* 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:
- for (i = 0; riter->u.a.mode[i] != CAF_ARR_REF_NONE; ++i)
- {
- switch (riter->u.a.mode[i])
- {
- case CAF_ARR_REF_VECTOR:
- delta = riter->u.a.dim[i].v.nvec;
-#define KINDCASE(kind, type) case kind: \
- memptr += (((index_type) \
- ((type *)riter->u.a.dim[i].v.vector)[0]) \
- - GFC_DIMENSION_LBOUND (src->dim[i])) \
- * GFC_DIMENSION_STRIDE (src->dim[i]) \
- * riter->item_size; \
- break
-
- switch (riter->u.a.dim[i].v.kind)
- {
- KINDCASE (1, GFC_INTEGER_1);
- KINDCASE (2, GFC_INTEGER_2);
- KINDCASE (4, GFC_INTEGER_4);
-#ifdef HAVE_GFC_INTEGER_8
- KINDCASE (8, GFC_INTEGER_8);
-#endif
-#ifdef HAVE_GFC_INTEGER_16
- KINDCASE (16, GFC_INTEGER_16);
-#endif
- default:
- caf_internal_error (vecrefunknownkind, stat, NULL, 0);
- return;
- }
-#undef KINDCASE
- break;
- case CAF_ARR_REF_FULL:
- COMPUTE_NUM_ITEMS (delta,
- riter->u.a.dim[i].s.stride,
- GFC_DIMENSION_LBOUND (src->dim[i]),
- GFC_DIMENSION_UBOUND (src->dim[i]));
- /* The memptr stays unchanged when ref'ing the first element
- in a dimension. */
- break;
- case CAF_ARR_REF_RANGE:
- COMPUTE_NUM_ITEMS (delta,
- riter->u.a.dim[i].s.stride,
- riter->u.a.dim[i].s.start,
- riter->u.a.dim[i].s.end);
- memptr += (riter->u.a.dim[i].s.start
- - GFC_DIMENSION_LBOUND (src->dim[i]))
- * GFC_DIMENSION_STRIDE (src->dim[i])
- * riter->item_size;
- break;
- case CAF_ARR_REF_SINGLE:
- delta = 1;
- memptr += (riter->u.a.dim[i].s.start
- - GFC_DIMENSION_LBOUND (src->dim[i]))
- * GFC_DIMENSION_STRIDE (src->dim[i])
- * riter->item_size;
- break;
- case CAF_ARR_REF_OPEN_END:
- COMPUTE_NUM_ITEMS (delta,
- riter->u.a.dim[i].s.stride,
- riter->u.a.dim[i].s.start,
- GFC_DIMENSION_UBOUND (src->dim[i]));
- memptr += (riter->u.a.dim[i].s.start
- - GFC_DIMENSION_LBOUND (src->dim[i]))
- * GFC_DIMENSION_STRIDE (src->dim[i])
- * riter->item_size;
- break;
- case CAF_ARR_REF_OPEN_START:
- COMPUTE_NUM_ITEMS (delta,
- riter->u.a.dim[i].s.stride,
- GFC_DIMENSION_LBOUND (src->dim[i]),
- riter->u.a.dim[i].s.end);
- /* The memptr stays unchanged when ref'ing the first element
- in a dimension. */
- break;
- default:
- caf_internal_error (unknownarrreftype, stat, NULL, 0);
- return;
- }
- if (delta <= 0)
- return;
- /* Check the various properties of the destination array.
- Is an array expected and present? */
- if (delta > 1 && dst_rank == 0)
- {
- /* No, an array is required, but not provided. */
- 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)
- {
- /* Check that dst_cur_dim is valid for dst. Can be
- superceeded only by scalar data. */
- if (dst_cur_dim >= dst_rank && delta != 1)
- {
- caf_internal_error (rankoutofrange, stat, NULL, 0);
- return;
- }
- /* Do further checks, when the source is not scalar. */
- else if (delta != 1)
- {
- /* Check that the extent is not scalar and we are not in
- an array ref for the dst side. */
- if (!in_array_ref)
- {
- /* Check that this is the non-scalar extent. */
- if (!array_extent_fixed)
- {
- /* In an array extent now. */
- in_array_ref = true;
- /* Check that we haven't skipped any scalar
- dimensions yet and that the dst is
- compatible. */
- if (i > 0
- && dst_rank == GFC_DESCRIPTOR_RANK (src))
- {
- if (dst_reallocatable)
- {
- /* Dst is reallocatable, which means that
- the bounds are not set. Set them. */
- for (dst_cur_dim= 0; dst_cur_dim < (int)i;
- ++dst_cur_dim)
- GFC_DIMENSION_SET (dst->dim[dst_cur_dim],
- 1, 1, 1);
- }
- else
- dst_cur_dim = i;
- }
- /* Else press thumbs, that there are enough
- dimensional refs to come. Checked below. */
- }
- else
- {
- caf_internal_error (doublearrayref, stat, NULL,
- 0);
- return;
- }
- }
- /* When the realloc is required, then no extent may have
- been set. */
- extent_mismatch = realloc_required
- || GFC_DESCRIPTOR_EXTENT (dst, dst_cur_dim) != delta;
- /* When it already known, that a realloc is needed or
- the extent does not match the needed one. */
- if (realloc_required || realloc_needed
- || extent_mismatch)
- {
- /* Check whether dst is reallocatable. */
- if (unlikely (!dst_reallocatable))
- {
- caf_internal_error (nonallocextentmismatch, stat,
- NULL, 0, delta,
- GFC_DESCRIPTOR_EXTENT (dst,
- dst_cur_dim));
- return;
- }
- /* Only report an error, when the extent needs to be
- modified, which is not allowed. */
- else if (!dst_reallocatable && extent_mismatch)
- {
- caf_internal_error (extentoutofrange, stat, NULL,
- 0);
- return;
- }
- realloc_needed = true;
- }
- /* Only change the extent when it does not match. This is
- to prevent resetting given array bounds. */
- if (extent_mismatch)
- GFC_DIMENSION_SET (dst->dim[dst_cur_dim], 1, delta,
- size);
- }
-
- /* Only increase the dim counter, when in an array ref. */
- if (in_array_ref && dst_cur_dim < dst_rank)
- ++dst_cur_dim;
- }
- size *= (index_type)delta;
- }
- if (in_array_ref)
- {
- array_extent_fixed = true;
- in_array_ref = false;
- /* Check, if we got less dimensional refs than the rank of dst
- expects. */
- assert (dst_cur_dim == GFC_DESCRIPTOR_RANK (dst));
- }
- break;
- case CAF_REF_STATIC_ARRAY:
- for (i = 0; riter->u.a.mode[i] != CAF_ARR_REF_NONE; ++i)
- {
- switch (riter->u.a.mode[i])
- {
- case CAF_ARR_REF_VECTOR:
- delta = riter->u.a.dim[i].v.nvec;
-#define KINDCASE(kind, type) case kind: \
- memptr += ((type *)riter->u.a.dim[i].v.vector)[0] \
- * riter->item_size; \
- break
-
- switch (riter->u.a.dim[i].v.kind)
- {
- KINDCASE (1, GFC_INTEGER_1);
- KINDCASE (2, GFC_INTEGER_2);
- KINDCASE (4, GFC_INTEGER_4);
-#ifdef HAVE_GFC_INTEGER_8
- KINDCASE (8, GFC_INTEGER_8);
-#endif
-#ifdef HAVE_GFC_INTEGER_16
- KINDCASE (16, GFC_INTEGER_16);
-#endif
- default:
- caf_internal_error (vecrefunknownkind, stat, NULL, 0);
- return;
- }
-#undef KINDCASE
- break;
- case CAF_ARR_REF_FULL:
- delta = riter->u.a.dim[i].s.end / riter->u.a.dim[i].s.stride
- + 1;
- /* The memptr stays unchanged when ref'ing the first element
- in a dimension. */
- break;
- case CAF_ARR_REF_RANGE:
- COMPUTE_NUM_ITEMS (delta,
- riter->u.a.dim[i].s.stride,
- riter->u.a.dim[i].s.start,
- riter->u.a.dim[i].s.end);
- memptr += riter->u.a.dim[i].s.start
- * riter->u.a.dim[i].s.stride
- * riter->item_size;
- break;
- case CAF_ARR_REF_SINGLE:
- delta = 1;
- memptr += riter->u.a.dim[i].s.start
- * riter->u.a.dim[i].s.stride
- * riter->item_size;
- break;
- case CAF_ARR_REF_OPEN_END:
- /* This and OPEN_START are mapped to a RANGE and therefore
- cannot occur here. */
- case CAF_ARR_REF_OPEN_START:
- default:
- caf_internal_error (unknownarrreftype, stat, NULL, 0);
- return;
- }
- if (delta <= 0)
- return;
- /* Check the various properties of the destination array.
- Is an array expected and present? */
- if (delta > 1 && dst_rank == 0)
- {
- /* No, an array is required, but not provided. */
- 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)
- {
- /* Check that dst_cur_dim is valid for dst. Can be
- superceeded only by scalar data. */
- if (dst_cur_dim >= dst_rank && delta != 1)
- {
- caf_internal_error (rankoutofrange, stat, NULL, 0);
- return;
- }
- /* Do further checks, when the source is not scalar. */
- else if (delta != 1)
- {
- /* Check that the extent is not scalar and we are not in
- an array ref for the dst side. */
- if (!in_array_ref)
- {
- /* Check that this is the non-scalar extent. */
- if (!array_extent_fixed)
- {
- /* In an array extent now. */
- in_array_ref = true;
- /* The dst is not reallocatable, so nothing more
- to do, then correct the dim counter. */
- dst_cur_dim = i;
- }
- else
- {
- caf_internal_error (doublearrayref, stat, NULL,
- 0);
- return;
- }
- }
- /* When the realloc is required, then no extent may have
- been set. */
- extent_mismatch = realloc_required
- || GFC_DESCRIPTOR_EXTENT (dst, dst_cur_dim) != delta;
- /* When it is already known, that a realloc is needed or
- the extent does not match the needed one. */
- if (realloc_required || realloc_needed
- || extent_mismatch)
- {
- /* Check whether dst is reallocatable. */
- if (unlikely (!dst_reallocatable))
- {
- caf_internal_error (nonallocextentmismatch, stat,
- NULL, 0, delta,
- GFC_DESCRIPTOR_EXTENT (dst,
- dst_cur_dim));
- return;
- }
- /* Only report an error, when the extent needs to be
- modified, which is not allowed. */
- else if (!dst_reallocatable && extent_mismatch)
- {
- caf_internal_error (extentoutofrange, stat, NULL,
- 0);
- return;
- }
- realloc_needed = true;
- }
- /* Only change the extent when it does not match. This is
- to prevent resetting given array bounds. */
- if (extent_mismatch)
- GFC_DIMENSION_SET (dst->dim[dst_cur_dim], 1, delta,
- size);
- }
- /* Only increase the dim counter, when in an array ref. */
- if (in_array_ref && dst_cur_dim < dst_rank)
- ++dst_cur_dim;
- }
- size *= (index_type)delta;
- }
- if (in_array_ref)
- {
- array_extent_fixed = true;
- in_array_ref = false;
- /* Check, if we got less dimensional refs than the rank of dst
- expects. */
- assert (dst_cur_dim == GFC_DESCRIPTOR_RANK (dst));
- }
- break;
- default:
- caf_internal_error (unknownreftype, stat, NULL, 0);
- return;
- }
- src_size = riter->item_size;
- riter = riter->next;
- }
- if (size == 0 || src_size == 0)
- return;
- /* Postcondition:
- - size contains the number of elements to store in the destination array,
- - src_size gives the size in bytes of each item in the destination array.
- */
-
- if (realloc_needed)
- {
- 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);
- }
-
- GFC_DESCRIPTOR_DATA (dst) = malloc (size * GFC_DESCRIPTOR_SIZE (dst));
- if (unlikely (GFC_DESCRIPTOR_DATA (dst) == NULL))
- {
- caf_internal_error (cannotallocdst, stat, NULL, 0);
- return;
- }
- }
-
- /* Reset the token. */
- single_token = TOKEN (token);
- memptr = single_token->memptr;
- src = single_token->desc;
- memset(dst_index, 0, sizeof (dst_index));
- 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, src_type);
-}
-
-
-static void
-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, int dst_type)
-{
- const char vecrefunknownkind[] = "libcaf_single::caf_send_by_ref(): "
- "unknown kind in vector-ref.\n";
- ptrdiff_t extent_dst = 1, array_offset_dst = 0, stride_dst;
- const size_t src_rank = GFC_DESCRIPTOR_RANK (src);
-
- if (unlikely (ref == NULL))
- /* May be we should issue an error here, because this case should not
- occur. */
- return;
-
- if (ref->next == NULL)
- {
- size_t src_size = GFC_DESCRIPTOR_SIZE (src);
- ptrdiff_t array_offset_src = 0;;
-
- switch (ref->type)
- {
- case CAF_REF_COMPONENT:
- if (ref->u.c.caf_token_offset > 0)
- {
- if (*(void**)(ds + ref->u.c.offset) == NULL)
- {
- /* Create a scalar temporary array descriptor. */
- gfc_descriptor_t static_dst;
- GFC_DESCRIPTOR_DATA (&static_dst) = NULL;
- GFC_DESCRIPTOR_DTYPE (&static_dst)
- = GFC_DESCRIPTOR_DTYPE (src);
- /* The component can be allocated now, because it is a
- scalar. */
- _gfortran_caf_register (ref->item_size,
- CAF_REGTYPE_COARRAY_ALLOC,
- ds + ref->u.c.caf_token_offset,
- &static_dst, stat, NULL, 0);
- single_token = *(caf_single_token_t *)
- (ds + ref->u.c.caf_token_offset);
- /* In case of an error in allocation return. When stat is
- NULL, then register_component() terminates on error. */
- if (stat != NULL && *stat)
- return;
- /* Publish the allocated memory. */
- *((void **)(ds + ref->u.c.offset))
- = GFC_DESCRIPTOR_DATA (&static_dst);
- ds = GFC_DESCRIPTOR_DATA (&static_dst);
- /* Set the type from the src. */
- dst_type = GFC_DESCRIPTOR_TYPE (src);
- }
- else
- {
- single_token = *(caf_single_token_t *)
- (ds + ref->u.c.caf_token_offset);
- dst = single_token->desc;
- if (dst)
- {
- ds = GFC_DESCRIPTOR_DATA (dst);
- dst_type = GFC_DESCRIPTOR_TYPE (dst);
- }
- else
- 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_type,
- GFC_DESCRIPTOR_TYPE (src),
- dst_kind, src_kind, ref->item_size, src_size, 1, stat);
- ++(*i);
- return;
- case CAF_REF_STATIC_ARRAY:
- /* Intentionally fall through. */
- case CAF_REF_ARRAY:
- if (ref->u.a.mode[dst_dim] == CAF_ARR_REF_NONE)
- {
- if (src_rank > 0)
- {
- for (size_t d = 0; d < src_rank; ++d)
- array_offset_src += src_index[d];
- 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, GFC_DESCRIPTOR_TYPE (src),
- dst_kind, src_kind, ref->item_size, src_size, num,
- stat);
- *i += num;
- return;
- }
- break;
- default:
- caf_runtime_error (unreachable);
- }
- }
-
- switch (ref->type)
- {
- case CAF_REF_COMPONENT:
- if (ref->u.c.caf_token_offset > 0)
- {
- if (*(void**)(ds + ref->u.c.offset) == NULL)
- {
- /* This component refs an unallocated array. Non-arrays are
- caught in the if (!ref->next) above. */
- dst = (gfc_descriptor_t *)(ds + ref->u.c.offset);
- /* Assume that the rank and the dimensions fit for copying src
- to dst. */
- GFC_DESCRIPTOR_DTYPE (dst) = GFC_DESCRIPTOR_DTYPE (src);
- GFC_DESCRIPTOR_SPAN (dst) = GFC_DESCRIPTOR_SPAN (src);
- stride_dst = 1;
- dst->offset = 0;
- for (size_t d = 0; d < src_rank; ++d)
- {
- extent_dst = GFC_DIMENSION_EXTENT (src->dim[d]);
- GFC_DIMENSION_LBOUND (dst->dim[d]) = 1;
- GFC_DIMENSION_UBOUND (dst->dim[d]) = extent_dst;
- GFC_DIMENSION_STRIDE (dst->dim[d]) = stride_dst;
- dst->offset -= stride_dst;
- stride_dst *= extent_dst;
- }
- /* Null the data-pointer to make register_component allocate
- its own memory. */
- GFC_DESCRIPTOR_DATA (dst) = NULL;
-
- /* The size of the array is given by size. */
- _gfortran_caf_register (size * ref->item_size,
- CAF_REGTYPE_COARRAY_ALLOC,
- ds + ref->u.c.caf_token_offset,
- dst, stat, NULL, 0);
- /* In case of an error in allocation return. When stat is
- NULL, then register_component() terminates on error. */
- if (stat != NULL && *stat)
- 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, 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, 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, dst_type);
- return;
- }
- /* Only when on the left most index switch the data pointer to
- the array's data pointer. And only for non-static arrays. */
- if (dst_dim == 0 && ref->type != CAF_REF_STATIC_ARRAY)
- ds = GFC_DESCRIPTOR_DATA (dst);
- switch (ref->u.a.mode[dst_dim])
- {
- case CAF_ARR_REF_VECTOR:
- array_offset_dst = 0;
- src_index[src_dim] = 0;
- for (size_t idx = 0; idx < ref->u.a.dim[dst_dim].v.nvec;
- ++idx)
- {
-#define KINDCASE(kind, type) case kind: \
- array_offset_dst = (((index_type) \
- ((type *)ref->u.a.dim[dst_dim].v.vector)[idx]) \
- - GFC_DIMENSION_LBOUND (dst->dim[dst_dim])) \
- * GFC_DIMENSION_STRIDE (dst->dim[dst_dim]); \
- break
-
- switch (ref->u.a.dim[dst_dim].v.kind)
- {
- KINDCASE (1, GFC_INTEGER_1);
- KINDCASE (2, GFC_INTEGER_2);
- KINDCASE (4, GFC_INTEGER_4);
-#ifdef HAVE_GFC_INTEGER_8
- KINDCASE (8, GFC_INTEGER_8);
-#endif
-#ifdef HAVE_GFC_INTEGER_16
- KINDCASE (16, GFC_INTEGER_16);
-#endif
- default:
- caf_internal_error (vecrefunknownkind, stat, NULL, 0);
- return;
- }
-#undef KINDCASE
-
- 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, dst_type);
- if (src_rank > 0)
- src_index[src_dim]
- += GFC_DIMENSION_STRIDE (src->dim[src_dim]);
- }
- return;
- case CAF_ARR_REF_FULL:
- COMPUTE_NUM_ITEMS (extent_dst,
- ref->u.a.dim[dst_dim].s.stride,
- GFC_DIMENSION_LBOUND (dst->dim[dst_dim]),
- GFC_DIMENSION_UBOUND (dst->dim[dst_dim]));
- array_offset_dst = 0;
- stride_dst = GFC_DIMENSION_STRIDE (dst->dim[dst_dim])
- * ref->u.a.dim[dst_dim].s.stride;
- src_index[src_dim] = 0;
- for (index_type idx = 0; idx < extent_dst;
- ++idx, array_offset_dst += stride_dst)
- {
- 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, dst_type);
- if (src_rank > 0)
- src_index[src_dim]
- += GFC_DIMENSION_STRIDE (src->dim[src_dim]);
- }
- return;
- case CAF_ARR_REF_RANGE:
- COMPUTE_NUM_ITEMS (extent_dst,
- ref->u.a.dim[dst_dim].s.stride,
- ref->u.a.dim[dst_dim].s.start,
- ref->u.a.dim[dst_dim].s.end);
- array_offset_dst = ref->u.a.dim[dst_dim].s.start
- - GFC_DIMENSION_LBOUND (dst->dim[dst_dim]);
- stride_dst = GFC_DIMENSION_STRIDE (dst->dim[dst_dim])
- * ref->u.a.dim[dst_dim].s.stride;
- src_index[src_dim] = 0;
- for (index_type idx = 0; idx < extent_dst; ++idx)
- {
- 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, dst_type);
- if (src_rank > 0)
- src_index[src_dim]
- += GFC_DIMENSION_STRIDE (src->dim[src_dim]);
- array_offset_dst += stride_dst;
- }
- return;
- case CAF_ARR_REF_SINGLE:
- array_offset_dst = (ref->u.a.dim[dst_dim].s.start
- - GFC_DIMENSION_LBOUND (dst->dim[dst_dim]))
- * GFC_DIMENSION_STRIDE (dst->dim[dst_dim]);
- 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, dst_type);
- return;
- case CAF_ARR_REF_OPEN_END:
- COMPUTE_NUM_ITEMS (extent_dst,
- ref->u.a.dim[dst_dim].s.stride,
- ref->u.a.dim[dst_dim].s.start,
- GFC_DIMENSION_UBOUND (dst->dim[dst_dim]));
- array_offset_dst = ref->u.a.dim[dst_dim].s.start
- - GFC_DIMENSION_LBOUND (dst->dim[dst_dim]);
- stride_dst = GFC_DIMENSION_STRIDE (dst->dim[dst_dim])
- * ref->u.a.dim[dst_dim].s.stride;
- src_index[src_dim] = 0;
- for (index_type idx = 0; idx < extent_dst; ++idx)
- {
- 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, dst_type);
- if (src_rank > 0)
- src_index[src_dim]
- += GFC_DIMENSION_STRIDE (src->dim[src_dim]);
- array_offset_dst += stride_dst;
- }
- return;
- case CAF_ARR_REF_OPEN_START:
- COMPUTE_NUM_ITEMS (extent_dst,
- ref->u.a.dim[dst_dim].s.stride,
- GFC_DIMENSION_LBOUND (dst->dim[dst_dim]),
- ref->u.a.dim[dst_dim].s.end);
- array_offset_dst = 0;
- stride_dst = GFC_DIMENSION_STRIDE (dst->dim[dst_dim])
- * ref->u.a.dim[dst_dim].s.stride;
- src_index[src_dim] = 0;
- for (index_type idx = 0; idx < extent_dst; ++idx)
- {
- 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, dst_type);
- if (src_rank > 0)
- src_index[src_dim]
- += GFC_DIMENSION_STRIDE (src->dim[src_dim]);
- array_offset_dst += stride_dst;
- }
- return;
- default:
- caf_runtime_error (unreachable);
- }
- return;
- case CAF_REF_STATIC_ARRAY:
- if (ref->u.a.mode[dst_dim] == CAF_ARR_REF_NONE)
- {
- send_by_ref (ref->next, i, src_index, single_token, NULL,
- src, ds, sr, dst_kind, src_kind,
- 0, src_dim, 1, size, stat, dst_type);
- return;
- }
- switch (ref->u.a.mode[dst_dim])
- {
- case CAF_ARR_REF_VECTOR:
- array_offset_dst = 0;
- src_index[src_dim] = 0;
- for (size_t idx = 0; idx < ref->u.a.dim[dst_dim].v.nvec;
- ++idx)
- {
-#define KINDCASE(kind, type) case kind: \
- array_offset_dst = ((type *)ref->u.a.dim[dst_dim].v.vector)[idx]; \
- break
-
- switch (ref->u.a.dim[dst_dim].v.kind)
- {
- KINDCASE (1, GFC_INTEGER_1);
- KINDCASE (2, GFC_INTEGER_2);
- KINDCASE (4, GFC_INTEGER_4);
-#ifdef HAVE_GFC_INTEGER_8
- KINDCASE (8, GFC_INTEGER_8);
-#endif
-#ifdef HAVE_GFC_INTEGER_16
- KINDCASE (16, GFC_INTEGER_16);
-#endif
- default:
- caf_runtime_error (unreachable);
- return;
- }
-#undef KINDCASE
-
- 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, dst_type);
- src_index[src_dim]
- += GFC_DIMENSION_STRIDE (src->dim[src_dim]);
- }
- return;
- case CAF_ARR_REF_FULL:
- src_index[src_dim] = 0;
- for (array_offset_dst = 0 ;
- array_offset_dst <= ref->u.a.dim[dst_dim].s.end;
- array_offset_dst += ref->u.a.dim[dst_dim].s.stride)
- {
- 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, dst_type);
- if (src_rank > 0)
- src_index[src_dim]
- += GFC_DIMENSION_STRIDE (src->dim[src_dim]);
- }
- return;
- case CAF_ARR_REF_RANGE:
- COMPUTE_NUM_ITEMS (extent_dst,
- ref->u.a.dim[dst_dim].s.stride,
- ref->u.a.dim[dst_dim].s.start,
- ref->u.a.dim[dst_dim].s.end);
- array_offset_dst = ref->u.a.dim[dst_dim].s.start;
- src_index[src_dim] = 0;
- for (index_type idx = 0; idx < extent_dst; ++idx)
- {
- 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, dst_type);
- if (src_rank > 0)
- src_index[src_dim]
- += GFC_DIMENSION_STRIDE (src->dim[src_dim]);
- array_offset_dst += ref->u.a.dim[dst_dim].s.stride;
- }
- return;
- case CAF_ARR_REF_SINGLE:
- array_offset_dst = ref->u.a.dim[dst_dim].s.start;
- 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, dst_type);
- return;
- /* The OPEN_* are mapped to a RANGE and therefore cannot occur. */
- case CAF_ARR_REF_OPEN_END:
- case CAF_ARR_REF_OPEN_START:
- default:
- caf_runtime_error (unreachable);
- }
- return;
- default:
- caf_runtime_error (unreachable);
- }
-}
-
-
-void
-_gfortran_caf_send_by_ref (caf_token_t token,
- int image_index __attribute__ ((unused)),
- 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, int dst_type)
-{
- const char vecrefunknownkind[] = "libcaf_single::caf_get_by_ref(): "
- "unknown kind in vector-ref.\n";
- const char unknownreftype[] = "libcaf_single::caf_send_by_ref(): "
- "unknown reference type.\n";
- const char unknownarrreftype[] = "libcaf_single::caf_send_by_ref(): "
- "unknown array reference type.\n";
- const char rankoutofrange[] = "libcaf_single::caf_send_by_ref(): "
- "rank out of range.\n";
- const char realloconinnerref[] = "libcaf_single::caf_send_by_ref(): "
- "reallocation of array followed by component ref not allowed.\n";
- const char cannotallocdst[] = "libcaf_single::caf_send_by_ref(): "
- "cannot allocate memory.\n";
- const char nonallocextentmismatch[] = "libcaf_single::caf_send_by_ref(): "
- "extent of non-allocatable array mismatch.\n";
- const char innercompref[] = "libcaf_single::caf_send_by_ref(): "
- "inner unallocated component detected.\n";
- size_t size, i;
- size_t dst_index[GFC_MAX_DIMENSIONS];
- int src_rank = GFC_DESCRIPTOR_RANK (src);
- int src_cur_dim = 0;
- size_t src_size = 0;
- caf_single_token_t single_token = TOKEN (token);
- void *memptr = single_token->memptr;
- gfc_descriptor_t *dst = single_token->desc;
- caf_reference_t *riter = refs;
- long delta;
- bool extent_mismatch;
- /* Note that the component is not allocated yet. */
- index_type new_component_idx = -1;
-
- if (stat)
- *stat = 0;
-
- /* Compute the size of the result. In the beginning size just counts the
- number of elements. */
- size = 1;
- while (riter)
- {
- switch (riter->type)
- {
- case CAF_REF_COMPONENT:
- if (unlikely (new_component_idx != -1))
- {
- /* Allocating a component in the middle of a component ref is not
- support. We don't know the type to allocate. */
- caf_internal_error (innercompref, stat, NULL, 0);
- return;
- }
- if (riter->u.c.caf_token_offset > 0)
- {
- /* Check whether the allocatable component is zero, then no
- token is present, too. The token's pointer is not cleared
- when the structure is initialized. */
- if (*(void**)(memptr + riter->u.c.offset) == NULL)
- {
- /* This component is not yet allocated. Check that it is
- allocatable here. */
- if (!dst_reallocatable)
- {
- caf_internal_error (cannotallocdst, stat, NULL, 0);
- return;
- }
- single_token = NULL;
- memptr = NULL;
- dst = NULL;
- break;
- }
- single_token = *(caf_single_token_t*)
- (memptr + riter->u.c.caf_token_offset);
- memptr += riter->u.c.offset;
- dst = single_token->desc;
- }
- else
- {
- /* Regular component. */
- memptr += riter->u.c.offset;
- dst = (gfc_descriptor_t *)memptr;
- }
- break;
- case CAF_REF_ARRAY:
- if (dst != NULL)
- memptr = GFC_DESCRIPTOR_DATA (dst);
- else
- dst = src;
- /* When the dst array needs to be allocated, then look at the
- extent of the source array in the dimension dst_cur_dim. */
- for (i = 0; riter->u.a.mode[i] != CAF_ARR_REF_NONE; ++i)
- {
- switch (riter->u.a.mode[i])
- {
- case CAF_ARR_REF_VECTOR:
- delta = riter->u.a.dim[i].v.nvec;
-#define KINDCASE(kind, type) case kind: \
- memptr += (((index_type) \
- ((type *)riter->u.a.dim[i].v.vector)[0]) \
- - GFC_DIMENSION_LBOUND (dst->dim[i])) \
- * GFC_DIMENSION_STRIDE (dst->dim[i]) \
- * riter->item_size; \
- break
-
- switch (riter->u.a.dim[i].v.kind)
- {
- KINDCASE (1, GFC_INTEGER_1);
- KINDCASE (2, GFC_INTEGER_2);
- KINDCASE (4, GFC_INTEGER_4);
-#ifdef HAVE_GFC_INTEGER_8
- KINDCASE (8, GFC_INTEGER_8);
-#endif
-#ifdef HAVE_GFC_INTEGER_16
- KINDCASE (16, GFC_INTEGER_16);
-#endif
- default:
- caf_internal_error (vecrefunknownkind, stat, NULL, 0);
- return;
- }
-#undef KINDCASE
- break;
- case CAF_ARR_REF_FULL:
- if (dst)
- COMPUTE_NUM_ITEMS (delta,
- riter->u.a.dim[i].s.stride,
- GFC_DIMENSION_LBOUND (dst->dim[i]),
- GFC_DIMENSION_UBOUND (dst->dim[i]));
- else
- COMPUTE_NUM_ITEMS (delta,
- riter->u.a.dim[i].s.stride,
- GFC_DIMENSION_LBOUND (src->dim[src_cur_dim]),
- GFC_DIMENSION_UBOUND (src->dim[src_cur_dim]));
- break;
- case CAF_ARR_REF_RANGE:
- COMPUTE_NUM_ITEMS (delta,
- riter->u.a.dim[i].s.stride,
- riter->u.a.dim[i].s.start,
- riter->u.a.dim[i].s.end);
- memptr += (riter->u.a.dim[i].s.start
- - dst->dim[i].lower_bound)
- * GFC_DIMENSION_STRIDE (dst->dim[i])
- * riter->item_size;
- break;
- case CAF_ARR_REF_SINGLE:
- delta = 1;
- memptr += (riter->u.a.dim[i].s.start
- - dst->dim[i].lower_bound)
- * GFC_DIMENSION_STRIDE (dst->dim[i])
- * riter->item_size;
- break;
- case CAF_ARR_REF_OPEN_END:
- if (dst)
- COMPUTE_NUM_ITEMS (delta,
- riter->u.a.dim[i].s.stride,
- riter->u.a.dim[i].s.start,
- GFC_DIMENSION_UBOUND (dst->dim[i]));
- else
- COMPUTE_NUM_ITEMS (delta,
- riter->u.a.dim[i].s.stride,
- riter->u.a.dim[i].s.start,
- GFC_DIMENSION_UBOUND (src->dim[src_cur_dim]));
- memptr += (riter->u.a.dim[i].s.start
- - dst->dim[i].lower_bound)
- * GFC_DIMENSION_STRIDE (dst->dim[i])
- * riter->item_size;
- break;
- case CAF_ARR_REF_OPEN_START:
- if (dst)
- COMPUTE_NUM_ITEMS (delta,
- riter->u.a.dim[i].s.stride,
- GFC_DIMENSION_LBOUND (dst->dim[i]),
- riter->u.a.dim[i].s.end);
- else
- COMPUTE_NUM_ITEMS (delta,
- riter->u.a.dim[i].s.stride,
- GFC_DIMENSION_LBOUND (src->dim[src_cur_dim]),
- riter->u.a.dim[i].s.end);
- /* The memptr stays unchanged when ref'ing the first element
- in a dimension. */
- break;
- default:
- caf_internal_error (unknownarrreftype, stat, NULL, 0);
- return;
- }
-
- if (delta <= 0)
- return;
- /* Check the various properties of the source array.
- When src is an array. */
- if (delta > 1 && src_rank > 0)
- {
- /* Check that src_cur_dim is valid for src. Can be
- superceeded only by scalar data. */
- if (src_cur_dim >= src_rank)
- {
- caf_internal_error (rankoutofrange, stat, NULL, 0);
- return;
- }
- /* Do further checks, when the source is not scalar. */
- else
- {
- /* When the realloc is required, then no extent may have
- been set. */
- extent_mismatch = memptr == NULL
- || (dst
- && GFC_DESCRIPTOR_EXTENT (dst, src_cur_dim)
- != delta);
- /* When it already known, that a realloc is needed or
- the extent does not match the needed one. */
- if (extent_mismatch)
- {
- /* Check whether dst is reallocatable. */
- if (unlikely (!dst_reallocatable))
- {
- caf_internal_error (nonallocextentmismatch, stat,
- NULL, 0, delta,
- GFC_DESCRIPTOR_EXTENT (dst,
- src_cur_dim));
- return;
- }
- /* Report error on allocatable but missing inner
- ref. */
- else if (riter->next != NULL)
- {
- caf_internal_error (realloconinnerref, stat, NULL,
- 0);
- return;
- }
- }
- /* Only change the extent when it does not match. This is
- to prevent resetting given array bounds. */
- if (extent_mismatch)
- GFC_DIMENSION_SET (dst->dim[src_cur_dim], 1, delta,
- size);
- }
- /* Increase the dim-counter of the src only when the extent
- matches. */
- if (src_cur_dim < src_rank
- && GFC_DESCRIPTOR_EXTENT (src, src_cur_dim) == delta)
- ++src_cur_dim;
- }
- size *= (index_type)delta;
- }
- break;
- case CAF_REF_STATIC_ARRAY:
- for (i = 0; riter->u.a.mode[i] != CAF_ARR_REF_NONE; ++i)
- {
- switch (riter->u.a.mode[i])
- {
- case CAF_ARR_REF_VECTOR:
- delta = riter->u.a.dim[i].v.nvec;
-#define KINDCASE(kind, type) case kind: \
- memptr += ((type *)riter->u.a.dim[i].v.vector)[0] \
- * riter->item_size; \
- break
-
- switch (riter->u.a.dim[i].v.kind)
- {
- KINDCASE (1, GFC_INTEGER_1);
- KINDCASE (2, GFC_INTEGER_2);
- KINDCASE (4, GFC_INTEGER_4);
-#ifdef HAVE_GFC_INTEGER_8
- KINDCASE (8, GFC_INTEGER_8);
-#endif
-#ifdef HAVE_GFC_INTEGER_16
- KINDCASE (16, GFC_INTEGER_16);
-#endif
- default:
- caf_internal_error (vecrefunknownkind, stat, NULL, 0);
- return;
- }
-#undef KINDCASE
- break;
- case CAF_ARR_REF_FULL:
- delta = riter->u.a.dim[i].s.end / riter->u.a.dim[i].s.stride
- + 1;
- /* The memptr stays unchanged when ref'ing the first element
- in a dimension. */
- break;
- case CAF_ARR_REF_RANGE:
- COMPUTE_NUM_ITEMS (delta,
- riter->u.a.dim[i].s.stride,
- riter->u.a.dim[i].s.start,
- riter->u.a.dim[i].s.end);
- memptr += riter->u.a.dim[i].s.start
- * riter->u.a.dim[i].s.stride
- * riter->item_size;
- break;
- case CAF_ARR_REF_SINGLE:
- delta = 1;
- memptr += riter->u.a.dim[i].s.start
- * riter->u.a.dim[i].s.stride
- * riter->item_size;
- break;
- case CAF_ARR_REF_OPEN_END:
- /* This and OPEN_START are mapped to a RANGE and therefore
- cannot occur here. */
- case CAF_ARR_REF_OPEN_START:
- default:
- caf_internal_error (unknownarrreftype, stat, NULL, 0);
- return;
- }
- if (delta <= 0)
- return;
- /* Check the various properties of the source array.
- Only when the source array is not scalar examine its
- properties. */
- if (delta > 1 && src_rank > 0)
- {
- /* Check that src_cur_dim is valid for src. Can be
- superceeded only by scalar data. */
- if (src_cur_dim >= src_rank)
- {
- caf_internal_error (rankoutofrange, stat, NULL, 0);
- return;
- }
- else
- {
- /* We will not be able to realloc the dst, because that's
- a fixed size array. */
- extent_mismatch = GFC_DESCRIPTOR_EXTENT (src, src_cur_dim)
- != delta;
- /* When the extent does not match the needed one we can
- only stop here. */
- if (extent_mismatch)
- {
- caf_internal_error (nonallocextentmismatch, stat,
- NULL, 0, delta,
- GFC_DESCRIPTOR_EXTENT (src,
- src_cur_dim));
- return;
- }
- }
- ++src_cur_dim;
- }
- size *= (index_type)delta;
- }
- break;
- default:
- caf_internal_error (unknownreftype, stat, NULL, 0);
- return;
- }
- src_size = riter->item_size;
- riter = riter->next;
- }
- if (size == 0 || src_size == 0)
- return;
- /* Postcondition:
- - size contains the number of elements to store in the destination array,
- - src_size gives the size in bytes of each item in the destination array.
- */
-
- /* Reset the token. */
- single_token = TOKEN (token);
- memptr = single_token->memptr;
- dst = single_token->desc;
- memset (dst_index, 0, sizeof (dst_index));
- 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, dst_type);
- assert (i == size);
-}
-
-
-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_type, int src_type)
-{
- 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,
- (gfc_descriptor_t *) &temp, src_refs,
- dst_kind, src_kind, may_require_tmp, true,
- src_stat, src_type);
-
- if (src_stat && *src_stat != 0)
- return;
-
- _gfortran_caf_send_by_ref (dst_token, dst_image_index,
- (gfc_descriptor_t *) &temp, dst_refs,
- dst_kind, dst_kind, may_require_tmp, true,
- dst_stat, dst_type);
- if (GFC_DESCRIPTOR_DATA (&temp))
- free (GFC_DESCRIPTOR_DATA (&temp));
-}
-
void
_gfortran_caf_register_accessor (const int hash, getter_t accessor)
{
--
2.48.1