/* Single-image implementation of GNU Fortran Coarray Library
- Copyright (C) 2011-2018 Free Software Foundation, Inc.
+ Copyright (C) 2011-2019 Free Software Foundation, Inc.
Contributed by Tobias Burnus <burnus@net-b.de>
This file is part of the GNU Fortran Coarray Runtime Library (libcaf).
#include <stdlib.h> /* For exit and malloc. */
#include <string.h> /* For memcpy and memset. */
#include <stdarg.h> /* For variadic arguments. */
+#include <stdint.h>
#include <assert.h>
/* Define GFC_CAF_CHECK to enable run-time checking. */
/* Error handling is similar everytime. */
static void
caf_internal_error (const char *msg, int *stat, char *errmsg,
- int errmsg_len, ...)
+ size_t errmsg_len, ...)
{
va_list args;
va_start (args, errmsg_len);
*stat = 1;
if (errmsg_len > 0)
{
- size_t len = snprintf (errmsg, errmsg_len, msg, args);
- if ((size_t)errmsg_len > len)
+ int len = snprintf (errmsg, errmsg_len, msg, args);
+ if (len >= 0 && errmsg_len > (size_t) len)
memset (&errmsg[len], ' ', errmsg_len - len);
}
va_end (args);
void
_gfortran_caf_register (size_t size, caf_register_t type, caf_token_t *token,
gfc_descriptor_t *data, int *stat, char *errmsg,
- int errmsg_len)
+ size_t errmsg_len)
{
const char alloc_fail_msg[] = "Failed to allocate coarray";
void *local;
void
_gfortran_caf_deregister (caf_token_t *token, caf_deregister_t type, int *stat,
char *errmsg __attribute__ ((unused)),
- int errmsg_len __attribute__ ((unused)))
+ size_t errmsg_len __attribute__ ((unused)))
{
caf_single_token_t single_token = TOKEN (*token);
void
_gfortran_caf_sync_all (int *stat,
char *errmsg __attribute__ ((unused)),
- int errmsg_len __attribute__ ((unused)))
+ size_t errmsg_len __attribute__ ((unused)))
{
__asm__ __volatile__ ("":::"memory");
if (stat)
void
_gfortran_caf_sync_memory (int *stat,
char *errmsg __attribute__ ((unused)),
- int errmsg_len __attribute__ ((unused)))
+ size_t errmsg_len __attribute__ ((unused)))
{
__asm__ __volatile__ ("":::"memory");
if (stat)
int images[] __attribute__ ((unused)),
int *stat,
char *errmsg __attribute__ ((unused)),
- int errmsg_len __attribute__ ((unused)))
+ size_t errmsg_len __attribute__ ((unused)))
{
#ifdef GFC_CAF_CHECK
int i;
void
-_gfortran_caf_stop_numeric(int32_t stop_code)
+_gfortran_caf_stop_numeric(int stop_code, bool quiet)
{
- fprintf (stderr, "STOP %d\n", stop_code);
+ if (!quiet)
+ fprintf (stderr, "STOP %d\n", stop_code);
exit (0);
}
void
-_gfortran_caf_stop_str(const char *string, int32_t len)
+_gfortran_caf_stop_str(const char *string, size_t len, bool quiet)
{
- fputs ("STOP ", stderr);
- while (len--)
- fputc (*(string++), stderr);
- fputs ("\n", stderr);
-
+ if (!quiet)
+ {
+ fputs ("STOP ", stderr);
+ while (len--)
+ fputc (*(string++), stderr);
+ fputs ("\n", stderr);
+ }
exit (0);
}
void
-_gfortran_caf_error_stop_str (const char *string, int32_t len)
+_gfortran_caf_error_stop_str (const char *string, size_t len, bool quiet)
{
- fputs ("ERROR STOP ", stderr);
- while (len--)
- fputc (*(string++), stderr);
- fputs ("\n", stderr);
-
+ if (!quiet)
+ {
+ fputs ("ERROR STOP ", stderr);
+ while (len--)
+ fputc (*(string++), stderr);
+ fputs ("\n", stderr);
+ }
exit (1);
}
}
-/* Single image library. There can not be any failed images with only one
+/* Single image library. There cannot be any failed images with only one
image. */
void
void
-_gfortran_caf_error_stop (int32_t error)
+_gfortran_caf_error_stop (int error, bool quiet)
{
- fprintf (stderr, "ERROR STOP %d\n", error);
+ if (!quiet)
+ fprintf (stderr, "ERROR STOP %d\n", error);
exit (error);
}
_gfortran_caf_co_broadcast (gfc_descriptor_t *a __attribute__ ((unused)),
int source_image __attribute__ ((unused)),
int *stat, char *errmsg __attribute__ ((unused)),
- int errmsg_len __attribute__ ((unused)))
+ size_t errmsg_len __attribute__ ((unused)))
{
if (stat)
*stat = 0;
_gfortran_caf_co_sum (gfc_descriptor_t *a __attribute__ ((unused)),
int result_image __attribute__ ((unused)),
int *stat, char *errmsg __attribute__ ((unused)),
- int errmsg_len __attribute__ ((unused)))
+ size_t errmsg_len __attribute__ ((unused)))
{
if (stat)
*stat = 0;
int result_image __attribute__ ((unused)),
int *stat, char *errmsg __attribute__ ((unused)),
int a_len __attribute__ ((unused)),
- int errmsg_len __attribute__ ((unused)))
+ size_t errmsg_len __attribute__ ((unused)))
{
if (stat)
*stat = 0;
int result_image __attribute__ ((unused)),
int *stat, char *errmsg __attribute__ ((unused)),
int a_len __attribute__ ((unused)),
- int errmsg_len __attribute__ ((unused)))
+ size_t errmsg_len __attribute__ ((unused)))
{
if (stat)
*stat = 0;
int result_image __attribute__ ((unused)),
int *stat, char *errmsg __attribute__ ((unused)),
int a_len __attribute__ ((unused)),
- int errmsg_len __attribute__ ((unused)))
+ size_t errmsg_len __attribute__ ((unused)))
{
if (stat)
*stat = 0;
caf_single_token_t single_token, gfc_descriptor_t *dst,
gfc_descriptor_t *src, void *ds, void *sr,
int dst_kind, int src_kind, size_t dst_dim, size_t src_dim,
- size_t num, int *stat)
+ size_t num, int *stat, int src_type)
{
ptrdiff_t extent_src = 1, array_offset_src = 0, stride_src;
size_t next_dst_dim;
size_t dst_size = GFC_DESCRIPTOR_SIZE (dst);
ptrdiff_t array_offset_dst = 0;;
size_t dst_rank = GFC_DESCRIPTOR_RANK (dst);
- int src_type = -1;
switch (ref->type)
{
case CAF_REF_COMPONENT:
/* Because the token is always registered after the component, its
- offset is always greater zeor. */
+ offset is always greater zero. */
if (ref->u.c.caf_token_offset > 0)
+ /* Note, that sr is dereffed here. */
copy_data (ds, *(void **)(sr + ref->u.c.offset),
- GFC_DESCRIPTOR_TYPE (dst), GFC_DESCRIPTOR_TYPE (dst),
+ GFC_DESCRIPTOR_TYPE (dst), src_type,
dst_kind, src_kind, dst_size, ref->item_size, 1, stat);
else
copy_data (ds, sr + ref->u.c.offset,
- GFC_DESCRIPTOR_TYPE (dst), GFC_DESCRIPTOR_TYPE (src),
+ GFC_DESCRIPTOR_TYPE (dst), src_type,
dst_kind, src_kind, dst_size, ref->item_size, 1, stat);
++(*i);
return;
case CAF_REF_STATIC_ARRAY:
- src_type = ref->u.a.static_array_type;
/* Intentionally fall through. */
case CAF_REF_ARRAY:
if (ref->u.a.mode[src_dim] == CAF_ARR_REF_NONE)
for (size_t d = 0; d < dst_rank; ++d)
array_offset_dst += dst_index[d];
copy_data (ds + array_offset_dst * dst_size, sr,
- GFC_DESCRIPTOR_TYPE (dst),
- src_type == -1 ? GFC_DESCRIPTOR_TYPE (src) : src_type,
+ GFC_DESCRIPTOR_TYPE (dst), src_type,
dst_kind, src_kind, dst_size, ref->item_size, num,
stat);
*i += num;
{
case CAF_REF_COMPONENT:
if (ref->u.c.caf_token_offset > 0)
- get_for_ref (ref->next, i, dst_index,
- *(caf_single_token_t*)(sr + ref->u.c.caf_token_offset), dst,
- (*(caf_single_token_t*)(sr + ref->u.c.caf_token_offset))->desc,
- ds, sr + ref->u.c.offset, dst_kind, src_kind, dst_dim, 0,
- 1, stat);
+ {
+ single_token = *(caf_single_token_t*)(sr + ref->u.c.caf_token_offset);
+
+ if (ref->next && ref->next->type == CAF_REF_ARRAY)
+ src = single_token->desc;
+ else
+ src = NULL;
+
+ if (ref->next && ref->next->type == CAF_REF_COMPONENT)
+ /* The currently ref'ed component was allocatabe (caf_token_offset
+ > 0) and the next ref is a component, too, then the new sr has to
+ be dereffed. (static arrays 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);
+ stat, src_type);
return;
case CAF_REF_ARRAY:
if (ref->u.a.mode[src_dim] == CAF_ARR_REF_NONE)
{
get_for_ref (ref->next, i, dst_index, single_token, dst,
src, ds, sr, dst_kind, src_kind,
- dst_dim, 0, 1, stat);
+ dst_dim, 0, 1, stat, src_type);
return;
}
/* Only when on the left most index switch the data pointer to
get_for_ref (ref, i, dst_index, single_token, dst, src,
ds, sr + array_offset_src * ref->item_size,
dst_kind, src_kind, dst_dim + 1, src_dim + 1,
- 1, stat);
+ 1, stat, src_type);
dst_index[dst_dim]
+= GFC_DIMENSION_STRIDE (dst->dim[dst_dim]);
}
get_for_ref (ref, i, dst_index, single_token, dst, src,
ds, sr + array_offset_src * ref->item_size,
dst_kind, src_kind, dst_dim + 1, src_dim + 1,
- 1, stat);
+ 1, stat, src_type);
dst_index[dst_dim]
+= GFC_DIMENSION_STRIDE (dst->dim[dst_dim]);
}
get_for_ref (ref, i, dst_index, single_token, dst, src,
ds, sr + array_offset_src * ref->item_size,
dst_kind, src_kind, next_dst_dim, src_dim + 1,
- 1, stat);
+ 1, stat, src_type);
dst_index[dst_dim]
+= GFC_DIMENSION_STRIDE (dst->dim[dst_dim]);
array_offset_src += stride_src;
get_for_ref (ref, i, dst_index, single_token, dst, src, ds,
sr + array_offset_src * ref->item_size,
dst_kind, src_kind, dst_dim, src_dim + 1, 1,
- stat);
+ stat, src_type);
return;
case CAF_ARR_REF_OPEN_END:
COMPUTE_NUM_ITEMS (extent_src,
get_for_ref (ref, i, dst_index, single_token, dst, src,
ds, sr + array_offset_src * ref->item_size,
dst_kind, src_kind, dst_dim + 1, src_dim + 1,
- 1, stat);
+ 1, stat, src_type);
dst_index[dst_dim]
+= GFC_DIMENSION_STRIDE (dst->dim[dst_dim]);
array_offset_src += stride_src;
get_for_ref (ref, i, dst_index, single_token, dst, src,
ds, sr + array_offset_src * ref->item_size,
dst_kind, src_kind, dst_dim + 1, src_dim + 1,
- 1, stat);
+ 1, stat, src_type);
dst_index[dst_dim]
+= GFC_DIMENSION_STRIDE (dst->dim[dst_dim]);
array_offset_src += stride_src;
{
get_for_ref (ref->next, i, dst_index, single_token, dst,
NULL, ds, sr, dst_kind, src_kind,
- dst_dim, 0, 1, stat);
+ dst_dim, 0, 1, stat, src_type);
return;
}
switch (ref->u.a.mode[src_dim])
get_for_ref (ref, i, dst_index, single_token, dst, NULL,
ds, sr + array_offset_src * ref->item_size,
dst_kind, src_kind, dst_dim + 1, src_dim + 1,
- 1, stat);
+ 1, stat, src_type);
dst_index[dst_dim]
+= GFC_DIMENSION_STRIDE (dst->dim[dst_dim]);
}
get_for_ref (ref, i, dst_index, single_token, dst, NULL,
ds, sr + array_offset_src * ref->item_size,
dst_kind, src_kind, dst_dim + 1, src_dim + 1,
- 1, stat);
+ 1, stat, src_type);
dst_index[dst_dim]
+= GFC_DIMENSION_STRIDE (dst->dim[dst_dim]);
}
get_for_ref (ref, i, dst_index, single_token, dst, NULL,
ds, sr + array_offset_src * ref->item_size,
dst_kind, src_kind, dst_dim + 1, src_dim + 1,
- 1, stat);
+ 1, stat, src_type);
dst_index[dst_dim]
+= GFC_DIMENSION_STRIDE (dst->dim[dst_dim]);
array_offset_src += ref->u.a.dim[src_dim].s.stride;
get_for_ref (ref, i, dst_index, single_token, dst, NULL, ds,
sr + array_offset_src * ref->item_size,
dst_kind, src_kind, dst_dim, src_dim + 1, 1,
- stat);
+ stat, src_type);
return;
- /* The OPEN_* are mapped to a RANGE and therefore can not occur. */
+ /* The OPEN_* are mapped to a RANGE and therefore cannot occur. */
case CAF_ARR_REF_OPEN_END:
case CAF_ARR_REF_OPEN_START:
default:
gfc_descriptor_t *dst, caf_reference_t *refs,
int dst_kind, int src_kind,
bool may_require_tmp __attribute__ ((unused)),
- bool dst_reallocatable, int *stat)
+ bool dst_reallocatable, int *stat,
+ int src_type)
{
const char vecrefunknownkind[] = "libcaf_single::caf_get_by_ref(): "
"unknown kind in vector-ref.\n";
const char extentoutofrange[] = "libcaf_single::caf_get_by_ref(): "
"extent out of range.\n";
const char cannotallocdst[] = "libcaf_single::caf_get_by_ref(): "
- "can not allocate memory.\n";
+ "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(): "
else
{
memptr += riter->u.c.offset;
- src = (gfc_descriptor_t *)memptr;
+ /* When the next ref is an array ref, assume there is an
+ array descriptor at memptr. Note, static arrays do not have
+ a descriptor. */
+ if (riter->next && riter->next->type == CAF_REF_ARRAY)
+ src = (gfc_descriptor_t *)memptr;
+ else
+ src = NULL;
}
break;
case CAF_REF_ARRAY:
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)
{
break;
case CAF_ARR_REF_OPEN_END:
/* This and OPEN_START are mapped to a RANGE and therefore
- can not occur here. */
+ cannot occur here. */
case CAF_ARR_REF_OPEN_START:
default:
caf_internal_error (unknownarrreftype, stat, NULL, 0);
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)
{
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);
i = 0;
get_for_ref (refs, &i, dst_index, single_token, dst, src,
GFC_DESCRIPTOR_DATA (dst), memptr, dst_kind, src_kind, 0, 0,
- 1, stat);
+ 1, stat, src_type);
}
caf_single_token_t single_token, gfc_descriptor_t *dst,
gfc_descriptor_t *src, void *ds, void *sr,
int dst_kind, int src_kind, size_t dst_dim, size_t src_dim,
- size_t num, size_t size, int *stat)
+ size_t num, size_t size, int *stat, int dst_type)
{
const char vecrefunknownkind[] = "libcaf_single::caf_send_by_ref(): "
"unknown kind in vector-ref.\n";
{
size_t src_size = GFC_DESCRIPTOR_SIZE (src);
ptrdiff_t array_offset_src = 0;;
- int dst_type = -1;
switch (ref->type)
{
dst_type = GFC_DESCRIPTOR_TYPE (dst);
}
else
- {
- /* When no destination descriptor is present, assume that
- source and dest type are identical. */
- dst_type = GFC_DESCRIPTOR_TYPE (src);
- ds = *(void **)(ds + ref->u.c.offset);
- }
+ ds = *(void **)(ds + ref->u.c.offset);
}
copy_data (ds, sr, dst_type, GFC_DESCRIPTOR_TYPE (src),
dst_kind, src_kind, ref->item_size, src_size, 1, stat);
}
else
- copy_data (ds + ref->u.c.offset, sr,
- dst != NULL ? GFC_DESCRIPTOR_TYPE (dst)
- : GFC_DESCRIPTOR_TYPE (src),
+ copy_data (ds + ref->u.c.offset, sr, dst_type,
GFC_DESCRIPTOR_TYPE (src),
dst_kind, src_kind, ref->item_size, src_size, 1, stat);
++(*i);
return;
case CAF_REF_STATIC_ARRAY:
- dst_type = ref->u.a.static_array_type;
/* Intentionally fall through. */
case CAF_REF_ARRAY:
if (ref->u.a.mode[dst_dim] == CAF_ARR_REF_NONE)
{
for (size_t d = 0; d < src_rank; ++d)
array_offset_src += src_index[d];
- copy_data (ds, sr + array_offset_src * ref->item_size,
- dst_type == -1 ? GFC_DESCRIPTOR_TYPE (dst)
- : dst_type,
- GFC_DESCRIPTOR_TYPE (src), dst_kind, src_kind,
- ref->item_size, src_size, num, stat);
+ copy_data (ds, sr + array_offset_src * src_size,
+ dst_type, GFC_DESCRIPTOR_TYPE (src), dst_kind,
+ src_kind, ref->item_size, src_size, num, stat);
}
else
- copy_data (ds, sr,
- dst_type == -1 ? GFC_DESCRIPTOR_TYPE (dst)
- : dst_type,
- GFC_DESCRIPTOR_TYPE (src), dst_kind, src_kind,
- ref->item_size, src_size, num, stat);
+ copy_data (ds, sr, dst_type, GFC_DESCRIPTOR_TYPE (src),
+ dst_kind, src_kind, ref->item_size, src_size, num,
+ stat);
*i += num;
return;
}
return;
}
single_token = *(caf_single_token_t*)(ds + ref->u.c.caf_token_offset);
+ /* When a component is allocatable (caf_token_offset != 0) and not an
+ array (ref->next->type == CAF_REF_COMPONENT), then ds has to be
+ dereffed. */
+ if (ref->next && ref->next->type == CAF_REF_COMPONENT)
+ ds = *(void **)(ds + ref->u.c.offset);
+ else
+ ds += ref->u.c.offset;
+
send_by_ref (ref->next, i, src_index, single_token,
- single_token->desc, src, ds + ref->u.c.offset, sr,
- dst_kind, src_kind, 0, src_dim, 1, size, stat);
+ single_token->desc, src, ds, sr,
+ dst_kind, src_kind, 0, src_dim, 1, size, stat, dst_type);
}
else
send_by_ref (ref->next, i, src_index, single_token,
(gfc_descriptor_t *)(ds + ref->u.c.offset), src,
ds + ref->u.c.offset, sr, dst_kind, src_kind, 0, src_dim,
- 1, size, stat);
+ 1, size, stat, dst_type);
return;
case CAF_REF_ARRAY:
if (ref->u.a.mode[dst_dim] == CAF_ARR_REF_NONE)
{
send_by_ref (ref->next, i, src_index, single_token,
(gfc_descriptor_t *)ds, src, ds, sr, dst_kind, src_kind,
- 0, src_dim, 1, size, stat);
+ 0, src_dim, 1, size, stat, dst_type);
return;
}
/* Only when on the left most index switch the data pointer to
send_by_ref (ref, i, src_index, single_token, dst, src,
ds + array_offset_dst * ref->item_size, sr,
dst_kind, src_kind, dst_dim + 1, src_dim + 1,
- 1, size, stat);
+ 1, size, stat, dst_type);
if (src_rank > 0)
src_index[src_dim]
+= GFC_DIMENSION_STRIDE (src->dim[src_dim]);
send_by_ref (ref, i, src_index, single_token, dst, src,
ds + array_offset_dst * ref->item_size, sr,
dst_kind, src_kind, dst_dim + 1, src_dim + 1,
- 1, size, stat);
+ 1, size, stat, dst_type);
if (src_rank > 0)
src_index[src_dim]
+= GFC_DIMENSION_STRIDE (src->dim[src_dim]);
send_by_ref (ref, i, src_index, single_token, dst, src,
ds + array_offset_dst * ref->item_size, sr,
dst_kind, src_kind, dst_dim + 1, src_dim + 1,
- 1, size, stat);
+ 1, size, stat, dst_type);
if (src_rank > 0)
src_index[src_dim]
+= GFC_DIMENSION_STRIDE (src->dim[src_dim]);
send_by_ref (ref, i, src_index, single_token, dst, src, ds
+ array_offset_dst * ref->item_size, sr,
dst_kind, src_kind, dst_dim + 1, src_dim, 1,
- size, stat);
+ size, stat, dst_type);
return;
case CAF_ARR_REF_OPEN_END:
COMPUTE_NUM_ITEMS (extent_dst,
send_by_ref (ref, i, src_index, single_token, dst, src,
ds + array_offset_dst * ref->item_size, sr,
dst_kind, src_kind, dst_dim + 1, src_dim + 1,
- 1, size, stat);
+ 1, size, stat, dst_type);
if (src_rank > 0)
src_index[src_dim]
+= GFC_DIMENSION_STRIDE (src->dim[src_dim]);
send_by_ref (ref, i, src_index, single_token, dst, src,
ds + array_offset_dst * ref->item_size, sr,
dst_kind, src_kind, dst_dim + 1, src_dim + 1,
- 1, size, stat);
+ 1, size, stat, dst_type);
if (src_rank > 0)
src_index[src_dim]
+= GFC_DIMENSION_STRIDE (src->dim[src_dim]);
{
send_by_ref (ref->next, i, src_index, single_token, NULL,
src, ds, sr, dst_kind, src_kind,
- 0, src_dim, 1, size, stat);
+ 0, src_dim, 1, size, stat, dst_type);
return;
}
switch (ref->u.a.mode[dst_dim])
send_by_ref (ref, i, src_index, single_token, NULL, src,
ds + array_offset_dst * ref->item_size, sr,
dst_kind, src_kind, dst_dim + 1, src_dim + 1,
- 1, size, stat);
+ 1, size, stat, dst_type);
src_index[src_dim]
+= GFC_DIMENSION_STRIDE (src->dim[src_dim]);
}
send_by_ref (ref, i, src_index, single_token, NULL, src,
ds + array_offset_dst * ref->item_size, sr,
dst_kind, src_kind, dst_dim + 1, src_dim + 1,
- 1, size, stat);
+ 1, size, stat, dst_type);
if (src_rank > 0)
src_index[src_dim]
+= GFC_DIMENSION_STRIDE (src->dim[src_dim]);
send_by_ref (ref, i, src_index, single_token, NULL, src,
ds + array_offset_dst * ref->item_size, sr,
dst_kind, src_kind, dst_dim + 1, src_dim + 1,
- 1, size, stat);
+ 1, size, stat, dst_type);
if (src_rank > 0)
src_index[src_dim]
+= GFC_DIMENSION_STRIDE (src->dim[src_dim]);
send_by_ref (ref, i, src_index, single_token, NULL, src,
ds + array_offset_dst * ref->item_size, sr,
dst_kind, src_kind, dst_dim + 1, src_dim, 1,
- size, stat);
+ size, stat, dst_type);
return;
- /* The OPEN_* are mapped to a RANGE and therefore can not occur. */
+ /* The OPEN_* are mapped to a RANGE and therefore cannot occur. */
case CAF_ARR_REF_OPEN_END:
case CAF_ARR_REF_OPEN_START:
default:
gfc_descriptor_t *src, caf_reference_t *refs,
int dst_kind, int src_kind,
bool may_require_tmp __attribute__ ((unused)),
- bool dst_reallocatable, int *stat)
+ bool dst_reallocatable, int *stat, int dst_type)
{
const char vecrefunknownkind[] = "libcaf_single::caf_get_by_ref(): "
"unknown kind in vector-ref.\n";
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(): "
- "can not allocate memory.\n";
+ "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(): "
break;
case CAF_ARR_REF_OPEN_END:
/* This and OPEN_START are mapped to a RANGE and therefore
- can not occur here. */
+ cannot occur here. */
case CAF_ARR_REF_OPEN_START:
default:
caf_internal_error (unknownarrreftype, stat, NULL, 0);
i = 0;
send_by_ref (refs, &i, dst_index, single_token, dst, src,
memptr, GFC_DESCRIPTOR_DATA (src), dst_kind, src_kind, 0, 0,
- 1, size, stat);
+ 1, size, stat, dst_type);
assert (i == size);
}
int src_image_index,
caf_reference_t *src_refs, int dst_kind,
int src_kind, bool may_require_tmp, int *dst_stat,
- int *src_stat)
+ int *src_stat, int dst_type, int src_type)
{
- gfc_array_void temp;
+ GFC_FULL_ARRAY_DESCRIPTOR (GFC_MAX_DIMENSIONS, void) temp;
+ GFC_DESCRIPTOR_DATA (&temp) = NULL;
+ GFC_DESCRIPTOR_RANK (&temp) = -1;
+ GFC_DESCRIPTOR_TYPE (&temp) = dst_type;
_gfortran_caf_get_by_ref (src_token, src_image_index, &temp, src_refs,
dst_kind, src_kind, may_require_tmp, true,
- src_stat);
+ src_stat, src_type);
if (src_stat && *src_stat != 0)
return;
_gfortran_caf_send_by_ref (dst_token, dst_image_index, &temp, dst_refs,
- dst_kind, src_kind, may_require_tmp, true,
- dst_stat);
+ dst_kind, dst_kind, may_require_tmp, true,
+ dst_stat, dst_type);
if (GFC_DESCRIPTOR_DATA (&temp))
free (GFC_DESCRIPTOR_DATA (&temp));
}
_gfortran_caf_event_post (caf_token_t token, size_t index,
int image_index __attribute__ ((unused)),
int *stat, char *errmsg __attribute__ ((unused)),
- int errmsg_len __attribute__ ((unused)))
+ size_t errmsg_len __attribute__ ((unused)))
{
uint32_t value = 1;
uint32_t *event = (uint32_t *) ((char *) MEMTOK (token) + index
_gfortran_caf_event_wait (caf_token_t token, size_t index,
int until_count, int *stat,
char *errmsg __attribute__ ((unused)),
- int errmsg_len __attribute__ ((unused)))
+ size_t errmsg_len __attribute__ ((unused)))
{
uint32_t *event = (uint32_t *) ((char *) MEMTOK (token) + index
* sizeof (uint32_t));
void
_gfortran_caf_lock (caf_token_t token, size_t index,
int image_index __attribute__ ((unused)),
- int *aquired_lock, int *stat, char *errmsg, int errmsg_len)
+ int *aquired_lock, int *stat, char *errmsg, size_t errmsg_len)
{
const char *msg = "Already locked";
bool *lock = &((bool *) MEMTOK (token))[index];
*stat = 1;
if (errmsg_len > 0)
{
- int len = ((int) sizeof (msg) > errmsg_len) ? errmsg_len
- : (int) sizeof (msg);
+ size_t len = (sizeof (msg) > errmsg_len) ? errmsg_len
+ : sizeof (msg);
memcpy (errmsg, msg, len);
if (errmsg_len > len)
memset (&errmsg[len], ' ', errmsg_len-len);
}
return;
}
- _gfortran_caf_error_stop_str (msg, (int32_t) strlen (msg));
+ _gfortran_caf_error_stop_str (msg, strlen (msg), false);
}
void
_gfortran_caf_unlock (caf_token_t token, size_t index,
int image_index __attribute__ ((unused)),
- int *stat, char *errmsg, int errmsg_len)
+ int *stat, char *errmsg, size_t errmsg_len)
{
const char *msg = "Variable is not locked";
bool *lock = &((bool *) MEMTOK (token))[index];
*stat = 1;
if (errmsg_len > 0)
{
- int len = ((int) sizeof (msg) > errmsg_len) ? errmsg_len
- : (int) sizeof (msg);
+ size_t len = (sizeof (msg) > errmsg_len) ? errmsg_len
+ : sizeof (msg);
memcpy (errmsg, msg, len);
if (errmsg_len > len)
memset (&errmsg[len], ' ', errmsg_len-len);
}
return;
}
- _gfortran_caf_error_stop_str (msg, (int32_t) strlen (msg));
+ _gfortran_caf_error_stop_str (msg, strlen (msg), false);
}
int
projects / thirdparty / gcc.git / blobdiff