]> git.ipfire.org Git - thirdparty/gcc.git/blame - libgfortran/caf/single.c
projects / thirdparty / gcc.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Update copyright years.
[thirdparty/gcc.git] / libgfortran / caf / single.c
CommitLineData
5092eb96 1/* Single-image implementation of GNU Fortran Coarray Library
8d9254fc 2 Copyright (C) 2011-2020 Free Software Foundation, Inc.
5092eb96
TB		 3 Contributed by Tobias Burnus <burnus@net-b.de>
4
5This file is part of the GNU Fortran Coarray Runtime Library (libcaf).
6
7Libcaf is free software; you can redistribute it and/or modify
8it under the terms of the GNU General Public License as published by
9the Free Software Foundation; either version 3, or (at your option)
10any later version.
11
12Libcaf is distributed in the hope that it will be useful,
13but WITHOUT ANY WARRANTY; without even the implied warranty of
14MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15GNU General Public License for more details.
16
17Under Section 7 of GPL version 3, you are granted additional
18permissions described in the GCC Runtime Library Exception, version
193.1, as published by the Free Software Foundation.
20
21You should have received a copy of the GNU General Public License and
22a copy of the GCC Runtime Library Exception along with this program;
23see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
24<http://www.gnu.org/licenses/>. */
25
26#include "libcaf.h"
27#include <stdio.h> /* For fputs and fprintf. */
cc9ae24c 28#include <stdlib.h> /* For exit and malloc. */
4054bc52 29#include <string.h> /* For memcpy and memset. */
80196940 30#include <stdarg.h> /* For variadic arguments. */
3f5fabc0 31#include <stdint.h>
42a8246d 32#include <assert.h>
5092eb96
TB		 33
34/* Define GFC_CAF_CHECK to enable run-time checking. */
35/* #define GFC_CAF_CHECK 1 */
36
3c9f5092
AV		 37struct caf_single_token
38{
39 /* The pointer to the memory registered. For arrays this is the data member
40 in the descriptor. For components it's the pure data pointer. */
41 void *memptr;
42 /* The descriptor when this token is associated to an allocatable array. */
43 gfc_descriptor_t *desc;
44 /* Set when the caf lib has allocated the memory in memptr and is responsible
45 for freeing it on deregister. */
46 bool owning_memory;
47};
48typedef struct caf_single_token *caf_single_token_t;
49
50#define TOKEN(X) ((caf_single_token_t) (X))
51#define MEMTOK(X) ((caf_single_token_t) (X))->memptr
a8a5f4a9 52
5092eb96
TB		 53/* Single-image implementation of the CAF library.
54 Note: For performance reasons -fcoarry=single should be used
55 rather than this library. */
56
0a1138af
DC		 57/* Global variables. */
58caf_static_t *caf_static_list = NULL;
59
80196940
DC		 60/* Keep in sync with mpi.c. */
61static void
62caf_runtime_error (const char *message, ...)
63{
64 va_list ap;
65 fprintf (stderr, "Fortran runtime error: ");
66 va_start (ap, message);
c0f15792 67 vfprintf (stderr, message, ap);
80196940
DC		 68 va_end (ap);
69 fprintf (stderr, "\n");
17abb5ac 70
80196940
DC		 71 /* FIXME: Shutdown the Fortran RTL to flush the buffer. PR 43849. */
72 exit (EXIT_FAILURE);
73}
74
3c9f5092
AV		 75/* Error handling is similar everytime. */
76static void
77caf_internal_error (const char *msg, int *stat, char *errmsg,
3f5fabc0 78 size_t errmsg_len, ...)
3c9f5092
AV		 79{
80 va_list args;
81 va_start (args, errmsg_len);
82 if (stat)
83 {
84 *stat = 1;
85 if (errmsg_len > 0)
86 {
3f5fabc0
JB		 87 int len = snprintf (errmsg, errmsg_len, msg, args);
88 if (len >= 0 && errmsg_len > (size_t) len)
3c9f5092
AV		 89 memset (&errmsg[len], ' ', errmsg_len - len);
90 }
0f0565b1 91 va_end (args);
3c9f5092
AV		 92 return;
93 }
94 else
95 caf_runtime_error (msg, args);
96 va_end (args);
97}
98
99
5092eb96
TB		 100void
101_gfortran_caf_init (int *argc __attribute__ ((unused)),
a8a5f4a9 102 char ***argv __attribute__ ((unused)))
5092eb96 103{
5092eb96
TB		 104}
105
cc9ae24c 106
5092eb96
TB		 107void
108_gfortran_caf_finalize (void)
109{
0a1138af
DC		 110 while (caf_static_list != NULL)
111 {
86187d0f 112 caf_static_t *tmp = caf_static_list->prev;
86187d0f
TB		 113 free (caf_static_list->token);
114 free (caf_static_list);
115 caf_static_list = tmp;
0a1138af 116 }
5092eb96
TB		 117}
118
cc9ae24c 119
a8a5f4a9
TB		 120int
121_gfortran_caf_this_image (int distance __attribute__ ((unused)))
122{
123 return 1;
124}
125
126
127int
128_gfortran_caf_num_images (int distance __attribute__ ((unused)),
a9fe6877 129 int failed __attribute__ ((unused)))
a8a5f4a9
TB		 130{
131 return 1;
132}
133
134
3c9f5092 135void
a8a5f4a9 136_gfortran_caf_register (size_t size, caf_register_t type, caf_token_t *token,
3c9f5092 137 gfc_descriptor_t *data, int *stat, char *errmsg,
3f5fabc0 138 size_t errmsg_len)
cc9ae24c 139{
3c9f5092 140 const char alloc_fail_msg[] = "Failed to allocate coarray";
0a1138af 141 void *local;
3c9f5092 142 caf_single_token_t single_token;
0a1138af 143
bc0229f9 144 if (type == CAF_REGTYPE_LOCK_STATIC || type == CAF_REGTYPE_LOCK_ALLOC
4ccff88b 145 || type == CAF_REGTYPE_CRITICAL)
bc0229f9 146 local = calloc (size, sizeof (bool));
4ccff88b
AV		 147 else if (type == CAF_REGTYPE_EVENT_STATIC || type == CAF_REGTYPE_EVENT_ALLOC)
148 /* In the event_(wait|post) function the counter for events is a uint32,
149 so better allocate enough memory here. */
150 local = calloc (size, sizeof (uint32_t));
ba85c8c3
AV		 151 else if (type == CAF_REGTYPE_COARRAY_ALLOC_REGISTER_ONLY)
152 local = NULL;
bc0229f9
TB		 153 else
154 local = malloc (size);
0a1138af 155
ba85c8c3
AV		 156 if (type != CAF_REGTYPE_COARRAY_ALLOC_ALLOCATE_ONLY)
157 *token = malloc (sizeof (struct caf_single_token));
158
159 if (unlikely (*token == NULL
160 || (local == NULL
161 && type != CAF_REGTYPE_COARRAY_ALLOC_REGISTER_ONLY)))
4054bc52 162 {
0f0565b1
AV		 163 /* Freeing the memory conditionally seems pointless, but
164 caf_internal_error () may return, when a stat is given and then the
165 memory may be lost. */
166 if (local)
167 free (local);
168 if (*token)
169 free (*token);
3c9f5092
AV		 170 caf_internal_error (alloc_fail_msg, stat, errmsg, errmsg_len);
171 return;
4054bc52
TB		 172 }
173
3c9f5092
AV		 174 single_token = TOKEN (*token);
175 single_token->memptr = local;
ba85c8c3 176 single_token->owning_memory = type != CAF_REGTYPE_COARRAY_ALLOC_REGISTER_ONLY;
3c9f5092
AV		 177 single_token->desc = GFC_DESCRIPTOR_RANK (data) > 0 ? data : NULL;
178
a8a5f4a9 179
4054bc52
TB		 180 if (stat)
181 *stat = 0;
182
bc0229f9 183 if (type == CAF_REGTYPE_COARRAY_STATIC || type == CAF_REGTYPE_LOCK_STATIC
5df445a2
TB		 184 || type == CAF_REGTYPE_CRITICAL || type == CAF_REGTYPE_EVENT_STATIC
185 || type == CAF_REGTYPE_EVENT_ALLOC)
0a1138af
DC		 186 {
187 caf_static_t *tmp = malloc (sizeof (caf_static_t));
188 tmp->prev = caf_static_list;
5d81ddd0 189 tmp->token = *token;
0a1138af
DC		 190 caf_static_list = tmp;
191 }
3c9f5092 192 GFC_DESCRIPTOR_DATA (data) = local;
cc9ae24c
TB		 193}
194
195
86187d0f 196void
ba85c8c3 197_gfortran_caf_deregister (caf_token_t *token, caf_deregister_t type, int *stat,
86187d0f 198 char *errmsg __attribute__ ((unused)),
3f5fabc0 199 size_t errmsg_len __attribute__ ((unused)))
cc9ae24c 200{
3c9f5092
AV		 201 caf_single_token_t single_token = TOKEN (*token);
202
203 if (single_token->owning_memory && single_token->memptr)
204 free (single_token->memptr);
205
ba85c8c3
AV		 206 if (type != CAF_DEREGTYPE_COARRAY_DEALLOCATE_ONLY)
207 {
208 free (TOKEN (*token));
209 *token = NULL;
210 }
211 else
212 {
213 single_token->memptr = NULL;
214 single_token->owning_memory = false;
215 }
86187d0f
TB		 216
217 if (stat)
218 *stat = 0;
cc9ae24c
TB		 219}
220
221
f5c01f5b
DC		 222void
223_gfortran_caf_sync_all (int *stat,
224 char *errmsg __attribute__ ((unused)),
3f5fabc0 225 size_t errmsg_len __attribute__ ((unused)))
5092eb96 226{
9315dff0
AF		 227 __asm__ __volatile__ ("":::"memory");
228 if (stat)
229 *stat = 0;
230}
231
232
233void
234_gfortran_caf_sync_memory (int *stat,
235 char *errmsg __attribute__ ((unused)),
3f5fabc0 236 size_t errmsg_len __attribute__ ((unused)))
9315dff0
AF		 237{
238 __asm__ __volatile__ ("":::"memory");
f5c01f5b
DC		 239 if (stat)
240 *stat = 0;
5092eb96
TB		 241}
242
0a1138af 243
f5c01f5b 244void
5092eb96
TB		 245_gfortran_caf_sync_images (int count __attribute__ ((unused)),
246 int images[] __attribute__ ((unused)),
f5c01f5b 247 int *stat,
5092eb96 248 char *errmsg __attribute__ ((unused)),
3f5fabc0 249 size_t errmsg_len __attribute__ ((unused)))
5092eb96
TB		 250{
251#ifdef GFC_CAF_CHECK
252 int i;
253
254 for (i = 0; i < count; i++)
255 if (images[i] != 1)
256 {
257 fprintf (stderr, "COARRAY ERROR: Invalid image index %d to SYNC "
258 "IMAGES", images[i]);
80196940 259 exit (EXIT_FAILURE);
5092eb96
TB		 260 }
261#endif
262
9315dff0 263 __asm__ __volatile__ ("":::"memory");
f5c01f5b
DC		 264 if (stat)
265 *stat = 0;
5092eb96
TB		 266}
267
ef78bc3c 268
0daa7ed9 269void
dffb1e22 270_gfortran_caf_stop_numeric(int stop_code, bool quiet)
0daa7ed9 271{
dffb1e22
JB		 272 if (!quiet)
273 fprintf (stderr, "STOP %d\n", stop_code);
0daa7ed9
AF		 274 exit (0);
275}
276
ef78bc3c 277
0daa7ed9 278void
dffb1e22 279_gfortran_caf_stop_str(const char *string, size_t len, bool quiet)
0daa7ed9 280{
dffb1e22
JB		 281 if (!quiet)
282 {
283 fputs ("STOP ", stderr);
284 while (len--)
285 fputc (*(string++), stderr);
286 fputs ("\n", stderr);
287 }
0daa7ed9
AF		 288 exit (0);
289}
5092eb96 290
ef78bc3c 291
5092eb96 292void
dffb1e22 293_gfortran_caf_error_stop_str (const char *string, size_t len, bool quiet)
5092eb96 294{
dffb1e22
JB		 295 if (!quiet)
296 {
297 fputs ("ERROR STOP ", stderr);
298 while (len--)
299 fputc (*(string++), stderr);
300 fputs ("\n", stderr);
301 }
5092eb96
TB		 302 exit (1);
303}
304
cc9ae24c 305
ef78bc3c
AV		 306/* Reported that the program terminated because of a fail image issued.
307 Because this is a single image library, nothing else than aborting the whole
308 program can be done. */
309
310void _gfortran_caf_fail_image (void)
311{
312 fputs ("IMAGE FAILED!\n", stderr);
313 exit (0);
314}
315
316
317/* Get the status of image IMAGE. Because being the single image library all
318 other images are reported to be stopped. */
319
320int _gfortran_caf_image_status (int image,
321 caf_team_t * team __attribute__ ((unused)))
322{
323 if (image == 1)
324 return 0;
325 else
326 return CAF_STAT_STOPPED_IMAGE;
327}
328
329
67914693 330/* Single image library. There cannot be any failed images with only one
ef78bc3c
AV		 331 image. */
332
333void
334_gfortran_caf_failed_images (gfc_descriptor_t *array,
335 caf_team_t * team __attribute__ ((unused)),
336 int * kind)
337{
338 int local_kind = kind != NULL ? *kind : 4;
339
340 array->base_addr = NULL;
7fb43006
PT		 341 array->dtype.type = BT_INTEGER;
342 array->dtype.elem_len = local_kind;
ef78bc3c
AV		 343 /* Setting lower_bound higher then upper_bound is what the compiler does to
344 indicate an empty array. */
345 array->dim[0].lower_bound = 0;
346 array->dim[0]._ubound = -1;
347 array->dim[0]._stride = 1;
348 array->offset = 0;
349}
350
351
352/* With only one image available no other images can be stopped. Therefore
353 return an empty array. */
354
355void
356_gfortran_caf_stopped_images (gfc_descriptor_t *array,
357 caf_team_t * team __attribute__ ((unused)),
358 int * kind)
359{
360 int local_kind = kind != NULL ? *kind : 4;
361
362 array->base_addr = NULL;
7fb43006
PT		 363 array->dtype.type = BT_INTEGER;
364 array->dtype.elem_len = local_kind;
ef78bc3c
AV		 365 /* Setting lower_bound higher then upper_bound is what the compiler does to
366 indicate an empty array. */
367 array->dim[0].lower_bound = 0;
368 array->dim[0]._ubound = -1;
369 array->dim[0]._stride = 1;
370 array->offset = 0;
371}
372
373
5092eb96 374void
dffb1e22 375_gfortran_caf_error_stop (int error, bool quiet)
5092eb96 376{
dffb1e22
JB		 377 if (!quiet)
378 fprintf (stderr, "ERROR STOP %d\n", error);
5092eb96
TB		 379 exit (error);
380}
d62cf3df
TB		 381
382
a16ee379
TB		 383void
384_gfortran_caf_co_broadcast (gfc_descriptor_t *a __attribute__ ((unused)),
385 int source_image __attribute__ ((unused)),
386 int *stat, char *errmsg __attribute__ ((unused)),
3f5fabc0 387 size_t errmsg_len __attribute__ ((unused)))
a16ee379
TB		 388{
389 if (stat)
390 *stat = 0;
391}
392
d62cf3df 393void
b5116268 394_gfortran_caf_co_sum (gfc_descriptor_t *a __attribute__ ((unused)),
d62cf3df
TB		 395 int result_image __attribute__ ((unused)),
396 int *stat, char *errmsg __attribute__ ((unused)),
3f5fabc0 397 size_t errmsg_len __attribute__ ((unused)))
d62cf3df
TB		 398{
399 if (stat)
7f6c4159 400 *stat = 0;
d62cf3df
TB		 401}
402
403void
b5116268 404_gfortran_caf_co_min (gfc_descriptor_t *a __attribute__ ((unused)),
d62cf3df
TB		 405 int result_image __attribute__ ((unused)),
406 int *stat, char *errmsg __attribute__ ((unused)),
a16ee379 407 int a_len __attribute__ ((unused)),
3f5fabc0 408 size_t errmsg_len __attribute__ ((unused)))
d62cf3df
TB		 409{
410 if (stat)
7f6c4159 411 *stat = 0;
d62cf3df
TB		 412}
413
414void
b5116268 415_gfortran_caf_co_max (gfc_descriptor_t *a __attribute__ ((unused)),
d62cf3df
TB		 416 int result_image __attribute__ ((unused)),
417 int *stat, char *errmsg __attribute__ ((unused)),
a16ee379 418 int a_len __attribute__ ((unused)),
3f5fabc0 419 size_t errmsg_len __attribute__ ((unused)))
d62cf3df
TB		 420{
421 if (stat)
7f6c4159 422 *stat = 0;
d62cf3df 423}
b5116268 424
5c75088c 425
09de7c25
TB		 426void
427_gfortran_caf_co_reduce (gfc_descriptor_t *a __attribute__ ((unused)),
428 void * (*opr) (void *, void *)
429 __attribute__ ((unused)),
430 int opr_flags __attribute__ ((unused)),
431 int result_image __attribute__ ((unused)),
432 int *stat, char *errmsg __attribute__ ((unused)),
433 int a_len __attribute__ ((unused)),
3f5fabc0 434 size_t errmsg_len __attribute__ ((unused)))
09de7c25
TB		 435 {
436 if (stat)
437 *stat = 0;
438 }
439
440
5c75088c
TB		 441static void
442assign_char4_from_char1 (size_t dst_size, size_t src_size, uint32_t *dst,
443 unsigned char *src)
444{
445 size_t i, n;
446 n = dst_size/4 > src_size ? src_size : dst_size/4;
447 for (i = 0; i < n; ++i)
448 dst[i] = (int32_t) src[i];
449 for (; i < dst_size/4; ++i)
450 dst[i] = (int32_t) ' ';
451}
452
453
454static void
455assign_char1_from_char4 (size_t dst_size, size_t src_size, unsigned char *dst,
456 uint32_t *src)
457{
458 size_t i, n;
459 n = dst_size > src_size/4 ? src_size/4 : dst_size;
460 for (i = 0; i < n; ++i)
461 dst[i] = src[i] > UINT8_MAX ? (unsigned char) '?' : (unsigned char) src[i];
462 if (dst_size > n)
3c9f5092 463 memset (&dst[n], ' ', dst_size - n);
5c75088c
TB		 464}
465
466
467static void
468convert_type (void *dst, int dst_type, int dst_kind, void *src, int src_type,
9fe9a3a7 469 int src_kind, int *stat)
5c75088c
TB		 470{
471#ifdef HAVE_GFC_INTEGER_16
472 typedef __int128 int128t;
473#else
474 typedef int64_t int128t;
475#endif
476
477#if defined(GFC_REAL_16_IS_LONG_DOUBLE)
478 typedef long double real128t;
479 typedef _Complex long double complex128t;
480#elif defined(HAVE_GFC_REAL_16)
481 typedef _Complex float __attribute__((mode(TC))) __complex128;
482 typedef __float128 real128t;
483 typedef __complex128 complex128t;
484#elif defined(HAVE_GFC_REAL_10)
485 typedef long double real128t;
486 typedef long double complex128t;
487#else
488 typedef double real128t;
489 typedef _Complex double complex128t;
490#endif
491
492 int128t int_val = 0;
493 real128t real_val = 0;
494 complex128t cmpx_val = 0;
495
496 switch (src_type)
497 {
498 case BT_INTEGER:
499 if (src_kind == 1)
500 int_val = *(int8_t*) src;
501 else if (src_kind == 2)
502 int_val = *(int16_t*) src;
503 else if (src_kind == 4)
504 int_val = *(int32_t*) src;
505 else if (src_kind == 8)
506 int_val = *(int64_t*) src;
507#ifdef HAVE_GFC_INTEGER_16
508 else if (src_kind == 16)
509 int_val = *(int128t*) src;
510#endif
511 else
512 goto error;
513 break;
514 case BT_REAL:
515 if (src_kind == 4)
516 real_val = *(float*) src;
517 else if (src_kind == 8)
518 real_val = *(double*) src;
519#ifdef HAVE_GFC_REAL_10
520 else if (src_kind == 10)
521 real_val = *(long double*) src;
522#endif
523#ifdef HAVE_GFC_REAL_16
524 else if (src_kind == 16)
525 real_val = *(real128t*) src;
526#endif
527 else
528 goto error;
529 break;
530 case BT_COMPLEX:
531 if (src_kind == 4)
532 cmpx_val = *(_Complex float*) src;
533 else if (src_kind == 8)
534 cmpx_val = *(_Complex double*) src;
535#ifdef HAVE_GFC_REAL_10
536 else if (src_kind == 10)
537 cmpx_val = *(_Complex long double*) src;
538#endif
539#ifdef HAVE_GFC_REAL_16
540 else if (src_kind == 16)
541 cmpx_val = *(complex128t*) src;
542#endif
543 else
544 goto error;
545 break;
546 default:
547 goto error;
548 }
549
550 switch (dst_type)
551 {
552 case BT_INTEGER:
553 if (src_type == BT_INTEGER)
554 {
555 if (dst_kind == 1)
556 *(int8_t*) dst = (int8_t) int_val;
557 else if (dst_kind == 2)
558 *(int16_t*) dst = (int16_t) int_val;
559 else if (dst_kind == 4)
560 *(int32_t*) dst = (int32_t) int_val;
561 else if (dst_kind == 8)
562 *(int64_t*) dst = (int64_t) int_val;
563#ifdef HAVE_GFC_INTEGER_16
564 else if (dst_kind == 16)
565 *(int128t*) dst = (int128t) int_val;
566#endif
567 else
568 goto error;
569 }
570 else if (src_type == BT_REAL)
571 {
572 if (dst_kind == 1)
573 *(int8_t*) dst = (int8_t) real_val;
574 else if (dst_kind == 2)
575 *(int16_t*) dst = (int16_t) real_val;
576 else if (dst_kind == 4)
577 *(int32_t*) dst = (int32_t) real_val;
578 else if (dst_kind == 8)
579 *(int64_t*) dst = (int64_t) real_val;
580#ifdef HAVE_GFC_INTEGER_16
581 else if (dst_kind == 16)
582 *(int128t*) dst = (int128t) real_val;
583#endif
584 else
585 goto error;
586 }
587 else if (src_type == BT_COMPLEX)
588 {
589 if (dst_kind == 1)
590 *(int8_t*) dst = (int8_t) cmpx_val;
591 else if (dst_kind == 2)
592 *(int16_t*) dst = (int16_t) cmpx_val;
593 else if (dst_kind == 4)
594 *(int32_t*) dst = (int32_t) cmpx_val;
595 else if (dst_kind == 8)
596 *(int64_t*) dst = (int64_t) cmpx_val;
597#ifdef HAVE_GFC_INTEGER_16
598 else if (dst_kind == 16)
599 *(int128t*) dst = (int128t) cmpx_val;
600#endif
601 else
602 goto error;
603 }
604 else
605 goto error;
3c9f5092 606 return;
5c75088c
TB		 607 case BT_REAL:
608 if (src_type == BT_INTEGER)
609 {
610 if (dst_kind == 4)
611 *(float*) dst = (float) int_val;
612 else if (dst_kind == 8)
613 *(double*) dst = (double) int_val;
614#ifdef HAVE_GFC_REAL_10
615 else if (dst_kind == 10)
616 *(long double*) dst = (long double) int_val;
617#endif
618#ifdef HAVE_GFC_REAL_16
619 else if (dst_kind == 16)
620 *(real128t*) dst = (real128t) int_val;
621#endif
622 else
623 goto error;
624 }
625 else if (src_type == BT_REAL)
626 {
627 if (dst_kind == 4)
628 *(float*) dst = (float) real_val;
629 else if (dst_kind == 8)
630 *(double*) dst = (double) real_val;
631#ifdef HAVE_GFC_REAL_10
632 else if (dst_kind == 10)
633 *(long double*) dst = (long double) real_val;
634#endif
635#ifdef HAVE_GFC_REAL_16
636 else if (dst_kind == 16)
637 *(real128t*) dst = (real128t) real_val;
638#endif
639 else
640 goto error;
641 }
642 else if (src_type == BT_COMPLEX)
643 {
644 if (dst_kind == 4)
645 *(float*) dst = (float) cmpx_val;
646 else if (dst_kind == 8)
647 *(double*) dst = (double) cmpx_val;
648#ifdef HAVE_GFC_REAL_10
649 else if (dst_kind == 10)
650 *(long double*) dst = (long double) cmpx_val;
651#endif
652#ifdef HAVE_GFC_REAL_16
653 else if (dst_kind == 16)
654 *(real128t*) dst = (real128t) cmpx_val;
655#endif
656 else
657 goto error;
658 }
3c9f5092 659 return;
5c75088c
TB		 660 case BT_COMPLEX:
661 if (src_type == BT_INTEGER)
662 {
663 if (dst_kind == 4)
664 *(_Complex float*) dst = (_Complex float) int_val;
665 else if (dst_kind == 8)
666 *(_Complex double*) dst = (_Complex double) int_val;
667#ifdef HAVE_GFC_REAL_10
668 else if (dst_kind == 10)
669 *(_Complex long double*) dst = (_Complex long double) int_val;
670#endif
671#ifdef HAVE_GFC_REAL_16
672 else if (dst_kind == 16)
673 *(complex128t*) dst = (complex128t) int_val;
674#endif
675 else
676 goto error;
677 }
678 else if (src_type == BT_REAL)
679 {
680 if (dst_kind == 4)
681 *(_Complex float*) dst = (_Complex float) real_val;
682 else if (dst_kind == 8)
683 *(_Complex double*) dst = (_Complex double) real_val;
684#ifdef HAVE_GFC_REAL_10
685 else if (dst_kind == 10)
686 *(_Complex long double*) dst = (_Complex long double) real_val;
687#endif
688#ifdef HAVE_GFC_REAL_16
689 else if (dst_kind == 16)
690 *(complex128t*) dst = (complex128t) real_val;
691#endif
692 else
693 goto error;
694 }
695 else if (src_type == BT_COMPLEX)
696 {
697 if (dst_kind == 4)
698 *(_Complex float*) dst = (_Complex float) cmpx_val;
699 else if (dst_kind == 8)
700 *(_Complex double*) dst = (_Complex double) cmpx_val;
701#ifdef HAVE_GFC_REAL_10
702 else if (dst_kind == 10)
703 *(_Complex long double*) dst = (_Complex long double) cmpx_val;
704#endif
705#ifdef HAVE_GFC_REAL_16
706 else if (dst_kind == 16)
707 *(complex128t*) dst = (complex128t) cmpx_val;
708#endif
709 else
710 goto error;
711 }
712 else
713 goto error;
3c9f5092 714 return;
5c75088c
TB		 715 default:
716 goto error;
717 }
718
719error:
720 fprintf (stderr, "libcaf_single RUNTIME ERROR: Cannot convert type %d kind "
721 "%d to type %d kind %d\n", src_type, src_kind, dst_type, dst_kind);
9fe9a3a7
AV		 722 if (stat)
723 *stat = 1;
724 else
725 abort ();
5c75088c
TB		 726}
727
728
b5116268
TB		 729void
730_gfortran_caf_get (caf_token_t token, size_t offset,
731 int image_index __attribute__ ((unused)),
bc0229f9 732 gfc_descriptor_t *src,
b5116268 733 caf_vector_t *src_vector __attribute__ ((unused)),
93e2e046 734 gfc_descriptor_t *dest, int src_kind, int dst_kind,
9fe9a3a7 735 bool may_require_tmp, int *stat)
b5116268 736{
5c75088c 737 /* FIXME: Handle vector subscripts. */
b5116268
TB		 738 size_t i, k, size;
739 int j;
740 int rank = GFC_DESCRIPTOR_RANK (dest);
741 size_t src_size = GFC_DESCRIPTOR_SIZE (src);
742 size_t dst_size = GFC_DESCRIPTOR_SIZE (dest);
743
9fe9a3a7
AV		 744 if (stat)
745 *stat = 0;
746
b5116268
TB		 747 if (rank == 0)
748 {
3c9f5092 749 void *sr = (void *) ((char *) MEMTOK (token) + offset);
5c75088c
TB		 750 if (GFC_DESCRIPTOR_TYPE (dest) == GFC_DESCRIPTOR_TYPE (src)
751 && dst_kind == src_kind)
b5116268 752 {
5c75088c
TB		 753 memmove (GFC_DESCRIPTOR_DATA (dest), sr,
754 dst_size > src_size ? src_size : dst_size);
755 if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_size > src_size)
756 {
757 if (dst_kind == 1)
758 memset ((void*)(char*) GFC_DESCRIPTOR_DATA (dest) + src_size,
759 ' ', dst_size - src_size);
760 else /* dst_kind == 4. */
761 for (i = src_size/4; i < dst_size/4; i++)
762 ((int32_t*) GFC_DESCRIPTOR_DATA (dest))[i] = (int32_t) ' ';
763 }
b5116268 764 }
5c75088c
TB		 765 else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_kind == 1)
766 assign_char1_from_char4 (dst_size, src_size, GFC_DESCRIPTOR_DATA (dest),
767 sr);
768 else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER)
769 assign_char4_from_char1 (dst_size, src_size, GFC_DESCRIPTOR_DATA (dest),
770 sr);
771 else
772 convert_type (GFC_DESCRIPTOR_DATA (dest), GFC_DESCRIPTOR_TYPE (dest),
9fe9a3a7 773 dst_kind, sr, GFC_DESCRIPTOR_TYPE (src), src_kind, stat);
b5116268
TB		 774 return;
775 }
776
777 size = 1;
778 for (j = 0; j < rank; j++)
779 {
780 ptrdiff_t dimextent = dest->dim[j]._ubound - dest->dim[j].lower_bound + 1;
781 if (dimextent < 0)
782 dimextent = 0;
783 size *= dimextent;
784 }
785
786 if (size == 0)
787 return;
788
93e2e046
TB		 789 if (may_require_tmp)
790 {
791 ptrdiff_t array_offset_sr, array_offset_dst;
792 void *tmp = malloc (size*src_size);
793
794 array_offset_dst = 0;
795 for (i = 0; i < size; i++)
796 {
797 ptrdiff_t array_offset_sr = 0;
798 ptrdiff_t stride = 1;
799 ptrdiff_t extent = 1;
800 for (j = 0; j < GFC_DESCRIPTOR_RANK (src)-1; j++)
801 {
802 array_offset_sr += ((i / (extent*stride))
803 % (src->dim[j]._ubound
804 - src->dim[j].lower_bound + 1))
805 * src->dim[j]._stride;
806 extent = (src->dim[j]._ubound - src->dim[j].lower_bound + 1);
807 stride = src->dim[j]._stride;
808 }
809 array_offset_sr += (i / extent) * src->dim[rank-1]._stride;
3c9f5092 810 void *sr = (void *)((char *) MEMTOK (token) + offset
93e2e046
TB		 811 + array_offset_sr*GFC_DESCRIPTOR_SIZE (src));
812 memcpy ((void *) ((char *) tmp + array_offset_dst), sr, src_size);
813 array_offset_dst += src_size;
814 }
815
816 array_offset_sr = 0;
817 for (i = 0; i < size; i++)
818 {
819 ptrdiff_t array_offset_dst = 0;
820 ptrdiff_t stride = 1;
821 ptrdiff_t extent = 1;
822 for (j = 0; j < rank-1; j++)
823 {
824 array_offset_dst += ((i / (extent*stride))
825 % (dest->dim[j]._ubound
826 - dest->dim[j].lower_bound + 1))
827 * dest->dim[j]._stride;
828 extent = (dest->dim[j]._ubound - dest->dim[j].lower_bound + 1);
829 stride = dest->dim[j]._stride;
830 }
831 array_offset_dst += (i / extent) * dest->dim[rank-1]._stride;
832 void *dst = dest->base_addr
833 + array_offset_dst*GFC_DESCRIPTOR_SIZE (dest);
834 void *sr = tmp + array_offset_sr;
835
836 if (GFC_DESCRIPTOR_TYPE (dest) == GFC_DESCRIPTOR_TYPE (src)
837 && dst_kind == src_kind)
838 {
839 memmove (dst, sr, dst_size > src_size ? src_size : dst_size);
840 if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER
841 && dst_size > src_size)
842 {
843 if (dst_kind == 1)
844 memset ((void*)(char*) dst + src_size, ' ',
845 dst_size-src_size);
846 else /* dst_kind == 4. */
847 for (k = src_size/4; k < dst_size/4; k++)
848 ((int32_t*) dst)[k] = (int32_t) ' ';
849 }
850 }
851 else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_kind == 1)
852 assign_char1_from_char4 (dst_size, src_size, dst, sr);
853 else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER)
854 assign_char4_from_char1 (dst_size, src_size, dst, sr);
855 else
856 convert_type (dst, GFC_DESCRIPTOR_TYPE (dest), dst_kind,
9fe9a3a7 857 sr, GFC_DESCRIPTOR_TYPE (src), src_kind, stat);
93e2e046
TB		 858 array_offset_sr += src_size;
859 }
860
861 free (tmp);
862 return;
863 }
864
b5116268
TB		 865 for (i = 0; i < size; i++)
866 {
867 ptrdiff_t array_offset_dst = 0;
868 ptrdiff_t stride = 1;
869 ptrdiff_t extent = 1;
870 for (j = 0; j < rank-1; j++)
871 {
872 array_offset_dst += ((i / (extent*stride))
873 % (dest->dim[j]._ubound
874 - dest->dim[j].lower_bound + 1))
875 * dest->dim[j]._stride;
876 extent = (dest->dim[j]._ubound - dest->dim[j].lower_bound + 1);
877 stride = dest->dim[j]._stride;
878 }
879 array_offset_dst += (i / extent) * dest->dim[rank-1]._stride;
880 void *dst = dest->base_addr + array_offset_dst*GFC_DESCRIPTOR_SIZE (dest);
881
5c75088c
TB		 882 ptrdiff_t array_offset_sr = 0;
883 stride = 1;
884 extent = 1;
885 for (j = 0; j < GFC_DESCRIPTOR_RANK (src)-1; j++)
b5116268 886 {
5c75088c
TB		 887 array_offset_sr += ((i / (extent*stride))
888 % (src->dim[j]._ubound
889 - src->dim[j].lower_bound + 1))
890 * src->dim[j]._stride;
891 extent = (src->dim[j]._ubound - src->dim[j].lower_bound + 1);
892 stride = src->dim[j]._stride;
b5116268 893 }
5c75088c 894 array_offset_sr += (i / extent) * src->dim[rank-1]._stride;
3c9f5092 895 void *sr = (void *)((char *) MEMTOK (token) + offset
5c75088c 896 + array_offset_sr*GFC_DESCRIPTOR_SIZE (src));
b5116268 897
5c75088c
TB		 898 if (GFC_DESCRIPTOR_TYPE (dest) == GFC_DESCRIPTOR_TYPE (src)
899 && dst_kind == src_kind)
b5116268 900 {
5c75088c
TB		 901 memmove (dst, sr, dst_size > src_size ? src_size : dst_size);
902 if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_size > src_size)
903 {
904 if (dst_kind == 1)
905 memset ((void*)(char*) dst + src_size, ' ', dst_size-src_size);
906 else /* dst_kind == 4. */
907 for (k = src_size/4; k < dst_size/4; k++)
908 ((int32_t*) dst)[k] = (int32_t) ' ';
909 }
b5116268 910 }
5c75088c
TB		 911 else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_kind == 1)
912 assign_char1_from_char4 (dst_size, src_size, dst, sr);
913 else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER)
914 assign_char4_from_char1 (dst_size, src_size, dst, sr);
915 else
916 convert_type (dst, GFC_DESCRIPTOR_TYPE (dest), dst_kind,
9fe9a3a7 917 sr, GFC_DESCRIPTOR_TYPE (src), src_kind, stat);
b5116268
TB		 918 }
919}
920
921
922void
923_gfortran_caf_send (caf_token_t token, size_t offset,
924 int image_index __attribute__ ((unused)),
925 gfc_descriptor_t *dest,
926 caf_vector_t *dst_vector __attribute__ ((unused)),
93e2e046 927 gfc_descriptor_t *src, int dst_kind, int src_kind,
9fe9a3a7 928 bool may_require_tmp, int *stat)
b5116268 929{
5c75088c 930 /* FIXME: Handle vector subscripts. */
b5116268
TB		 931 size_t i, k, size;
932 int j;
933 int rank = GFC_DESCRIPTOR_RANK (dest);
934 size_t src_size = GFC_DESCRIPTOR_SIZE (src);
935 size_t dst_size = GFC_DESCRIPTOR_SIZE (dest);
936
9fe9a3a7
AV		 937 if (stat)
938 *stat = 0;
939
b5116268
TB		 940 if (rank == 0)
941 {
3c9f5092 942 void *dst = (void *) ((char *) MEMTOK (token) + offset);
5c75088c
TB		 943 if (GFC_DESCRIPTOR_TYPE (dest) == GFC_DESCRIPTOR_TYPE (src)
944 && dst_kind == src_kind)
b5116268 945 {
5c75088c
TB		 946 memmove (dst, GFC_DESCRIPTOR_DATA (src),
947 dst_size > src_size ? src_size : dst_size);
948 if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_size > src_size)
949 {
950 if (dst_kind == 1)
951 memset ((void*)(char*) dst + src_size, ' ', dst_size-src_size);
952 else /* dst_kind == 4. */
953 for (i = src_size/4; i < dst_size/4; i++)
954 ((int32_t*) dst)[i] = (int32_t) ' ';
955 }
b5116268 956 }
5c75088c
TB		 957 else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_kind == 1)
958 assign_char1_from_char4 (dst_size, src_size, dst,
959 GFC_DESCRIPTOR_DATA (src));
960 else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER)
961 assign_char4_from_char1 (dst_size, src_size, dst,
962 GFC_DESCRIPTOR_DATA (src));
963 else
964 convert_type (dst, GFC_DESCRIPTOR_TYPE (dest), dst_kind,
965 GFC_DESCRIPTOR_DATA (src), GFC_DESCRIPTOR_TYPE (src),
9fe9a3a7 966 src_kind, stat);
b5116268
TB		 967 return;
968 }
969
970 size = 1;
971 for (j = 0; j < rank; j++)
972 {
973 ptrdiff_t dimextent = dest->dim[j]._ubound - dest->dim[j].lower_bound + 1;
974 if (dimextent < 0)
975 dimextent = 0;
976 size *= dimextent;
977 }
978
979 if (size == 0)
980 return;
981
93e2e046
TB		 982 if (may_require_tmp)
983 {
984 ptrdiff_t array_offset_sr, array_offset_dst;
985 void *tmp;
986
987 if (GFC_DESCRIPTOR_RANK (src) == 0)
988 {
989 tmp = malloc (src_size);
990 memcpy (tmp, GFC_DESCRIPTOR_DATA (src), src_size);
991 }
992 else
993 {
994 tmp = malloc (size*src_size);
995 array_offset_dst = 0;
996 for (i = 0; i < size; i++)
997 {
998 ptrdiff_t array_offset_sr = 0;
999 ptrdiff_t stride = 1;
1000 ptrdiff_t extent = 1;
1001 for (j = 0; j < GFC_DESCRIPTOR_RANK (src)-1; j++)
1002 {
1003 array_offset_sr += ((i / (extent*stride))
1004 % (src->dim[j]._ubound
1005 - src->dim[j].lower_bound + 1))
1006 * src->dim[j]._stride;
1007 extent = (src->dim[j]._ubound - src->dim[j].lower_bound + 1);
1008 stride = src->dim[j]._stride;
1009 }
1010 array_offset_sr += (i / extent) * src->dim[rank-1]._stride;
1011 void *sr = (void *) ((char *) src->base_addr
1012 + array_offset_sr*GFC_DESCRIPTOR_SIZE (src));
1013 memcpy ((void *) ((char *) tmp + array_offset_dst), sr, src_size);
1014 array_offset_dst += src_size;
1015 }
1016 }
1017
1018 array_offset_sr = 0;
1019 for (i = 0; i < size; i++)
1020 {
1021 ptrdiff_t array_offset_dst = 0;
1022 ptrdiff_t stride = 1;
1023 ptrdiff_t extent = 1;
1024 for (j = 0; j < rank-1; j++)
1025 {
1026 array_offset_dst += ((i / (extent*stride))
1027 % (dest->dim[j]._ubound
1028 - dest->dim[j].lower_bound + 1))
1029 * dest->dim[j]._stride;
1030 extent = (dest->dim[j]._ubound - dest->dim[j].lower_bound + 1);
1031 stride = dest->dim[j]._stride;
1032 }
1033 array_offset_dst += (i / extent) * dest->dim[rank-1]._stride;
3c9f5092 1034 void *dst = (void *)((char *) MEMTOK (token) + offset
93e2e046
TB		 1035 + array_offset_dst*GFC_DESCRIPTOR_SIZE (dest));
1036 void *sr = tmp + array_offset_sr;
1037 if (GFC_DESCRIPTOR_TYPE (dest) == GFC_DESCRIPTOR_TYPE (src)
1038 && dst_kind == src_kind)
1039 {
1040 memmove (dst, sr,
1041 dst_size > src_size ? src_size : dst_size);
1042 if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER
1043 && dst_size > src_size)
1044 {
1045 if (dst_kind == 1)
1046 memset ((void*)(char*) dst + src_size, ' ',
1047 dst_size-src_size);
1048 else /* dst_kind == 4. */
1049 for (k = src_size/4; k < dst_size/4; k++)
1050 ((int32_t*) dst)[k] = (int32_t) ' ';
1051 }
1052 }
1053 else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_kind == 1)
1054 assign_char1_from_char4 (dst_size, src_size, dst, sr);
1055 else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER)
1056 assign_char4_from_char1 (dst_size, src_size, dst, sr);
1057 else
1058 convert_type (dst, GFC_DESCRIPTOR_TYPE (dest), dst_kind,
9fe9a3a7 1059 sr, GFC_DESCRIPTOR_TYPE (src), src_kind, stat);
93e2e046
TB		 1060 if (GFC_DESCRIPTOR_RANK (src))
1061 array_offset_sr += src_size;
1062 }
1063 free (tmp);
1064 return;
1065 }
1066
b5116268
TB		 1067 for (i = 0; i < size; i++)
1068 {
1069 ptrdiff_t array_offset_dst = 0;
1070 ptrdiff_t stride = 1;
1071 ptrdiff_t extent = 1;
1072 for (j = 0; j < rank-1; j++)
1073 {
1074 array_offset_dst += ((i / (extent*stride))
1075 % (dest->dim[j]._ubound
1076 - dest->dim[j].lower_bound + 1))
1077 * dest->dim[j]._stride;
1078 extent = (dest->dim[j]._ubound - dest->dim[j].lower_bound + 1);
1079 stride = dest->dim[j]._stride;
1080 }
1081 array_offset_dst += (i / extent) * dest->dim[rank-1]._stride;
3c9f5092 1082 void *dst = (void *)((char *) MEMTOK (token) + offset
b5116268
TB		 1083 + array_offset_dst*GFC_DESCRIPTOR_SIZE (dest));
1084 void *sr;
1085 if (GFC_DESCRIPTOR_RANK (src) != 0)
1086 {
1087 ptrdiff_t array_offset_sr = 0;
1088 stride = 1;
1089 extent = 1;
1090 for (j = 0; j < GFC_DESCRIPTOR_RANK (src)-1; j++)
1091 {
1092 array_offset_sr += ((i / (extent*stride))
1093 % (src->dim[j]._ubound
1094 - src->dim[j].lower_bound + 1))
1095 * src->dim[j]._stride;
1096 extent = (src->dim[j]._ubound - src->dim[j].lower_bound + 1);
1097 stride = src->dim[j]._stride;
1098 }
1099 array_offset_sr += (i / extent) * src->dim[rank-1]._stride;
1100 sr = (void *)((char *) src->base_addr
1101 + array_offset_sr*GFC_DESCRIPTOR_SIZE (src));
1102 }
1103 else
1104 sr = src->base_addr;
1105
5c75088c
TB		 1106 if (GFC_DESCRIPTOR_TYPE (dest) == GFC_DESCRIPTOR_TYPE (src)
1107 && dst_kind == src_kind)
b5116268 1108 {
5c75088c
TB		 1109 memmove (dst, sr,
1110 dst_size > src_size ? src_size : dst_size);
1111 if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_size > src_size)
1112 {
1113 if (dst_kind == 1)
1114 memset ((void*)(char*) dst + src_size, ' ', dst_size-src_size);
1115 else /* dst_kind == 4. */
1116 for (k = src_size/4; k < dst_size/4; k++)
1117 ((int32_t*) dst)[k] = (int32_t) ' ';
1118 }
b5116268 1119 }
5c75088c
TB		 1120 else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_kind == 1)
1121 assign_char1_from_char4 (dst_size, src_size, dst, sr);
1122 else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER)
1123 assign_char4_from_char1 (dst_size, src_size, dst, sr);
1124 else
1125 convert_type (dst, GFC_DESCRIPTOR_TYPE (dest), dst_kind,
9fe9a3a7 1126 sr, GFC_DESCRIPTOR_TYPE (src), src_kind, stat);
b5116268
TB		 1127 }
1128}
1129
1130
1131void
1132_gfortran_caf_sendget (caf_token_t dst_token, size_t dst_offset,
1133 int dst_image_index, gfc_descriptor_t *dest,
1134 caf_vector_t *dst_vector, caf_token_t src_token,
1135 size_t src_offset,
1136 int src_image_index __attribute__ ((unused)),
1137 gfc_descriptor_t *src,
1138 caf_vector_t *src_vector __attribute__ ((unused)),
93e2e046 1139 int dst_kind, int src_kind, bool may_require_tmp)
b5116268
TB		 1140{
1141 /* FIXME: Handle vector subscript of 'src_vector'. */
1142 /* For a single image, src->base_addr should be the same as src_token + offset
1143 but to play save, we do it properly. */
1144 void *src_base = GFC_DESCRIPTOR_DATA (src);
3c9f5092
AV		 1145 GFC_DESCRIPTOR_DATA (src) = (void *) ((char *) MEMTOK (src_token)
1146 + src_offset);
b5116268 1147 _gfortran_caf_send (dst_token, dst_offset, dst_image_index, dest, dst_vector,
9fe9a3a7 1148 src, dst_kind, src_kind, may_require_tmp, NULL);
b5116268
TB		 1149 GFC_DESCRIPTOR_DATA (src) = src_base;
1150}
42a8246d
TB		 1151
1152
3c9f5092
AV		 1153/* Emitted when a theorectically unreachable part is reached. */
1154const char unreachable[] = "Fatal error: unreachable alternative found.\n";
1155
1156
1157static void
1158copy_data (void *ds, void *sr, int dst_type, int src_type,
1159 int dst_kind, int src_kind, size_t dst_size, size_t src_size,
1160 size_t num, int *stat)
1161{
1162 size_t k;
1163 if (dst_type == src_type && dst_kind == src_kind)
1164 {
1165 memmove (ds, sr, (dst_size > src_size ? src_size : dst_size) * num);
1166 if ((dst_type == BT_CHARACTER || src_type == BT_CHARACTER)
1167 && dst_size > src_size)
1168 {
1169 if (dst_kind == 1)
1170 memset ((void*)(char*) ds + src_size, ' ', dst_size-src_size);
1171 else /* dst_kind == 4. */
1172 for (k = src_size/4; k < dst_size/4; k++)
1173 ((int32_t*) ds)[k] = (int32_t) ' ';
1174 }
1175 }
1176 else if (dst_type == BT_CHARACTER && dst_kind == 1)
1177 assign_char1_from_char4 (dst_size, src_size, ds, sr);
1178 else if (dst_type == BT_CHARACTER)
1179 assign_char4_from_char1 (dst_size, src_size, ds, sr);
1180 else
1181 for (k = 0; k < num; ++k)
1182 {
1183 convert_type (ds, dst_type, dst_kind, sr, src_type, src_kind, stat);
1184 ds += dst_size;
1185 sr += src_size;
1186 }
1187}
1188
1189
1190#define COMPUTE_NUM_ITEMS(num, stride, lb, ub) \
1191 do { \
1192 index_type abs_stride = (stride) > 0 ? (stride) : -(stride); \
1193 num = (stride) > 0 ? (ub) + 1 - (lb) : (lb) + 1 - (ub); \
1194 if (num <= 0 || abs_stride < 1) return; \
1195 num = (abs_stride > 1) ? (1 + (num - 1) / abs_stride) : num; \
1196 } while (0)
1197
1198
1199static void
1200get_for_ref (caf_reference_t *ref, size_t *i, size_t *dst_index,
1201 caf_single_token_t single_token, gfc_descriptor_t *dst,
1202 gfc_descriptor_t *src, void *ds, void *sr,
1203 int dst_kind, int src_kind, size_t dst_dim, size_t src_dim,
87e8aa3b 1204 size_t num, int *stat, int src_type)
3c9f5092
AV		 1205{
1206 ptrdiff_t extent_src = 1, array_offset_src = 0, stride_src;
1207 size_t next_dst_dim;
1208
1209 if (unlikely (ref == NULL))
1210 /* May be we should issue an error here, because this case should not
1211 occur. */
1212 return;
1213
1214 if (ref->next == NULL)
1215 {
1216 size_t dst_size = GFC_DESCRIPTOR_SIZE (dst);
1217 ptrdiff_t array_offset_dst = 0;;
1218 size_t dst_rank = GFC_DESCRIPTOR_RANK (dst);
3c9f5092
AV		 1219
1220 switch (ref->type)
1221 {
1222 case CAF_REF_COMPONENT:
1223 /* Because the token is always registered after the component, its
87e8aa3b 1224 offset is always greater zero. */
3c9f5092 1225 if (ref->u.c.caf_token_offset > 0)
87e8aa3b 1226 /* Note, that sr is dereffed here. */
3c9f5092 1227 copy_data (ds, *(void **)(sr + ref->u.c.offset),
87e8aa3b 1228 GFC_DESCRIPTOR_TYPE (dst), src_type,
3c9f5092
AV		 1229 dst_kind, src_kind, dst_size, ref->item_size, 1, stat);
1230 else
1231 copy_data (ds, sr + ref->u.c.offset,
87e8aa3b 1232 GFC_DESCRIPTOR_TYPE (dst), src_type,
3c9f5092
AV		 1233 dst_kind, src_kind, dst_size, ref->item_size, 1, stat);
1234 ++(*i);
1235 return;
1236 case CAF_REF_STATIC_ARRAY:
3c9f5092
AV		 1237 /* Intentionally fall through. */
1238 case CAF_REF_ARRAY:
1239 if (ref->u.a.mode[src_dim] == CAF_ARR_REF_NONE)
1240 {
1241 for (size_t d = 0; d < dst_rank; ++d)
1242 array_offset_dst += dst_index[d];
1243 copy_data (ds + array_offset_dst * dst_size, sr,
87e8aa3b 1244 GFC_DESCRIPTOR_TYPE (dst), src_type,
3c9f5092
AV		 1245 dst_kind, src_kind, dst_size, ref->item_size, num,
1246 stat);
1247 *i += num;
1248 return;
1249 }
1250 break;
1251 default:
1252 caf_runtime_error (unreachable);
1253 }
1254 }
1255
1256 switch (ref->type)
1257 {
1258 case CAF_REF_COMPONENT:
1259 if (ref->u.c.caf_token_offset > 0)
87e8aa3b
AV		 1260 {
1261 single_token = *(caf_single_token_t*)(sr + ref->u.c.caf_token_offset);
1262
1263 if (ref->next && ref->next->type == CAF_REF_ARRAY)
1264 src = single_token->desc;
1265 else
1266 src = NULL;
1267
1268 if (ref->next && ref->next->type == CAF_REF_COMPONENT)
1269 /* The currently ref'ed component was allocatabe (caf_token_offset
1270 > 0) and the next ref is a component, too, then the new sr has to
67914693 1271 be dereffed. (static arrays cannot be allocatable or they
87e8aa3b
AV		 1272 become an array with descriptor. */
1273 sr = *(void **)(sr + ref->u.c.offset);
1274 else
1275 sr += ref->u.c.offset;
1276
1277 get_for_ref (ref->next, i, dst_index, single_token, dst, src,
1278 ds, sr, dst_kind, src_kind, dst_dim, 0,
1279 1, stat, src_type);
1280 }
3c9f5092
AV		 1281 else
1282 get_for_ref (ref->next, i, dst_index, single_token, dst,
1283 (gfc_descriptor_t *)(sr + ref->u.c.offset), ds,
1284 sr + ref->u.c.offset, dst_kind, src_kind, dst_dim, 0, 1,
87e8aa3b 1285 stat, src_type);
3c9f5092
AV		 1286 return;
1287 case CAF_REF_ARRAY:
1288 if (ref->u.a.mode[src_dim] == CAF_ARR_REF_NONE)
1289 {
1290 get_for_ref (ref->next, i, dst_index, single_token, dst,
1291 src, ds, sr, dst_kind, src_kind,
87e8aa3b 1292 dst_dim, 0, 1, stat, src_type);
3c9f5092
AV		 1293 return;
1294 }
1295 /* Only when on the left most index switch the data pointer to
1296 the array's data pointer. */
1297 if (src_dim == 0)
1298 sr = GFC_DESCRIPTOR_DATA (src);
1299 switch (ref->u.a.mode[src_dim])
1300 {
1301 case CAF_ARR_REF_VECTOR:
1302 extent_src = GFC_DIMENSION_EXTENT (src->dim[src_dim]);
1303 array_offset_src = 0;
1304 dst_index[dst_dim] = 0;
1305 for (size_t idx = 0; idx < ref->u.a.dim[src_dim].v.nvec;
1306 ++idx)
1307 {
1308#define KINDCASE(kind, type) case kind: \
1309 array_offset_src = (((index_type) \
1310 ((type *)ref->u.a.dim[src_dim].v.vector)[idx]) \
1311 - GFC_DIMENSION_LBOUND (src->dim[src_dim])) \
1312 * GFC_DIMENSION_STRIDE (src->dim[src_dim]); \
1313 break
1314
1315 switch (ref->u.a.dim[src_dim].v.kind)
1316 {
1317 KINDCASE (1, GFC_INTEGER_1);
1318 KINDCASE (2, GFC_INTEGER_2);
1319 KINDCASE (4, GFC_INTEGER_4);
1320#ifdef HAVE_GFC_INTEGER_8
1321 KINDCASE (8, GFC_INTEGER_8);
1322#endif
1323#ifdef HAVE_GFC_INTEGER_16
1324 KINDCASE (16, GFC_INTEGER_16);
1325#endif
1326 default:
1327 caf_runtime_error (unreachable);
1328 return;
1329 }
1330#undef KINDCASE
1331
1332 get_for_ref (ref, i, dst_index, single_token, dst, src,
1333 ds, sr + array_offset_src * ref->item_size,
1334 dst_kind, src_kind, dst_dim + 1, src_dim + 1,
87e8aa3b 1335 1, stat, src_type);
3c9f5092
AV		 1336 dst_index[dst_dim]
1337 += GFC_DIMENSION_STRIDE (dst->dim[dst_dim]);
1338 }
1339 return;
1340 case CAF_ARR_REF_FULL:
1341 COMPUTE_NUM_ITEMS (extent_src,
1342 ref->u.a.dim[src_dim].s.stride,
1343 GFC_DIMENSION_LBOUND (src->dim[src_dim]),
1344 GFC_DIMENSION_UBOUND (src->dim[src_dim]));
1345 stride_src = src->dim[src_dim]._stride
1346 * ref->u.a.dim[src_dim].s.stride;
1347 array_offset_src = 0;
1348 dst_index[dst_dim] = 0;
1349 for (index_type idx = 0; idx < extent_src;
1350 ++idx, array_offset_src += stride_src)
1351 {
1352 get_for_ref (ref, i, dst_index, single_token, dst, src,
1353 ds, sr + array_offset_src * ref->item_size,
1354 dst_kind, src_kind, dst_dim + 1, src_dim + 1,
87e8aa3b 1355 1, stat, src_type);
3c9f5092
AV		 1356 dst_index[dst_dim]
1357 += GFC_DIMENSION_STRIDE (dst->dim[dst_dim]);
1358 }
1359 return;
1360 case CAF_ARR_REF_RANGE:
1361 COMPUTE_NUM_ITEMS (extent_src,
1362 ref->u.a.dim[src_dim].s.stride,
1363 ref->u.a.dim[src_dim].s.start,
1364 ref->u.a.dim[src_dim].s.end);
1365 array_offset_src = (ref->u.a.dim[src_dim].s.start
1366 - GFC_DIMENSION_LBOUND (src->dim[src_dim]))
1367 * GFC_DIMENSION_STRIDE (src->dim[src_dim]);
1368 stride_src = GFC_DIMENSION_STRIDE (src->dim[src_dim])
1369 * ref->u.a.dim[src_dim].s.stride;
1370 dst_index[dst_dim] = 0;
1371 /* Increase the dst_dim only, when the src_extent is greater one
1372 or src and dst extent are both one. Don't increase when the scalar
1373 source is not present in the dst. */
1374 next_dst_dim = extent_src > 1
1375 || (GFC_DIMENSION_EXTENT (dst->dim[dst_dim]) == 1
1376 && extent_src == 1) ? (dst_dim + 1) : dst_dim;
1377 for (index_type idx = 0; idx < extent_src; ++idx)
1378 {
1379 get_for_ref (ref, i, dst_index, single_token, dst, src,
1380 ds, sr + array_offset_src * ref->item_size,
1381 dst_kind, src_kind, next_dst_dim, src_dim + 1,
87e8aa3b 1382 1, stat, src_type);
3c9f5092
AV		 1383 dst_index[dst_dim]
1384 += GFC_DIMENSION_STRIDE (dst->dim[dst_dim]);
1385 array_offset_src += stride_src;
1386 }
1387 return;
1388 case CAF_ARR_REF_SINGLE:
1389 array_offset_src = (ref->u.a.dim[src_dim].s.start
1390 - src->dim[src_dim].lower_bound)
1391 * GFC_DIMENSION_STRIDE (src->dim[src_dim]);
1392 dst_index[dst_dim] = 0;
1393 get_for_ref (ref, i, dst_index, single_token, dst, src, ds,
1394 sr + array_offset_src * ref->item_size,
1395 dst_kind, src_kind, dst_dim, src_dim + 1, 1,
87e8aa3b 1396 stat, src_type);
3c9f5092
AV		 1397 return;
1398 case CAF_ARR_REF_OPEN_END:
1399 COMPUTE_NUM_ITEMS (extent_src,
1400 ref->u.a.dim[src_dim].s.stride,
1401 ref->u.a.dim[src_dim].s.start,
1402 GFC_DIMENSION_UBOUND (src->dim[src_dim]));
1403 stride_src = GFC_DIMENSION_STRIDE (src->dim[src_dim])
1404 * ref->u.a.dim[src_dim].s.stride;
1405 array_offset_src = (ref->u.a.dim[src_dim].s.start
1406 - GFC_DIMENSION_LBOUND (src->dim[src_dim]))
1407 * GFC_DIMENSION_STRIDE (src->dim[src_dim]);
1408 dst_index[dst_dim] = 0;
1409 for (index_type idx = 0; idx < extent_src; ++idx)
1410 {
1411 get_for_ref (ref, i, dst_index, single_token, dst, src,
1412 ds, sr + array_offset_src * ref->item_size,
1413 dst_kind, src_kind, dst_dim + 1, src_dim + 1,
87e8aa3b 1414 1, stat, src_type);
3c9f5092
AV		 1415 dst_index[dst_dim]
1416 += GFC_DIMENSION_STRIDE (dst->dim[dst_dim]);
1417 array_offset_src += stride_src;
1418 }
1419 return;
1420 case CAF_ARR_REF_OPEN_START:
1421 COMPUTE_NUM_ITEMS (extent_src,
1422 ref->u.a.dim[src_dim].s.stride,
1423 GFC_DIMENSION_LBOUND (src->dim[src_dim]),
1424 ref->u.a.dim[src_dim].s.end);
1425 stride_src = GFC_DIMENSION_STRIDE (src->dim[src_dim])
1426 * ref->u.a.dim[src_dim].s.stride;
1427 array_offset_src = 0;
1428 dst_index[dst_dim] = 0;
1429 for (index_type idx = 0; idx < extent_src; ++idx)
1430 {
1431 get_for_ref (ref, i, dst_index, single_token, dst, src,
1432 ds, sr + array_offset_src * ref->item_size,
1433 dst_kind, src_kind, dst_dim + 1, src_dim + 1,
87e8aa3b 1434 1, stat, src_type);
3c9f5092
AV		 1435 dst_index[dst_dim]
1436 += GFC_DIMENSION_STRIDE (dst->dim[dst_dim]);
1437 array_offset_src += stride_src;
1438 }
1439 return;
1440 default:
1441 caf_runtime_error (unreachable);
1442 }
1443 return;
1444 case CAF_REF_STATIC_ARRAY:
1445 if (ref->u.a.mode[src_dim] == CAF_ARR_REF_NONE)
1446 {
1447 get_for_ref (ref->next, i, dst_index, single_token, dst,
1448 NULL, ds, sr, dst_kind, src_kind,
87e8aa3b 1449 dst_dim, 0, 1, stat, src_type);
3c9f5092
AV		 1450 return;
1451 }
1452 switch (ref->u.a.mode[src_dim])
1453 {
1454 case CAF_ARR_REF_VECTOR:
1455 array_offset_src = 0;
1456 dst_index[dst_dim] = 0;
1457 for (size_t idx = 0; idx < ref->u.a.dim[src_dim].v.nvec;
1458 ++idx)
1459 {
1460#define KINDCASE(kind, type) case kind: \
1461 array_offset_src = ((type *)ref->u.a.dim[src_dim].v.vector)[idx]; \
1462 break
1463
1464 switch (ref->u.a.dim[src_dim].v.kind)
1465 {
1466 KINDCASE (1, GFC_INTEGER_1);
1467 KINDCASE (2, GFC_INTEGER_2);
1468 KINDCASE (4, GFC_INTEGER_4);
1469#ifdef HAVE_GFC_INTEGER_8
1470 KINDCASE (8, GFC_INTEGER_8);
1471#endif
1472#ifdef HAVE_GFC_INTEGER_16
1473 KINDCASE (16, GFC_INTEGER_16);
1474#endif
1475 default:
1476 caf_runtime_error (unreachable);
1477 return;
1478 }
1479#undef KINDCASE
1480
1481 get_for_ref (ref, i, dst_index, single_token, dst, NULL,
1482 ds, sr + array_offset_src * ref->item_size,
1483 dst_kind, src_kind, dst_dim + 1, src_dim + 1,
87e8aa3b 1484 1, stat, src_type);
3c9f5092
AV		 1485 dst_index[dst_dim]
1486 += GFC_DIMENSION_STRIDE (dst->dim[dst_dim]);
1487 }
1488 return;
1489 case CAF_ARR_REF_FULL:
1490 dst_index[dst_dim] = 0;
1491 for (array_offset_src = 0 ;
1492 array_offset_src <= ref->u.a.dim[src_dim].s.end;
1493 array_offset_src += ref->u.a.dim[src_dim].s.stride)
1494 {
1495 get_for_ref (ref, i, dst_index, single_token, dst, NULL,
1496 ds, sr + array_offset_src * ref->item_size,
1497 dst_kind, src_kind, dst_dim + 1, src_dim + 1,
87e8aa3b 1498 1, stat, src_type);
3c9f5092
AV		 1499 dst_index[dst_dim]
1500 += GFC_DIMENSION_STRIDE (dst->dim[dst_dim]);
1501 }
1502 return;
1503 case CAF_ARR_REF_RANGE:
1504 COMPUTE_NUM_ITEMS (extent_src,
1505 ref->u.a.dim[src_dim].s.stride,
1506 ref->u.a.dim[src_dim].s.start,
1507 ref->u.a.dim[src_dim].s.end);
1508 array_offset_src = ref->u.a.dim[src_dim].s.start;
1509 dst_index[dst_dim] = 0;
1510 for (index_type idx = 0; idx < extent_src; ++idx)
1511 {
1512 get_for_ref (ref, i, dst_index, single_token, dst, NULL,
1513 ds, sr + array_offset_src * ref->item_size,
1514 dst_kind, src_kind, dst_dim + 1, src_dim + 1,
87e8aa3b 1515 1, stat, src_type);
3c9f5092
AV		 1516 dst_index[dst_dim]
1517 += GFC_DIMENSION_STRIDE (dst->dim[dst_dim]);
1518 array_offset_src += ref->u.a.dim[src_dim].s.stride;
1519 }
1520 return;
1521 case CAF_ARR_REF_SINGLE:
1522 array_offset_src = ref->u.a.dim[src_dim].s.start;
1523 get_for_ref (ref, i, dst_index, single_token, dst, NULL, ds,
1524 sr + array_offset_src * ref->item_size,
1525 dst_kind, src_kind, dst_dim, src_dim + 1, 1,
87e8aa3b 1526 stat, src_type);
3c9f5092 1527 return;
67914693 1528 /* The OPEN_* are mapped to a RANGE and therefore cannot occur. */
3c9f5092
AV		 1529 case CAF_ARR_REF_OPEN_END:
1530 case CAF_ARR_REF_OPEN_START:
1531 default:
1532 caf_runtime_error (unreachable);
1533 }
1534 return;
1535 default:
1536 caf_runtime_error (unreachable);
1537 }
1538}
1539
1540
1541void
1542_gfortran_caf_get_by_ref (caf_token_t token,
1543 int image_index __attribute__ ((unused)),
1544 gfc_descriptor_t *dst, caf_reference_t *refs,
1545 int dst_kind, int src_kind,
1546 bool may_require_tmp __attribute__ ((unused)),
87e8aa3b
AV		 1547 bool dst_reallocatable, int *stat,
1548 int src_type)
3c9f5092
AV		 1549{
1550 const char vecrefunknownkind[] = "libcaf_single::caf_get_by_ref(): "
1551 "unknown kind in vector-ref.\n";
1552 const char unknownreftype[] = "libcaf_single::caf_get_by_ref(): "
1553 "unknown reference type.\n";
1554 const char unknownarrreftype[] = "libcaf_single::caf_get_by_ref(): "
1555 "unknown array reference type.\n";
1556 const char rankoutofrange[] = "libcaf_single::caf_get_by_ref(): "
1557 "rank out of range.\n";
1558 const char extentoutofrange[] = "libcaf_single::caf_get_by_ref(): "
1559 "extent out of range.\n";
1560 const char cannotallocdst[] = "libcaf_single::caf_get_by_ref(): "
67914693 1561 "cannot allocate memory.\n";
3c9f5092
AV		 1562 const char nonallocextentmismatch[] = "libcaf_single::caf_get_by_ref(): "
1563 "extent of non-allocatable arrays mismatch (%lu != %lu).\n";
1564 const char doublearrayref[] = "libcaf_single::caf_get_by_ref(): "
1565 "two or more array part references are not supported.\n";
1566 size_t size, i;
1567 size_t dst_index[GFC_MAX_DIMENSIONS];
1568 int dst_rank = GFC_DESCRIPTOR_RANK (dst);
1569 int dst_cur_dim = 0;
8fb75185 1570 size_t src_size = 0;
3c9f5092
AV		 1571 caf_single_token_t single_token = TOKEN (token);
1572 void *memptr = single_token->memptr;
1573 gfc_descriptor_t *src = single_token->desc;
1574 caf_reference_t *riter = refs;
1575 long delta;
1576 /* Reallocation of dst.data is needed (e.g., array to small). */
1577 bool realloc_needed;
1578 /* Reallocation of dst.data is required, because data is not alloced at
1579 all. */
1580 bool realloc_required;
1581 bool extent_mismatch = false;
1582 /* Set when the first non-scalar array reference is encountered. */
1583 bool in_array_ref = false;
1584 bool array_extent_fixed = false;
1585 realloc_needed = realloc_required = GFC_DESCRIPTOR_DATA (dst) == NULL;
1586
0f0565b1 1587 assert (!realloc_needed || dst_reallocatable);
3c9f5092
AV		 1588
1589 if (stat)
1590 *stat = 0;
1591
1592 /* Compute the size of the result. In the beginning size just counts the
1593 number of elements. */
1594 size = 1;
1595 while (riter)
1596 {
1597 switch (riter->type)
1598 {
1599 case CAF_REF_COMPONENT:
1600 if (riter->u.c.caf_token_offset)
1601 {
1602 single_token = *(caf_single_token_t*)
1603 (memptr + riter->u.c.caf_token_offset);
1604 memptr = single_token->memptr;
1605 src = single_token->desc;
1606 }
1607 else
1608 {
1609 memptr += riter->u.c.offset;
87e8aa3b
AV		 1610 /* When the next ref is an array ref, assume there is an
1611 array descriptor at memptr. Note, static arrays do not have
1612 a descriptor. */
1613 if (riter->next && riter->next->type == CAF_REF_ARRAY)
1614 src = (gfc_descriptor_t *)memptr;
1615 else
1616 src = NULL;
3c9f5092
AV		 1617 }
1618 break;
1619 case CAF_REF_ARRAY:
1620 for (i = 0; riter->u.a.mode[i] != CAF_ARR_REF_NONE; ++i)
1621 {
1622 switch (riter->u.a.mode[i])
1623 {
1624 case CAF_ARR_REF_VECTOR:
1625 delta = riter->u.a.dim[i].v.nvec;
1626#define KINDCASE(kind, type) case kind: \
1627 memptr += (((index_type) \
1628 ((type *)riter->u.a.dim[i].v.vector)[0]) \
1629 - GFC_DIMENSION_LBOUND (src->dim[i])) \
1630 * GFC_DIMENSION_STRIDE (src->dim[i]) \
1631 * riter->item_size; \
1632 break
1633
1634 switch (riter->u.a.dim[i].v.kind)
1635 {
1636 KINDCASE (1, GFC_INTEGER_1);
1637 KINDCASE (2, GFC_INTEGER_2);
1638 KINDCASE (4, GFC_INTEGER_4);
1639#ifdef HAVE_GFC_INTEGER_8
1640 KINDCASE (8, GFC_INTEGER_8);
1641#endif
1642#ifdef HAVE_GFC_INTEGER_16
1643 KINDCASE (16, GFC_INTEGER_16);
1644#endif
1645 default:
1646 caf_internal_error (vecrefunknownkind, stat, NULL, 0);
1647 return;
1648 }
1649#undef KINDCASE
1650 break;
1651 case CAF_ARR_REF_FULL:
1652 COMPUTE_NUM_ITEMS (delta,
1653 riter->u.a.dim[i].s.stride,
1654 GFC_DIMENSION_LBOUND (src->dim[i]),
1655 GFC_DIMENSION_UBOUND (src->dim[i]));
1656 /* The memptr stays unchanged when ref'ing the first element
1657 in a dimension. */
1658 break;
1659 case CAF_ARR_REF_RANGE:
1660 COMPUTE_NUM_ITEMS (delta,
1661 riter->u.a.dim[i].s.stride,
1662 riter->u.a.dim[i].s.start,
1663 riter->u.a.dim[i].s.end);
1664 memptr += (riter->u.a.dim[i].s.start
1665 - GFC_DIMENSION_LBOUND (src->dim[i]))
1666 * GFC_DIMENSION_STRIDE (src->dim[i])
1667 * riter->item_size;
1668 break;
1669 case CAF_ARR_REF_SINGLE:
1670 delta = 1;
1671 memptr += (riter->u.a.dim[i].s.start
1672 - GFC_DIMENSION_LBOUND (src->dim[i]))
1673 * GFC_DIMENSION_STRIDE (src->dim[i])
1674 * riter->item_size;
1675 break;
1676 case CAF_ARR_REF_OPEN_END:
1677 COMPUTE_NUM_ITEMS (delta,
1678 riter->u.a.dim[i].s.stride,
1679 riter->u.a.dim[i].s.start,
1680 GFC_DIMENSION_UBOUND (src->dim[i]));
1681 memptr += (riter->u.a.dim[i].s.start
1682 - GFC_DIMENSION_LBOUND (src->dim[i]))
1683 * GFC_DIMENSION_STRIDE (src->dim[i])
1684 * riter->item_size;
1685 break;
1686 case CAF_ARR_REF_OPEN_START:
1687 COMPUTE_NUM_ITEMS (delta,
1688 riter->u.a.dim[i].s.stride,
1689 GFC_DIMENSION_LBOUND (src->dim[i]),
1690 riter->u.a.dim[i].s.end);
1691 /* The memptr stays unchanged when ref'ing the first element
1692 in a dimension. */
1693 break;
1694 default:
1695 caf_internal_error (unknownarrreftype, stat, NULL, 0);
1696 return;
1697 }
1698 if (delta <= 0)
1699 return;
1700 /* Check the various properties of the destination array.
1701 Is an array expected and present? */
1702 if (delta > 1 && dst_rank == 0)
1703 {
1704 /* No, an array is required, but not provided. */
1705 caf_internal_error (extentoutofrange, stat, NULL, 0);
1706 return;
1707 }
87e8aa3b
AV		 1708 /* Special mode when called by __caf_sendget_by_ref (). */
1709 if (dst_rank == -1 && GFC_DESCRIPTOR_DATA (dst) == NULL)
1710 {
1711 dst_rank = dst_cur_dim + 1;
1712 GFC_DESCRIPTOR_RANK (dst) = dst_rank;
1713 GFC_DESCRIPTOR_SIZE (dst) = dst_kind;
1714 }
3c9f5092
AV		 1715 /* When dst is an array. */
1716 if (dst_rank > 0)
1717 {
1718 /* Check that dst_cur_dim is valid for dst. Can be
1719 superceeded only by scalar data. */
1720 if (dst_cur_dim >= dst_rank && delta != 1)
1721 {
1722 caf_internal_error (rankoutofrange, stat, NULL, 0);
1723 return;
1724 }
1725 /* Do further checks, when the source is not scalar. */
1726 else if (delta != 1)
1727 {
1728 /* Check that the extent is not scalar and we are not in
1729 an array ref for the dst side. */
1730 if (!in_array_ref)
1731 {
1732 /* Check that this is the non-scalar extent. */
1733 if (!array_extent_fixed)
1734 {
1735 /* In an array extent now. */
1736 in_array_ref = true;
1737 /* Check that we haven't skipped any scalar
1738 dimensions yet and that the dst is
1739 compatible. */
1740 if (i > 0
1741 && dst_rank == GFC_DESCRIPTOR_RANK (src))
1742 {
1743 if (dst_reallocatable)
1744 {
1745 /* Dst is reallocatable, which means that
1746 the bounds are not set. Set them. */
1747 for (dst_cur_dim= 0; dst_cur_dim < (int)i;
1748 ++dst_cur_dim)
1749 GFC_DIMENSION_SET (dst->dim[dst_cur_dim],
1750 1, 1, 1);
1751 }
1752 else
1753 dst_cur_dim = i;
1754 }
1755 /* Else press thumbs, that there are enough
1756 dimensional refs to come. Checked below. */
1757 }
1758 else
1759 {
1760 caf_internal_error (doublearrayref, stat, NULL,
1761 0);
1762 return;
1763 }
1764 }
1765 /* When the realloc is required, then no extent may have
1766 been set. */
1767 extent_mismatch = realloc_required
1768 || GFC_DESCRIPTOR_EXTENT (dst, dst_cur_dim) != delta;
1769 /* When it already known, that a realloc is needed or
1770 the extent does not match the needed one. */
1771 if (realloc_required || realloc_needed
1772 || extent_mismatch)
1773 {
1774 /* Check whether dst is reallocatable. */
1775 if (unlikely (!dst_reallocatable))
1776 {
1777 caf_internal_error (nonallocextentmismatch, stat,
1778 NULL, 0, delta,
1779 GFC_DESCRIPTOR_EXTENT (dst,
1780 dst_cur_dim));
1781 return;
1782 }
1783 /* Only report an error, when the extent needs to be
1784 modified, which is not allowed. */
1785 else if (!dst_reallocatable && extent_mismatch)
1786 {
1787 caf_internal_error (extentoutofrange, stat, NULL,
1788 0);
1789 return;
1790 }
1791 realloc_needed = true;
1792 }
1793 /* Only change the extent when it does not match. This is
1794 to prevent resetting given array bounds. */
1795 if (extent_mismatch)
1796 GFC_DIMENSION_SET (dst->dim[dst_cur_dim], 1, delta,
1797 size);
1798 }
1799
1800 /* Only increase the dim counter, when in an array ref. */
1801 if (in_array_ref && dst_cur_dim < dst_rank)
1802 ++dst_cur_dim;
1803 }
1804 size *= (index_type)delta;
1805 }
1806 if (in_array_ref)
1807 {
1808 array_extent_fixed = true;
1809 in_array_ref = false;
1810 /* Check, if we got less dimensional refs than the rank of dst
1811 expects. */
1812 assert (dst_cur_dim == GFC_DESCRIPTOR_RANK (dst));
1813 }
1814 break;
1815 case CAF_REF_STATIC_ARRAY:
1816 for (i = 0; riter->u.a.mode[i] != CAF_ARR_REF_NONE; ++i)
1817 {
1818 switch (riter->u.a.mode[i])
1819 {
1820 case CAF_ARR_REF_VECTOR:
1821 delta = riter->u.a.dim[i].v.nvec;
1822#define KINDCASE(kind, type) case kind: \
1823 memptr += ((type *)riter->u.a.dim[i].v.vector)[0] \
1824 * riter->item_size; \
1825 break
1826
1827 switch (riter->u.a.dim[i].v.kind)
1828 {
1829 KINDCASE (1, GFC_INTEGER_1);
1830 KINDCASE (2, GFC_INTEGER_2);
1831 KINDCASE (4, GFC_INTEGER_4);
1832#ifdef HAVE_GFC_INTEGER_8
1833 KINDCASE (8, GFC_INTEGER_8);
1834#endif
1835#ifdef HAVE_GFC_INTEGER_16
1836 KINDCASE (16, GFC_INTEGER_16);
1837#endif
1838 default:
1839 caf_internal_error (vecrefunknownkind, stat, NULL, 0);
1840 return;
1841 }
1842#undef KINDCASE
1843 break;
1844 case CAF_ARR_REF_FULL:
1845 delta = riter->u.a.dim[i].s.end / riter->u.a.dim[i].s.stride
1846 + 1;
1847 /* The memptr stays unchanged when ref'ing the first element
1848 in a dimension. */
1849 break;
1850 case CAF_ARR_REF_RANGE:
1851 COMPUTE_NUM_ITEMS (delta,
1852 riter->u.a.dim[i].s.stride,
1853 riter->u.a.dim[i].s.start,
1854 riter->u.a.dim[i].s.end);
1855 memptr += riter->u.a.dim[i].s.start
1856 * riter->u.a.dim[i].s.stride
1857 * riter->item_size;
1858 break;
1859 case CAF_ARR_REF_SINGLE:
1860 delta = 1;
1861 memptr += riter->u.a.dim[i].s.start
1862 * riter->u.a.dim[i].s.stride
1863 * riter->item_size;
1864 break;
1865 case CAF_ARR_REF_OPEN_END:
1866 /* This and OPEN_START are mapped to a RANGE and therefore
67914693 1867 cannot occur here. */
3c9f5092
AV		 1868 case CAF_ARR_REF_OPEN_START:
1869 default:
1870 caf_internal_error (unknownarrreftype, stat, NULL, 0);
1871 return;
1872 }
1873 if (delta <= 0)
1874 return;
1875 /* Check the various properties of the destination array.
1876 Is an array expected and present? */
1877 if (delta > 1 && dst_rank == 0)
1878 {
1879 /* No, an array is required, but not provided. */
1880 caf_internal_error (extentoutofrange, stat, NULL, 0);
1881 return;
1882 }
87e8aa3b
AV		 1883 /* Special mode when called by __caf_sendget_by_ref (). */
1884 if (dst_rank == -1 && GFC_DESCRIPTOR_DATA (dst) == NULL)
1885 {
1886 dst_rank = dst_cur_dim + 1;
1887 GFC_DESCRIPTOR_RANK (dst) = dst_rank;
1888 GFC_DESCRIPTOR_SIZE (dst) = dst_kind;
1889 }
3c9f5092
AV		 1890 /* When dst is an array. */
1891 if (dst_rank > 0)
1892 {
1893 /* Check that dst_cur_dim is valid for dst. Can be
1894 superceeded only by scalar data. */
1895 if (dst_cur_dim >= dst_rank && delta != 1)
1896 {
1897 caf_internal_error (rankoutofrange, stat, NULL, 0);
1898 return;
1899 }
1900 /* Do further checks, when the source is not scalar. */
1901 else if (delta != 1)
1902 {
1903 /* Check that the extent is not scalar and we are not in
1904 an array ref for the dst side. */
1905 if (!in_array_ref)
1906 {
1907 /* Check that this is the non-scalar extent. */
1908 if (!array_extent_fixed)
1909 {
1910 /* In an array extent now. */
1911 in_array_ref = true;
1912 /* The dst is not reallocatable, so nothing more
1913 to do, then correct the dim counter. */
1914 dst_cur_dim = i;
1915 }
1916 else
1917 {
1918 caf_internal_error (doublearrayref, stat, NULL,
1919 0);
1920 return;
1921 }
1922 }
1923 /* When the realloc is required, then no extent may have
1924 been set. */
1925 extent_mismatch = realloc_required
1926 || GFC_DESCRIPTOR_EXTENT (dst, dst_cur_dim) != delta;
1927 /* When it is already known, that a realloc is needed or
1928 the extent does not match the needed one. */
1929 if (realloc_required || realloc_needed
1930 || extent_mismatch)
1931 {
1932 /* Check whether dst is reallocatable. */
1933 if (unlikely (!dst_reallocatable))
1934 {
1935 caf_internal_error (nonallocextentmismatch, stat,
1936 NULL, 0, delta,
1937 GFC_DESCRIPTOR_EXTENT (dst,
1938 dst_cur_dim));
1939 return;
1940 }
1941 /* Only report an error, when the extent needs to be
1942 modified, which is not allowed. */
1943 else if (!dst_reallocatable && extent_mismatch)
1944 {
1945 caf_internal_error (extentoutofrange, stat, NULL,
1946 0);
1947 return;
1948 }
1949 realloc_needed = true;
1950 }
1951 /* Only change the extent when it does not match. This is
1952 to prevent resetting given array bounds. */
1953 if (extent_mismatch)
1954 GFC_DIMENSION_SET (dst->dim[dst_cur_dim], 1, delta,
1955 size);
1956 }
1957 /* Only increase the dim counter, when in an array ref. */
1958 if (in_array_ref && dst_cur_dim < dst_rank)
1959 ++dst_cur_dim;
1960 }
1961 size *= (index_type)delta;
1962 }
1963 if (in_array_ref)
1964 {
1965 array_extent_fixed = true;
1966 in_array_ref = false;
1967 /* Check, if we got less dimensional refs than the rank of dst
1968 expects. */
1969 assert (dst_cur_dim == GFC_DESCRIPTOR_RANK (dst));
1970 }
1971 break;
1972 default:
1973 caf_internal_error (unknownreftype, stat, NULL, 0);
1974 return;
1975 }
1976 src_size = riter->item_size;
1977 riter = riter->next;
1978 }
1979 if (size == 0 || src_size == 0)
1980 return;
1981 /* Postcondition:
1982 - size contains the number of elements to store in the destination array,
1983 - src_size gives the size in bytes of each item in the destination array.
1984 */
1985
1986 if (realloc_needed)
1987 {
1988 if (!array_extent_fixed)
1989 {
1990 assert (size == 1);
87e8aa3b
AV		 1991 /* Special mode when called by __caf_sendget_by_ref (). */
1992 if (dst_rank == -1 && GFC_DESCRIPTOR_DATA (dst) == NULL)
1993 {
1994 dst_rank = dst_cur_dim + 1;
1995 GFC_DESCRIPTOR_RANK (dst) = dst_rank;
1996 GFC_DESCRIPTOR_SIZE (dst) = dst_kind;
1997 }
3c9f5092
AV		 1998 /* This can happen only, when the result is scalar. */
1999 for (dst_cur_dim = 0; dst_cur_dim < dst_rank; ++dst_cur_dim)
2000 GFC_DIMENSION_SET (dst->dim[dst_cur_dim], 1, 1, 1);
2001 }
2002
2003 GFC_DESCRIPTOR_DATA (dst) = malloc (size * GFC_DESCRIPTOR_SIZE (dst));
2004 if (unlikely (GFC_DESCRIPTOR_DATA (dst) == NULL))
2005 {
2006 caf_internal_error (cannotallocdst, stat, NULL, 0);
2007 return;
2008 }
2009 }
2010
2011 /* Reset the token. */
2012 single_token = TOKEN (token);
2013 memptr = single_token->memptr;
2014 src = single_token->desc;
2015 memset(dst_index, 0, sizeof (dst_index));
2016 i = 0;
2017 get_for_ref (refs, &i, dst_index, single_token, dst, src,
2018 GFC_DESCRIPTOR_DATA (dst), memptr, dst_kind, src_kind, 0, 0,
87e8aa3b 2019 1, stat, src_type);
3c9f5092
AV		 2020}
2021
2022
2023static void
2024send_by_ref (caf_reference_t *ref, size_t *i, size_t *src_index,
2025 caf_single_token_t single_token, gfc_descriptor_t *dst,
2026 gfc_descriptor_t *src, void *ds, void *sr,
2027 int dst_kind, int src_kind, size_t dst_dim, size_t src_dim,
87e8aa3b 2028 size_t num, size_t size, int *stat, int dst_type)
3c9f5092
AV		 2029{
2030 const char vecrefunknownkind[] = "libcaf_single::caf_send_by_ref(): "
2031 "unknown kind in vector-ref.\n";
2032 ptrdiff_t extent_dst = 1, array_offset_dst = 0, stride_dst;
2033 const size_t src_rank = GFC_DESCRIPTOR_RANK (src);
2034
2035 if (unlikely (ref == NULL))
2036 /* May be we should issue an error here, because this case should not
2037 occur. */
2038 return;
2039
2040 if (ref->next == NULL)
2041 {
2042 size_t src_size = GFC_DESCRIPTOR_SIZE (src);
2043 ptrdiff_t array_offset_src = 0;;
3c9f5092
AV		 2044
2045 switch (ref->type)
2046 {
2047 case CAF_REF_COMPONENT:
2048 if (ref->u.c.caf_token_offset > 0)
2049 {
2050 if (*(void**)(ds + ref->u.c.offset) == NULL)
2051 {
2052 /* Create a scalar temporary array descriptor. */
2053 gfc_descriptor_t static_dst;
2054 GFC_DESCRIPTOR_DATA (&static_dst) = NULL;
2055 GFC_DESCRIPTOR_DTYPE (&static_dst)
2056 = GFC_DESCRIPTOR_DTYPE (src);
0f0565b1 2057 /* The component can be allocated now, because it is a
3c9f5092 2058 scalar. */
3c9f5092
AV		 2059 _gfortran_caf_register (ref->item_size,
2060 CAF_REGTYPE_COARRAY_ALLOC,
0f0565b1 2061 ds + ref->u.c.caf_token_offset,
3c9f5092 2062 &static_dst, stat, NULL, 0);
0f0565b1
AV		 2063 single_token = *(caf_single_token_t *)
2064 (ds + ref->u.c.caf_token_offset);
3c9f5092
AV		 2065 /* In case of an error in allocation return. When stat is
2066 NULL, then register_component() terminates on error. */
2067 if (stat != NULL && *stat)
2068 return;
2069 /* Publish the allocated memory. */
2070 *((void **)(ds + ref->u.c.offset))
2071 = GFC_DESCRIPTOR_DATA (&static_dst);
2072 ds = GFC_DESCRIPTOR_DATA (&static_dst);
2073 /* Set the type from the src. */
2074 dst_type = GFC_DESCRIPTOR_TYPE (src);
2075 }
2076 else
2077 {
de91486c
AV		 2078 single_token = *(caf_single_token_t *)
2079 (ds + ref->u.c.caf_token_offset);
2080 dst = single_token->desc;
2081 if (dst)
2082 {
2083 ds = GFC_DESCRIPTOR_DATA (dst);
2084 dst_type = GFC_DESCRIPTOR_TYPE (dst);
2085 }
2086 else
87e8aa3b 2087 ds = *(void **)(ds + ref->u.c.offset);
3c9f5092
AV		 2088 }
2089 copy_data (ds, sr, dst_type, GFC_DESCRIPTOR_TYPE (src),
de91486c 2090 dst_kind, src_kind, ref->item_size, src_size, 1, stat);
3c9f5092
AV		 2091 }
2092 else
87e8aa3b 2093 copy_data (ds + ref->u.c.offset, sr, dst_type,
3c9f5092
AV		 2094 GFC_DESCRIPTOR_TYPE (src),
2095 dst_kind, src_kind, ref->item_size, src_size, 1, stat);
2096 ++(*i);
2097 return;
2098 case CAF_REF_STATIC_ARRAY:
3c9f5092
AV		 2099 /* Intentionally fall through. */
2100 case CAF_REF_ARRAY:
2101 if (ref->u.a.mode[dst_dim] == CAF_ARR_REF_NONE)
2102 {
2103 if (src_rank > 0)
2104 {
2105 for (size_t d = 0; d < src_rank; ++d)
2106 array_offset_src += src_index[d];
87e8aa3b
AV		 2107 copy_data (ds, sr + array_offset_src * src_size,
2108 dst_type, GFC_DESCRIPTOR_TYPE (src), dst_kind,
2109 src_kind, ref->item_size, src_size, num, stat);
3c9f5092
AV		 2110 }
2111 else
87e8aa3b
AV		 2112 copy_data (ds, sr, dst_type, GFC_DESCRIPTOR_TYPE (src),
2113 dst_kind, src_kind, ref->item_size, src_size, num,
2114 stat);
3c9f5092
AV		 2115 *i += num;
2116 return;
2117 }
2118 break;
2119 default:
2120 caf_runtime_error (unreachable);
2121 }
2122 }
2123
2124 switch (ref->type)
2125 {
2126 case CAF_REF_COMPONENT:
2127 if (ref->u.c.caf_token_offset > 0)
2128 {
2129 if (*(void**)(ds + ref->u.c.offset) == NULL)
2130 {
2131 /* This component refs an unallocated array. Non-arrays are
2132 caught in the if (!ref->next) above. */
2133 dst = (gfc_descriptor_t *)(ds + ref->u.c.offset);
2134 /* Assume that the rank and the dimensions fit for copying src
2135 to dst. */
2136 GFC_DESCRIPTOR_DTYPE (dst) = GFC_DESCRIPTOR_DTYPE (src);
2137 dst->offset = 0;
2138 stride_dst = 1;
2139 for (size_t d = 0; d < src_rank; ++d)
2140 {
2141 extent_dst = GFC_DIMENSION_EXTENT (src->dim[d]);
2142 GFC_DIMENSION_LBOUND (dst->dim[d]) = 0;
2143 GFC_DIMENSION_UBOUND (dst->dim[d]) = extent_dst - 1;
2144 GFC_DIMENSION_STRIDE (dst->dim[d]) = stride_dst;
2145 stride_dst *= extent_dst;
2146 }
2147 /* Null the data-pointer to make register_component allocate
2148 its own memory. */
2149 GFC_DESCRIPTOR_DATA (dst) = NULL;
2150
2151 /* The size of the array is given by size. */
2152 _gfortran_caf_register (size * ref->item_size,
2153 CAF_REGTYPE_COARRAY_ALLOC,
0f0565b1 2154 ds + ref->u.c.caf_token_offset,
3c9f5092
AV		 2155 dst, stat, NULL, 0);
2156 /* In case of an error in allocation return. When stat is
2157 NULL, then register_component() terminates on error. */
2158 if (stat != NULL && *stat)
2159 return;
3c9f5092
AV		 2160 }
2161 single_token = *(caf_single_token_t*)(ds + ref->u.c.caf_token_offset);
87e8aa3b
AV		 2162 /* When a component is allocatable (caf_token_offset != 0) and not an
2163 array (ref->next->type == CAF_REF_COMPONENT), then ds has to be
2164 dereffed. */
2165 if (ref->next && ref->next->type == CAF_REF_COMPONENT)
2166 ds = *(void **)(ds + ref->u.c.offset);
2167 else
2168 ds += ref->u.c.offset;
2169
3c9f5092 2170 send_by_ref (ref->next, i, src_index, single_token,
87e8aa3b
AV		 2171 single_token->desc, src, ds, sr,
2172 dst_kind, src_kind, 0, src_dim, 1, size, stat, dst_type);
3c9f5092
AV		 2173 }
2174 else
2175 send_by_ref (ref->next, i, src_index, single_token,
2176 (gfc_descriptor_t *)(ds + ref->u.c.offset), src,
2177 ds + ref->u.c.offset, sr, dst_kind, src_kind, 0, src_dim,
87e8aa3b 2178 1, size, stat, dst_type);
3c9f5092
AV		 2179 return;
2180 case CAF_REF_ARRAY:
2181 if (ref->u.a.mode[dst_dim] == CAF_ARR_REF_NONE)
2182 {
2183 send_by_ref (ref->next, i, src_index, single_token,
2184 (gfc_descriptor_t *)ds, src, ds, sr, dst_kind, src_kind,
87e8aa3b 2185 0, src_dim, 1, size, stat, dst_type);
3c9f5092
AV		 2186 return;
2187 }
2188 /* Only when on the left most index switch the data pointer to
de91486c 2189 the array's data pointer. And only for non-static arrays. */
3c9f5092
AV		 2190 if (dst_dim == 0 && ref->type != CAF_REF_STATIC_ARRAY)
2191 ds = GFC_DESCRIPTOR_DATA (dst);
2192 switch (ref->u.a.mode[dst_dim])
2193 {
2194 case CAF_ARR_REF_VECTOR:
2195 array_offset_dst = 0;
2196 src_index[src_dim] = 0;
2197 for (size_t idx = 0; idx < ref->u.a.dim[dst_dim].v.nvec;
2198 ++idx)
2199 {
2200#define KINDCASE(kind, type) case kind: \
2201 array_offset_dst = (((index_type) \
2202 ((type *)ref->u.a.dim[dst_dim].v.vector)[idx]) \
2203 - GFC_DIMENSION_LBOUND (dst->dim[dst_dim])) \
2204 * GFC_DIMENSION_STRIDE (dst->dim[dst_dim]); \
2205 break
2206
2207 switch (ref->u.a.dim[dst_dim].v.kind)
2208 {
2209 KINDCASE (1, GFC_INTEGER_1);
2210 KINDCASE (2, GFC_INTEGER_2);
2211 KINDCASE (4, GFC_INTEGER_4);
2212#ifdef HAVE_GFC_INTEGER_8
2213 KINDCASE (8, GFC_INTEGER_8);
2214#endif
2215#ifdef HAVE_GFC_INTEGER_16
2216 KINDCASE (16, GFC_INTEGER_16);
2217#endif
2218 default:
2219 caf_internal_error (vecrefunknownkind, stat, NULL, 0);
2220 return;
2221 }
2222#undef KINDCASE
2223
2224 send_by_ref (ref, i, src_index, single_token, dst, src,
2225 ds + array_offset_dst * ref->item_size, sr,
2226 dst_kind, src_kind, dst_dim + 1, src_dim + 1,
87e8aa3b 2227 1, size, stat, dst_type);
3c9f5092
AV		 2228 if (src_rank > 0)
2229 src_index[src_dim]
2230 += GFC_DIMENSION_STRIDE (src->dim[src_dim]);
2231 }
2232 return;
2233 case CAF_ARR_REF_FULL:
2234 COMPUTE_NUM_ITEMS (extent_dst,
2235 ref->u.a.dim[dst_dim].s.stride,
2236 GFC_DIMENSION_LBOUND (dst->dim[dst_dim]),
2237 GFC_DIMENSION_UBOUND (dst->dim[dst_dim]));
2238 array_offset_dst = 0;
2239 stride_dst = GFC_DIMENSION_STRIDE (dst->dim[dst_dim])
2240 * ref->u.a.dim[dst_dim].s.stride;
2241 src_index[src_dim] = 0;
2242 for (index_type idx = 0; idx < extent_dst;
2243 ++idx, array_offset_dst += stride_dst)
2244 {
2245 send_by_ref (ref, i, src_index, single_token, dst, src,
2246 ds + array_offset_dst * ref->item_size, sr,
2247 dst_kind, src_kind, dst_dim + 1, src_dim + 1,
87e8aa3b 2248 1, size, stat, dst_type);
3c9f5092
AV		 2249 if (src_rank > 0)
2250 src_index[src_dim]
2251 += GFC_DIMENSION_STRIDE (src->dim[src_dim]);
2252 }
2253 return;
2254 case CAF_ARR_REF_RANGE:
2255 COMPUTE_NUM_ITEMS (extent_dst,
2256 ref->u.a.dim[dst_dim].s.stride,
2257 ref->u.a.dim[dst_dim].s.start,
2258 ref->u.a.dim[dst_dim].s.end);
2259 array_offset_dst = ref->u.a.dim[dst_dim].s.start
2260 - GFC_DIMENSION_LBOUND (dst->dim[dst_dim]);
2261 stride_dst = GFC_DIMENSION_STRIDE (dst->dim[dst_dim])
2262 * ref->u.a.dim[dst_dim].s.stride;
2263 src_index[src_dim] = 0;
2264 for (index_type idx = 0; idx < extent_dst; ++idx)
2265 {
2266 send_by_ref (ref, i, src_index, single_token, dst, src,
2267 ds + array_offset_dst * ref->item_size, sr,
2268 dst_kind, src_kind, dst_dim + 1, src_dim + 1,
87e8aa3b 2269 1, size, stat, dst_type);
3c9f5092
AV		 2270 if (src_rank > 0)
2271 src_index[src_dim]
2272 += GFC_DIMENSION_STRIDE (src->dim[src_dim]);
2273 array_offset_dst += stride_dst;
2274 }
2275 return;
2276 case CAF_ARR_REF_SINGLE:
2277 array_offset_dst = (ref->u.a.dim[dst_dim].s.start
2278 - GFC_DIMENSION_LBOUND (dst->dim[dst_dim]))
2279 * GFC_DIMENSION_STRIDE (dst->dim[dst_dim]);
2280 send_by_ref (ref, i, src_index, single_token, dst, src, ds
2281 + array_offset_dst * ref->item_size, sr,
2282 dst_kind, src_kind, dst_dim + 1, src_dim, 1,
87e8aa3b 2283 size, stat, dst_type);
3c9f5092
AV		 2284 return;
2285 case CAF_ARR_REF_OPEN_END:
2286 COMPUTE_NUM_ITEMS (extent_dst,
2287 ref->u.a.dim[dst_dim].s.stride,
2288 ref->u.a.dim[dst_dim].s.start,
2289 GFC_DIMENSION_UBOUND (dst->dim[dst_dim]));
2290 array_offset_dst = ref->u.a.dim[dst_dim].s.start
2291 - GFC_DIMENSION_LBOUND (dst->dim[dst_dim]);
2292 stride_dst = GFC_DIMENSION_STRIDE (dst->dim[dst_dim])
2293 * ref->u.a.dim[dst_dim].s.stride;
2294 src_index[src_dim] = 0;
2295 for (index_type idx = 0; idx < extent_dst; ++idx)
2296 {
2297 send_by_ref (ref, i, src_index, single_token, dst, src,
2298 ds + array_offset_dst * ref->item_size, sr,
2299 dst_kind, src_kind, dst_dim + 1, src_dim + 1,
87e8aa3b 2300 1, size, stat, dst_type);
3c9f5092
AV		 2301 if (src_rank > 0)
2302 src_index[src_dim]
2303 += GFC_DIMENSION_STRIDE (src->dim[src_dim]);
2304 array_offset_dst += stride_dst;
2305 }
2306 return;
2307 case CAF_ARR_REF_OPEN_START:
2308 COMPUTE_NUM_ITEMS (extent_dst,
2309 ref->u.a.dim[dst_dim].s.stride,
2310 GFC_DIMENSION_LBOUND (dst->dim[dst_dim]),
2311 ref->u.a.dim[dst_dim].s.end);
2312 array_offset_dst = 0;
2313 stride_dst = GFC_DIMENSION_STRIDE (dst->dim[dst_dim])
2314 * ref->u.a.dim[dst_dim].s.stride;
2315 src_index[src_dim] = 0;
2316 for (index_type idx = 0; idx < extent_dst; ++idx)
2317 {
2318 send_by_ref (ref, i, src_index, single_token, dst, src,
2319 ds + array_offset_dst * ref->item_size, sr,
2320 dst_kind, src_kind, dst_dim + 1, src_dim + 1,
87e8aa3b 2321 1, size, stat, dst_type);
3c9f5092
AV		 2322 if (src_rank > 0)
2323 src_index[src_dim]
2324 += GFC_DIMENSION_STRIDE (src->dim[src_dim]);
2325 array_offset_dst += stride_dst;
2326 }
2327 return;
2328 default:
2329 caf_runtime_error (unreachable);
2330 }
2331 return;
2332 case CAF_REF_STATIC_ARRAY:
2333 if (ref->u.a.mode[dst_dim] == CAF_ARR_REF_NONE)
2334 {
2335 send_by_ref (ref->next, i, src_index, single_token, NULL,
2336 src, ds, sr, dst_kind, src_kind,
87e8aa3b 2337 0, src_dim, 1, size, stat, dst_type);
3c9f5092
AV		 2338 return;
2339 }
2340 switch (ref->u.a.mode[dst_dim])
2341 {
2342 case CAF_ARR_REF_VECTOR:
2343 array_offset_dst = 0;
2344 src_index[src_dim] = 0;
2345 for (size_t idx = 0; idx < ref->u.a.dim[dst_dim].v.nvec;
2346 ++idx)
2347 {
2348#define KINDCASE(kind, type) case kind: \
2349 array_offset_dst = ((type *)ref->u.a.dim[dst_dim].v.vector)[idx]; \
2350 break
2351
2352 switch (ref->u.a.dim[dst_dim].v.kind)
2353 {
2354 KINDCASE (1, GFC_INTEGER_1);
2355 KINDCASE (2, GFC_INTEGER_2);
2356 KINDCASE (4, GFC_INTEGER_4);
2357#ifdef HAVE_GFC_INTEGER_8
2358 KINDCASE (8, GFC_INTEGER_8);
2359#endif
2360#ifdef HAVE_GFC_INTEGER_16
2361 KINDCASE (16, GFC_INTEGER_16);
2362#endif
2363 default:
2364 caf_runtime_error (unreachable);
2365 return;
2366 }
2367#undef KINDCASE
2368
2369 send_by_ref (ref, i, src_index, single_token, NULL, src,
2370 ds + array_offset_dst * ref->item_size, sr,
2371 dst_kind, src_kind, dst_dim + 1, src_dim + 1,
87e8aa3b 2372 1, size, stat, dst_type);
3c9f5092
AV		 2373 src_index[src_dim]
2374 += GFC_DIMENSION_STRIDE (src->dim[src_dim]);
2375 }
2376 return;
2377 case CAF_ARR_REF_FULL:
2378 src_index[src_dim] = 0;
2379 for (array_offset_dst = 0 ;
2380 array_offset_dst <= ref->u.a.dim[dst_dim].s.end;
2381 array_offset_dst += ref->u.a.dim[dst_dim].s.stride)
2382 {
2383 send_by_ref (ref, i, src_index, single_token, NULL, src,
2384 ds + array_offset_dst * ref->item_size, sr,
2385 dst_kind, src_kind, dst_dim + 1, src_dim + 1,
87e8aa3b 2386 1, size, stat, dst_type);
3c9f5092
AV		 2387 if (src_rank > 0)
2388 src_index[src_dim]
2389 += GFC_DIMENSION_STRIDE (src->dim[src_dim]);
2390 }
2391 return;
2392 case CAF_ARR_REF_RANGE:
2393 COMPUTE_NUM_ITEMS (extent_dst,
2394 ref->u.a.dim[dst_dim].s.stride,
2395 ref->u.a.dim[dst_dim].s.start,
2396 ref->u.a.dim[dst_dim].s.end);
2397 array_offset_dst = ref->u.a.dim[dst_dim].s.start;
2398 src_index[src_dim] = 0;
2399 for (index_type idx = 0; idx < extent_dst; ++idx)
2400 {
2401 send_by_ref (ref, i, src_index, single_token, NULL, src,
2402 ds + array_offset_dst * ref->item_size, sr,
2403 dst_kind, src_kind, dst_dim + 1, src_dim + 1,
87e8aa3b 2404 1, size, stat, dst_type);
3c9f5092
AV		 2405 if (src_rank > 0)
2406 src_index[src_dim]
2407 += GFC_DIMENSION_STRIDE (src->dim[src_dim]);
2408 array_offset_dst += ref->u.a.dim[dst_dim].s.stride;
2409 }
2410 return;
2411 case CAF_ARR_REF_SINGLE:
2412 array_offset_dst = ref->u.a.dim[dst_dim].s.start;
2413 send_by_ref (ref, i, src_index, single_token, NULL, src,
2414 ds + array_offset_dst * ref->item_size, sr,
2415 dst_kind, src_kind, dst_dim + 1, src_dim, 1,
87e8aa3b 2416 size, stat, dst_type);
3c9f5092 2417 return;
67914693 2418 /* The OPEN_* are mapped to a RANGE and therefore cannot occur. */
3c9f5092
AV		 2419 case CAF_ARR_REF_OPEN_END:
2420 case CAF_ARR_REF_OPEN_START:
2421 default:
2422 caf_runtime_error (unreachable);
2423 }
2424 return;
2425 default:
2426 caf_runtime_error (unreachable);
2427 }
2428}
2429
2430
2431void
2432_gfortran_caf_send_by_ref (caf_token_t token,
2433 int image_index __attribute__ ((unused)),
2434 gfc_descriptor_t *src, caf_reference_t *refs,
2435 int dst_kind, int src_kind,
2436 bool may_require_tmp __attribute__ ((unused)),
87e8aa3b 2437 bool dst_reallocatable, int *stat, int dst_type)
3c9f5092
AV		 2438{
2439 const char vecrefunknownkind[] = "libcaf_single::caf_get_by_ref(): "
2440 "unknown kind in vector-ref.\n";
2441 const char unknownreftype[] = "libcaf_single::caf_send_by_ref(): "
2442 "unknown reference type.\n";
2443 const char unknownarrreftype[] = "libcaf_single::caf_send_by_ref(): "
2444 "unknown array reference type.\n";
2445 const char rankoutofrange[] = "libcaf_single::caf_send_by_ref(): "
2446 "rank out of range.\n";
2447 const char realloconinnerref[] = "libcaf_single::caf_send_by_ref(): "
2448 "reallocation of array followed by component ref not allowed.\n";
2449 const char cannotallocdst[] = "libcaf_single::caf_send_by_ref(): "
67914693 2450 "cannot allocate memory.\n";
3c9f5092
AV		 2451 const char nonallocextentmismatch[] = "libcaf_single::caf_send_by_ref(): "
2452 "extent of non-allocatable array mismatch.\n";
2453 const char innercompref[] = "libcaf_single::caf_send_by_ref(): "
2454 "inner unallocated component detected.\n";
2455 size_t size, i;
2456 size_t dst_index[GFC_MAX_DIMENSIONS];
2457 int src_rank = GFC_DESCRIPTOR_RANK (src);
2458 int src_cur_dim = 0;
8fb75185 2459 size_t src_size = 0;
3c9f5092
AV		 2460 caf_single_token_t single_token = TOKEN (token);
2461 void *memptr = single_token->memptr;
2462 gfc_descriptor_t *dst = single_token->desc;
2463 caf_reference_t *riter = refs;
2464 long delta;
2465 bool extent_mismatch;
2466 /* Note that the component is not allocated yet. */
2467 index_type new_component_idx = -1;
2468
2469 if (stat)
2470 *stat = 0;
2471
2472 /* Compute the size of the result. In the beginning size just counts the
2473 number of elements. */
2474 size = 1;
2475 while (riter)
2476 {
2477 switch (riter->type)
2478 {
2479 case CAF_REF_COMPONENT:
2480 if (unlikely (new_component_idx != -1))
2481 {
2482 /* Allocating a component in the middle of a component ref is not
2483 support. We don't know the type to allocate. */
2484 caf_internal_error (innercompref, stat, NULL, 0);
2485 return;
2486 }
2487 if (riter->u.c.caf_token_offset > 0)
2488 {
2489 /* Check whether the allocatable component is zero, then no
2490 token is present, too. The token's pointer is not cleared
2491 when the structure is initialized. */
2492 if (*(void**)(memptr + riter->u.c.offset) == NULL)
2493 {
2494 /* This component is not yet allocated. Check that it is
2495 allocatable here. */
2496 if (!dst_reallocatable)
2497 {
2498 caf_internal_error (cannotallocdst, stat, NULL, 0);
2499 return;
2500 }
2501 single_token = NULL;
2502 memptr = NULL;
2503 dst = NULL;
2504 break;
2505 }
2506 single_token = *(caf_single_token_t*)
2507 (memptr + riter->u.c.caf_token_offset);
2508 memptr += riter->u.c.offset;
2509 dst = single_token->desc;
2510 }
2511 else
2512 {
2513 /* Regular component. */
2514 memptr += riter->u.c.offset;
2515 dst = (gfc_descriptor_t *)memptr;
2516 }
2517 break;
2518 case CAF_REF_ARRAY:
2519 if (dst != NULL)
2520 memptr = GFC_DESCRIPTOR_DATA (dst);
2521 else
2522 dst = src;
2523 /* When the dst array needs to be allocated, then look at the
2524 extent of the source array in the dimension dst_cur_dim. */
2525 for (i = 0; riter->u.a.mode[i] != CAF_ARR_REF_NONE; ++i)
2526 {
2527 switch (riter->u.a.mode[i])
2528 {
2529 case CAF_ARR_REF_VECTOR:
2530 delta = riter->u.a.dim[i].v.nvec;
2531#define KINDCASE(kind, type) case kind: \
2532 memptr += (((index_type) \
2533 ((type *)riter->u.a.dim[i].v.vector)[0]) \
2534 - GFC_DIMENSION_LBOUND (dst->dim[i])) \
2535 * GFC_DIMENSION_STRIDE (dst->dim[i]) \
2536 * riter->item_size; \
2537 break
2538
2539 switch (riter->u.a.dim[i].v.kind)
2540 {
2541 KINDCASE (1, GFC_INTEGER_1);
2542 KINDCASE (2, GFC_INTEGER_2);
2543 KINDCASE (4, GFC_INTEGER_4);
2544#ifdef HAVE_GFC_INTEGER_8
2545 KINDCASE (8, GFC_INTEGER_8);
2546#endif
2547#ifdef HAVE_GFC_INTEGER_16
2548 KINDCASE (16, GFC_INTEGER_16);
2549#endif
2550 default:
2551 caf_internal_error (vecrefunknownkind, stat, NULL, 0);
2552 return;
2553 }
2554#undef KINDCASE
2555 break;
2556 case CAF_ARR_REF_FULL:
2557 if (dst)
2558 COMPUTE_NUM_ITEMS (delta,
2559 riter->u.a.dim[i].s.stride,
2560 GFC_DIMENSION_LBOUND (dst->dim[i]),
2561 GFC_DIMENSION_UBOUND (dst->dim[i]));
2562 else
2563 COMPUTE_NUM_ITEMS (delta,
2564 riter->u.a.dim[i].s.stride,
2565 GFC_DIMENSION_LBOUND (src->dim[src_cur_dim]),
2566 GFC_DIMENSION_UBOUND (src->dim[src_cur_dim]));
2567 break;
2568 case CAF_ARR_REF_RANGE:
2569 COMPUTE_NUM_ITEMS (delta,
2570 riter->u.a.dim[i].s.stride,
2571 riter->u.a.dim[i].s.start,
2572 riter->u.a.dim[i].s.end);
2573 memptr += (riter->u.a.dim[i].s.start
2574 - dst->dim[i].lower_bound)
2575 * GFC_DIMENSION_STRIDE (dst->dim[i])
2576 * riter->item_size;
2577 break;
2578 case CAF_ARR_REF_SINGLE:
2579 delta = 1;
2580 memptr += (riter->u.a.dim[i].s.start
2581 - dst->dim[i].lower_bound)
2582 * GFC_DIMENSION_STRIDE (dst->dim[i])
2583 * riter->item_size;
2584 break;
2585 case CAF_ARR_REF_OPEN_END:
2586 if (dst)
2587 COMPUTE_NUM_ITEMS (delta,
2588 riter->u.a.dim[i].s.stride,
2589 riter->u.a.dim[i].s.start,
2590 GFC_DIMENSION_UBOUND (dst->dim[i]));
2591 else
2592 COMPUTE_NUM_ITEMS (delta,
2593 riter->u.a.dim[i].s.stride,
2594 riter->u.a.dim[i].s.start,
2595 GFC_DIMENSION_UBOUND (src->dim[src_cur_dim]));
2596 memptr += (riter->u.a.dim[i].s.start
2597 - dst->dim[i].lower_bound)
2598 * GFC_DIMENSION_STRIDE (dst->dim[i])
2599 * riter->item_size;
2600 break;
2601 case CAF_ARR_REF_OPEN_START:
2602 if (dst)
2603 COMPUTE_NUM_ITEMS (delta,
2604 riter->u.a.dim[i].s.stride,
2605 GFC_DIMENSION_LBOUND (dst->dim[i]),
2606 riter->u.a.dim[i].s.end);
2607 else
2608 COMPUTE_NUM_ITEMS (delta,
2609 riter->u.a.dim[i].s.stride,
2610 GFC_DIMENSION_LBOUND (src->dim[src_cur_dim]),
2611 riter->u.a.dim[i].s.end);
2612 /* The memptr stays unchanged when ref'ing the first element
2613 in a dimension. */
2614 break;
2615 default:
2616 caf_internal_error (unknownarrreftype, stat, NULL, 0);
2617 return;
2618 }
2619
2620 if (delta <= 0)
2621 return;
2622 /* Check the various properties of the source array.
2623 When src is an array. */
2624 if (delta > 1 && src_rank > 0)
2625 {
2626 /* Check that src_cur_dim is valid for src. Can be
2627 superceeded only by scalar data. */
2628 if (src_cur_dim >= src_rank)
2629 {
2630 caf_internal_error (rankoutofrange, stat, NULL, 0);
2631 return;
2632 }
2633 /* Do further checks, when the source is not scalar. */
2634 else
2635 {
2636 /* When the realloc is required, then no extent may have
2637 been set. */
2638 extent_mismatch = memptr == NULL
2639 || (dst
2640 && GFC_DESCRIPTOR_EXTENT (dst, src_cur_dim)
2641 != delta);
2642 /* When it already known, that a realloc is needed or
2643 the extent does not match the needed one. */
2644 if (extent_mismatch)
2645 {
2646 /* Check whether dst is reallocatable. */
2647 if (unlikely (!dst_reallocatable))
2648 {
2649 caf_internal_error (nonallocextentmismatch, stat,
2650 NULL, 0, delta,
2651 GFC_DESCRIPTOR_EXTENT (dst,
2652 src_cur_dim));
2653 return;
2654 }
2655 /* Report error on allocatable but missing inner
2656 ref. */
2657 else if (riter->next != NULL)
2658 {
2659 caf_internal_error (realloconinnerref, stat, NULL,
2660 0);
2661 return;
2662 }
2663 }
2664 /* Only change the extent when it does not match. This is
2665 to prevent resetting given array bounds. */
2666 if (extent_mismatch)
2667 GFC_DIMENSION_SET (dst->dim[src_cur_dim], 1, delta,
2668 size);
2669 }
2670 /* Increase the dim-counter of the src only when the extent
2671 matches. */
2672 if (src_cur_dim < src_rank
2673 && GFC_DESCRIPTOR_EXTENT (src, src_cur_dim) == delta)
2674 ++src_cur_dim;
2675 }
2676 size *= (index_type)delta;
2677 }
2678 break;
2679 case CAF_REF_STATIC_ARRAY:
2680 for (i = 0; riter->u.a.mode[i] != CAF_ARR_REF_NONE; ++i)
2681 {
2682 switch (riter->u.a.mode[i])
2683 {
2684 case CAF_ARR_REF_VECTOR:
2685 delta = riter->u.a.dim[i].v.nvec;
2686#define KINDCASE(kind, type) case kind: \
2687 memptr += ((type *)riter->u.a.dim[i].v.vector)[0] \
2688 * riter->item_size; \
2689 break
2690
2691 switch (riter->u.a.dim[i].v.kind)
2692 {
2693 KINDCASE (1, GFC_INTEGER_1);
2694 KINDCASE (2, GFC_INTEGER_2);
2695 KINDCASE (4, GFC_INTEGER_4);
2696#ifdef HAVE_GFC_INTEGER_8
2697 KINDCASE (8, GFC_INTEGER_8);
2698#endif
2699#ifdef HAVE_GFC_INTEGER_16
2700 KINDCASE (16, GFC_INTEGER_16);
2701#endif
2702 default:
2703 caf_internal_error (vecrefunknownkind, stat, NULL, 0);
2704 return;
2705 }
2706#undef KINDCASE
2707 break;
2708 case CAF_ARR_REF_FULL:
2709 delta = riter->u.a.dim[i].s.end / riter->u.a.dim[i].s.stride
2710 + 1;
2711 /* The memptr stays unchanged when ref'ing the first element
2712 in a dimension. */
2713 break;
2714 case CAF_ARR_REF_RANGE:
2715 COMPUTE_NUM_ITEMS (delta,
2716 riter->u.a.dim[i].s.stride,
2717 riter->u.a.dim[i].s.start,
2718 riter->u.a.dim[i].s.end);
2719 memptr += riter->u.a.dim[i].s.start
2720 * riter->u.a.dim[i].s.stride
2721 * riter->item_size;
2722 break;
2723 case CAF_ARR_REF_SINGLE:
2724 delta = 1;
2725 memptr += riter->u.a.dim[i].s.start
2726 * riter->u.a.dim[i].s.stride
2727 * riter->item_size;
2728 break;
2729 case CAF_ARR_REF_OPEN_END:
2730 /* This and OPEN_START are mapped to a RANGE and therefore
67914693 2731 cannot occur here. */
3c9f5092
AV		 2732 case CAF_ARR_REF_OPEN_START:
2733 default:
2734 caf_internal_error (unknownarrreftype, stat, NULL, 0);
2735 return;
2736 }
2737 if (delta <= 0)
2738 return;
2739 /* Check the various properties of the source array.
2740 Only when the source array is not scalar examine its
2741 properties. */
2742 if (delta > 1 && src_rank > 0)
2743 {
2744 /* Check that src_cur_dim is valid for src. Can be
2745 superceeded only by scalar data. */
2746 if (src_cur_dim >= src_rank)
2747 {
2748 caf_internal_error (rankoutofrange, stat, NULL, 0);
2749 return;
2750 }
2751 else
2752 {
2753 /* We will not be able to realloc the dst, because that's
2754 a fixed size array. */
2755 extent_mismatch = GFC_DESCRIPTOR_EXTENT (src, src_cur_dim)
2756 != delta;
2757 /* When the extent does not match the needed one we can
2758 only stop here. */
2759 if (extent_mismatch)
2760 {
2761 caf_internal_error (nonallocextentmismatch, stat,
2762 NULL, 0, delta,
2763 GFC_DESCRIPTOR_EXTENT (src,
2764 src_cur_dim));
2765 return;
2766 }
2767 }
2768 ++src_cur_dim;
2769 }
2770 size *= (index_type)delta;
2771 }
2772 break;
2773 default:
2774 caf_internal_error (unknownreftype, stat, NULL, 0);
2775 return;
2776 }
2777 src_size = riter->item_size;
2778 riter = riter->next;
2779 }
2780 if (size == 0 || src_size == 0)
2781 return;
2782 /* Postcondition:
2783 - size contains the number of elements to store in the destination array,
2784 - src_size gives the size in bytes of each item in the destination array.
2785 */
2786
2787 /* Reset the token. */
2788 single_token = TOKEN (token);
2789 memptr = single_token->memptr;
2790 dst = single_token->desc;
2791 memset (dst_index, 0, sizeof (dst_index));
2792 i = 0;
2793 send_by_ref (refs, &i, dst_index, single_token, dst, src,
2794 memptr, GFC_DESCRIPTOR_DATA (src), dst_kind, src_kind, 0, 0,
87e8aa3b 2795 1, size, stat, dst_type);
3c9f5092
AV		 2796 assert (i == size);
2797}
2798
2799
2800void
2801_gfortran_caf_sendget_by_ref (caf_token_t dst_token, int dst_image_index,
2802 caf_reference_t *dst_refs, caf_token_t src_token,
2803 int src_image_index,
2804 caf_reference_t *src_refs, int dst_kind,
2805 int src_kind, bool may_require_tmp, int *dst_stat,
87e8aa3b 2806 int *src_stat, int dst_type, int src_type)
3c9f5092 2807{
87e8aa3b
AV		 2808 GFC_FULL_ARRAY_DESCRIPTOR (GFC_MAX_DIMENSIONS, void) temp;
2809 GFC_DESCRIPTOR_DATA (&temp) = NULL;
2810 GFC_DESCRIPTOR_RANK (&temp) = -1;
2811 GFC_DESCRIPTOR_TYPE (&temp) = dst_type;
3c9f5092 2812
934e9926
JJ		 2813 _gfortran_caf_get_by_ref (src_token, src_image_index,
2814 (gfc_descriptor_t *) &temp, src_refs,
3c9f5092 2815 dst_kind, src_kind, may_require_tmp, true,
87e8aa3b 2816 src_stat, src_type);
3c9f5092
AV		 2817
2818 if (src_stat && *src_stat != 0)
2819 return;
2820
934e9926
JJ		 2821 _gfortran_caf_send_by_ref (dst_token, dst_image_index,
2822 (gfc_descriptor_t *) &temp, dst_refs,
87e8aa3b
AV		 2823 dst_kind, dst_kind, may_require_tmp, true,
2824 dst_stat, dst_type);
3c9f5092
AV		 2825 if (GFC_DESCRIPTOR_DATA (&temp))
2826 free (GFC_DESCRIPTOR_DATA (&temp));
2827}
2828
2829
42a8246d
TB		 2830void
2831_gfortran_caf_atomic_define (caf_token_t token, size_t offset,
2832 int image_index __attribute__ ((unused)),
2833 void *value, int *stat,
2834 int type __attribute__ ((unused)), int kind)
2835{
2836 assert(kind == 4);
2837
3c9f5092 2838 uint32_t *atom = (uint32_t *) ((char *) MEMTOK (token) + offset);
42a8246d
TB		 2839
2840 __atomic_store (atom, (uint32_t *) value, __ATOMIC_RELAXED);
2841
2842 if (stat)
2843 *stat = 0;
2844}
2845
2846void
2847_gfortran_caf_atomic_ref (caf_token_t token, size_t offset,
2848 int image_index __attribute__ ((unused)),
2849 void *value, int *stat,
2850 int type __attribute__ ((unused)), int kind)
2851{
2852 assert(kind == 4);
2853
3c9f5092 2854 uint32_t *atom = (uint32_t *) ((char *) MEMTOK (token) + offset);
42a8246d
TB		 2855
2856 __atomic_load (atom, (uint32_t *) value, __ATOMIC_RELAXED);
2857
2858 if (stat)
2859 *stat = 0;
2860}
2861
2862
2863void
2864_gfortran_caf_atomic_cas (caf_token_t token, size_t offset,
2865 int image_index __attribute__ ((unused)),
2866 void *old, void *compare, void *new_val, int *stat,
2867 int type __attribute__ ((unused)), int kind)
2868{
2869 assert(kind == 4);
2870
3c9f5092 2871 uint32_t *atom = (uint32_t *) ((char *) MEMTOK (token) + offset);
42a8246d
TB		 2872
2873 *(uint32_t *) old = *(uint32_t *) compare;
2874 (void) __atomic_compare_exchange_n (atom, (uint32_t *) old,
2875 *(uint32_t *) new_val, false,
2876 __ATOMIC_RELAXED, __ATOMIC_RELAXED);
2877 if (stat)
2878 *stat = 0;
2879}
2880
2881
2882void
2883_gfortran_caf_atomic_op (int op, caf_token_t token, size_t offset,
2884 int image_index __attribute__ ((unused)),
2885 void *value, void *old, int *stat,
2886 int type __attribute__ ((unused)), int kind)
2887{
2888 assert(kind == 4);
2889
2890 uint32_t res;
3c9f5092 2891 uint32_t *atom = (uint32_t *) ((char *) MEMTOK (token) + offset);
42a8246d
TB		 2892
2893 switch (op)
2894 {
2895 case GFC_CAF_ATOMIC_ADD:
2896 res = __atomic_fetch_add (atom, *(uint32_t *) value, __ATOMIC_RELAXED);
2897 break;
2898 case GFC_CAF_ATOMIC_AND:
2899 res = __atomic_fetch_and (atom, *(uint32_t *) value, __ATOMIC_RELAXED);
2900 break;
2901 case GFC_CAF_ATOMIC_OR:
2902 res = __atomic_fetch_or (atom, *(uint32_t *) value, __ATOMIC_RELAXED);
2903 break;
2904 case GFC_CAF_ATOMIC_XOR:
2905 res = __atomic_fetch_xor (atom, *(uint32_t *) value, __ATOMIC_RELAXED);
2906 break;
2907 default:
2908 __builtin_unreachable();
2909 }
2910
2911 if (old)
2912 *(uint32_t *) old = res;
2913
2914 if (stat)
2915 *stat = 0;
2916}
bc0229f9 2917
5df445a2
TB		 2918void
2919_gfortran_caf_event_post (caf_token_t token, size_t index,
2920 int image_index __attribute__ ((unused)),
2921 int *stat, char *errmsg __attribute__ ((unused)),
3f5fabc0 2922 size_t errmsg_len __attribute__ ((unused)))
5df445a2
TB		 2923{
2924 uint32_t value = 1;
3c9f5092
AV		 2925 uint32_t *event = (uint32_t *) ((char *) MEMTOK (token) + index
2926 * sizeof (uint32_t));
5df445a2
TB		 2927 __atomic_fetch_add (event, (uint32_t) value, __ATOMIC_RELAXED);
2928
2929 if(stat)
2930 *stat = 0;
2931}
2932
2933void
2934_gfortran_caf_event_wait (caf_token_t token, size_t index,
2935 int until_count, int *stat,
2936 char *errmsg __attribute__ ((unused)),
3f5fabc0 2937 size_t errmsg_len __attribute__ ((unused)))
5df445a2 2938{
3c9f5092
AV		 2939 uint32_t *event = (uint32_t *) ((char *) MEMTOK (token) + index
2940 * sizeof (uint32_t));
5df445a2
TB		 2941 uint32_t value = (uint32_t)-until_count;
2942 __atomic_fetch_add (event, (uint32_t) value, __ATOMIC_RELAXED);
2943
2944 if(stat)
2945 *stat = 0;
2946}
2947
2948void
2949_gfortran_caf_event_query (caf_token_t token, size_t index,
2950 int image_index __attribute__ ((unused)),
2951 int *count, int *stat)
2952{
3c9f5092
AV		 2953 uint32_t *event = (uint32_t *) ((char *) MEMTOK (token) + index
2954 * sizeof (uint32_t));
5df445a2
TB		 2955 __atomic_load (event, (uint32_t *) count, __ATOMIC_RELAXED);
2956
2957 if(stat)
2958 *stat = 0;
2959}
bc0229f9
TB		 2960
2961void
2962_gfortran_caf_lock (caf_token_t token, size_t index,
2963 int image_index __attribute__ ((unused)),
3f5fabc0 2964 int *aquired_lock, int *stat, char *errmsg, size_t errmsg_len)
bc0229f9
TB		 2965{
2966 const char *msg = "Already locked";
3c9f5092 2967 bool *lock = &((bool *) MEMTOK (token))[index];
bc0229f9
TB		 2968
2969 if (!*lock)
2970 {
2971 *lock = true;
2972 if (aquired_lock)
2973 *aquired_lock = (int) true;
2974 if (stat)
2975 *stat = 0;
2976 return;
2977 }
2978
2979 if (aquired_lock)
2980 {
2981 *aquired_lock = (int) false;
2982 if (stat)
2983 *stat = 0;
2984 return;
2985 }
2986
2987
2988 if (stat)
2989 {
2990 *stat = 1;
2991 if (errmsg_len > 0)
2992 {
3f5fabc0
JB		 2993 size_t len = (sizeof (msg) > errmsg_len) ? errmsg_len
2994 : sizeof (msg);
bc0229f9
TB		 2995 memcpy (errmsg, msg, len);
2996 if (errmsg_len > len)
2997 memset (&errmsg[len], ' ', errmsg_len-len);
2998 }
2999 return;
3000 }
dffb1e22 3001 _gfortran_caf_error_stop_str (msg, strlen (msg), false);
bc0229f9
TB		 3002}
3003
3004
3005void
3006_gfortran_caf_unlock (caf_token_t token, size_t index,
3007 int image_index __attribute__ ((unused)),
3f5fabc0 3008 int *stat, char *errmsg, size_t errmsg_len)
bc0229f9
TB		 3009{
3010 const char *msg = "Variable is not locked";
3c9f5092 3011 bool *lock = &((bool *) MEMTOK (token))[index];
bc0229f9
TB		 3012
3013 if (*lock)
3014 {
3015 *lock = false;
3016 if (stat)
3017 *stat = 0;
3018 return;
3019 }
3020
3021 if (stat)
3022 {
3023 *stat = 1;
3024 if (errmsg_len > 0)
3025 {
3f5fabc0
JB		 3026 size_t len = (sizeof (msg) > errmsg_len) ? errmsg_len
3027 : sizeof (msg);
bc0229f9
TB		 3028 memcpy (errmsg, msg, len);
3029 if (errmsg_len > len)
3030 memset (&errmsg[len], ' ', errmsg_len-len);
3031 }
3032 return;
3033 }
dffb1e22 3034 _gfortran_caf_error_stop_str (msg, strlen (msg), false);
bc0229f9 3035}
ba85c8c3
AV		 3036
3037int
3038_gfortran_caf_is_present (caf_token_t token,
3039 int image_index __attribute__ ((unused)),
3040 caf_reference_t *refs)
3041{
3042 const char arraddressingnotallowed[] = "libcaf_single::caf_is_present(): "
3043 "only scalar indexes allowed.\n";
3044 const char unknownreftype[] = "libcaf_single::caf_get_by_ref(): "
3045 "unknown reference type.\n";
3046 const char unknownarrreftype[] = "libcaf_single::caf_get_by_ref(): "
3047 "unknown array reference type.\n";
3048 size_t i;
3049 caf_single_token_t single_token = TOKEN (token);
3050 void *memptr = single_token->memptr;
3051 gfc_descriptor_t *src = single_token->desc;
3052 caf_reference_t *riter = refs;
3053
3054 while (riter)
3055 {
3056 switch (riter->type)
3057 {
3058 case CAF_REF_COMPONENT:
3059 if (riter->u.c.caf_token_offset)
3060 {
3061 single_token = *(caf_single_token_t*)
3062 (memptr + riter->u.c.caf_token_offset);
3063 memptr = single_token->memptr;
3064 src = single_token->desc;
3065 }
3066 else
3067 {
3068 memptr += riter->u.c.offset;
3069 src = (gfc_descriptor_t *)memptr;
3070 }
3071 break;
3072 case CAF_REF_ARRAY:
3073 for (i = 0; riter->u.a.mode[i] != CAF_ARR_REF_NONE; ++i)
3074 {
3075 switch (riter->u.a.mode[i])
3076 {
3077 case CAF_ARR_REF_SINGLE:
3078 memptr += (riter->u.a.dim[i].s.start
3079 - GFC_DIMENSION_LBOUND (src->dim[i]))
3080 * GFC_DIMENSION_STRIDE (src->dim[i])
3081 * riter->item_size;
3082 break;
3083 case CAF_ARR_REF_FULL:
3084 /* A full array ref is allowed on the last reference only. */
3085 if (riter->next == NULL)
3086 break;
3087 /* else fall through reporting an error. */
9a0f2718 3088 /* FALLTHROUGH */
ba85c8c3
AV		 3089 case CAF_ARR_REF_VECTOR:
3090 case CAF_ARR_REF_RANGE:
3091 case CAF_ARR_REF_OPEN_END:
3092 case CAF_ARR_REF_OPEN_START:
3093 caf_internal_error (arraddressingnotallowed, 0, NULL, 0);
3094 return 0;
3095 default:
3096 caf_internal_error (unknownarrreftype, 0, NULL, 0);
3097 return 0;
3098 }
3099 }
3100 break;
3101 case CAF_REF_STATIC_ARRAY:
3102 for (i = 0; riter->u.a.mode[i] != CAF_ARR_REF_NONE; ++i)
3103 {
3104 switch (riter->u.a.mode[i])
3105 {
3106 case CAF_ARR_REF_SINGLE:
3107 memptr += riter->u.a.dim[i].s.start
3108 * riter->u.a.dim[i].s.stride
3109 * riter->item_size;
3110 break;
3111 case CAF_ARR_REF_FULL:
3112 /* A full array ref is allowed on the last reference only. */
3113 if (riter->next == NULL)
3114 break;
3115 /* else fall through reporting an error. */
9a0f2718 3116 /* FALLTHROUGH */
ba85c8c3
AV		 3117 case CAF_ARR_REF_VECTOR:
3118 case CAF_ARR_REF_RANGE:
3119 case CAF_ARR_REF_OPEN_END:
3120 case CAF_ARR_REF_OPEN_START:
3121 caf_internal_error (arraddressingnotallowed, 0, NULL, 0);
3122 return 0;
3123 default:
3124 caf_internal_error (unknownarrreftype, 0, NULL, 0);
3125 return 0;
3126 }
3127 }
3128 break;
3129 default:
3130 caf_internal_error (unknownreftype, 0, NULL, 0);
3131 return 0;
3132 }
3133 riter = riter->next;
3134 }
3135 return memptr != NULL;
3136}
Mirror of https://gcc.gnu.org/git/gcc.git