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