diff options
Diffstat (limited to 'libgfortran')
| -rw-r--r-- | libgfortran/ChangeLog | 106 | ||||
| -rw-r--r-- | libgfortran/caf/libcaf.h | 45 | ||||
| -rw-r--r-- | libgfortran/caf/mpi.c | 43 | ||||
| -rw-r--r-- | libgfortran/caf/single.c | 271 | ||||
| -rwxr-xr-x | libgfortran/configure | 21 | ||||
| -rw-r--r-- | libgfortran/io/transfer.c | 4 | ||||
| -rw-r--r-- | libgfortran/libgfortran.h | 2 | ||||
| -rw-r--r-- | libgfortran/runtime/pause.c | 12 | ||||
| -rw-r--r-- | libgfortran/runtime/stop.c | 53 |
9 files changed, 372 insertions, 185 deletions
diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog index 2220ec2bae6..eb94ebb5191 100644 --- a/libgfortran/ChangeLog +++ b/libgfortran/ChangeLog @@ -1,3 +1,109 @@ +2018-02-23 Janne Blomqvist <jb@gcc.gnu.org> + + PR fortran/84519 + * caf/libcaf.h (_gfortran_caf_stop_numeric): Add bool argument. + (_gfortran_caf_stop_str): Likewise. + (_gfortran_caf_error_stop_str): Likewise. + (_gfortran_caf_error_stop): Likewise. + * caf/mpi.c (_gfortran_caf_error_stop_str): Handle new argument. + (_gfortran_caf_error_stop): Likewise. + * caf/single.c (_gfortran_caf_stop_numeric): Likewise. + (_gfortran_caf_stop_str): Likewise. + (_gfortran_caf_error_stop_str): Likewise. + (_gfortran_caf_error_stop): Likewise. + (_gfortran_caf_lock): Likewise. + (_gfortran_caf_unlock): Likewise. + * libgfortran.h (stop_string): Add bool argument. + * runtime/pause.c (do_pause): Add false argument. + * runtime/stop.c (stop_numeric): Handle new argument. + (stop_string): Likewise. + (error_stop_string): Likewise. + (error_stop_numeric): Likewise. + +2018-02-22 Janne Blomqvist <jb@gcc.gnu.org> + + PR 78534 + PR 84509 + * runtime/pause.c (pause_numeric): Modify to take GFC_INTEGER_8 + argument. + (pause_string): Modify to take size_t character length argument. + +2018-02-22 Janne Blomqvist <jb@gcc.gnu.org> + + * libgfortran.h (stop_string): Use size_t for character length. + * runtime/stop.c (stop_string): Likewise. + (error_stop_string): Likewise. + (stop_numeric): Use int for exit code. + (error_stop_numeric): Likewise. + * caf/libcaf.h: Remove stdint.h include. + (_gfortran_caf_register): Use size_t for character length. + (_gfortran_caf_deregister): Likewise. + (_gfortran_caf_sync_all): Likewise. + (_gfortran_caf_sync_memory): Likewise. + (_gfortran_caf_sync_images): Likewise. + (_gfortran_caf_stop_numeric): Use int for exit code. + (_gfortran_caf_stop_str): Use size_t for character length. + (_gfortran_caf_error_stop_str): Likewise. + (_gfortran_caf_error_stop): Use int for exit code. + (_gfortran_caf_co_broadcast): Use size_t for character length. + (_gfortran_caf_co_sum): Likewise. + (_gfortran_caf_co_min): Likewise. + (_gfortran_caf_co_max): Likewise. + (_gfortran_caf_co_reduce): Likewise. + (_gfortran_caf_lock): Likewise. + (_gfortran_caf_unlock): Likewise. + (_gfortran_caf_event_post): Likewise. + (_gfortran_caf_event_wait): Likewise. + * caf/mpi.c (_gfortran_caf_register): Update implementation to + match prototype. + (_gfortran_caf_deregister): Likewise. + (_gfortran_caf_sync_all): Likewise. + (_gfortran_caf_sync_images): Likewise. + (_gfortran_caf_error_stop_str): Likewise. + (_gfortran_caf_error_stop): Likewise. + * caf/single.c (caf_internal_error): Likewise. + (_gfortran_caf_register): Likewise. + (_gfortran_caf_deregister): Likewise. + (_gfortran_caf_sync_all): Likewise. + (_gfortran_caf_sync_memory): Likewise. + (_gfortran_caf_sync_images): Likewise. + (_gfortran_caf_stop_numeric): Likewise. + (_gfortran_caf_stop_str): Likewise. + (_gfortran_caf_error_stop_str): Likewise. + (_gfortran_caf_error_stop): Likewise. + (_gfortran_caf_co_broadcast): Likewise. + (_gfortran_caf_co_sum): Likewise. + (_gfortran_caf_co_min): Likewise. + (_gfortran_caf_co_max): Likewise. + (_gfortran_caf_co_reduce): Likewise. + (_gfortran_caf_event_post): Likewise. + (_gfortran_caf_event_wait): Likewise. + (_gfortran_caf_lock): Likewise. + (_gfortran_caf_unlock): Likewise. + +2018-02-19 Andre Vehreschild <vehre@gcc.gnu.org> + + * caf/libcaf.h: Add type parameters to the caf_*_by_ref prototypes. + * caf/single.c (get_for_ref): Simplifications and now respecting + the type argument. + (_gfortran_caf_get_by_ref): Added source type handing to get_for_ref(). + (send_by_ref): Simplifications and respecting the dst_type now. + (_gfortran_caf_send_by_ref): Added destination type hand over to + send_by_ref(). + (_gfortran_caf_sendget_by_ref): Added general support and fixed stack + corruption. The function is now really usable. + +2018-02-14 Igor Tsimbalist <igor.v.tsimbalist@intel.com> + + PR target/84148 + * configure: Regenerate. + +2018-02-18 Jerry DeLisle <jvdelisle@gcc.gnu.org> + + PR libgfortran/84412 + * io/transfer.c (finalize_transfer): After completng an internal unit + I/O operation, clear internal_unit_kind. + 2018-02-12 Thomas Koenig <tkoenig@gcc.gnu.org> * libgfortran.h (GFC_ARRAY_DESCRIPTOR): Remove dimension diff --git a/libgfortran/caf/libcaf.h b/libgfortran/caf/libcaf.h index 12c73de8479..dd97166952c 100644 --- a/libgfortran/caf/libcaf.h +++ b/libgfortran/caf/libcaf.h @@ -28,7 +28,6 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see #include <stdbool.h> #include <stddef.h> /* For size_t. */ -#include <stdint.h> /* For int32_t. */ #include "libgfortran.h" @@ -190,29 +189,29 @@ int _gfortran_caf_this_image (int); int _gfortran_caf_num_images (int, int); void _gfortran_caf_register (size_t, caf_register_t, caf_token_t *, - gfc_descriptor_t *, int *, char *, int); + gfc_descriptor_t *, int *, char *, size_t); void _gfortran_caf_deregister (caf_token_t *, caf_deregister_t, int *, char *, - int); + size_t); -void _gfortran_caf_sync_all (int *, char *, int); -void _gfortran_caf_sync_memory (int *, char *, int); -void _gfortran_caf_sync_images (int, int[], int *, char *, int); +void _gfortran_caf_sync_all (int *, char *, size_t); +void _gfortran_caf_sync_memory (int *, char *, size_t); +void _gfortran_caf_sync_images (int, int[], int *, char *, size_t); -void _gfortran_caf_stop_numeric (int32_t) +void _gfortran_caf_stop_numeric (int, bool) __attribute__ ((noreturn)); -void _gfortran_caf_stop_str (const char *, int32_t) +void _gfortran_caf_stop_str (const char *, size_t, bool) __attribute__ ((noreturn)); -void _gfortran_caf_error_stop_str (const char *, int32_t) +void _gfortran_caf_error_stop_str (const char *, size_t, bool) __attribute__ ((noreturn)); -void _gfortran_caf_error_stop (int32_t) __attribute__ ((noreturn)); +void _gfortran_caf_error_stop (int, bool) __attribute__ ((noreturn)); void _gfortran_caf_fail_image (void) __attribute__ ((noreturn)); -void _gfortran_caf_co_broadcast (gfc_descriptor_t *, int, int *, char *, int); -void _gfortran_caf_co_sum (gfc_descriptor_t *, int, int *, char *, int); -void _gfortran_caf_co_min (gfc_descriptor_t *, int, int *, char *, int, int); -void _gfortran_caf_co_max (gfc_descriptor_t *, int, int *, char *, int, int); +void _gfortran_caf_co_broadcast (gfc_descriptor_t *, int, int *, char *, size_t); +void _gfortran_caf_co_sum (gfc_descriptor_t *, int, int *, char *, size_t); +void _gfortran_caf_co_min (gfc_descriptor_t *, int, int *, char *, int, size_t); +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, int); + 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, @@ -226,15 +225,17 @@ void _gfortran_caf_sendget (caf_token_t, size_t, int, gfc_descriptor_t *, void _gfortran_caf_get_by_ref (caf_token_t token, int image_idx, gfc_descriptor_t *dst, caf_reference_t *refs, int dst_kind, - int src_kind, bool may_require_tmp, bool dst_reallocatable, int *stat); + int src_kind, bool may_require_tmp, bool dst_reallocatable, int *stat, + int src_type); void _gfortran_caf_send_by_ref (caf_token_t token, int image_index, gfc_descriptor_t *src, caf_reference_t *refs, int dst_kind, - int src_kind, bool may_require_tmp, bool dst_reallocatable, int *stat); + int src_kind, bool may_require_tmp, bool dst_reallocatable, int *stat, + int dst_type); void _gfortran_caf_sendget_by_ref ( caf_token_t dst_token, int dst_image_index, caf_reference_t *dst_refs, caf_token_t src_token, int src_image_index, caf_reference_t *src_refs, int dst_kind, int src_kind, bool may_require_tmp, int *dst_stat, - int *src_stat); + int *src_stat, int dst_type, int src_type); void _gfortran_caf_atomic_define (caf_token_t, size_t, int, void *, int *, int, int); @@ -245,10 +246,10 @@ void _gfortran_caf_atomic_cas (caf_token_t, size_t, int, void *, void *, void _gfortran_caf_atomic_op (int, caf_token_t, size_t, int, void *, void *, int *, int, int); -void _gfortran_caf_lock (caf_token_t, size_t, int, int *, int *, char *, int); -void _gfortran_caf_unlock (caf_token_t, size_t, int, int *, char *, int); -void _gfortran_caf_event_post (caf_token_t, size_t, int, int *, char *, int); -void _gfortran_caf_event_wait (caf_token_t, size_t, int, int *, char *, int); +void _gfortran_caf_lock (caf_token_t, size_t, int, int *, int *, char *, size_t); +void _gfortran_caf_unlock (caf_token_t, size_t, int, int *, char *, size_t); +void _gfortran_caf_event_post (caf_token_t, size_t, int, int *, char *, size_t); +void _gfortran_caf_event_wait (caf_token_t, size_t, int, int *, char *, size_t); void _gfortran_caf_event_query (caf_token_t, size_t, int, int *, int *); void _gfortran_caf_failed_images (gfc_descriptor_t *, diff --git a/libgfortran/caf/mpi.c b/libgfortran/caf/mpi.c index 0f7977fc007..55d9908b8de 100644 --- a/libgfortran/caf/mpi.c +++ b/libgfortran/caf/mpi.c @@ -131,7 +131,7 @@ _gfortran_caf_num_images (int distance __attribute__ ((unused)), void * _gfortran_caf_register (size_t size, caf_register_t type, caf_token_t *token, - int *stat, char *errmsg, int errmsg_len, + int *stat, char *errmsg, size_t errmsg_len, int num_alloc_comps __attribute__ ((unused))) { void *local; @@ -189,8 +189,8 @@ error: *stat = caf_is_finalized ? STAT_STOPPED_IMAGE : 1; if (errmsg_len > 0) { - int len = ((int) strlen (msg) > errmsg_len) ? errmsg_len - : (int) strlen (msg); + size_t len = (strlen (msg) > errmsg_len) ? errmsg_len + : strlen (msg); memcpy (errmsg, msg, len); if (errmsg_len > len) memset (&errmsg[len], ' ', errmsg_len-len); @@ -205,7 +205,7 @@ error: void -_gfortran_caf_deregister (caf_token_t *token, int *stat, char *errmsg, int errmsg_len) +_gfortran_caf_deregister (caf_token_t *token, int *stat, char *errmsg, size_t errmsg_len) { if (unlikely (caf_is_finalized)) { @@ -217,8 +217,8 @@ _gfortran_caf_deregister (caf_token_t *token, int *stat, char *errmsg, int errms if (errmsg_len > 0) { - int len = ((int) sizeof (msg) - 1 > errmsg_len) - ? errmsg_len : (int) sizeof (msg) - 1; + size_t len = (sizeof (msg) - 1 > errmsg_len) + ? errmsg_len : sizeof (msg) - 1; memcpy (errmsg, msg, len); if (errmsg_len > len) memset (&errmsg[len], ' ', errmsg_len-len); @@ -239,7 +239,7 @@ _gfortran_caf_deregister (caf_token_t *token, int *stat, char *errmsg, int errms void -_gfortran_caf_sync_all (int *stat, char *errmsg, int errmsg_len) +_gfortran_caf_sync_all (int *stat, char *errmsg, size_t errmsg_len) { int ierr; @@ -261,8 +261,8 @@ _gfortran_caf_sync_all (int *stat, char *errmsg, int errmsg_len) if (errmsg_len > 0) { - int len = ((int) strlen (msg) > errmsg_len) ? errmsg_len - : (int) strlen (msg); + size_t len = (strlen (msg) > errmsg_len) ? errmsg_len + : strlen (msg); memcpy (errmsg, msg, len); if (errmsg_len > len) memset (&errmsg[len], ' ', errmsg_len-len); @@ -278,7 +278,7 @@ _gfortran_caf_sync_all (int *stat, char *errmsg, int errmsg_len) is not equivalent to SYNC ALL. */ void _gfortran_caf_sync_images (int count, int images[], int *stat, char *errmsg, - int errmsg_len) + size_t errmsg_len) { int ierr; if (count == 0 || (count == 1 && images[0] == caf_this_image)) @@ -329,8 +329,8 @@ _gfortran_caf_sync_images (int count, int images[], int *stat, char *errmsg, if (errmsg_len > 0) { - int len = ((int) strlen (msg) > errmsg_len) ? errmsg_len - : (int) strlen (msg); + size_t len = (strlen (msg) > errmsg_len) ? errmsg_len + : strlen (msg); memcpy (errmsg, msg, len); if (errmsg_len > len) memset (&errmsg[len], ' ', errmsg_len-len); @@ -358,13 +358,15 @@ error_stop (int error) /* ERROR STOP function for string arguments. */ 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); + } error_stop (1); } @@ -372,8 +374,9 @@ _gfortran_caf_error_stop_str (const char *string, int32_t len) /* ERROR STOP function for numerical arguments. */ 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); error_stop (error); } diff --git a/libgfortran/caf/single.c b/libgfortran/caf/single.c index bead09a386f..1ad13bd5643 100644 --- a/libgfortran/caf/single.c +++ b/libgfortran/caf/single.c @@ -28,6 +28,7 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see #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. */ @@ -74,7 +75,7 @@ caf_runtime_error (const char *message, ...) /* 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); @@ -83,8 +84,8 @@ caf_internal_error (const char *msg, int *stat, char *errmsg, *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); @@ -134,7 +135,7 @@ _gfortran_caf_num_images (int distance __attribute__ ((unused)), 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; @@ -195,7 +196,7 @@ _gfortran_caf_register (size_t size, caf_register_t type, caf_token_t *token, 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); @@ -221,7 +222,7 @@ _gfortran_caf_deregister (caf_token_t *token, caf_deregister_t type, int *stat, 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) @@ -232,7 +233,7 @@ _gfortran_caf_sync_all (int *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) @@ -245,7 +246,7 @@ _gfortran_caf_sync_images (int count __attribute__ ((unused)), 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; @@ -266,33 +267,38 @@ _gfortran_caf_sync_images (int count __attribute__ ((unused)), 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); } @@ -366,9 +372,10 @@ _gfortran_caf_stopped_images (gfc_descriptor_t *array, 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); } @@ -377,7 +384,7 @@ void _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; @@ -387,7 +394,7 @@ void _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; @@ -398,7 +405,7 @@ _gfortran_caf_co_min (gfc_descriptor_t *a __attribute__ ((unused)), 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; @@ -409,7 +416,7 @@ _gfortran_caf_co_max (gfc_descriptor_t *a __attribute__ ((unused)), 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; @@ -424,7 +431,7 @@ _gfortran_caf_co_reduce (gfc_descriptor_t *a __attribute__ ((unused)), 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; @@ -1194,7 +1201,7 @@ get_for_ref (caf_reference_t *ref, size_t *i, size_t *dst_index, caf_single_token_t single_token, gfc_descriptor_t *dst, gfc_descriptor_t *src, void *ds, void *sr, int dst_kind, int src_kind, size_t dst_dim, size_t src_dim, - size_t num, int *stat) + size_t num, int *stat, int src_type) { ptrdiff_t extent_src = 1, array_offset_src = 0, stride_src; size_t next_dst_dim; @@ -1209,25 +1216,24 @@ get_for_ref (caf_reference_t *ref, size_t *i, size_t *dst_index, size_t dst_size = GFC_DESCRIPTOR_SIZE (dst); ptrdiff_t array_offset_dst = 0;; size_t dst_rank = GFC_DESCRIPTOR_RANK (dst); - int src_type = -1; switch (ref->type) { case CAF_REF_COMPONENT: /* Because the token is always registered after the component, its - offset is always greater zeor. */ + offset is always greater zero. */ if (ref->u.c.caf_token_offset > 0) + /* Note, that sr is dereffed here. */ copy_data (ds, *(void **)(sr + ref->u.c.offset), - GFC_DESCRIPTOR_TYPE (dst), GFC_DESCRIPTOR_TYPE (dst), + GFC_DESCRIPTOR_TYPE (dst), src_type, dst_kind, src_kind, dst_size, ref->item_size, 1, stat); else copy_data (ds, sr + ref->u.c.offset, - GFC_DESCRIPTOR_TYPE (dst), GFC_DESCRIPTOR_TYPE (src), + GFC_DESCRIPTOR_TYPE (dst), src_type, dst_kind, src_kind, dst_size, ref->item_size, 1, stat); ++(*i); return; case CAF_REF_STATIC_ARRAY: - src_type = ref->u.a.static_array_type; /* Intentionally fall through. */ case CAF_REF_ARRAY: if (ref->u.a.mode[src_dim] == CAF_ARR_REF_NONE) @@ -1235,8 +1241,7 @@ get_for_ref (caf_reference_t *ref, size_t *i, size_t *dst_index, for (size_t d = 0; d < dst_rank; ++d) array_offset_dst += dst_index[d]; copy_data (ds + array_offset_dst * dst_size, sr, - GFC_DESCRIPTOR_TYPE (dst), - src_type == -1 ? GFC_DESCRIPTOR_TYPE (src) : src_type, + GFC_DESCRIPTOR_TYPE (dst), src_type, dst_kind, src_kind, dst_size, ref->item_size, num, stat); *i += num; @@ -1252,23 +1257,39 @@ get_for_ref (caf_reference_t *ref, size_t *i, size_t *dst_index, { case CAF_REF_COMPONENT: if (ref->u.c.caf_token_offset > 0) - get_for_ref (ref->next, i, dst_index, - *(caf_single_token_t*)(sr + ref->u.c.caf_token_offset), dst, - (*(caf_single_token_t*)(sr + ref->u.c.caf_token_offset))->desc, - ds, sr + ref->u.c.offset, dst_kind, src_kind, dst_dim, 0, - 1, stat); + { + single_token = *(caf_single_token_t*)(sr + ref->u.c.caf_token_offset); + + if (ref->next && ref->next->type == CAF_REF_ARRAY) + src = single_token->desc; + else + src = NULL; + + if (ref->next && ref->next->type == CAF_REF_COMPONENT) + /* The currently ref'ed component was allocatabe (caf_token_offset + > 0) and the next ref is a component, too, then the new sr has to + be dereffed. (static arrays can not be allocatable or they + become an array with descriptor. */ + sr = *(void **)(sr + ref->u.c.offset); + else + sr += ref->u.c.offset; + + get_for_ref (ref->next, i, dst_index, single_token, dst, src, + ds, sr, dst_kind, src_kind, dst_dim, 0, + 1, stat, src_type); + } else get_for_ref (ref->next, i, dst_index, single_token, dst, (gfc_descriptor_t *)(sr + ref->u.c.offset), ds, sr + ref->u.c.offset, dst_kind, src_kind, dst_dim, 0, 1, - stat); + stat, src_type); return; case CAF_REF_ARRAY: if (ref->u.a.mode[src_dim] == CAF_ARR_REF_NONE) { get_for_ref (ref->next, i, dst_index, single_token, dst, src, ds, sr, dst_kind, src_kind, - dst_dim, 0, 1, stat); + dst_dim, 0, 1, stat, src_type); return; } /* Only when on the left most index switch the data pointer to @@ -1311,7 +1332,7 @@ get_for_ref (caf_reference_t *ref, size_t *i, size_t *dst_index, get_for_ref (ref, i, dst_index, single_token, dst, src, ds, sr + array_offset_src * ref->item_size, dst_kind, src_kind, dst_dim + 1, src_dim + 1, - 1, stat); + 1, stat, src_type); dst_index[dst_dim] += GFC_DIMENSION_STRIDE (dst->dim[dst_dim]); } @@ -1331,7 +1352,7 @@ get_for_ref (caf_reference_t *ref, size_t *i, size_t *dst_index, get_for_ref (ref, i, dst_index, single_token, dst, src, ds, sr + array_offset_src * ref->item_size, dst_kind, src_kind, dst_dim + 1, src_dim + 1, - 1, stat); + 1, stat, src_type); dst_index[dst_dim] += GFC_DIMENSION_STRIDE (dst->dim[dst_dim]); } @@ -1358,7 +1379,7 @@ get_for_ref (caf_reference_t *ref, size_t *i, size_t *dst_index, get_for_ref (ref, i, dst_index, single_token, dst, src, ds, sr + array_offset_src * ref->item_size, dst_kind, src_kind, next_dst_dim, src_dim + 1, - 1, stat); + 1, stat, src_type); dst_index[dst_dim] += GFC_DIMENSION_STRIDE (dst->dim[dst_dim]); array_offset_src += stride_src; @@ -1372,7 +1393,7 @@ get_for_ref (caf_reference_t *ref, size_t *i, size_t *dst_index, get_for_ref (ref, i, dst_index, single_token, dst, src, ds, sr + array_offset_src * ref->item_size, dst_kind, src_kind, dst_dim, src_dim + 1, 1, - stat); + stat, src_type); return; case CAF_ARR_REF_OPEN_END: COMPUTE_NUM_ITEMS (extent_src, @@ -1390,7 +1411,7 @@ get_for_ref (caf_reference_t *ref, size_t *i, size_t *dst_index, get_for_ref (ref, i, dst_index, single_token, dst, src, ds, sr + array_offset_src * ref->item_size, dst_kind, src_kind, dst_dim + 1, src_dim + 1, - 1, stat); + 1, stat, src_type); dst_index[dst_dim] += GFC_DIMENSION_STRIDE (dst->dim[dst_dim]); array_offset_src += stride_src; @@ -1410,7 +1431,7 @@ get_for_ref (caf_reference_t *ref, size_t *i, size_t *dst_index, get_for_ref (ref, i, dst_index, single_token, dst, src, ds, sr + array_offset_src * ref->item_size, dst_kind, src_kind, dst_dim + 1, src_dim + 1, - 1, stat); + 1, stat, src_type); dst_index[dst_dim] += GFC_DIMENSION_STRIDE (dst->dim[dst_dim]); array_offset_src += stride_src; @@ -1425,7 +1446,7 @@ get_for_ref (caf_reference_t *ref, size_t *i, size_t *dst_index, { get_for_ref (ref->next, i, dst_index, single_token, dst, NULL, ds, sr, dst_kind, src_kind, - dst_dim, 0, 1, stat); + dst_dim, 0, 1, stat, src_type); return; } switch (ref->u.a.mode[src_dim]) @@ -1460,7 +1481,7 @@ get_for_ref (caf_reference_t *ref, size_t *i, size_t *dst_index, get_for_ref (ref, i, dst_index, single_token, dst, NULL, ds, sr + array_offset_src * ref->item_size, dst_kind, src_kind, dst_dim + 1, src_dim + 1, - 1, stat); + 1, stat, src_type); dst_index[dst_dim] += GFC_DIMENSION_STRIDE (dst->dim[dst_dim]); } @@ -1474,7 +1495,7 @@ get_for_ref (caf_reference_t *ref, size_t *i, size_t *dst_index, get_for_ref (ref, i, dst_index, single_token, dst, NULL, ds, sr + array_offset_src * ref->item_size, dst_kind, src_kind, dst_dim + 1, src_dim + 1, - 1, stat); + 1, stat, src_type); dst_index[dst_dim] += GFC_DIMENSION_STRIDE (dst->dim[dst_dim]); } @@ -1491,7 +1512,7 @@ get_for_ref (caf_reference_t *ref, size_t *i, size_t *dst_index, get_for_ref (ref, i, dst_index, single_token, dst, NULL, ds, sr + array_offset_src * ref->item_size, dst_kind, src_kind, dst_dim + 1, src_dim + 1, - 1, stat); + 1, stat, src_type); dst_index[dst_dim] += GFC_DIMENSION_STRIDE (dst->dim[dst_dim]); array_offset_src += ref->u.a.dim[src_dim].s.stride; @@ -1502,7 +1523,7 @@ get_for_ref (caf_reference_t *ref, size_t *i, size_t *dst_index, get_for_ref (ref, i, dst_index, single_token, dst, NULL, ds, sr + array_offset_src * ref->item_size, dst_kind, src_kind, dst_dim, src_dim + 1, 1, - stat); + stat, src_type); return; /* The OPEN_* are mapped to a RANGE and therefore can not occur. */ case CAF_ARR_REF_OPEN_END: @@ -1523,7 +1544,8 @@ _gfortran_caf_get_by_ref (caf_token_t token, gfc_descriptor_t *dst, caf_reference_t *refs, int dst_kind, int src_kind, bool may_require_tmp __attribute__ ((unused)), - bool dst_reallocatable, int *stat) + bool dst_reallocatable, int *stat, + int src_type) { const char vecrefunknownkind[] = "libcaf_single::caf_get_by_ref(): " "unknown kind in vector-ref.\n"; @@ -1585,7 +1607,13 @@ _gfortran_caf_get_by_ref (caf_token_t token, else { memptr += riter->u.c.offset; - src = (gfc_descriptor_t *)memptr; + /* When the next ref is an array ref, assume there is an + array descriptor at memptr. Note, static arrays do not have + a descriptor. */ + if (riter->next && riter->next->type == CAF_REF_ARRAY) + src = (gfc_descriptor_t *)memptr; + else + src = NULL; } break; case CAF_REF_ARRAY: @@ -1677,6 +1705,13 @@ _gfortran_caf_get_by_ref (caf_token_t token, caf_internal_error (extentoutofrange, stat, NULL, 0); return; } + /* Special mode when called by __caf_sendget_by_ref (). */ + if (dst_rank == -1 && GFC_DESCRIPTOR_DATA (dst) == NULL) + { + dst_rank = dst_cur_dim + 1; + GFC_DESCRIPTOR_RANK (dst) = dst_rank; + GFC_DESCRIPTOR_SIZE (dst) = dst_kind; + } /* When dst is an array. */ if (dst_rank > 0) { @@ -1845,6 +1880,13 @@ _gfortran_caf_get_by_ref (caf_token_t token, caf_internal_error (extentoutofrange, stat, NULL, 0); return; } + /* Special mode when called by __caf_sendget_by_ref (). */ + if (dst_rank == -1 && GFC_DESCRIPTOR_DATA (dst) == NULL) + { + dst_rank = dst_cur_dim + 1; + GFC_DESCRIPTOR_RANK (dst) = dst_rank; + GFC_DESCRIPTOR_SIZE (dst) = dst_kind; + } /* When dst is an array. */ if (dst_rank > 0) { @@ -1946,6 +1988,13 @@ _gfortran_caf_get_by_ref (caf_token_t token, if (!array_extent_fixed) { assert (size == 1); + /* Special mode when called by __caf_sendget_by_ref (). */ + if (dst_rank == -1 && GFC_DESCRIPTOR_DATA (dst) == NULL) + { + dst_rank = dst_cur_dim + 1; + GFC_DESCRIPTOR_RANK (dst) = dst_rank; + GFC_DESCRIPTOR_SIZE (dst) = dst_kind; + } /* This can happen only, when the result is scalar. */ for (dst_cur_dim = 0; dst_cur_dim < dst_rank; ++dst_cur_dim) GFC_DIMENSION_SET (dst->dim[dst_cur_dim], 1, 1, 1); @@ -1967,7 +2016,7 @@ _gfortran_caf_get_by_ref (caf_token_t token, i = 0; get_for_ref (refs, &i, dst_index, single_token, dst, src, GFC_DESCRIPTOR_DATA (dst), memptr, dst_kind, src_kind, 0, 0, - 1, stat); + 1, stat, src_type); } @@ -1976,7 +2025,7 @@ send_by_ref (caf_reference_t *ref, size_t *i, size_t *src_index, caf_single_token_t single_token, gfc_descriptor_t *dst, gfc_descriptor_t *src, void *ds, void *sr, int dst_kind, int src_kind, size_t dst_dim, size_t src_dim, - size_t num, size_t size, int *stat) + size_t num, size_t size, int *stat, int dst_type) { const char vecrefunknownkind[] = "libcaf_single::caf_send_by_ref(): " "unknown kind in vector-ref.\n"; @@ -1992,7 +2041,6 @@ send_by_ref (caf_reference_t *ref, size_t *i, size_t *src_index, { size_t src_size = GFC_DESCRIPTOR_SIZE (src); ptrdiff_t array_offset_src = 0;; - int dst_type = -1; switch (ref->type) { @@ -2036,26 +2084,18 @@ send_by_ref (caf_reference_t *ref, size_t *i, size_t *src_index, dst_type = GFC_DESCRIPTOR_TYPE (dst); } else - { - /* When no destination descriptor is present, assume that - source and dest type are identical. */ - dst_type = GFC_DESCRIPTOR_TYPE (src); - ds = *(void **)(ds + ref->u.c.offset); - } + ds = *(void **)(ds + ref->u.c.offset); } copy_data (ds, sr, dst_type, GFC_DESCRIPTOR_TYPE (src), dst_kind, src_kind, ref->item_size, src_size, 1, stat); } else - copy_data (ds + ref->u.c.offset, sr, - dst != NULL ? GFC_DESCRIPTOR_TYPE (dst) - : GFC_DESCRIPTOR_TYPE (src), + copy_data (ds + ref->u.c.offset, sr, dst_type, GFC_DESCRIPTOR_TYPE (src), dst_kind, src_kind, ref->item_size, src_size, 1, stat); ++(*i); return; case CAF_REF_STATIC_ARRAY: - dst_type = ref->u.a.static_array_type; /* Intentionally fall through. */ case CAF_REF_ARRAY: if (ref->u.a.mode[dst_dim] == CAF_ARR_REF_NONE) @@ -2064,18 +2104,14 @@ send_by_ref (caf_reference_t *ref, size_t *i, size_t *src_index, { for (size_t d = 0; d < src_rank; ++d) array_offset_src += src_index[d]; - copy_data (ds, sr + array_offset_src * ref->item_size, - dst_type == -1 ? GFC_DESCRIPTOR_TYPE (dst) - : dst_type, - GFC_DESCRIPTOR_TYPE (src), dst_kind, src_kind, - ref->item_size, src_size, num, stat); + copy_data (ds, sr + array_offset_src * src_size, + dst_type, GFC_DESCRIPTOR_TYPE (src), dst_kind, + src_kind, ref->item_size, src_size, num, stat); } else - copy_data (ds, sr, - dst_type == -1 ? GFC_DESCRIPTOR_TYPE (dst) - : dst_type, - GFC_DESCRIPTOR_TYPE (src), dst_kind, src_kind, - ref->item_size, src_size, num, stat); + copy_data (ds, sr, dst_type, GFC_DESCRIPTOR_TYPE (src), + dst_kind, src_kind, ref->item_size, src_size, num, + stat); *i += num; return; } @@ -2123,22 +2159,30 @@ send_by_ref (caf_reference_t *ref, size_t *i, size_t *src_index, return; } single_token = *(caf_single_token_t*)(ds + ref->u.c.caf_token_offset); + /* When a component is allocatable (caf_token_offset != 0) and not an + array (ref->next->type == CAF_REF_COMPONENT), then ds has to be + dereffed. */ + if (ref->next && ref->next->type == CAF_REF_COMPONENT) + ds = *(void **)(ds + ref->u.c.offset); + else + ds += ref->u.c.offset; + send_by_ref (ref->next, i, src_index, single_token, - single_token->desc, src, ds + ref->u.c.offset, sr, - dst_kind, src_kind, 0, src_dim, 1, size, stat); + single_token->desc, src, ds, sr, + dst_kind, src_kind, 0, src_dim, 1, size, stat, dst_type); } else send_by_ref (ref->next, i, src_index, single_token, (gfc_descriptor_t *)(ds + ref->u.c.offset), src, ds + ref->u.c.offset, sr, dst_kind, src_kind, 0, src_dim, - 1, size, stat); + 1, size, stat, dst_type); return; case CAF_REF_ARRAY: if (ref->u.a.mode[dst_dim] == CAF_ARR_REF_NONE) { send_by_ref (ref->next, i, src_index, single_token, (gfc_descriptor_t *)ds, src, ds, sr, dst_kind, src_kind, - 0, src_dim, 1, size, stat); + 0, src_dim, 1, size, stat, dst_type); return; } /* Only when on the left most index switch the data pointer to @@ -2180,7 +2224,7 @@ send_by_ref (caf_reference_t *ref, size_t *i, size_t *src_index, send_by_ref (ref, i, src_index, single_token, dst, src, ds + array_offset_dst * ref->item_size, sr, dst_kind, src_kind, dst_dim + 1, src_dim + 1, - 1, size, stat); + 1, size, stat, dst_type); if (src_rank > 0) src_index[src_dim] += GFC_DIMENSION_STRIDE (src->dim[src_dim]); @@ -2201,7 +2245,7 @@ send_by_ref (caf_reference_t *ref, size_t *i, size_t *src_index, send_by_ref (ref, i, src_index, single_token, dst, src, ds + array_offset_dst * ref->item_size, sr, dst_kind, src_kind, dst_dim + 1, src_dim + 1, - 1, size, stat); + 1, size, stat, dst_type); if (src_rank > 0) src_index[src_dim] += GFC_DIMENSION_STRIDE (src->dim[src_dim]); @@ -2222,7 +2266,7 @@ send_by_ref (caf_reference_t *ref, size_t *i, size_t *src_index, send_by_ref (ref, i, src_index, single_token, dst, src, ds + array_offset_dst * ref->item_size, sr, dst_kind, src_kind, dst_dim + 1, src_dim + 1, - 1, size, stat); + 1, size, stat, dst_type); if (src_rank > 0) src_index[src_dim] += GFC_DIMENSION_STRIDE (src->dim[src_dim]); @@ -2236,7 +2280,7 @@ send_by_ref (caf_reference_t *ref, size_t *i, size_t *src_index, send_by_ref (ref, i, src_index, single_token, dst, src, ds + array_offset_dst * ref->item_size, sr, dst_kind, src_kind, dst_dim + 1, src_dim, 1, - size, stat); + size, stat, dst_type); return; case CAF_ARR_REF_OPEN_END: COMPUTE_NUM_ITEMS (extent_dst, @@ -2253,7 +2297,7 @@ send_by_ref (caf_reference_t *ref, size_t *i, size_t *src_index, send_by_ref (ref, i, src_index, single_token, dst, src, ds + array_offset_dst * ref->item_size, sr, dst_kind, src_kind, dst_dim + 1, src_dim + 1, - 1, size, stat); + 1, size, stat, dst_type); if (src_rank > 0) src_index[src_dim] += GFC_DIMENSION_STRIDE (src->dim[src_dim]); @@ -2274,7 +2318,7 @@ send_by_ref (caf_reference_t *ref, size_t *i, size_t *src_index, send_by_ref (ref, i, src_index, single_token, dst, src, ds + array_offset_dst * ref->item_size, sr, dst_kind, src_kind, dst_dim + 1, src_dim + 1, - 1, size, stat); + 1, size, stat, dst_type); if (src_rank > 0) src_index[src_dim] += GFC_DIMENSION_STRIDE (src->dim[src_dim]); @@ -2290,7 +2334,7 @@ send_by_ref (caf_reference_t *ref, size_t *i, size_t *src_index, { send_by_ref (ref->next, i, src_index, single_token, NULL, src, ds, sr, dst_kind, src_kind, - 0, src_dim, 1, size, stat); + 0, src_dim, 1, size, stat, dst_type); return; } switch (ref->u.a.mode[dst_dim]) @@ -2325,7 +2369,7 @@ send_by_ref (caf_reference_t *ref, size_t *i, size_t *src_index, send_by_ref (ref, i, src_index, single_token, NULL, src, ds + array_offset_dst * ref->item_size, sr, dst_kind, src_kind, dst_dim + 1, src_dim + 1, - 1, size, stat); + 1, size, stat, dst_type); src_index[src_dim] += GFC_DIMENSION_STRIDE (src->dim[src_dim]); } @@ -2339,7 +2383,7 @@ send_by_ref (caf_reference_t *ref, size_t *i, size_t *src_index, send_by_ref (ref, i, src_index, single_token, NULL, src, ds + array_offset_dst * ref->item_size, sr, dst_kind, src_kind, dst_dim + 1, src_dim + 1, - 1, size, stat); + 1, size, stat, dst_type); if (src_rank > 0) src_index[src_dim] += GFC_DIMENSION_STRIDE (src->dim[src_dim]); @@ -2357,7 +2401,7 @@ send_by_ref (caf_reference_t *ref, size_t *i, size_t *src_index, send_by_ref (ref, i, src_index, single_token, NULL, src, ds + array_offset_dst * ref->item_size, sr, dst_kind, src_kind, dst_dim + 1, src_dim + 1, - 1, size, stat); + 1, size, stat, dst_type); if (src_rank > 0) src_index[src_dim] += GFC_DIMENSION_STRIDE (src->dim[src_dim]); @@ -2369,7 +2413,7 @@ send_by_ref (caf_reference_t *ref, size_t *i, size_t *src_index, send_by_ref (ref, i, src_index, single_token, NULL, src, ds + array_offset_dst * ref->item_size, sr, dst_kind, src_kind, dst_dim + 1, src_dim, 1, - size, stat); + size, stat, dst_type); return; /* The OPEN_* are mapped to a RANGE and therefore can not occur. */ case CAF_ARR_REF_OPEN_END: @@ -2390,7 +2434,7 @@ _gfortran_caf_send_by_ref (caf_token_t token, gfc_descriptor_t *src, caf_reference_t *refs, int dst_kind, int src_kind, bool may_require_tmp __attribute__ ((unused)), - bool dst_reallocatable, int *stat) + bool dst_reallocatable, int *stat, int dst_type) { const char vecrefunknownkind[] = "libcaf_single::caf_get_by_ref(): " "unknown kind in vector-ref.\n"; @@ -2748,7 +2792,7 @@ _gfortran_caf_send_by_ref (caf_token_t token, i = 0; send_by_ref (refs, &i, dst_index, single_token, dst, src, memptr, GFC_DESCRIPTOR_DATA (src), dst_kind, src_kind, 0, 0, - 1, size, stat); + 1, size, stat, dst_type); assert (i == size); } @@ -2759,20 +2803,23 @@ _gfortran_caf_sendget_by_ref (caf_token_t dst_token, int dst_image_index, int src_image_index, caf_reference_t *src_refs, int dst_kind, int src_kind, bool may_require_tmp, int *dst_stat, - int *src_stat) + int *src_stat, int dst_type, int src_type) { - gfc_array_void temp; + GFC_FULL_ARRAY_DESCRIPTOR (GFC_MAX_DIMENSIONS, void) temp; + GFC_DESCRIPTOR_DATA (&temp) = NULL; + GFC_DESCRIPTOR_RANK (&temp) = -1; + GFC_DESCRIPTOR_TYPE (&temp) = dst_type; _gfortran_caf_get_by_ref (src_token, src_image_index, &temp, src_refs, dst_kind, src_kind, may_require_tmp, true, - src_stat); + src_stat, src_type); if (src_stat && *src_stat != 0) return; _gfortran_caf_send_by_ref (dst_token, dst_image_index, &temp, dst_refs, - dst_kind, src_kind, may_require_tmp, true, - dst_stat); + dst_kind, dst_kind, may_require_tmp, true, + dst_stat, dst_type); if (GFC_DESCRIPTOR_DATA (&temp)) free (GFC_DESCRIPTOR_DATA (&temp)); } @@ -2870,7 +2917,7 @@ void _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 @@ -2885,7 +2932,7 @@ void _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)); @@ -2912,7 +2959,7 @@ _gfortran_caf_event_query (caf_token_t token, size_t index, 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]; @@ -2941,22 +2988,22 @@ _gfortran_caf_lock (caf_token_t token, size_t 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]; @@ -2974,15 +3021,15 @@ _gfortran_caf_unlock (caf_token_t token, size_t 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 diff --git a/libgfortran/configure b/libgfortran/configure index 60e18a7b3e8..86904ef7eea 100755 --- a/libgfortran/configure +++ b/libgfortran/configure @@ -5804,18 +5804,28 @@ else fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for CET support" >&5 +$as_echo_n "checking for CET support... " >&6; } + case "$host" in i[34567]86-*-linux* | x86_64-*-linux*) case "$enable_cet" in default) - # Check if assembler supports CET. + # Check if target supports multi-byte NOPs + # and if assembler supports CET insn. cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main () { + +#if !defined(__SSE2__) +#error target does not support multi-byte NOPs +#else asm ("setssbsy"); +#endif + ; return 0; } @@ -5855,6 +5865,11 @@ rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext esac if test x$enable_cet = xyes; then CET_FLAGS="-fcf-protection -mcet" + { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +$as_echo "yes" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } fi AM_FCFLAGS="$AM_FCFLAGS $CET_FLAGS" @@ -12498,7 +12513,7 @@ else lt_dlunknown=0; lt_dlno_uscore=1; lt_dlneed_uscore=2 lt_status=$lt_dlunknown cat > conftest.$ac_ext <<_LT_EOF -#line 12501 "configure" +#line 12516 "configure" #include "confdefs.h" #if HAVE_DLFCN_H @@ -12604,7 +12619,7 @@ else lt_dlunknown=0; lt_dlno_uscore=1; lt_dlneed_uscore=2 lt_status=$lt_dlunknown cat > conftest.$ac_ext <<_LT_EOF -#line 12607 "configure" +#line 12622 "configure" #include "confdefs.h" #if HAVE_DLFCN_H diff --git a/libgfortran/io/transfer.c b/libgfortran/io/transfer.c index 8bc828c0214..df33bed1561 100644 --- a/libgfortran/io/transfer.c +++ b/libgfortran/io/transfer.c @@ -3993,6 +3993,10 @@ finalize_transfer (st_parameter_dt *dtp) if (dtp->u.p.unit_is_internal) { + /* The unit structure may be reused later so clear the + internal unit kind. */ + dtp->u.p.current_unit->internal_unit_kind = 0; + fbuf_destroy (dtp->u.p.current_unit); if (dtp->u.p.current_unit && (dtp->u.p.current_unit->child_dtio == 0) diff --git a/libgfortran/libgfortran.h b/libgfortran/libgfortran.h index 38e364f1012..ca06e6db620 100644 --- a/libgfortran/libgfortran.h +++ b/libgfortran/libgfortran.h @@ -888,7 +888,7 @@ internal_proto(filename_from_unit); /* stop.c */ -extern _Noreturn void stop_string (const char *, GFC_INTEGER_4); +extern _Noreturn void stop_string (const char *, size_t, bool); export_proto(stop_string); /* reshape_packed.c */ diff --git a/libgfortran/runtime/pause.c b/libgfortran/runtime/pause.c index 25690d8319e..37672d4a02c 100644 --- a/libgfortran/runtime/pause.c +++ b/libgfortran/runtime/pause.c @@ -40,29 +40,29 @@ do_pause (void) fgets(buff, 4, stdin); if (strncmp(buff, "go\n", 3) != 0) - stop_string ('\0', 0); + stop_string ('\0', 0, false); estr_write ("RESUMED\n"); } /* A numeric PAUSE statement. */ -extern void pause_numeric (GFC_INTEGER_4); +extern void pause_numeric (GFC_INTEGER_8); export_proto(pause_numeric); void -pause_numeric (GFC_INTEGER_4 code) +pause_numeric (GFC_INTEGER_8 code) { - st_printf ("PAUSE %d\n", (int) code); + st_printf ("PAUSE %ld\n", (long) code); do_pause (); } /* A character string or blank PAUSE statement. */ -extern void pause_string (char *string, GFC_INTEGER_4 len); +extern void pause_string (char *string, size_t len); export_proto(pause_string); void -pause_string (char *string, GFC_INTEGER_4 len) +pause_string (char *string, size_t len) { estr_write ("PAUSE "); ssize_t w = write (STDERR_FILENO, string, len); diff --git a/libgfortran/runtime/stop.c b/libgfortran/runtime/stop.c index 6f8b62f8385..1e6dd8c28d0 100644 --- a/libgfortran/runtime/stop.c +++ b/libgfortran/runtime/stop.c @@ -81,14 +81,17 @@ report_exception (void) /* A numeric STOP statement. */ -extern _Noreturn void stop_numeric (GFC_INTEGER_4); +extern _Noreturn void stop_numeric (int, bool); export_proto(stop_numeric); void -stop_numeric (GFC_INTEGER_4 code) +stop_numeric (int code, bool quiet) { - report_exception (); - st_printf ("STOP %d\n", (int)code); + if (!quiet) + { + report_exception (); + st_printf ("STOP %d\n", code); + } exit (code); } @@ -96,14 +99,17 @@ stop_numeric (GFC_INTEGER_4 code) /* A character string or blank STOP statement. */ void -stop_string (const char *string, GFC_INTEGER_4 len) +stop_string (const char *string, size_t len, bool quiet) { - report_exception (); - if (string) + if (!quiet) { - estr_write ("STOP "); - (void) write (STDERR_FILENO, string, len); - estr_write ("\n"); + report_exception (); + if (string) + { + estr_write ("STOP "); + (void) write (STDERR_FILENO, string, len); + estr_write ("\n"); + } } exit (0); } @@ -114,30 +120,35 @@ stop_string (const char *string, GFC_INTEGER_4 len) initiates error termination of execution." Thus, error_stop_string returns a nonzero exit status code. */ -extern _Noreturn void error_stop_string (const char *, GFC_INTEGER_4); +extern _Noreturn void error_stop_string (const char *, size_t, bool); export_proto(error_stop_string); void -error_stop_string (const char *string, GFC_INTEGER_4 len) +error_stop_string (const char *string, size_t len, bool quiet) { - report_exception (); - estr_write ("ERROR STOP "); - (void) write (STDERR_FILENO, string, len); - estr_write ("\n"); - + if (!quiet) + { + report_exception (); + estr_write ("ERROR STOP "); + (void) write (STDERR_FILENO, string, len); + estr_write ("\n"); + } exit_error (1); } /* A numeric ERROR STOP statement. */ -extern _Noreturn void error_stop_numeric (GFC_INTEGER_4); +extern _Noreturn void error_stop_numeric (int, bool); export_proto(error_stop_numeric); void -error_stop_numeric (GFC_INTEGER_4 code) +error_stop_numeric (int code, bool quiet) { - report_exception (); - st_printf ("ERROR STOP %d\n", (int) code); + if (!quiet) + { + report_exception (); + st_printf ("ERROR STOP %d\n", code); + } exit_error (code); } |