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