Branch data Line data Source code
1 : : /* Rewrite the expression tree for coarrays.
2 : : Copyright (C) 2010-2025 Free Software Foundation, Inc.
3 : : Contributed by Andre Vehreschild.
4 : :
5 : : This file is part of GCC.
6 : :
7 : : GCC is free software; you can redistribute it and/or modify it under
8 : : the terms of the GNU General Public License as published by the Free
9 : : Software Foundation; either version 3, or (at your option) any later
10 : : version.
11 : :
12 : : GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 : : WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 : : FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
15 : : for more details.
16 : :
17 : : You should have received a copy of the GNU General Public License
18 : : along with GCC; see the file COPYING3. If not see
19 : : <http://www.gnu.org/licenses/>. */
20 : :
21 : : /* Rewrite the expression for coarrays where needed:
22 : : - coarray indexing operations need the indexing expression put into a
23 : : routine callable on the remote image
24 : :
25 : : This rewriter is meant to used for non-optimisational expression tree
26 : : rewrites. When implementing early optimisation it is recommended to
27 : : do this in frontend-passes.cc.
28 : : */
29 : :
30 : : #include "config.h"
31 : : #include "system.h"
32 : : #include "coretypes.h"
33 : : #include "options.h"
34 : : #include "bitmap.h"
35 : : #include "gfortran.h"
36 : :
37 : : /* The code tree element that is currently processed. */
38 : : static gfc_code **current_code;
39 : :
40 : : /* Code that is inserted into the current caf_accessor at the beginning. */
41 : : static gfc_code *caf_accessor_prepend = nullptr;
42 : :
43 : : static bool caf_on_lhs = false;
44 : :
45 : : static int caf_sym_cnt = 0;
46 : :
47 : : static gfc_array_spec *
48 : 25 : get_arrayspec_from_expr (gfc_expr *expr)
49 : : {
50 : 25 : gfc_array_spec *src_as, *dst_as = NULL;
51 : 25 : gfc_ref *ref;
52 : 25 : gfc_array_ref mod_src_ar;
53 : 25 : int dst_rank = 0;
54 : :
55 : 25 : if (expr->rank == 0)
56 : : return NULL;
57 : :
58 : 25 : if (expr->expr_type == EXPR_FUNCTION)
59 : 0 : return gfc_copy_array_spec (expr->symtree->n.sym->as);
60 : :
61 : : /* Follow any component references. */
62 : 25 : if (expr->expr_type == EXPR_VARIABLE || expr->expr_type == EXPR_CONSTANT)
63 : : {
64 : 25 : if (expr->symtree)
65 : 25 : src_as = expr->symtree->n.sym->as;
66 : : else
67 : : src_as = NULL;
68 : :
69 : 50 : for (ref = expr->ref; ref; ref = ref->next)
70 : : {
71 : 25 : switch (ref->type)
72 : : {
73 : 0 : case REF_COMPONENT:
74 : 0 : src_as = ref->u.c.component->as;
75 : 0 : continue;
76 : :
77 : 0 : case REF_SUBSTRING:
78 : 0 : case REF_INQUIRY:
79 : 0 : continue;
80 : :
81 : 25 : case REF_ARRAY:
82 : 25 : switch (ref->u.ar.type)
83 : : {
84 : : case AR_ELEMENT:
85 : 25 : src_as = NULL;
86 : : break;
87 : 0 : case AR_SECTION:
88 : 0 : {
89 : 0 : if (!dst_as)
90 : 0 : dst_as = gfc_get_array_spec ();
91 : 0 : memset (&mod_src_ar, 0, sizeof (gfc_array_ref));
92 : 0 : mod_src_ar = ref->u.ar;
93 : 0 : for (int dim = 0; dim < src_as->rank; ++dim)
94 : : {
95 : 0 : switch (ref->u.ar.dimen_type[dim])
96 : : {
97 : 0 : case DIMEN_ELEMENT:
98 : 0 : gfc_free_expr (mod_src_ar.start[dim]);
99 : 0 : mod_src_ar.start[dim] = NULL;
100 : 0 : break;
101 : 0 : case DIMEN_RANGE:
102 : 0 : dst_as->lower[dst_rank]
103 : 0 : = gfc_copy_expr (ref->u.ar.start[dim]);
104 : 0 : mod_src_ar.start[dst_rank]
105 : 0 : = gfc_copy_expr (ref->u.ar.start[dim]);
106 : 0 : if (ref->u.ar.end[dim])
107 : : {
108 : 0 : dst_as->upper[dst_rank]
109 : 0 : = gfc_copy_expr (ref->u.ar.end[dim]);
110 : 0 : mod_src_ar.end[dst_rank] = ref->u.ar.end[dim];
111 : 0 : mod_src_ar.stride[dst_rank]
112 : 0 : = ref->u.ar.stride[dim];
113 : : }
114 : : else
115 : 0 : dst_as->upper[dst_rank]
116 : 0 : = gfc_copy_expr (ref->u.ar.as->upper[dim]);
117 : 0 : ++dst_rank;
118 : 0 : break;
119 : 0 : case DIMEN_STAR:
120 : 0 : dst_as->lower[dst_rank]
121 : 0 : = gfc_copy_expr (ref->u.ar.as->lower[dim]);
122 : 0 : mod_src_ar.start[dst_rank]
123 : 0 : = gfc_copy_expr (ref->u.ar.start[dim]);
124 : 0 : if (ref->u.ar.as->upper[dim])
125 : : {
126 : 0 : dst_as->upper[dst_rank]
127 : 0 : = gfc_copy_expr (ref->u.ar.as->upper[dim]);
128 : 0 : mod_src_ar.end[dst_rank] = ref->u.ar.end[dim];
129 : 0 : mod_src_ar.stride[dst_rank]
130 : 0 : = ref->u.ar.stride[dim];
131 : : }
132 : 0 : ++dst_rank;
133 : 0 : break;
134 : 0 : case DIMEN_VECTOR:
135 : 0 : dst_as->lower[dst_rank]
136 : 0 : = gfc_get_constant_expr (BT_INTEGER,
137 : : gfc_index_integer_kind,
138 : : &expr->where);
139 : 0 : mpz_set_ui (dst_as->lower[dst_rank]->value.integer,
140 : : 1);
141 : 0 : mod_src_ar.start[dst_rank]
142 : 0 : = gfc_copy_expr (ref->u.ar.start[dim]);
143 : 0 : dst_as->upper[dst_rank]
144 : 0 : = gfc_get_constant_expr (BT_INTEGER,
145 : : gfc_index_integer_kind,
146 : : &expr->where);
147 : 0 : mpz_set (dst_as->upper[dst_rank]->value.integer,
148 : 0 : ref->u.ar.start[dim]->shape[0]);
149 : 0 : ++dst_rank;
150 : 0 : break;
151 : 0 : case DIMEN_THIS_IMAGE:
152 : 0 : case DIMEN_UNKNOWN:
153 : 0 : gcc_unreachable ();
154 : : }
155 : 0 : if (ref->u.ar.dimen_type[dim] != DIMEN_ELEMENT)
156 : 0 : mod_src_ar.dimen_type[dst_rank]
157 : 0 : = ref->u.ar.dimen_type[dim];
158 : : }
159 : 0 : dst_as->rank = dst_rank;
160 : 0 : dst_as->type = AS_EXPLICIT;
161 : 0 : ref->u.ar = mod_src_ar;
162 : 0 : ref->u.ar.dimen = dst_rank;
163 : 0 : break;
164 : :
165 : : case AR_UNKNOWN:
166 : 25 : src_as = NULL;
167 : : break;
168 : :
169 : 25 : case AR_FULL:
170 : 25 : if (dst_as)
171 : : /* Prevent memory loss. */
172 : 0 : gfc_free_array_spec (dst_as);
173 : 25 : dst_as = gfc_copy_array_spec (src_as);
174 : 25 : break;
175 : : }
176 : : break;
177 : : }
178 : 0 : }
179 : : }
180 : : }
181 : : else
182 : 25 : src_as = NULL;
183 : :
184 : : return dst_as;
185 : : }
186 : :
187 : : static void
188 : 833 : remove_coarray_from_derived_type (gfc_symbol *base, gfc_namespace *ns,
189 : : gfc_array_spec *src_as = NULL)
190 : : {
191 : 833 : gfc_symbol *derived;
192 : 833 : gfc_symbol *src_derived = base->ts.u.derived;
193 : :
194 : 833 : if (!src_as)
195 : 803 : src_as = src_derived->as;
196 : 833 : gfc_get_symbol (src_derived->name, ns, &derived);
197 : 833 : derived->attr.flavor = FL_DERIVED;
198 : 833 : derived->attr.alloc_comp = src_derived->attr.alloc_comp;
199 : 833 : if (src_as && src_as->rank != 0)
200 : : {
201 : 17 : base->attr.dimension = 1;
202 : 17 : base->as = gfc_copy_array_spec (src_as);
203 : 17 : base->as->corank = 0;
204 : : }
205 : 4349 : for (gfc_component *p = NULL, *c = src_derived->components; c; c = c->next)
206 : : {
207 : 3516 : gfc_component *n = gfc_get_component ();
208 : 3516 : *n = *c;
209 : 3516 : if (n->as)
210 : 1613 : n->as = gfc_copy_array_spec (c->as);
211 : 3516 : n->backend_decl = NULL;
212 : 3516 : n->initializer = NULL;
213 : 3516 : n->param_list = NULL;
214 : 3516 : if (p)
215 : 2683 : p->next = n;
216 : : else
217 : 833 : derived->components = n;
218 : :
219 : 3516 : p = n;
220 : : }
221 : 833 : derived->declared_at = base->declared_at;
222 : 833 : gfc_set_sym_referenced (derived);
223 : 833 : gfc_commit_symbol (derived);
224 : 833 : base->ts.u.derived = derived;
225 : 833 : gfc_commit_symbol (base);
226 : 833 : }
227 : :
228 : : static void
229 : 30 : convert_coarray_class_to_derived_type (gfc_symbol *base, gfc_namespace *ns)
230 : : {
231 : 30 : gfc_symbol *src_derived = CLASS_DATA (base)->ts.u.derived;
232 : 30 : gfc_array_spec *src_as = CLASS_DATA (base)->as;
233 : 60 : const bool attr_allocatable
234 : 30 : = src_as && src_as->rank && src_as->type == AS_DEFERRED;
235 : :
236 : 30 : base->ts.type = BT_DERIVED;
237 : 30 : base->ts.u.derived = src_derived;
238 : :
239 : 30 : remove_coarray_from_derived_type (base, ns, src_as);
240 : :
241 : 30 : base->attr.allocatable = attr_allocatable;
242 : 30 : base->attr.pointer = 0; // Ensure, that it is no pointer.
243 : 30 : }
244 : :
245 : : static void
246 : 1116 : move_coarray_ref (gfc_ref **from, gfc_expr *expr)
247 : : {
248 : 1116 : int i;
249 : 1116 : gfc_ref *to = expr->ref;
250 : 1145 : for (; to && to->next; to = to->next)
251 : : ;
252 : :
253 : 1116 : if (!to)
254 : : {
255 : 1063 : expr->ref = gfc_get_ref ();
256 : 1063 : to = expr->ref;
257 : 1063 : to->type = REF_ARRAY;
258 : : }
259 : 1116 : gcc_assert (to->type == REF_ARRAY);
260 : 1116 : to->u.ar.as = gfc_copy_array_spec ((*from)->u.ar.as);
261 : 1116 : to->u.ar.codimen = (*from)->u.ar.codimen;
262 : 1116 : to->u.ar.dimen = (*from)->u.ar.dimen;
263 : 1116 : to->u.ar.type = AR_FULL;
264 : 1116 : to->u.ar.stat = (*from)->u.ar.stat;
265 : 1116 : (*from)->u.ar.stat = nullptr;
266 : 1116 : to->u.ar.team = (*from)->u.ar.team;
267 : 1116 : (*from)->u.ar.team = nullptr;
268 : 1116 : to->u.ar.team_type = (*from)->u.ar.team_type;
269 : 1116 : (*from)->u.ar.team_type = TEAM_UNSET;
270 : 1413 : for (i = 0; i < to->u.ar.dimen; ++i)
271 : : {
272 : 297 : to->u.ar.start[i] = nullptr;
273 : 297 : to->u.ar.end[i] = nullptr;
274 : 297 : to->u.ar.stride[i] = nullptr;
275 : : }
276 : 2246 : for (i = (*from)->u.ar.dimen; i < (*from)->u.ar.dimen + (*from)->u.ar.codimen;
277 : : ++i)
278 : : {
279 : 1130 : to->u.ar.dimen_type[i] = (*from)->u.ar.dimen_type[i];
280 : 1130 : to->u.ar.start[i] = (*from)->u.ar.start[i];
281 : 1130 : (*from)->u.ar.start[i] = nullptr;
282 : 1130 : to->u.ar.end[i] = (*from)->u.ar.end[i];
283 : 1130 : (*from)->u.ar.end[i] = nullptr;
284 : 1130 : to->u.ar.stride[i] = (*from)->u.ar.stride[i];
285 : 1130 : (*from)->u.ar.stride[i] = nullptr;
286 : : }
287 : 1116 : (*from)->u.ar.codimen = 0;
288 : 1116 : if ((*from)->u.ar.dimen == 0)
289 : : {
290 : 879 : gfc_ref *nref = (*from)->next;
291 : 879 : (*from)->next = nullptr;
292 : 879 : gfc_free_ref_list (*from);
293 : 879 : *from = nref;
294 : : }
295 : 1116 : }
296 : :
297 : : static void
298 : 2232 : fixup_comp_refs (gfc_expr *expr)
299 : : {
300 : 2232 : bool class_ref = expr->symtree->n.sym->ts.type == BT_CLASS;
301 : 6133 : gfc_symbol *type
302 : : = expr->symtree->n.sym->ts.type == BT_DERIVED
303 : 2232 : ? expr->symtree->n.sym->ts.u.derived
304 : 587 : : (class_ref ? CLASS_DATA (expr->symtree->n.sym)->ts.u.derived
305 : : : nullptr);
306 : 1669 : if (!type)
307 : : return;
308 : 1669 : gfc_ref **pref = &(expr->ref);
309 : 1669 : for (gfc_ref *ref = expr->ref; ref && type;)
310 : : {
311 : 2220 : switch (ref->type)
312 : : {
313 : 1186 : case REF_COMPONENT:
314 : 1186 : gfc_find_component (type, ref->u.c.component->name, false, true,
315 : : pref);
316 : 1186 : if (!*pref)
317 : : {
318 : : /* This happens when there were errors previously. Just don't
319 : : crash. */
320 : : ref = nullptr;
321 : : break;
322 : : }
323 : 1186 : if (class_ref)
324 : : /* Link to the class type to allow for derived type resolution. */
325 : 0 : (*pref)->u.c.sym = ref->u.c.sym;
326 : 1186 : (*pref)->next = ref->next;
327 : 1186 : ref->next = NULL;
328 : 1186 : gfc_free_ref_list (ref);
329 : 1186 : ref = (*pref)->next;
330 : 2372 : type = (*pref)->u.c.component->ts.type == BT_DERIVED
331 : 1186 : ? (*pref)->u.c.component->ts.u.derived
332 : : : ((*pref)->u.c.component->ts.type == BT_CLASS
333 : 836 : ? CLASS_DATA ((*pref)->u.c.component)->ts.u.derived
334 : : : nullptr);
335 : 1186 : pref = &(*pref)->next;
336 : 1186 : break;
337 : 1034 : case REF_ARRAY:
338 : 1034 : pref = &ref->next;
339 : 1034 : ref = ref->next;
340 : 1034 : break;
341 : 0 : default:
342 : 0 : gcc_unreachable ();
343 : 3889 : break;
344 : : }
345 : : }
346 : : }
347 : :
348 : : static void
349 : 1116 : split_expr_at_caf_ref (gfc_expr *expr, gfc_namespace *ns,
350 : : gfc_expr **post_caf_ref_expr, bool for_send)
351 : : {
352 : 1116 : gfc_ref *caf_ref = NULL;
353 : 1116 : gfc_symtree *st;
354 : 1116 : gfc_symbol *base;
355 : 1116 : gfc_typespec *caf_ts;
356 : 1116 : bool created;
357 : :
358 : 1116 : gcc_assert (expr->expr_type == EXPR_VARIABLE);
359 : 1116 : caf_ts = &expr->symtree->n.sym->ts;
360 : 1116 : if (!expr->symtree->n.sym->attr.codimension)
361 : : {
362 : : /* The coarray is in some component. Find it. */
363 : 53 : caf_ref = expr->ref;
364 : 82 : while (caf_ref)
365 : : {
366 : 82 : if (caf_ref->type == REF_ARRAY && caf_ref->u.ar.codimen != 0)
367 : : break;
368 : 29 : if (caf_ref->type == REF_COMPONENT)
369 : 29 : caf_ts = &caf_ref->u.c.component->ts;
370 : 29 : caf_ref = caf_ref->next;
371 : : }
372 : : }
373 : :
374 : 1116 : created = !gfc_get_sym_tree (!caf_ref ? expr->symtree->name : "base", ns, &st,
375 : : false);
376 : 1116 : gcc_assert (created);
377 : 1116 : st->n.sym->attr.flavor = FL_PARAMETER;
378 : 1116 : st->n.sym->attr.dummy = 1;
379 : 1116 : st->n.sym->attr.intent = INTENT_IN;
380 : 1116 : st->n.sym->ts = *caf_ts;
381 : 1116 : st->n.sym->declared_at = expr->where;
382 : :
383 : 1116 : *post_caf_ref_expr = gfc_get_variable_expr (st);
384 : 1116 : (*post_caf_ref_expr)->where = expr->where;
385 : 1116 : base = (*post_caf_ref_expr)->symtree->n.sym;
386 : :
387 : 1116 : if (!caf_ref)
388 : : {
389 : 1063 : (*post_caf_ref_expr)->ref = gfc_get_ref ();
390 : 1063 : *(*post_caf_ref_expr)->ref = *expr->ref;
391 : 1063 : expr->ref = nullptr;
392 : 1063 : move_coarray_ref (&(*post_caf_ref_expr)->ref, expr);
393 : 1063 : fixup_comp_refs (expr);
394 : :
395 : 1063 : if (expr->symtree->n.sym->attr.dimension)
396 : : {
397 : 218 : base->as = gfc_copy_array_spec (expr->symtree->n.sym->as);
398 : 218 : base->as->corank = 0;
399 : 218 : base->attr.dimension = 1;
400 : 218 : base->attr.allocatable = expr->symtree->n.sym->attr.allocatable;
401 : 218 : base->attr.pointer = expr->symtree->n.sym->attr.pointer
402 : 218 : || expr->symtree->n.sym->attr.associate_var;
403 : : }
404 : : }
405 : : else
406 : : {
407 : 53 : (*post_caf_ref_expr)->ref = gfc_get_ref ();
408 : 53 : *(*post_caf_ref_expr)->ref = *caf_ref;
409 : 53 : caf_ref->next = nullptr;
410 : 53 : move_coarray_ref (&(*post_caf_ref_expr)->ref, expr);
411 : 53 : fixup_comp_refs (expr);
412 : :
413 : 53 : if (caf_ref && caf_ref->u.ar.dimen)
414 : : {
415 : 19 : base->as = gfc_copy_array_spec (caf_ref->u.ar.as);
416 : 19 : base->as->corank = 0;
417 : 19 : base->attr.dimension = 1;
418 : 19 : base->attr.allocatable = caf_ref->u.ar.as->type != AS_EXPLICIT;
419 : : }
420 : 53 : base->ts = *caf_ts;
421 : : }
422 : 1116 : (*post_caf_ref_expr)->ts = expr->ts;
423 : 1116 : if (base->ts.type == BT_CHARACTER)
424 : : {
425 : 107 : base->ts.u.cl = gfc_get_charlen ();
426 : 107 : *base->ts.u.cl = *(caf_ts->u.cl);
427 : 107 : base->ts.deferred = 1;
428 : 107 : base->ts.u.cl->length = nullptr;
429 : : }
430 : 1009 : else if (base->ts.type == BT_DERIVED)
431 : 803 : remove_coarray_from_derived_type (base, ns);
432 : 206 : else if (base->ts.type == BT_CLASS)
433 : 30 : convert_coarray_class_to_derived_type (base, ns);
434 : :
435 : 1116 : gfc_expression_rank (*post_caf_ref_expr);
436 : 1116 : if (for_send)
437 : 444 : gfc_expression_rank (expr);
438 : : else
439 : 672 : expr->rank = (*post_caf_ref_expr)->rank;
440 : 1116 : }
441 : :
442 : : static void add_caf_get_from_remote (gfc_expr *e);
443 : :
444 : : static gfc_component *
445 : 202 : find_comp (gfc_symbol *type, gfc_expr *e, int *cnt, const bool is_var)
446 : : {
447 : 202 : char *temp_name = nullptr;
448 : 202 : gfc_component *comp = type->components;
449 : :
450 : : /* For variables:
451 : : - look up same name or create new
452 : : all else:
453 : : - create unique new
454 : : */
455 : 202 : if (is_var)
456 : : {
457 : 202 : ++(*cnt);
458 : 202 : free (temp_name);
459 : 202 : temp_name = xasprintf ("caf_temp_%s_%d", e->symtree->name, *cnt);
460 : 852 : while (comp && strcmp (comp->name, temp_name) != 0)
461 : 448 : comp = comp->next;
462 : 202 : if (!comp)
463 : : {
464 : 198 : const bool added = gfc_add_component (type, temp_name, &comp);
465 : 198 : gcc_assert (added);
466 : : }
467 : : }
468 : : else
469 : : {
470 : : int r = -1;
471 : : /* Components are always appended, i.e., when searching to add a unique
472 : : one just iterating forward is sufficient. */
473 : 0 : do
474 : : {
475 : 0 : ++(*cnt);
476 : 0 : free (temp_name);
477 : 0 : temp_name = xasprintf ("caf_temp_%s_%d", e->symtree->name, *cnt);
478 : :
479 : 0 : while (comp && (r = strcmp (comp->name, temp_name)) <= 0)
480 : 0 : comp = comp->next;
481 : : }
482 : 0 : while (comp && r <= 0);
483 : 0 : {
484 : 0 : const bool added = gfc_add_component (type, temp_name, &comp);
485 : 0 : gcc_assert (added);
486 : : }
487 : : }
488 : :
489 : 202 : comp->loc = e->where;
490 : 202 : comp->ts = e->ts;
491 : 202 : free (temp_name);
492 : :
493 : 202 : return comp;
494 : : }
495 : :
496 : : static void
497 : 202 : check_add_new_comp_handle_array (gfc_expr *e, gfc_symbol *type,
498 : : gfc_symbol *add_data)
499 : : {
500 : 202 : gfc_component *comp;
501 : 202 : int cnt = -1;
502 : 202 : gfc_symtree *caller_image;
503 : 202 : gfc_code *pre_code = caf_accessor_prepend;
504 : 202 : bool static_array_or_scalar = true;
505 : 202 : symbol_attribute e_attr = gfc_expr_attr (e);
506 : :
507 : 202 : gfc_free_shape (&e->shape, e->rank);
508 : :
509 : : /* When already code to prepend into the accessor exists, go to
510 : : the end of the chain. */
511 : 404 : for (; pre_code && pre_code->next; pre_code = pre_code->next)
512 : : ;
513 : :
514 : 202 : comp = find_comp (type, e, &cnt,
515 : 202 : e->symtree->n.sym->attr.flavor == FL_VARIABLE
516 : 202 : || e->symtree->n.sym->attr.flavor == FL_PARAMETER);
517 : :
518 : 202 : if (e->expr_type == EXPR_FUNCTION
519 : 202 : || (e->expr_type == EXPR_VARIABLE && e_attr.dimension
520 : 202 : && e_attr.allocatable))
521 : : {
522 : 1 : gfc_code *code;
523 : 1 : gfc_symtree *st;
524 : 1 : const bool created
525 : 1 : = !gfc_get_sym_tree (comp->name, gfc_current_ns, &st, false, &e->where);
526 : 1 : gcc_assert (created);
527 : :
528 : 1 : st->n.sym->ts = e->ts;
529 : 1 : gfc_set_sym_referenced (st->n.sym);
530 : 1 : code = gfc_get_code (EXEC_ASSIGN);
531 : 1 : code->loc = e->where;
532 : 1 : code->expr1 = gfc_get_variable_expr (st);
533 : 1 : code->expr2 = XCNEW (gfc_expr);
534 : 1 : *(code->expr2) = *e;
535 : 1 : code->next = *current_code;
536 : 1 : *current_code = code;
537 : :
538 : 1 : if (e_attr.dimension)
539 : : {
540 : 1 : gfc_array_spec *as = get_arrayspec_from_expr (e);
541 : 1 : static_array_or_scalar = gfc_is_compile_time_shape (as);
542 : :
543 : 1 : comp->attr.dimension = 1;
544 : 1 : st->n.sym->attr.dimension = 1;
545 : 1 : st->n.sym->as = as;
546 : :
547 : 1 : if (!static_array_or_scalar)
548 : : {
549 : 1 : comp->attr.allocatable = 1;
550 : 1 : st->n.sym->attr.allocatable = 1;
551 : : }
552 : 1 : code->expr1->rank = as->rank;
553 : 1 : gfc_add_full_array_ref (code->expr1, gfc_copy_array_spec (as));
554 : 1 : comp->as = gfc_copy_array_spec (as);
555 : : }
556 : :
557 : 1 : gfc_expression_rank (code->expr1);
558 : 1 : comp->initializer = gfc_get_variable_expr (st);
559 : 1 : gfc_commit_symbol (st->n.sym);
560 : 1 : }
561 : : else
562 : : {
563 : 201 : comp->initializer = gfc_copy_expr (e);
564 : 201 : if (e_attr.dimension)
565 : : {
566 : 24 : comp->attr.dimension = 1;
567 : 24 : comp->as = get_arrayspec_from_expr (e);
568 : : }
569 : : }
570 : 202 : comp->initializer->where = e->where;
571 : 202 : comp->attr.access = ACCESS_PRIVATE;
572 : 202 : memset (e, 0, sizeof (gfc_expr));
573 : 202 : e->ts = comp->initializer->ts;
574 : 202 : e->expr_type = EXPR_VARIABLE;
575 : 202 : e->where = comp->initializer->where;
576 : :
577 : 202 : if (comp->as && comp->as->rank)
578 : : {
579 : 25 : if (static_array_or_scalar)
580 : : {
581 : 24 : e->ref = gfc_get_ref ();
582 : 24 : e->ref->type = REF_ARRAY;
583 : 24 : e->ref->u.ar.as = gfc_copy_array_spec (add_data->as);
584 : 24 : e->ref->u.ar.codimen = 1;
585 : 24 : e->ref->u.ar.dimen_type[0] = DIMEN_THIS_IMAGE;
586 : : }
587 : : else
588 : : {
589 : 1 : gfc_code *c;
590 : 1 : gfc_symtree *lv, *ad;
591 : 1 : bool created = !gfc_get_sym_tree (comp->name, add_data->ns, &lv,
592 : 1 : false, &e->where);
593 : 1 : gcc_assert (created);
594 : :
595 : 1 : lv->n.sym->ts = e->ts;
596 : 1 : lv->n.sym->attr.dimension = 1;
597 : 1 : lv->n.sym->attr.allocatable = 1;
598 : 1 : lv->n.sym->attr.flavor = FL_VARIABLE;
599 : 1 : lv->n.sym->as = gfc_copy_array_spec (comp->as);
600 : 1 : gfc_set_sym_referenced (lv->n.sym);
601 : 1 : gfc_commit_symbol (lv->n.sym);
602 : 1 : c = gfc_get_code (EXEC_ASSIGN);
603 : 1 : c->loc = e->where;
604 : 1 : c->expr1 = gfc_get_variable_expr (lv);
605 : 1 : c->expr1->where = e->where;
606 : :
607 : 1 : created = !gfc_find_sym_tree (add_data->name, add_data->ns, 0, &ad);
608 : 1 : gcc_assert (created);
609 : 1 : c->expr2 = gfc_get_variable_expr (ad);
610 : 1 : c->expr2->where = e->where;
611 : 1 : c->expr2->ts = comp->initializer->ts;
612 : 1 : c->expr2->ref = gfc_get_ref ();
613 : 1 : c->expr2->ref->type = REF_ARRAY;
614 : 1 : c->expr2->ref->u.ar.as = gfc_copy_array_spec (add_data->as);
615 : 1 : c->expr2->ref->u.ar.codimen = 1;
616 : 1 : c->expr2->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT;
617 : 1 : caller_image
618 : 1 : = gfc_find_symtree_in_proc ("caller_image", add_data->ns);
619 : 1 : gcc_assert (caller_image);
620 : 1 : c->expr2->ref->u.ar.start[0] = gfc_get_variable_expr (caller_image);
621 : 1 : c->expr2->ref->u.ar.start[0]->where = e->where;
622 : 1 : created = gfc_find_component (ad->n.sym->ts.u.derived, comp->name,
623 : : false, true, &c->expr2->ref->next)
624 : : != nullptr;
625 : 1 : gcc_assert (created);
626 : 1 : c->expr2->rank = comp->as->rank;
627 : 1 : gfc_add_full_array_ref (c->expr2, gfc_copy_array_spec (comp->as));
628 : 1 : gfc_set_sym_referenced (ad->n.sym);
629 : 1 : gfc_commit_symbol (ad->n.sym);
630 : 1 : if (pre_code)
631 : 0 : pre_code->next = c;
632 : : else
633 : 1 : caf_accessor_prepend = c;
634 : 1 : add_caf_get_from_remote (c->expr2);
635 : :
636 : 1 : e->symtree = lv;
637 : 1 : gfc_expression_rank (e);
638 : 1 : gfc_add_full_array_ref (e, gfc_copy_array_spec (comp->as));
639 : : }
640 : : }
641 : : else
642 : : {
643 : 177 : e->ref = gfc_get_ref ();
644 : 177 : e->ref->type = REF_ARRAY;
645 : 177 : e->ref->u.ar.as = gfc_copy_array_spec (add_data->as);
646 : 177 : e->ref->u.ar.codimen = 1;
647 : 177 : e->ref->u.ar.dimen_type[0] = DIMEN_THIS_IMAGE;
648 : : }
649 : :
650 : 202 : if (static_array_or_scalar)
651 : : {
652 : 201 : const bool created
653 : 201 : = gfc_find_component (add_data->ts.u.derived, comp->name, false, true,
654 : 201 : &e->ref);
655 : 201 : gcc_assert (created);
656 : 201 : e->symtree = gfc_find_symtree (add_data->ns->sym_root, add_data->name);
657 : 201 : gcc_assert (e->symtree);
658 : 201 : if (IS_CLASS_ARRAY (e->ref->u.c.component)
659 : 201 : || e->ref->u.c.component->attr.dimension)
660 : : {
661 : 24 : gfc_add_full_array_ref (e, e->ref->u.c.component->ts.type == BT_CLASS
662 : 0 : ? CLASS_DATA (e->ref->u.c.component)->as
663 : : : e->ref->u.c.component->as);
664 : 48 : e->ref->next->u.ar.dimen
665 : 24 : = e->ref->u.c.component->ts.type == BT_CLASS
666 : 24 : ? CLASS_DATA (e->ref->u.c.component)->as->rank
667 : 24 : : e->ref->u.c.component->as->rank;
668 : : }
669 : 201 : gfc_expression_rank (e);
670 : : }
671 : 202 : }
672 : :
673 : : static void
674 : 4207 : check_add_new_component (gfc_symbol *type, gfc_expr *e, gfc_symbol *add_data)
675 : : {
676 : 4245 : if (e)
677 : : {
678 : 920 : switch (e->expr_type)
679 : : {
680 : : case EXPR_CONSTANT:
681 : : case EXPR_NULL:
682 : : break;
683 : 40 : case EXPR_OP:
684 : 40 : check_add_new_component (type, e->value.op.op1, add_data);
685 : 40 : if (e->value.op.op2)
686 : : check_add_new_component (type, e->value.op.op2, add_data);
687 : : break;
688 : 0 : case EXPR_COMPCALL:
689 : 0 : for (gfc_actual_arglist *actual = e->value.compcall.actual; actual;
690 : 0 : actual = actual->next)
691 : 0 : check_add_new_component (type, actual->expr, add_data);
692 : : break;
693 : 60 : case EXPR_FUNCTION:
694 : 60 : if (!e->symtree->n.sym->attr.pure
695 : 60 : && !e->symtree->n.sym->attr.elemental)
696 : : /* Treat non-pure/non-elemental functions. */
697 : 0 : check_add_new_comp_handle_array (e, type, add_data);
698 : : else
699 : 120 : for (gfc_actual_arglist *actual = e->value.function.actual; actual;
700 : 60 : actual = actual->next)
701 : 60 : check_add_new_component (type, actual->expr, add_data);
702 : : break;
703 : 202 : case EXPR_VARIABLE:
704 : 202 : check_add_new_comp_handle_array (e, type, add_data);
705 : 202 : break;
706 : 0 : case EXPR_ARRAY:
707 : 0 : case EXPR_PPC:
708 : 0 : case EXPR_STRUCTURE:
709 : 0 : case EXPR_SUBSTRING:
710 : 0 : gcc_unreachable ();
711 : : default:;
712 : : }
713 : : }
714 : 4207 : }
715 : :
716 : : static gfc_symbol *
717 : 1116 : create_caf_add_data_parameter_type (gfc_expr *expr, gfc_namespace *ns,
718 : : gfc_symbol *add_data)
719 : : {
720 : 1116 : static int type_cnt = 0;
721 : 1116 : char tname[GFC_MAX_SYMBOL_LEN + 1];
722 : 1116 : char *name;
723 : 1116 : gfc_symbol *type;
724 : :
725 : 1116 : gcc_assert (expr->expr_type == EXPR_VARIABLE);
726 : :
727 : 1116 : strcpy (tname, expr->symtree->name);
728 : 1116 : name = xasprintf ("@_caf_add_data_t_%s_%d", tname, ++type_cnt);
729 : 1116 : gfc_get_symbol (name, ns, &type);
730 : :
731 : 1116 : type->attr.flavor = FL_DERIVED;
732 : 1116 : add_data->ts.u.derived = type;
733 : 1116 : add_data->attr.codimension = 1;
734 : 1116 : add_data->as = gfc_get_array_spec ();
735 : 1116 : add_data->as->corank = 1;
736 : 1116 : add_data->as->type = AS_EXPLICIT;
737 : 1116 : add_data->as->cotype = AS_DEFERRED;
738 : 1116 : add_data->as->lower[0]
739 : 1116 : = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
740 : : &expr->where);
741 : 1116 : mpz_init (add_data->as->lower[0]->value.integer);
742 : 1116 : mpz_set_si (add_data->as->lower[0]->value.integer, 1);
743 : :
744 : 3186 : for (gfc_ref *ref = expr->ref; ref; ref = ref->next)
745 : : {
746 : 2070 : if (ref->type == REF_ARRAY)
747 : : {
748 : : gfc_array_ref *ar = &ref->u.ar;
749 : 2282 : for (int i = 0; i < ar->dimen; ++i)
750 : : {
751 : 1369 : check_add_new_component (type, ar->start[i], add_data);
752 : 1369 : check_add_new_component (type, ar->end[i], add_data);
753 : 1369 : check_add_new_component (type, ar->stride[i], add_data);
754 : : }
755 : : }
756 : : }
757 : :
758 : 1116 : type->declared_at = expr->where;
759 : 1116 : gfc_set_sym_referenced (type);
760 : 1116 : gfc_commit_symbol (type);
761 : 1116 : return type;
762 : : }
763 : :
764 : : static void
765 : 1116 : remove_caf_ref (gfc_expr *expr, const bool conv_to_this_image_cafref = false)
766 : : {
767 : 1116 : gfc_ref *ref = expr->ref;
768 : 3186 : while (ref && (ref->type != REF_ARRAY || ref->u.ar.codimen == 0))
769 : : {
770 : 2070 : ref = ref->next;
771 : : }
772 : 1116 : if (ref && ref->type == REF_ARRAY && ref->u.ar.codimen != 0)
773 : : {
774 : 0 : if (ref->u.ar.dimen != 0)
775 : : {
776 : 0 : ref->u.ar.codimen = 0;
777 : 0 : ref = ref->next;
778 : : }
779 : : else
780 : : {
781 : 0 : if (conv_to_this_image_cafref)
782 : : {
783 : 0 : for (int i = ref->u.ar.dimen;
784 : 0 : i < ref->u.ar.dimen + ref->u.ar.codimen; ++i)
785 : 0 : ref->u.ar.dimen_type[i] = DIMEN_THIS_IMAGE;
786 : : }
787 : : else
788 : : {
789 : 0 : expr->ref = ref->next;
790 : 0 : ref->next = NULL;
791 : 0 : gfc_free_ref_list (ref);
792 : 0 : ref = expr->ref;
793 : : }
794 : : }
795 : : }
796 : 1116 : fixup_comp_refs (expr);
797 : 1116 : }
798 : :
799 : : static gfc_expr *
800 : 672 : create_get_callback (gfc_expr *expr)
801 : : {
802 : 672 : gfc_namespace *ns;
803 : 672 : gfc_symbol *extproc, *proc, *buffer, *free_buffer, *base, *get_data,
804 : : *old_buffer_data, *caller_image;
805 : 672 : char tname[GFC_MAX_SYMBOL_LEN + 1];
806 : 672 : char *name;
807 : 672 : const char *mname;
808 : 672 : gfc_expr *cb, *post_caf_ref_expr;
809 : 672 : gfc_code *code;
810 : 672 : int expr_rank = expr->rank;
811 : 672 : gfc_code *backup_caf_accessor_prepend = caf_accessor_prepend;
812 : 672 : caf_accessor_prepend = nullptr;
813 : :
814 : : /* Find the top-level namespace. */
815 : 750 : for (ns = gfc_current_ns; ns->parent; ns = ns->parent)
816 : : ;
817 : :
818 : 672 : if (expr->expr_type == EXPR_VARIABLE)
819 : 672 : strcpy (tname, expr->symtree->name);
820 : : else
821 : 0 : strcpy (tname, "dummy");
822 : 672 : if (expr->symtree->n.sym->module)
823 : 3 : mname = expr->symtree->n.sym->module;
824 : : else
825 : : mname = "main";
826 : 672 : name = xasprintf ("_caf_accessor_%s_%s_%d", mname, tname, ++caf_sym_cnt);
827 : 672 : gfc_get_symbol (name, ns, &extproc);
828 : 672 : extproc->declared_at = expr->where;
829 : 672 : gfc_set_sym_referenced (extproc);
830 : 672 : ++extproc->refs;
831 : 672 : gfc_commit_symbol (extproc);
832 : :
833 : : /* Set up namespace. */
834 : 672 : gfc_namespace *sub_ns = gfc_get_namespace (ns, 0);
835 : 672 : sub_ns->sibling = ns->contained;
836 : 672 : ns->contained = sub_ns;
837 : 672 : sub_ns->resolved = 1;
838 : : /* Set up procedure symbol. */
839 : 672 : gfc_find_symbol (name, sub_ns, 1, &proc);
840 : 672 : sub_ns->proc_name = proc;
841 : 672 : proc->attr.if_source = IFSRC_DECL;
842 : 672 : proc->attr.access = ACCESS_PUBLIC;
843 : 672 : gfc_add_subroutine (&proc->attr, name, NULL);
844 : 672 : proc->attr.host_assoc = 1;
845 : 672 : proc->attr.always_explicit = 1;
846 : 672 : ++proc->refs;
847 : 672 : proc->declared_at = expr->where;
848 : 672 : gfc_commit_symbol (proc);
849 : 672 : free (name);
850 : :
851 : 672 : split_expr_at_caf_ref (expr, sub_ns, &post_caf_ref_expr, false);
852 : :
853 : 672 : if (ns->proc_name->attr.flavor == FL_MODULE)
854 : 1 : proc->module = ns->proc_name->name;
855 : 672 : gfc_set_sym_referenced (proc);
856 : : /* Set up formal arguments. */
857 : 672 : gfc_formal_arglist **argptr = &proc->formal;
858 : : #define ADD_ARG(name, nsym, stype, skind, sintent) \
859 : : gfc_get_symbol (name, sub_ns, &nsym); \
860 : : nsym->ts.type = stype; \
861 : : nsym->ts.kind = skind; \
862 : : nsym->attr.flavor = FL_PARAMETER; \
863 : : nsym->attr.dummy = 1; \
864 : : nsym->attr.intent = sintent; \
865 : : nsym->declared_at = expr->where; \
866 : : gfc_set_sym_referenced (nsym); \
867 : : *argptr = gfc_get_formal_arglist (); \
868 : : (*argptr)->sym = nsym; \
869 : : argptr = &(*argptr)->next
870 : :
871 : 672 : name = xasprintf ("add_data_%s_%s_%d", mname, tname, caf_sym_cnt);
872 : 672 : ADD_ARG (name, get_data, BT_DERIVED, 0, INTENT_IN);
873 : 672 : gfc_commit_symbol (get_data);
874 : 672 : free (name);
875 : :
876 : 672 : ADD_ARG ("caller_image", caller_image, BT_INTEGER, gfc_default_integer_kind,
877 : : INTENT_IN);
878 : 672 : gfc_commit_symbol (caller_image);
879 : :
880 : 672 : ADD_ARG ("buffer", buffer, expr->ts.type, expr->ts.kind, INTENT_INOUT);
881 : 672 : buffer->ts = expr->ts;
882 : 672 : if (expr_rank)
883 : : {
884 : 402 : buffer->as = gfc_get_array_spec ();
885 : 402 : buffer->as->rank = expr_rank;
886 : 402 : if (expr->shape)
887 : : {
888 : 227 : buffer->as->type = AS_EXPLICIT;
889 : 566 : for (int d = 0; d < expr_rank; ++d)
890 : : {
891 : 339 : buffer->as->lower[d]
892 : 339 : = gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind,
893 : : &gfc_current_locus);
894 : 339 : gfc_mpz_set_hwi (buffer->as->lower[d]->value.integer, 1);
895 : 339 : buffer->as->upper[d]
896 : 339 : = gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind,
897 : : &gfc_current_locus);
898 : 339 : gfc_mpz_set_hwi (buffer->as->upper[d]->value.integer,
899 : 339 : gfc_mpz_get_hwi (expr->shape[d]));
900 : : }
901 : 227 : buffer->attr.allocatable = 1;
902 : : }
903 : : else
904 : : {
905 : 175 : buffer->as->type = AS_DEFERRED;
906 : 175 : buffer->attr.allocatable = 1;
907 : : }
908 : 402 : buffer->attr.dimension = 1;
909 : : }
910 : : else
911 : 270 : buffer->attr.pointer = 1;
912 : 672 : if (buffer->ts.type == BT_CHARACTER)
913 : : {
914 : 49 : buffer->ts.u.cl = gfc_get_charlen ();
915 : 49 : *buffer->ts.u.cl = *expr->ts.u.cl;
916 : 49 : buffer->ts.u.cl->length = gfc_copy_expr (expr->ts.u.cl->length);
917 : : }
918 : 672 : gfc_commit_symbol (buffer);
919 : :
920 : 672 : ADD_ARG ("free_buffer", free_buffer, BT_LOGICAL, gfc_default_logical_kind,
921 : : INTENT_OUT);
922 : 672 : gfc_commit_symbol (free_buffer);
923 : :
924 : : // ADD_ARG (expr->symtree->name, base, BT_VOID, INTENT_IN);
925 : 672 : base = post_caf_ref_expr->symtree->n.sym;
926 : 672 : gfc_set_sym_referenced (base);
927 : 672 : gfc_commit_symbol (base);
928 : 672 : *argptr = gfc_get_formal_arglist ();
929 : 672 : (*argptr)->sym = base;
930 : 672 : argptr = &(*argptr)->next;
931 : 672 : gfc_commit_symbol (base);
932 : : #undef ADD_ARG
933 : :
934 : : /* Set up code. */
935 : 672 : if (expr->rank != 0)
936 : : {
937 : : /* Code: old_buffer_ptr = C_LOC (buffer); */
938 : 402 : code = sub_ns->code = gfc_get_code (EXEC_ASSIGN);
939 : 402 : gfc_get_symbol ("old_buffer_data", sub_ns, &old_buffer_data);
940 : 402 : old_buffer_data->ts.type = BT_VOID;
941 : 402 : old_buffer_data->attr.flavor = FL_VARIABLE;
942 : 402 : old_buffer_data->declared_at = expr->where;
943 : 402 : gfc_set_sym_referenced (old_buffer_data);
944 : 402 : gfc_commit_symbol (old_buffer_data);
945 : 402 : code->loc = expr->where;
946 : 402 : code->expr1 = gfc_lval_expr_from_sym (old_buffer_data);
947 : 402 : code->expr2 = gfc_build_intrinsic_call (ns, GFC_ISYM_C_LOC, "C_LOC",
948 : : gfc_current_locus, 1,
949 : : gfc_lval_expr_from_sym (buffer));
950 : 402 : code->next = gfc_get_code (EXEC_ASSIGN);
951 : 402 : code = code->next;
952 : : }
953 : : else
954 : 270 : code = sub_ns->code = gfc_get_code (EXEC_POINTER_ASSIGN);
955 : :
956 : : /* Code: buffer = expr; */
957 : 672 : code->loc = expr->where;
958 : 672 : code->expr1 = gfc_lval_expr_from_sym (buffer);
959 : 672 : code->expr2 = post_caf_ref_expr;
960 : 672 : remove_caf_ref (post_caf_ref_expr);
961 : 672 : get_data->ts.u.derived
962 : 672 : = create_caf_add_data_parameter_type (code->expr2, ns, get_data);
963 : 672 : if (code->expr2->rank == 0 && code->expr2->ts.type != BT_CHARACTER)
964 : 237 : code->expr2 = gfc_build_intrinsic_call (ns, GFC_ISYM_C_LOC, "C_LOC",
965 : : gfc_current_locus, 1, code->expr2);
966 : :
967 : : /* Code: *free_buffer = old_buffer_ptr /= C_LOC (buffer); for rank != 0 or
968 : : * *free_buffer = 0; for rank == 0. */
969 : 672 : code->next = gfc_get_code (EXEC_ASSIGN);
970 : 672 : code = code->next;
971 : 672 : code->loc = expr->where;
972 : 672 : code->expr1 = gfc_lval_expr_from_sym (free_buffer);
973 : 672 : if (expr->rank != 0)
974 : : {
975 : 402 : code->expr2 = gfc_get_operator_expr (
976 : : &gfc_current_locus, INTRINSIC_NE_OS,
977 : : gfc_lval_expr_from_sym (old_buffer_data),
978 : : gfc_build_intrinsic_call (ns, GFC_ISYM_C_LOC, "C_LOC",
979 : : gfc_current_locus, 1,
980 : : gfc_lval_expr_from_sym (buffer)));
981 : 402 : code->expr2->ts.type = BT_LOGICAL;
982 : 402 : code->expr2->ts.kind = gfc_default_logical_kind;
983 : : }
984 : : else
985 : : {
986 : 270 : code->expr2 = gfc_get_logical_expr (gfc_default_logical_kind,
987 : : &gfc_current_locus, false);
988 : : }
989 : :
990 : 672 : cb = gfc_lval_expr_from_sym (extproc);
991 : 672 : cb->ts.interface = extproc;
992 : :
993 : 672 : if (caf_accessor_prepend)
994 : : {
995 : : gfc_code *c = caf_accessor_prepend;
996 : : /* Find last in chain. */
997 : 1 : for (; c->next; c = c->next)
998 : : ;
999 : 1 : c->next = sub_ns->code;
1000 : 1 : sub_ns->code = caf_accessor_prepend;
1001 : : }
1002 : 672 : caf_accessor_prepend = backup_caf_accessor_prepend;
1003 : 672 : return cb;
1004 : : }
1005 : :
1006 : : void
1007 : 730 : add_caf_get_from_remote (gfc_expr *e)
1008 : : {
1009 : 730 : gfc_expr *wrapper, *tmp_expr, *get_from_remote_expr,
1010 : : *get_from_remote_hash_expr;
1011 : 730 : gfc_ref *ref;
1012 : 730 : int n;
1013 : :
1014 : 773 : for (ref = e->ref; ref; ref = ref->next)
1015 : 773 : if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
1016 : : break;
1017 : 730 : if (ref == NULL)
1018 : : return;
1019 : :
1020 : 1349 : for (n = ref->u.ar.dimen; n < ref->u.ar.dimen + ref->u.ar.codimen; n++)
1021 : 767 : if (ref->u.ar.dimen_type[n] != DIMEN_ELEMENT)
1022 : : return;
1023 : :
1024 : 582 : tmp_expr = XCNEW (gfc_expr);
1025 : 582 : *tmp_expr = *e;
1026 : 582 : get_from_remote_expr = create_get_callback (tmp_expr);
1027 : 582 : get_from_remote_hash_expr = gfc_get_expr ();
1028 : 582 : get_from_remote_hash_expr->expr_type = EXPR_CONSTANT;
1029 : 582 : get_from_remote_hash_expr->ts.type = BT_INTEGER;
1030 : 582 : get_from_remote_hash_expr->ts.kind = gfc_default_integer_kind;
1031 : 582 : get_from_remote_hash_expr->where = tmp_expr->where;
1032 : 582 : mpz_init_set_ui (get_from_remote_hash_expr->value.integer,
1033 : 582 : gfc_hash_value (get_from_remote_expr->symtree->n.sym));
1034 : 582 : wrapper = gfc_build_intrinsic_call (gfc_current_ns, GFC_ISYM_CAF_GET,
1035 : : "caf_get", tmp_expr->where, 3, tmp_expr,
1036 : : get_from_remote_hash_expr,
1037 : : get_from_remote_expr);
1038 : 582 : gfc_add_caf_accessor (get_from_remote_hash_expr, get_from_remote_expr);
1039 : 582 : wrapper->ts = e->ts;
1040 : 582 : wrapper->rank = e->rank;
1041 : 582 : wrapper->corank = e->corank;
1042 : 582 : if (e->rank)
1043 : 358 : wrapper->shape = gfc_copy_shape (e->shape, e->rank);
1044 : 582 : *e = *wrapper;
1045 : 582 : free (wrapper);
1046 : : }
1047 : :
1048 : : static gfc_expr *
1049 : 66 : create_allocated_callback (gfc_expr *expr)
1050 : : {
1051 : 66 : gfc_namespace *ns;
1052 : 66 : gfc_symbol *extproc, *proc, *result, *base, *add_data, *caller_image;
1053 : 66 : char tname[GFC_MAX_SYMBOL_LEN + 1];
1054 : 66 : char *name;
1055 : 66 : const char *mname;
1056 : 66 : gfc_expr *cb, *post_caf_ref_expr;
1057 : 66 : gfc_code *code;
1058 : 66 : gfc_code *backup_caf_accessor_prepend = caf_accessor_prepend;
1059 : 66 : caf_accessor_prepend = nullptr;
1060 : 66 : gfc_expr swp;
1061 : :
1062 : : /* Find the top-level namespace. */
1063 : 66 : for (ns = gfc_current_ns; ns->parent; ns = ns->parent)
1064 : : ;
1065 : :
1066 : 66 : if (expr->value.function.actual->expr->expr_type == EXPR_VARIABLE)
1067 : 66 : strcpy (tname, expr->value.function.actual->expr->symtree->name);
1068 : : else
1069 : 0 : strcpy (tname, "dummy");
1070 : 66 : if (expr->value.function.actual->expr->symtree->n.sym->module)
1071 : 0 : mname = expr->value.function.actual->expr->symtree->n.sym->module;
1072 : : else
1073 : : mname = "main";
1074 : 66 : name = xasprintf ("_caf_present_%s_%s_%d", mname, tname, ++caf_sym_cnt);
1075 : 66 : gfc_get_symbol (name, ns, &extproc);
1076 : 66 : extproc->declared_at = expr->where;
1077 : 66 : gfc_set_sym_referenced (extproc);
1078 : 66 : ++extproc->refs;
1079 : 66 : gfc_commit_symbol (extproc);
1080 : :
1081 : : /* Set up namespace. */
1082 : 66 : gfc_namespace *sub_ns = gfc_get_namespace (ns, 0);
1083 : 66 : sub_ns->sibling = ns->contained;
1084 : 66 : ns->contained = sub_ns;
1085 : 66 : sub_ns->resolved = 1;
1086 : : /* Set up procedure symbol. */
1087 : 66 : gfc_find_symbol (name, sub_ns, 1, &proc);
1088 : 66 : sub_ns->proc_name = proc;
1089 : 66 : proc->attr.if_source = IFSRC_DECL;
1090 : 66 : proc->attr.access = ACCESS_PUBLIC;
1091 : 66 : gfc_add_subroutine (&proc->attr, name, NULL);
1092 : 66 : proc->attr.host_assoc = 1;
1093 : 66 : proc->attr.always_explicit = 1;
1094 : 66 : proc->declared_at = expr->where;
1095 : 66 : ++proc->refs;
1096 : 66 : gfc_commit_symbol (proc);
1097 : 66 : free (name);
1098 : :
1099 : 66 : split_expr_at_caf_ref (expr->value.function.actual->expr, sub_ns,
1100 : : &post_caf_ref_expr, true);
1101 : :
1102 : 66 : if (ns->proc_name->attr.flavor == FL_MODULE)
1103 : 0 : proc->module = ns->proc_name->name;
1104 : 66 : gfc_set_sym_referenced (proc);
1105 : : /* Set up formal arguments. */
1106 : 66 : gfc_formal_arglist **argptr = &proc->formal;
1107 : : #define ADD_ARG(name, nsym, stype, skind, sintent) \
1108 : : gfc_get_symbol (name, sub_ns, &nsym); \
1109 : : nsym->ts.type = stype; \
1110 : : nsym->ts.kind = skind; \
1111 : : nsym->attr.flavor = FL_PARAMETER; \
1112 : : nsym->attr.dummy = 1; \
1113 : : nsym->attr.intent = sintent; \
1114 : : nsym->declared_at = expr->where; \
1115 : : gfc_set_sym_referenced (nsym); \
1116 : : *argptr = gfc_get_formal_arglist (); \
1117 : : (*argptr)->sym = nsym; \
1118 : : argptr = &(*argptr)->next
1119 : :
1120 : 66 : name = xasprintf ("add_data_%s_%s_%d", mname, tname, ++caf_sym_cnt);
1121 : 66 : ADD_ARG (name, add_data, BT_DERIVED, 0, INTENT_IN);
1122 : 66 : gfc_commit_symbol (add_data);
1123 : 66 : free (name);
1124 : 66 : ADD_ARG ("caller_image", caller_image, BT_INTEGER, gfc_default_integer_kind,
1125 : : INTENT_IN);
1126 : 66 : gfc_commit_symbol (caller_image);
1127 : :
1128 : 66 : ADD_ARG ("result", result, BT_LOGICAL, gfc_default_logical_kind, INTENT_OUT);
1129 : 66 : gfc_commit_symbol (result);
1130 : :
1131 : : // ADD_ARG (expr->symtree->name, base, BT_VOID, INTENT_IN);
1132 : 66 : base = post_caf_ref_expr->symtree->n.sym;
1133 : 66 : gfc_set_sym_referenced (base);
1134 : 66 : gfc_commit_symbol (base);
1135 : 66 : *argptr = gfc_get_formal_arglist ();
1136 : 66 : (*argptr)->sym = base;
1137 : 66 : argptr = &(*argptr)->next;
1138 : 66 : gfc_commit_symbol (base);
1139 : : #undef ADD_ARG
1140 : :
1141 : : /* Set up code. */
1142 : : /* Code: result = post_caf_ref_expr; */
1143 : 66 : code = sub_ns->code = gfc_get_code (EXEC_ASSIGN);
1144 : 66 : code->loc = expr->where;
1145 : 66 : code->expr1 = gfc_lval_expr_from_sym (result);
1146 : 66 : swp = *expr;
1147 : 66 : *expr = *swp.value.function.actual->expr;
1148 : 66 : swp.value.function.actual->expr = nullptr;
1149 : 66 : code->expr2 = gfc_copy_expr (&swp);
1150 : 66 : code->expr2->value.function.actual->expr = post_caf_ref_expr;
1151 : :
1152 : 66 : remove_caf_ref (code->expr2->value.function.actual->expr, true);
1153 : 66 : add_data->ts.u.derived
1154 : 66 : = create_caf_add_data_parameter_type (post_caf_ref_expr, ns, add_data);
1155 : :
1156 : 66 : cb = gfc_lval_expr_from_sym (extproc);
1157 : 66 : cb->ts.interface = extproc;
1158 : :
1159 : 66 : if (caf_accessor_prepend)
1160 : : {
1161 : : gfc_code *c = caf_accessor_prepend;
1162 : : /* Find last in chain. */
1163 : 0 : for (; c->next; c = c->next)
1164 : : ;
1165 : 0 : c->next = sub_ns->code;
1166 : 0 : sub_ns->code = caf_accessor_prepend;
1167 : : }
1168 : 66 : caf_accessor_prepend = backup_caf_accessor_prepend;
1169 : 66 : return cb;
1170 : : }
1171 : :
1172 : : static void
1173 : 66 : rewrite_caf_allocated (gfc_expr **e)
1174 : : {
1175 : 66 : gfc_expr *present_fn_expr, *present_hash_expr, *wrapper;
1176 : :
1177 : 66 : present_fn_expr = create_allocated_callback (*e);
1178 : :
1179 : 66 : present_hash_expr = gfc_get_expr ();
1180 : 66 : present_hash_expr->expr_type = EXPR_CONSTANT;
1181 : 66 : present_hash_expr->ts.type = BT_INTEGER;
1182 : 66 : present_hash_expr->ts.kind = gfc_default_integer_kind;
1183 : 66 : present_hash_expr->where = (*e)->where;
1184 : 66 : mpz_init_set_ui (present_hash_expr->value.integer,
1185 : 66 : gfc_hash_value (present_fn_expr->symtree->n.sym));
1186 : 66 : wrapper
1187 : 66 : = gfc_build_intrinsic_call (gfc_current_ns,
1188 : : GFC_ISYM_CAF_IS_PRESENT_ON_REMOTE,
1189 : : "caf_is_present_on_remote", (*e)->where, 3, *e,
1190 : : present_hash_expr, present_fn_expr);
1191 : 66 : gfc_add_caf_accessor (present_hash_expr, present_fn_expr);
1192 : 66 : *e = wrapper;
1193 : 66 : }
1194 : :
1195 : : static gfc_expr *
1196 : 378 : create_send_callback (gfc_expr *expr, gfc_expr *rhs)
1197 : : {
1198 : 378 : gfc_namespace *ns;
1199 : 378 : gfc_symbol *extproc, *proc, *buffer, *base, *send_data, *caller_image;
1200 : 378 : char tname[GFC_MAX_SYMBOL_LEN + 1];
1201 : 378 : char *name;
1202 : 378 : const char *mname;
1203 : 378 : gfc_expr *cb, *post_caf_ref_expr;
1204 : 378 : gfc_code *code;
1205 : 378 : gfc_code *backup_caf_accessor_prepend = caf_accessor_prepend;
1206 : 378 : caf_accessor_prepend = nullptr;
1207 : :
1208 : : /* Find the top-level namespace. */
1209 : 458 : for (ns = gfc_current_ns; ns->parent; ns = ns->parent)
1210 : : ;
1211 : :
1212 : 378 : if (expr->expr_type == EXPR_VARIABLE)
1213 : 378 : strcpy (tname, expr->symtree->name);
1214 : : else
1215 : 0 : strcpy (tname, "dummy");
1216 : 378 : if (expr->symtree->n.sym->module)
1217 : 0 : mname = expr->symtree->n.sym->module;
1218 : : else
1219 : : mname = "main";
1220 : 378 : name = xasprintf ("_caf_accessor_%s_%s_%d", mname, tname, ++caf_sym_cnt);
1221 : 378 : gfc_get_symbol (name, ns, &extproc);
1222 : 378 : extproc->declared_at = expr->where;
1223 : 378 : gfc_set_sym_referenced (extproc);
1224 : 378 : ++extproc->refs;
1225 : 378 : gfc_commit_symbol (extproc);
1226 : :
1227 : : /* Set up namespace. */
1228 : 378 : gfc_namespace *sub_ns = gfc_get_namespace (ns, 0);
1229 : 378 : sub_ns->sibling = ns->contained;
1230 : 378 : ns->contained = sub_ns;
1231 : 378 : sub_ns->resolved = 1;
1232 : : /* Set up procedure symbol. */
1233 : 378 : gfc_find_symbol (name, sub_ns, 1, &proc);
1234 : 378 : sub_ns->proc_name = proc;
1235 : 378 : proc->attr.if_source = IFSRC_DECL;
1236 : 378 : proc->attr.access = ACCESS_PUBLIC;
1237 : 378 : gfc_add_subroutine (&proc->attr, name, NULL);
1238 : 378 : proc->attr.host_assoc = 1;
1239 : 378 : proc->attr.always_explicit = 1;
1240 : 378 : ++proc->refs;
1241 : 378 : proc->declared_at = expr->where;
1242 : 378 : gfc_commit_symbol (proc);
1243 : 378 : free (name);
1244 : :
1245 : 378 : split_expr_at_caf_ref (expr, sub_ns, &post_caf_ref_expr, true);
1246 : :
1247 : 378 : if (ns->proc_name->attr.flavor == FL_MODULE)
1248 : 1 : proc->module = ns->proc_name->name;
1249 : 378 : gfc_set_sym_referenced (proc);
1250 : : /* Set up formal arguments. */
1251 : 378 : gfc_formal_arglist **argptr = &proc->formal;
1252 : : #define ADD_ARG(name, nsym, stype, skind, sintent) \
1253 : : gfc_get_symbol (name, sub_ns, &nsym); \
1254 : : nsym->ts.type = stype; \
1255 : : nsym->ts.kind = skind; \
1256 : : nsym->attr.flavor = FL_PARAMETER; \
1257 : : nsym->attr.dummy = 1; \
1258 : : nsym->attr.intent = sintent; \
1259 : : nsym->declared_at = expr->where; \
1260 : : gfc_set_sym_referenced (nsym); \
1261 : : *argptr = gfc_get_formal_arglist (); \
1262 : : (*argptr)->sym = nsym; \
1263 : : argptr = &(*argptr)->next
1264 : :
1265 : 378 : name = xasprintf ("add_send_data_%s_%s_%d", mname, tname, caf_sym_cnt);
1266 : 378 : ADD_ARG (name, send_data, BT_DERIVED, 0, INTENT_IN);
1267 : 378 : gfc_commit_symbol (send_data);
1268 : 378 : free (name);
1269 : :
1270 : 378 : ADD_ARG ("caller_image", caller_image, BT_INTEGER, gfc_default_integer_kind,
1271 : : INTENT_IN);
1272 : 378 : gfc_commit_symbol (caller_image);
1273 : :
1274 : : // ADD_ARG (expr->symtree->name, base, BT_VOID, INTENT_IN);
1275 : 378 : base = post_caf_ref_expr->symtree->n.sym;
1276 : 378 : base->attr.intent = INTENT_INOUT;
1277 : 378 : gfc_set_sym_referenced (base);
1278 : 378 : gfc_commit_symbol (base);
1279 : 378 : *argptr = gfc_get_formal_arglist ();
1280 : 378 : (*argptr)->sym = base;
1281 : 378 : argptr = &(*argptr)->next;
1282 : 378 : gfc_commit_symbol (base);
1283 : :
1284 : 378 : ADD_ARG ("buffer", buffer, rhs->ts.type, rhs->ts.kind, INTENT_IN);
1285 : 378 : buffer->ts = rhs->ts;
1286 : 378 : if (rhs->rank)
1287 : : {
1288 : 166 : buffer->as = gfc_get_array_spec ();
1289 : 166 : buffer->as->rank = rhs->rank;
1290 : 166 : buffer->as->type = AS_DEFERRED;
1291 : 166 : buffer->attr.allocatable = 1;
1292 : 166 : buffer->attr.dimension = 1;
1293 : : }
1294 : 378 : if (buffer->ts.type == BT_CHARACTER)
1295 : : {
1296 : 58 : buffer->ts.u.cl = gfc_get_charlen ();
1297 : 58 : *buffer->ts.u.cl = *rhs->ts.u.cl;
1298 : 58 : buffer->ts.deferred = 1;
1299 : 58 : buffer->ts.u.cl->length = gfc_copy_expr (rhs->ts.u.cl->length);
1300 : : }
1301 : 378 : gfc_commit_symbol (buffer);
1302 : : #undef ADD_ARG
1303 : :
1304 : : /* Set up code. */
1305 : : /* Code: base = buffer; */
1306 : 378 : code = sub_ns->code = gfc_get_code (EXEC_ASSIGN);
1307 : 378 : code->loc = expr->where;
1308 : 378 : code->expr1 = post_caf_ref_expr;
1309 : 378 : if (code->expr1->ts.type == BT_CHARACTER
1310 : 58 : && code->expr1->ts.kind != buffer->ts.kind)
1311 : : {
1312 : 28 : bool converted;
1313 : 28 : code->expr2 = gfc_lval_expr_from_sym (buffer);
1314 : 28 : converted = gfc_convert_chartype (code->expr2, &code->expr1->ts);
1315 : 28 : gcc_assert (converted);
1316 : : }
1317 : 350 : else if (code->expr1->ts.type != buffer->ts.type)
1318 : : {
1319 : 126 : bool converted;
1320 : 126 : code->expr2 = gfc_lval_expr_from_sym (buffer);
1321 : 252 : converted = gfc_convert_type_warn (code->expr2, &code->expr1->ts, 0, 0,
1322 : 126 : buffer->attr.dimension);
1323 : 126 : gcc_assert (converted);
1324 : : }
1325 : : else
1326 : 224 : code->expr2 = gfc_lval_expr_from_sym (buffer);
1327 : 378 : remove_caf_ref (post_caf_ref_expr);
1328 : 378 : send_data->ts.u.derived
1329 : 378 : = create_caf_add_data_parameter_type (code->expr1, ns, send_data);
1330 : :
1331 : 378 : cb = gfc_lval_expr_from_sym (extproc);
1332 : 378 : cb->ts.interface = extproc;
1333 : :
1334 : 378 : if (caf_accessor_prepend)
1335 : : {
1336 : : gfc_code *c = caf_accessor_prepend;
1337 : : /* Find last in chain. */
1338 : 0 : for (; c->next; c = c->next)
1339 : : ;
1340 : 0 : c->next = sub_ns->code;
1341 : 0 : sub_ns->code = caf_accessor_prepend;
1342 : : }
1343 : 378 : caf_accessor_prepend = backup_caf_accessor_prepend;
1344 : 378 : return cb;
1345 : : }
1346 : :
1347 : : static void
1348 : 378 : rewrite_caf_send (gfc_code *c)
1349 : : {
1350 : 378 : gfc_expr *send_to_remote_expr, *send_to_remote_hash_expr, *lhs, *rhs;
1351 : 378 : gfc_actual_arglist *arg = c->ext.actual;
1352 : :
1353 : 378 : lhs = arg->expr;
1354 : 378 : arg = arg->next;
1355 : 378 : rhs = arg->expr;
1356 : : /* Detect an already rewritten caf_send. */
1357 : 378 : if (arg->next && arg->next->expr->expr_type == EXPR_CONSTANT
1358 : 0 : && arg->next->next && arg->next->next->expr->expr_type == EXPR_VARIABLE)
1359 : : return;
1360 : :
1361 : 378 : send_to_remote_expr = create_send_callback (lhs, rhs);
1362 : 378 : send_to_remote_hash_expr = gfc_get_expr ();
1363 : 378 : send_to_remote_hash_expr->expr_type = EXPR_CONSTANT;
1364 : 378 : send_to_remote_hash_expr->ts.type = BT_INTEGER;
1365 : 378 : send_to_remote_hash_expr->ts.kind = gfc_default_integer_kind;
1366 : 378 : send_to_remote_hash_expr->where = lhs->where;
1367 : 378 : mpz_init_set_ui (send_to_remote_hash_expr->value.integer,
1368 : 378 : gfc_hash_value (send_to_remote_expr->symtree->n.sym));
1369 : 378 : arg->next = gfc_get_actual_arglist ();
1370 : 378 : arg = arg->next;
1371 : 378 : arg->expr = send_to_remote_hash_expr;
1372 : 378 : arg->next = gfc_get_actual_arglist ();
1373 : 378 : arg = arg->next;
1374 : 378 : arg->expr = send_to_remote_expr;
1375 : 378 : gfc_add_caf_accessor (send_to_remote_hash_expr, send_to_remote_expr);
1376 : :
1377 : 378 : if (gfc_is_coindexed (rhs))
1378 : : {
1379 : 90 : gfc_expr *get_from_remote_expr, *get_from_remote_hash_expr;
1380 : :
1381 : 90 : c->resolved_isym = gfc_intrinsic_subroutine_by_id (GFC_ISYM_CAF_SENDGET);
1382 : 90 : get_from_remote_expr = create_get_callback (rhs);
1383 : 90 : get_from_remote_hash_expr = gfc_get_expr ();
1384 : 90 : get_from_remote_hash_expr->expr_type = EXPR_CONSTANT;
1385 : 90 : get_from_remote_hash_expr->ts.type = BT_INTEGER;
1386 : 90 : get_from_remote_hash_expr->ts.kind = gfc_default_integer_kind;
1387 : 90 : get_from_remote_hash_expr->where = rhs->where;
1388 : 90 : mpz_init_set_ui (get_from_remote_hash_expr->value.integer,
1389 : 90 : gfc_hash_value (get_from_remote_expr->symtree->n.sym));
1390 : 90 : arg->next = gfc_get_actual_arglist ();
1391 : 90 : arg = arg->next;
1392 : 90 : arg->expr = get_from_remote_hash_expr;
1393 : 90 : arg->next = gfc_get_actual_arglist ();
1394 : 90 : arg = arg->next;
1395 : 90 : arg->expr = get_from_remote_expr;
1396 : 90 : gfc_add_caf_accessor (get_from_remote_hash_expr, get_from_remote_expr);
1397 : : }
1398 : : }
1399 : :
1400 : : static int
1401 : 46141 : coindexed_expr_callback (gfc_expr **e, int *walk_subtrees,
1402 : : void *data ATTRIBUTE_UNUSED)
1403 : : {
1404 : 46141 : *walk_subtrees = 1;
1405 : :
1406 : 46141 : switch ((*e)->expr_type)
1407 : : {
1408 : 17581 : case EXPR_VARIABLE:
1409 : 17581 : if (!caf_on_lhs && gfc_is_coindexed (*e))
1410 : : {
1411 : 729 : add_caf_get_from_remote (*e);
1412 : 729 : *walk_subtrees = 0;
1413 : : }
1414 : : /* Clear the flag to rewrite caf_gets in sub expressions of the lhs. */
1415 : 17581 : caf_on_lhs = false;
1416 : 17581 : break;
1417 : 5253 : case EXPR_FUNCTION:
1418 : 5253 : if ((*e)->value.function.isym)
1419 : 5200 : switch ((*e)->value.function.isym->id)
1420 : : {
1421 : 377 : case GFC_ISYM_ALLOCATED:
1422 : 377 : if ((*e)->value.function.actual->expr
1423 : 377 : && gfc_is_coindexed ((*e)->value.function.actual->expr))
1424 : : {
1425 : 66 : rewrite_caf_allocated (e);
1426 : 66 : *walk_subtrees = 0;
1427 : : }
1428 : : break;
1429 : 2 : case GFC_ISYM_CAF_GET:
1430 : 2 : case GFC_ISYM_CAF_IS_PRESENT_ON_REMOTE:
1431 : 2 : *walk_subtrees = 0;
1432 : 2 : break;
1433 : : default:
1434 : : break;
1435 : : }
1436 : : default:
1437 : : break;
1438 : : }
1439 : :
1440 : 46141 : return 0;
1441 : : }
1442 : :
1443 : : static int
1444 : 11591 : coindexed_code_callback (gfc_code **c, int *walk_subtrees,
1445 : : void *data ATTRIBUTE_UNUSED)
1446 : : {
1447 : 11591 : int ws = 1;
1448 : 11591 : current_code = c;
1449 : :
1450 : 11591 : switch ((*c)->op)
1451 : : {
1452 : 4408 : case EXEC_ASSIGN:
1453 : 4408 : case EXEC_POINTER_ASSIGN:
1454 : 4408 : caf_on_lhs = true;
1455 : 4408 : coindexed_expr_callback (&((*c)->expr1), &ws, NULL);
1456 : 4408 : caf_on_lhs = false;
1457 : 4408 : ws = 1;
1458 : 4408 : coindexed_expr_callback (&((*c)->expr2), &ws, NULL);
1459 : 4408 : *walk_subtrees = ws;
1460 : 4408 : break;
1461 : 68 : case EXEC_LOCK:
1462 : 68 : case EXEC_UNLOCK:
1463 : 68 : case EXEC_EVENT_POST:
1464 : 68 : case EXEC_EVENT_WAIT:
1465 : 68 : *walk_subtrees = 0;
1466 : 68 : break;
1467 : 691 : case EXEC_CALL:
1468 : 691 : *walk_subtrees = 1;
1469 : 691 : if ((*c)->resolved_isym)
1470 : 555 : switch ((*c)->resolved_isym->id)
1471 : : {
1472 : 378 : case GFC_ISYM_CAF_SEND:
1473 : 378 : rewrite_caf_send (*c);
1474 : 378 : *walk_subtrees = 0;
1475 : 378 : break;
1476 : 0 : case GFC_ISYM_CAF_SENDGET:
1477 : : /* Seldomly this routine is called again with the symbol already
1478 : : changed to CAF_SENDGET. Do not process the subtree again. The
1479 : : rewrite has already been done by rewrite_caf_send (). */
1480 : 0 : *walk_subtrees = 0;
1481 : 0 : break;
1482 : 91 : case GFC_ISYM_ATOMIC_ADD:
1483 : 91 : case GFC_ISYM_ATOMIC_AND:
1484 : 91 : case GFC_ISYM_ATOMIC_CAS:
1485 : 91 : case GFC_ISYM_ATOMIC_DEF:
1486 : 91 : case GFC_ISYM_ATOMIC_FETCH_ADD:
1487 : 91 : case GFC_ISYM_ATOMIC_FETCH_AND:
1488 : 91 : case GFC_ISYM_ATOMIC_FETCH_OR:
1489 : 91 : case GFC_ISYM_ATOMIC_FETCH_XOR:
1490 : 91 : case GFC_ISYM_ATOMIC_OR:
1491 : 91 : case GFC_ISYM_ATOMIC_REF:
1492 : 91 : case GFC_ISYM_ATOMIC_XOR:
1493 : 91 : *walk_subtrees = 0;
1494 : 91 : break;
1495 : : default:
1496 : : break;
1497 : : }
1498 : : break;
1499 : 6424 : default:
1500 : 6424 : *walk_subtrees = 1;
1501 : 6424 : break;
1502 : : }
1503 : 11591 : return 0;
1504 : : }
1505 : :
1506 : : void
1507 : 1503 : gfc_coarray_rewrite (gfc_namespace *ns)
1508 : : {
1509 : 1503 : gfc_namespace *saved_ns = gfc_current_ns;
1510 : 1503 : gfc_current_ns = ns;
1511 : :
1512 : 1503 : if (flag_coarray == GFC_FCOARRAY_LIB)
1513 : : {
1514 : 1503 : gfc_code_walker (&ns->code, coindexed_code_callback,
1515 : : coindexed_expr_callback, NULL);
1516 : :
1517 : 2660 : for (gfc_namespace *cns = ns->contained; cns; cns = cns->sibling)
1518 : 1157 : gfc_coarray_rewrite (cns);
1519 : : }
1520 : :
1521 : 1503 : gfc_current_ns = saved_ns;
1522 : 1503 : }
|
