Line data Source code
1 : /* Statement translation -- generate GCC trees from gfc_code.
2 : Copyright (C) 2002-2026 Free Software Foundation, Inc.
3 : Contributed by Paul Brook <paul@nowt.org>
4 : and Steven Bosscher <s.bosscher@student.tudelft.nl>
5 :
6 : This file is part of GCC.
7 :
8 : GCC is free software; you can redistribute it and/or modify it under
9 : the terms of the GNU General Public License as published by the Free
10 : Software Foundation; either version 3, or (at your option) any later
11 : version.
12 :
13 : GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 : WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 : FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
16 : for more details.
17 :
18 : You should have received a copy of the GNU General Public License
19 : along with GCC; see the file COPYING3. If not see
20 : <http://www.gnu.org/licenses/>. */
21 :
22 : #define INCLUDE_VECTOR
23 : #include "config.h"
24 : #include "system.h"
25 : #include "coretypes.h"
26 : #include "options.h"
27 : #include "tree.h"
28 : #include "gfortran.h"
29 : #include "trans.h"
30 : #include "stringpool.h"
31 : #include "fold-const.h"
32 : #include "trans-stmt.h"
33 : #include "trans-types.h"
34 : #include "trans-array.h"
35 : #include "trans-const.h"
36 : #include "trans-descriptor.h"
37 : #include "dependency.h"
38 : #include "constructor.h"
39 :
40 : typedef struct iter_info
41 : {
42 : tree var;
43 : tree start;
44 : tree end;
45 : tree step;
46 : gfc_loop_annot annot;
47 : struct iter_info *next;
48 : }
49 : iter_info;
50 :
51 : typedef struct forall_info
52 : {
53 : iter_info *this_loop;
54 : tree mask;
55 : tree maskindex;
56 : int nvar;
57 : tree size;
58 : struct forall_info *prev_nest;
59 : bool do_concurrent;
60 : }
61 : forall_info;
62 :
63 : static void gfc_trans_where_2 (gfc_code *, tree, bool,
64 : forall_info *, stmtblock_t *);
65 :
66 : /* Translate a F95 label number to a LABEL_EXPR. */
67 :
68 : tree
69 3574 : gfc_trans_label_here (gfc_code * code)
70 : {
71 3574 : return build1_v (LABEL_EXPR, gfc_get_label_decl (code->here));
72 : }
73 :
74 :
75 : /* Given a variable expression which has been ASSIGNed to, find the decl
76 : containing the auxiliary variables. For variables in common blocks this
77 : is a field_decl. */
78 :
79 : void
80 187 : gfc_conv_label_variable (gfc_se * se, gfc_expr * expr)
81 : {
82 187 : gcc_assert (expr->symtree->n.sym->attr.assign == 1);
83 187 : gfc_conv_expr (se, expr);
84 : /* Deals with variable in common block. Get the field declaration. */
85 187 : if (TREE_CODE (se->expr) == COMPONENT_REF)
86 0 : se->expr = TREE_OPERAND (se->expr, 1);
87 : /* Deals with dummy argument. Get the parameter declaration. */
88 187 : else if (INDIRECT_REF_P (se->expr))
89 12 : se->expr = TREE_OPERAND (se->expr, 0);
90 187 : }
91 :
92 : /* Translate a label assignment statement. */
93 :
94 : tree
95 116 : gfc_trans_label_assign (gfc_code * code)
96 : {
97 116 : tree label_tree;
98 116 : gfc_se se;
99 116 : tree len;
100 116 : tree addr;
101 116 : tree len_tree;
102 116 : int label_len;
103 :
104 : /* Start a new block. */
105 116 : gfc_init_se (&se, NULL);
106 116 : gfc_start_block (&se.pre);
107 116 : gfc_conv_label_variable (&se, code->expr1);
108 :
109 116 : len = GFC_DECL_STRING_LEN (se.expr);
110 116 : addr = GFC_DECL_ASSIGN_ADDR (se.expr);
111 :
112 116 : label_tree = gfc_get_label_decl (code->label1);
113 :
114 116 : if (code->label1->defined == ST_LABEL_TARGET
115 116 : || code->label1->defined == ST_LABEL_DO_TARGET)
116 : {
117 115 : label_tree = gfc_build_addr_expr (pvoid_type_node, label_tree);
118 115 : len_tree = build_int_cst (gfc_charlen_type_node, -1);
119 : }
120 : else
121 : {
122 1 : gfc_expr *format = code->label1->format;
123 :
124 1 : label_len = format->value.character.length;
125 1 : len_tree = build_int_cst (gfc_charlen_type_node, label_len);
126 2 : label_tree = gfc_build_wide_string_const (format->ts.kind, label_len + 1,
127 1 : format->value.character.string);
128 1 : label_tree = gfc_build_addr_expr (pvoid_type_node, label_tree);
129 : }
130 :
131 116 : gfc_add_modify (&se.pre, len, fold_convert (TREE_TYPE (len), len_tree));
132 116 : gfc_add_modify (&se.pre, addr, label_tree);
133 :
134 116 : return gfc_finish_block (&se.pre);
135 : }
136 :
137 : /* Translate a GOTO statement. */
138 :
139 : tree
140 1242 : gfc_trans_goto (gfc_code * code)
141 : {
142 1242 : locus loc = code->loc;
143 1242 : tree assigned_goto;
144 1242 : tree target;
145 1242 : tree tmp;
146 1242 : gfc_se se;
147 :
148 1242 : if (code->label1 != NULL)
149 1172 : return build1_v (GOTO_EXPR, gfc_get_label_decl (code->label1));
150 :
151 : /* ASSIGNED GOTO. */
152 70 : gfc_init_se (&se, NULL);
153 70 : gfc_start_block (&se.pre);
154 70 : gfc_conv_label_variable (&se, code->expr1);
155 70 : tmp = GFC_DECL_STRING_LEN (se.expr);
156 70 : tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, tmp,
157 70 : build_int_cst (TREE_TYPE (tmp), -1));
158 70 : gfc_trans_runtime_check (true, false, tmp, &se.pre, &loc,
159 : "Assigned label is not a target label");
160 :
161 70 : assigned_goto = GFC_DECL_ASSIGN_ADDR (se.expr);
162 :
163 : /* We're going to ignore a label list. It does not really change the
164 : statement's semantics (because it is just a further restriction on
165 : what's legal code); before, we were comparing label addresses here, but
166 : that's a very fragile business and may break with optimization. So
167 : just ignore it. */
168 :
169 70 : target = fold_build1_loc (input_location, GOTO_EXPR, void_type_node,
170 : assigned_goto);
171 70 : gfc_add_expr_to_block (&se.pre, target);
172 70 : return gfc_finish_block (&se.pre);
173 : }
174 :
175 :
176 : /* Translate an ENTRY statement. Just adds a label for this entry point. */
177 : tree
178 1412 : gfc_trans_entry (gfc_code * code)
179 : {
180 1412 : return build1_v (LABEL_EXPR, code->ext.entry->label);
181 : }
182 :
183 :
184 : /* Replace a gfc_ss structure by another both in the gfc_se struct
185 : and the gfc_loopinfo struct. This is used in gfc_conv_elemental_dependencies
186 : to replace a variable ss by the corresponding temporary. */
187 :
188 : static void
189 379 : replace_ss (gfc_se *se, gfc_ss *old_ss, gfc_ss *new_ss)
190 : {
191 379 : gfc_ss **sess, **loopss;
192 :
193 : /* The old_ss is a ss for a single variable. */
194 379 : gcc_assert (old_ss->info->type == GFC_SS_SECTION);
195 :
196 526 : for (sess = &(se->ss); *sess != gfc_ss_terminator; sess = &((*sess)->next))
197 526 : if (*sess == old_ss)
198 : break;
199 379 : gcc_assert (*sess != gfc_ss_terminator);
200 :
201 379 : *sess = new_ss;
202 379 : new_ss->next = old_ss->next;
203 :
204 : /* Make sure that trailing references are not lost. */
205 379 : if (old_ss->info
206 379 : && old_ss->info->data.array.ref
207 379 : && old_ss->info->data.array.ref->next
208 25 : && !(new_ss->info->data.array.ref
209 0 : && new_ss->info->data.array.ref->next))
210 25 : new_ss->info->data.array.ref = old_ss->info->data.array.ref;
211 :
212 526 : for (loopss = &(se->loop->ss); *loopss != gfc_ss_terminator;
213 147 : loopss = &((*loopss)->loop_chain))
214 526 : if (*loopss == old_ss)
215 : break;
216 379 : gcc_assert (*loopss != gfc_ss_terminator);
217 :
218 379 : *loopss = new_ss;
219 379 : new_ss->loop_chain = old_ss->loop_chain;
220 379 : new_ss->loop = old_ss->loop;
221 :
222 379 : gfc_free_ss (old_ss);
223 379 : }
224 :
225 :
226 : /* Check for dependencies between INTENT(IN) and INTENT(OUT) arguments of
227 : elemental subroutines. Make temporaries for output arguments if any such
228 : dependencies are found. Output arguments are chosen because internal_unpack
229 : can be used, as is, to copy the result back to the variable. */
230 : static void
231 2456 : gfc_conv_elemental_dependencies (gfc_se * se, gfc_se * loopse,
232 : gfc_symbol * sym, gfc_actual_arglist * arg,
233 : gfc_dep_check check_variable)
234 : {
235 2456 : gfc_actual_arglist *arg0;
236 2456 : gfc_expr *e;
237 2456 : gfc_formal_arglist *formal;
238 2456 : gfc_se parmse;
239 2456 : gfc_ss *ss;
240 2456 : gfc_symbol *fsym;
241 2456 : tree data;
242 2456 : tree size;
243 2456 : tree tmp;
244 :
245 2456 : if (loopse->ss == NULL)
246 0 : return;
247 :
248 2456 : ss = loopse->ss;
249 2456 : arg0 = arg;
250 2456 : formal = gfc_sym_get_dummy_args (sym);
251 :
252 : /* Loop over all the arguments testing for dependencies. */
253 14998 : for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
254 : {
255 5043 : e = arg->expr;
256 5043 : if (e == NULL)
257 12 : continue;
258 :
259 : /* Obtain the info structure for the current argument. */
260 8647 : for (ss = loopse->ss; ss && ss != gfc_ss_terminator; ss = ss->next)
261 8333 : if (ss->info->expr == e)
262 : break;
263 :
264 : /* If there is a dependency, create a temporary and use it
265 : instead of the variable. */
266 5031 : fsym = formal ? formal->sym : NULL;
267 5031 : if (e->expr_type == EXPR_VARIABLE
268 3808 : && e->rank && fsym
269 3299 : && fsym->attr.intent != INTENT_IN
270 1725 : && !fsym->attr.value
271 6696 : && gfc_check_fncall_dependency (e, fsym->attr.intent,
272 : sym, arg0, check_variable))
273 : {
274 379 : tree initial, temptype;
275 379 : stmtblock_t temp_post;
276 379 : gfc_ss *tmp_ss;
277 :
278 379 : tmp_ss = gfc_get_array_ss (gfc_ss_terminator, NULL, ss->dimen,
279 : GFC_SS_SECTION);
280 379 : gfc_mark_ss_chain_used (tmp_ss, 1);
281 379 : tmp_ss->info->expr = ss->info->expr;
282 379 : replace_ss (loopse, ss, tmp_ss);
283 :
284 : /* Obtain the argument descriptor for unpacking. */
285 379 : gfc_init_se (&parmse, NULL);
286 379 : parmse.want_pointer = 1;
287 379 : gfc_conv_expr_descriptor (&parmse, e);
288 379 : gfc_add_block_to_block (&se->pre, &parmse.pre);
289 :
290 : /* If we've got INTENT(INOUT) or a derived type with INTENT(OUT),
291 : initialize the array temporary with a copy of the values. */
292 379 : if (fsym->attr.intent == INTENT_INOUT
293 287 : || (fsym->ts.type ==BT_DERIVED
294 51 : && fsym->attr.intent == INTENT_OUT))
295 143 : initial = parmse.expr;
296 : /* For class expressions, we always initialize with the copy of
297 : the values. */
298 236 : else if (e->ts.type == BT_CLASS)
299 0 : initial = parmse.expr;
300 : else
301 : initial = NULL_TREE;
302 :
303 379 : if (e->ts.type != BT_CLASS)
304 : {
305 : /* Find the type of the temporary to create; we don't use the type
306 : of e itself as this breaks for subcomponent-references in e
307 : (where the type of e is that of the final reference, but
308 : parmse.expr's type corresponds to the full derived-type). */
309 : /* TODO: Fix this somehow so we don't need a temporary of the whole
310 : array but instead only the components referenced. */
311 379 : temptype = TREE_TYPE (parmse.expr); /* Pointer to descriptor. */
312 379 : gcc_assert (TREE_CODE (temptype) == POINTER_TYPE);
313 379 : temptype = TREE_TYPE (temptype);
314 379 : temptype = gfc_get_element_type (temptype);
315 : }
316 :
317 : else
318 : /* For class arrays signal that the size of the dynamic type has to
319 : be obtained from the vtable, using the 'initial' expression. */
320 : temptype = NULL_TREE;
321 :
322 : /* Generate the temporary. Cleaning up the temporary should be the
323 : very last thing done, so we add the code to a new block and add it
324 : to se->post as last instructions. */
325 379 : size = gfc_create_var (gfc_array_index_type, NULL);
326 379 : data = gfc_create_var (pvoid_type_node, NULL);
327 379 : gfc_init_block (&temp_post);
328 758 : tmp = gfc_trans_create_temp_array (&se->pre, &temp_post, tmp_ss,
329 : temptype, initial, false, true,
330 379 : false, &arg->expr->where);
331 379 : gfc_add_modify (&se->pre, size, tmp);
332 379 : tmp = fold_convert (pvoid_type_node, tmp_ss->info->data.array.data);
333 379 : gfc_add_modify (&se->pre, data, tmp);
334 :
335 : /* Update other ss' delta. */
336 379 : gfc_set_delta (loopse->loop);
337 :
338 : /* Copy the result back using unpack..... */
339 379 : if (e->ts.type != BT_CLASS)
340 379 : tmp = build_call_expr_loc (input_location,
341 : gfor_fndecl_in_unpack, 2, parmse.expr, data);
342 : else
343 : {
344 : /* ... except for class results where the copy is
345 : unconditional. */
346 0 : tmp = build_fold_indirect_ref_loc (input_location, parmse.expr);
347 0 : tmp = gfc_conv_descriptor_data_get (tmp);
348 0 : tmp = build_call_expr_loc (input_location,
349 : builtin_decl_explicit (BUILT_IN_MEMCPY),
350 : 3, tmp, data,
351 : fold_convert (size_type_node, size));
352 : }
353 379 : gfc_add_expr_to_block (&se->post, tmp);
354 :
355 : /* parmse.pre is already added above. */
356 379 : gfc_add_block_to_block (&se->post, &parmse.post);
357 379 : gfc_add_block_to_block (&se->post, &temp_post);
358 : }
359 : }
360 : }
361 :
362 :
363 : /* Given an executable statement referring to an intrinsic function call,
364 : returns the intrinsic symbol. */
365 :
366 : static gfc_intrinsic_sym *
367 6394 : get_intrinsic_for_code (gfc_code *code)
368 : {
369 6394 : if (code->op == EXEC_CALL)
370 : {
371 5937 : gfc_intrinsic_sym * const isym = code->resolved_isym;
372 5937 : if (isym)
373 : return isym;
374 : else
375 5740 : return gfc_get_intrinsic_for_expr (code->expr1);
376 : }
377 :
378 : return NULL;
379 : }
380 :
381 :
382 : /* Handle the OpenACC routines acc_attach{,_async} and
383 : acc_detach{,_finalize}{,_async} explicitly. This is required as the
384 : the corresponding device pointee is attached to the corresponding device
385 : pointer, but if a temporary array descriptor is created for the call,
386 : that one is used as pointer instead of the original pointer. */
387 :
388 : tree
389 55 : gfc_trans_call_acc_attach_detach (gfc_code *code)
390 : {
391 55 : stmtblock_t block;
392 55 : gfc_se ptr_addr_se, async_se;
393 55 : tree fn;
394 :
395 55 : fn = code->resolved_sym->backend_decl;
396 55 : if (fn == NULL)
397 : {
398 18 : fn = gfc_get_symbol_decl (code->resolved_sym);
399 18 : code->resolved_sym->backend_decl = fn;
400 : }
401 :
402 55 : gfc_start_block (&block);
403 :
404 55 : gfc_init_se (&ptr_addr_se, NULL);
405 55 : ptr_addr_se.descriptor_only = 1;
406 55 : ptr_addr_se.want_pointer = 1;
407 55 : gfc_conv_expr (&ptr_addr_se, code->ext.actual->expr);
408 55 : gfc_add_block_to_block (&block, &ptr_addr_se.pre);
409 55 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (ptr_addr_se.expr)))
410 27 : ptr_addr_se.expr = gfc_conv_descriptor_data_get (ptr_addr_se.expr);
411 55 : ptr_addr_se.expr = build_fold_addr_expr (ptr_addr_se.expr);
412 :
413 55 : bool async = code->ext.actual->next != NULL;
414 55 : if (async)
415 : {
416 3 : gfc_init_se (&async_se, NULL);
417 3 : gfc_conv_expr (&async_se, code->ext.actual->next->expr);
418 3 : fn = build_call_expr_loc (gfc_get_location (&code->loc), fn, 2,
419 : ptr_addr_se.expr, async_se.expr);
420 : }
421 : else
422 52 : fn = build_call_expr_loc (gfc_get_location (&code->loc),
423 : fn, 1, ptr_addr_se.expr);
424 55 : gfc_add_expr_to_block (&block, fn);
425 55 : gfc_add_block_to_block (&block, &ptr_addr_se.post);
426 55 : if (async)
427 3 : gfc_add_block_to_block (&block, &async_se.post);
428 :
429 55 : return gfc_finish_block (&block);
430 : }
431 :
432 :
433 : /* Translate the CALL statement. Builds a call to an F95 subroutine. */
434 :
435 : tree
436 80678 : gfc_trans_call (gfc_code * code, bool dependency_check,
437 : tree mask, tree count1, bool invert)
438 : {
439 80678 : gfc_se se;
440 80678 : gfc_ss * ss;
441 80678 : int has_alternate_specifier;
442 80678 : gfc_dep_check check_variable;
443 80678 : tree index = NULL_TREE;
444 80678 : tree maskexpr = NULL_TREE;
445 80678 : tree tmp;
446 80678 : bool is_intrinsic_mvbits;
447 :
448 80678 : gcc_assert (code->resolved_sym);
449 :
450 : /* Unfortunately, acc_attach* and acc_detach* need some special treatment for
451 : attaching the the pointee to a pointer as GCC might introduce a temporary
452 : array descriptor, whose data component is then used as to be attached to
453 : pointer. */
454 80678 : if (flag_openacc
455 2528 : && code->resolved_sym->attr.subroutine
456 2522 : && code->resolved_sym->formal
457 1357 : && code->resolved_sym->formal->sym->ts.type == BT_ASSUMED
458 350 : && code->resolved_sym->formal->sym->attr.dimension
459 350 : && code->resolved_sym->formal->sym->as->type == AS_ASSUMED_RANK
460 243 : && startswith (code->resolved_sym->name, "acc_")
461 80921 : && (!strcmp (code->resolved_sym->name + 4, "attach")
462 217 : || !strcmp (code->resolved_sym->name + 4, "attach_async")
463 216 : || !strcmp (code->resolved_sym->name + 4, "detach")
464 191 : || !strcmp (code->resolved_sym->name + 4, "detach_async")
465 190 : || !strcmp (code->resolved_sym->name + 4, "detach_finalize")
466 189 : || !strcmp (code->resolved_sym->name + 4, "detach_finalize_async")))
467 55 : return gfc_trans_call_acc_attach_detach (code);
468 :
469 : /* A CALL starts a new block because the actual arguments may have to
470 : be evaluated first. */
471 80623 : gfc_init_se (&se, NULL);
472 80623 : gfc_start_block (&se.pre);
473 :
474 80623 : ss = gfc_ss_terminator;
475 80623 : if (code->resolved_sym->attr.elemental)
476 6394 : ss = gfc_walk_elemental_function_args (ss, code->ext.actual,
477 : get_intrinsic_for_code (code),
478 : GFC_SS_REFERENCE);
479 :
480 : /* MVBITS is inlined but needs the dependency checking found here. */
481 161246 : is_intrinsic_mvbits = code->resolved_isym
482 80623 : && code->resolved_isym->id == GFC_ISYM_MVBITS;
483 :
484 : /* Is not an elemental subroutine call with array valued arguments. */
485 80623 : if (ss == gfc_ss_terminator)
486 : {
487 :
488 78167 : if (is_intrinsic_mvbits)
489 : {
490 130 : has_alternate_specifier = 0;
491 130 : gfc_conv_intrinsic_mvbits (&se, code->ext.actual, NULL);
492 : }
493 : else
494 : {
495 : /* Translate the call. */
496 78037 : has_alternate_specifier =
497 78037 : gfc_conv_procedure_call (&se, code->resolved_sym,
498 : code->ext.actual, code->expr1, NULL);
499 :
500 : /* A subroutine without side-effect, by definition, does nothing! */
501 78037 : TREE_SIDE_EFFECTS (se.expr) = 1;
502 : }
503 :
504 : /* Chain the pieces together and return the block. */
505 78167 : if (has_alternate_specifier)
506 : {
507 140 : gfc_code *select_code;
508 140 : gfc_symbol *sym;
509 140 : select_code = code->next;
510 140 : gcc_assert(select_code->op == EXEC_SELECT);
511 140 : sym = select_code->expr1->symtree->n.sym;
512 140 : se.expr = convert (gfc_typenode_for_spec (&sym->ts), se.expr);
513 140 : if (sym->backend_decl == NULL)
514 1 : sym->backend_decl = gfc_get_symbol_decl (sym);
515 140 : gfc_add_modify (&se.pre, sym->backend_decl, se.expr);
516 : }
517 : else
518 78027 : gfc_add_expr_to_block (&se.pre, se.expr);
519 :
520 78167 : gfc_add_block_to_block (&se.finalblock, &se.post);
521 78167 : gfc_add_block_to_block (&se.pre, &se.finalblock);
522 : }
523 :
524 : else
525 : {
526 : /* An elemental subroutine call with array valued arguments has
527 : to be scalarized. */
528 2456 : gfc_loopinfo loop;
529 2456 : stmtblock_t body;
530 2456 : stmtblock_t block;
531 2456 : gfc_se loopse;
532 2456 : gfc_se depse;
533 :
534 : /* gfc_walk_elemental_function_args renders the ss chain in the
535 : reverse order to the actual argument order. */
536 2456 : ss = gfc_reverse_ss (ss);
537 :
538 : /* Initialize the loop. */
539 2456 : gfc_init_se (&loopse, NULL);
540 2456 : gfc_init_loopinfo (&loop);
541 2456 : gfc_add_ss_to_loop (&loop, ss);
542 :
543 2456 : gfc_conv_ss_startstride (&loop);
544 : /* TODO: gfc_conv_loop_setup generates a temporary for vector
545 : subscripts. This could be prevented in the elemental case
546 : as temporaries are handled separately
547 : (below in gfc_conv_elemental_dependencies). */
548 2456 : if (code->expr1)
549 243 : gfc_conv_loop_setup (&loop, &code->expr1->where);
550 : else
551 2213 : gfc_conv_loop_setup (&loop, &code->loc);
552 :
553 2456 : gfc_mark_ss_chain_used (ss, 1);
554 :
555 : /* Convert the arguments, checking for dependencies. */
556 2456 : gfc_copy_loopinfo_to_se (&loopse, &loop);
557 2456 : loopse.ss = ss;
558 :
559 : /* For operator assignment, do dependency checking. */
560 2456 : if (dependency_check)
561 : check_variable = ELEM_CHECK_VARIABLE;
562 : else
563 2018 : check_variable = ELEM_DONT_CHECK_VARIABLE;
564 :
565 2456 : gfc_init_se (&depse, NULL);
566 2456 : gfc_conv_elemental_dependencies (&depse, &loopse, code->resolved_sym,
567 : code->ext.actual, check_variable);
568 :
569 2456 : gfc_add_block_to_block (&loop.pre, &depse.pre);
570 2456 : gfc_add_block_to_block (&loop.post, &depse.post);
571 :
572 : /* Generate the loop body. */
573 2456 : gfc_start_scalarized_body (&loop, &body);
574 2456 : gfc_init_block (&block);
575 :
576 2456 : if (mask && count1)
577 : {
578 : /* Form the mask expression according to the mask. */
579 44 : index = count1;
580 44 : maskexpr = gfc_build_array_ref (mask, index, NULL);
581 44 : if (invert)
582 11 : maskexpr = fold_build1_loc (input_location, TRUTH_NOT_EXPR,
583 11 : TREE_TYPE (maskexpr), maskexpr);
584 : }
585 :
586 2456 : if (is_intrinsic_mvbits)
587 : {
588 67 : has_alternate_specifier = 0;
589 67 : gfc_conv_intrinsic_mvbits (&loopse, code->ext.actual, &loop);
590 : }
591 : else
592 : {
593 : /* Add the subroutine call to the block. */
594 2389 : gfc_conv_procedure_call (&loopse, code->resolved_sym,
595 : code->ext.actual, code->expr1,
596 : NULL);
597 : }
598 :
599 2456 : if (mask && count1)
600 : {
601 44 : tmp = build3_v (COND_EXPR, maskexpr, loopse.expr,
602 : build_empty_stmt (input_location));
603 44 : gfc_add_expr_to_block (&loopse.pre, tmp);
604 44 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
605 : gfc_array_index_type,
606 : count1, gfc_index_one_node);
607 44 : gfc_add_modify (&loopse.pre, count1, tmp);
608 : }
609 : else
610 2412 : gfc_add_expr_to_block (&loopse.pre, loopse.expr);
611 :
612 2456 : gfc_add_block_to_block (&block, &loopse.pre);
613 2456 : gfc_add_block_to_block (&block, &loopse.post);
614 :
615 : /* Finish up the loop block and the loop. */
616 2456 : gfc_add_expr_to_block (&body, gfc_finish_block (&block));
617 2456 : gfc_trans_scalarizing_loops (&loop, &body);
618 2456 : gfc_add_block_to_block (&se.pre, &loop.pre);
619 2456 : gfc_add_block_to_block (&se.pre, &loop.post);
620 2456 : gfc_add_block_to_block (&se.pre, &loopse.finalblock);
621 2456 : gfc_add_block_to_block (&se.pre, &se.post);
622 2456 : gfc_cleanup_loop (&loop);
623 : }
624 :
625 80623 : return gfc_finish_block (&se.pre);
626 : }
627 :
628 :
629 : /* Translate the RETURN statement. */
630 :
631 : tree
632 3211 : gfc_trans_return (gfc_code * code)
633 : {
634 3211 : if (code->expr1)
635 : {
636 50 : gfc_se se;
637 50 : tree tmp;
638 50 : tree result;
639 :
640 : /* If code->expr is not NULL, this return statement must appear
641 : in a subroutine and current_fake_result_decl has already
642 : been generated. */
643 :
644 50 : result = gfc_get_fake_result_decl (NULL, 0);
645 50 : if (!result)
646 : {
647 0 : gfc_warning (0,
648 : "An alternate return at %L without a * dummy argument",
649 0 : &code->expr1->where);
650 0 : return gfc_generate_return ();
651 : }
652 :
653 : /* Start a new block for this statement. */
654 50 : gfc_init_se (&se, NULL);
655 50 : gfc_start_block (&se.pre);
656 :
657 50 : gfc_conv_expr (&se, code->expr1);
658 :
659 : /* Note that the actually returned expression is a simple value and
660 : does not depend on any pointers or such; thus we can clean-up with
661 : se.post before returning. */
662 50 : tmp = fold_build2_loc (input_location, MODIFY_EXPR, TREE_TYPE (result),
663 50 : result, fold_convert (TREE_TYPE (result),
664 : se.expr));
665 50 : gfc_add_expr_to_block (&se.pre, tmp);
666 50 : gfc_add_block_to_block (&se.pre, &se.post);
667 :
668 50 : tmp = gfc_generate_return ();
669 50 : gfc_add_expr_to_block (&se.pre, tmp);
670 50 : return gfc_finish_block (&se.pre);
671 : }
672 :
673 3161 : return gfc_generate_return ();
674 : }
675 :
676 :
677 : /* Translate the PAUSE statement. We have to translate this statement
678 : to a runtime library call. */
679 :
680 : tree
681 30 : gfc_trans_pause (gfc_code * code)
682 : {
683 30 : tree gfc_int8_type_node = gfc_get_int_type (8);
684 30 : gfc_se se;
685 30 : tree tmp;
686 :
687 : /* Start a new block for this statement. */
688 30 : gfc_init_se (&se, NULL);
689 30 : gfc_start_block (&se.pre);
690 :
691 :
692 30 : if (code->expr1 == NULL)
693 : {
694 10 : tmp = build_int_cst (size_type_node, 0);
695 10 : tmp = build_call_expr_loc (input_location,
696 : gfor_fndecl_pause_string, 2,
697 : build_int_cst (pchar_type_node, 0), tmp);
698 : }
699 20 : else if (code->expr1->ts.type == BT_INTEGER)
700 : {
701 9 : gfc_conv_expr (&se, code->expr1);
702 9 : tmp = build_call_expr_loc (input_location,
703 : gfor_fndecl_pause_numeric, 1,
704 : fold_convert (gfc_int8_type_node, se.expr));
705 : }
706 : else
707 : {
708 11 : gfc_conv_expr_reference (&se, code->expr1);
709 11 : tmp = build_call_expr_loc (input_location,
710 : gfor_fndecl_pause_string, 2,
711 : se.expr, fold_convert (size_type_node,
712 : se.string_length));
713 : }
714 :
715 30 : gfc_add_expr_to_block (&se.pre, tmp);
716 :
717 30 : gfc_add_block_to_block (&se.pre, &se.post);
718 :
719 30 : return gfc_finish_block (&se.pre);
720 : }
721 :
722 :
723 : /* Translate the STOP statement. We have to translate this statement
724 : to a runtime library call. */
725 :
726 : tree
727 221998 : gfc_trans_stop (gfc_code *code, bool error_stop)
728 : {
729 221998 : gfc_se se;
730 221998 : tree tmp;
731 221998 : tree quiet;
732 :
733 : /* Start a new block for this statement. */
734 221998 : gfc_init_se (&se, NULL);
735 221998 : gfc_start_block (&se.pre);
736 :
737 221998 : if (code->expr2)
738 : {
739 25 : gfc_conv_expr_val (&se, code->expr2);
740 25 : quiet = fold_convert (boolean_type_node, se.expr);
741 : }
742 : else
743 221973 : quiet = boolean_false_node;
744 :
745 221998 : if (code->expr1 == NULL)
746 : {
747 20487 : tmp = build_int_cst (size_type_node, 0);
748 40974 : tmp = build_call_expr_loc (input_location,
749 : error_stop
750 19465 : ? (flag_coarray == GFC_FCOARRAY_LIB
751 19465 : ? gfor_fndecl_caf_error_stop_str
752 : : gfor_fndecl_error_stop_string)
753 1022 : : (flag_coarray == GFC_FCOARRAY_LIB
754 1022 : ? gfor_fndecl_caf_stop_str
755 : : gfor_fndecl_stop_string),
756 : 3, build_int_cst (pchar_type_node, 0), tmp,
757 : quiet);
758 : }
759 201511 : else if (code->expr1->ts.type == BT_INTEGER)
760 : {
761 201021 : gfc_conv_expr (&se, code->expr1);
762 402042 : tmp = build_call_expr_loc (input_location,
763 : error_stop
764 19646 : ? (flag_coarray == GFC_FCOARRAY_LIB
765 19646 : ? gfor_fndecl_caf_error_stop
766 : : gfor_fndecl_error_stop_numeric)
767 181375 : : (flag_coarray == GFC_FCOARRAY_LIB
768 181375 : ? gfor_fndecl_caf_stop_numeric
769 : : gfor_fndecl_stop_numeric), 2,
770 : fold_convert (integer_type_node, se.expr),
771 : quiet);
772 : }
773 : else
774 : {
775 490 : gfc_conv_expr_reference (&se, code->expr1);
776 980 : tmp = build_call_expr_loc (input_location,
777 : error_stop
778 378 : ? (flag_coarray == GFC_FCOARRAY_LIB
779 378 : ? gfor_fndecl_caf_error_stop_str
780 : : gfor_fndecl_error_stop_string)
781 112 : : (flag_coarray == GFC_FCOARRAY_LIB
782 112 : ? gfor_fndecl_caf_stop_str
783 : : gfor_fndecl_stop_string),
784 : 3, se.expr, fold_convert (size_type_node,
785 : se.string_length),
786 : quiet);
787 : }
788 :
789 221998 : gfc_add_expr_to_block (&se.pre, tmp);
790 :
791 221998 : gfc_add_block_to_block (&se.pre, &se.post);
792 :
793 221998 : return gfc_finish_block (&se.pre);
794 : }
795 :
796 : tree
797 79 : trans_exit ()
798 : {
799 79 : const char *name = gfc_get_string (PREFIX ("exit_i%d"), 4);
800 79 : gfc_symbol *exsym = gfc_get_intrinsic_sub_symbol (name);
801 79 : tree tmp = gfc_get_symbol_decl (exsym);
802 79 : return build_call_expr_loc (input_location, tmp, 1, integer_zero_node);
803 : }
804 :
805 : /* Translate the FAIL IMAGE statement. */
806 :
807 : tree
808 21 : gfc_trans_fail_image (gfc_code *code ATTRIBUTE_UNUSED)
809 : {
810 21 : if (flag_coarray == GFC_FCOARRAY_LIB)
811 15 : return build_call_expr_loc (input_location,
812 15 : gfor_fndecl_caf_fail_image, 0);
813 : else
814 6 : return trans_exit ();
815 : }
816 :
817 : void
818 616 : gfc_trans_sync_stat (struct sync_stat *sync_stat, gfc_se *se, tree *stat,
819 : tree *errmsg, tree *errmsg_len)
820 : {
821 616 : gfc_se argse;
822 :
823 616 : if (sync_stat->stat)
824 : {
825 92 : gfc_init_se (&argse, NULL);
826 92 : gfc_conv_expr (&argse, sync_stat->stat);
827 92 : gfc_add_block_to_block (&se->pre, &argse.pre);
828 :
829 92 : if (TREE_TYPE (argse.expr) != integer_type_node)
830 : {
831 6 : tree tstat = gfc_create_var (integer_type_node, "stat");
832 6 : TREE_THIS_VOLATILE (tstat) = 1;
833 6 : gfc_add_modify (&se->pre, tstat,
834 : fold_convert (integer_type_node, argse.expr));
835 6 : gfc_add_modify (&se->post, argse.expr,
836 6 : fold_convert (TREE_TYPE (argse.expr), tstat));
837 6 : *stat = build_fold_addr_expr (tstat);
838 : }
839 : else
840 86 : *stat = gfc_build_addr_expr (NULL_TREE, argse.expr);
841 : }
842 : else
843 524 : *stat = null_pointer_node;
844 :
845 616 : if (sync_stat->errmsg)
846 : {
847 46 : gfc_init_se (&argse, NULL);
848 46 : gfc_conv_expr_reference (&argse, sync_stat->errmsg);
849 46 : gfc_add_block_to_block (&se->pre, &argse.pre);
850 46 : *errmsg = argse.expr;
851 46 : *errmsg_len = fold_convert (size_type_node, argse.string_length);
852 : }
853 : else
854 : {
855 570 : *errmsg = null_pointer_node;
856 570 : *errmsg_len = build_zero_cst (size_type_node);
857 : }
858 616 : }
859 :
860 : /* Translate the FORM TEAM statement. */
861 :
862 : tree
863 168 : gfc_trans_form_team (gfc_code *code)
864 : {
865 168 : if (flag_coarray == GFC_FCOARRAY_LIB)
866 : {
867 124 : gfc_se se, argse;
868 124 : tree team_id, team_type, new_index, stat, errmsg, errmsg_len, tmp;
869 :
870 124 : gfc_init_se (&se, NULL);
871 124 : gfc_init_se (&argse, NULL);
872 :
873 124 : gfc_conv_expr_val (&argse, code->expr1);
874 124 : team_id = fold_convert (integer_type_node, argse.expr);
875 124 : gfc_conv_expr_reference (&argse, code->expr2);
876 124 : team_type = argse.expr;
877 :
878 : /* NEW_INDEX=. */
879 124 : if (code->expr3)
880 : {
881 26 : gfc_conv_expr_reference (&argse, code->expr3);
882 26 : new_index = argse.expr;
883 : }
884 : else
885 98 : new_index = null_pointer_node;
886 :
887 124 : gfc_add_block_to_block (&se.post, &argse.post);
888 :
889 124 : gfc_trans_sync_stat (&code->ext.sync_stat, &se, &stat, &errmsg,
890 : &errmsg_len);
891 :
892 124 : gfc_add_block_to_block (&se.pre, &argse.pre);
893 :
894 124 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_form_team, 6,
895 : team_id, team_type, new_index, stat, errmsg,
896 : errmsg_len);
897 124 : gfc_add_expr_to_block (&se.pre, tmp);
898 124 : gfc_add_block_to_block (&se.pre, &se.post);
899 124 : return gfc_finish_block (&se.pre);
900 : }
901 : else
902 44 : return trans_exit ();
903 : }
904 :
905 : /* Translate the CHANGE TEAM statement. */
906 :
907 : tree
908 112 : gfc_trans_change_team (gfc_code *code)
909 : {
910 112 : if (flag_coarray == GFC_FCOARRAY_LIB)
911 : {
912 83 : stmtblock_t block;
913 83 : gfc_se se;
914 83 : tree team_type, stat, errmsg, errmsg_len, tmp;
915 :
916 83 : gfc_init_se (&se, NULL);
917 83 : gfc_start_block (&block);
918 :
919 83 : gfc_conv_expr_val (&se, code->expr1);
920 83 : team_type = se.expr;
921 :
922 83 : gfc_trans_sync_stat (&code->ext.block.sync_stat, &se, &stat, &errmsg,
923 : &errmsg_len);
924 :
925 83 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_change_team, 4,
926 : team_type, stat, errmsg, errmsg_len);
927 :
928 83 : gfc_add_expr_to_block (&se.pre, tmp);
929 83 : gfc_add_block_to_block (&se.pre, &se.post);
930 83 : gfc_add_block_to_block (&block, &se.pre);
931 83 : gfc_add_expr_to_block (&block, gfc_trans_block_construct (code));
932 83 : return gfc_finish_block (&block);
933 : }
934 : else
935 29 : return trans_exit ();
936 : }
937 :
938 : /* Translate the END TEAM statement. */
939 :
940 : tree
941 83 : gfc_trans_end_team (gfc_code *code)
942 : {
943 83 : if (flag_coarray == GFC_FCOARRAY_LIB)
944 : {
945 83 : gfc_se se;
946 83 : tree stat, errmsg, errmsg_len, tmp;
947 :
948 83 : gfc_init_se (&se, NULL);
949 83 : gfc_start_block (&se.pre);
950 :
951 83 : gfc_trans_sync_stat (&code->ext.sync_stat, &se, &stat, &errmsg,
952 : &errmsg_len);
953 :
954 83 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_end_team, 3,
955 : stat, errmsg, errmsg_len);
956 83 : gfc_add_expr_to_block (&se.pre, tmp);
957 83 : gfc_add_block_to_block (&se.pre, &se.post);
958 83 : return gfc_finish_block (&se.pre);
959 : }
960 : else
961 0 : return trans_exit ();
962 : }
963 :
964 : /* Translate the SYNC TEAM statement. */
965 :
966 : tree
967 36 : gfc_trans_sync_team (gfc_code *code)
968 : {
969 36 : if (flag_coarray == GFC_FCOARRAY_LIB)
970 : {
971 36 : gfc_se se;
972 36 : tree team_type, stat, errmsg, errmsg_len, tmp;
973 :
974 36 : gfc_init_se (&se, NULL);
975 :
976 36 : gfc_conv_expr_val (&se, code->expr1);
977 36 : team_type = se.expr;
978 :
979 36 : gfc_trans_sync_stat (&code->ext.sync_stat, &se, &stat, &errmsg,
980 : &errmsg_len);
981 :
982 36 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_team, 4,
983 : team_type, stat, errmsg, errmsg_len);
984 36 : gfc_add_expr_to_block (&se.pre, tmp);
985 36 : gfc_add_block_to_block (&se.pre, &se.post);
986 36 : return gfc_finish_block (&se.pre);
987 : }
988 : else
989 0 : return trans_exit ();
990 : }
991 :
992 : tree
993 126 : gfc_trans_lock_unlock (gfc_code *code, gfc_exec_op op)
994 : {
995 126 : gfc_se se, argse;
996 126 : tree stat = NULL_TREE, stat2 = NULL_TREE;
997 126 : tree lock_acquired = NULL_TREE, lock_acquired2 = NULL_TREE;
998 :
999 : /* Short cut: For single images without STAT= or LOCK_ACQUIRED
1000 : return early. (ERRMSG= is always untouched for -fcoarray=single.) */
1001 126 : if (!code->expr2 && !code->expr4 && flag_coarray != GFC_FCOARRAY_LIB)
1002 : return NULL_TREE;
1003 :
1004 106 : if (code->expr2)
1005 : {
1006 40 : gcc_assert (code->expr2->expr_type == EXPR_VARIABLE);
1007 40 : gfc_init_se (&argse, NULL);
1008 40 : gfc_conv_expr_val (&argse, code->expr2);
1009 40 : stat = argse.expr;
1010 : }
1011 66 : else if (flag_coarray == GFC_FCOARRAY_LIB)
1012 60 : stat = null_pointer_node;
1013 :
1014 106 : if (code->expr4)
1015 : {
1016 20 : gcc_assert (code->expr4->expr_type == EXPR_VARIABLE);
1017 20 : gfc_init_se (&argse, NULL);
1018 20 : gfc_conv_expr_val (&argse, code->expr4);
1019 20 : lock_acquired = argse.expr;
1020 : }
1021 86 : else if (flag_coarray == GFC_FCOARRAY_LIB)
1022 74 : lock_acquired = null_pointer_node;
1023 :
1024 106 : gfc_start_block (&se.pre);
1025 106 : if (flag_coarray == GFC_FCOARRAY_LIB)
1026 : {
1027 88 : tree tmp, token, image_index, errmsg, errmsg_len;
1028 88 : tree index = build_zero_cst (gfc_array_index_type);
1029 88 : tree caf_decl = gfc_get_tree_for_caf_expr (code->expr1);
1030 :
1031 88 : if (code->expr1->symtree->n.sym->ts.type != BT_DERIVED
1032 88 : || code->expr1->symtree->n.sym->ts.u.derived->from_intmod
1033 : != INTMOD_ISO_FORTRAN_ENV
1034 84 : || code->expr1->symtree->n.sym->ts.u.derived->intmod_sym_id
1035 : != ISOFORTRAN_LOCK_TYPE)
1036 : {
1037 4 : gfc_error ("Sorry, the lock component of derived type at %L is not "
1038 : "yet supported", &code->expr1->where);
1039 4 : return NULL_TREE;
1040 : }
1041 :
1042 84 : gfc_get_caf_token_offset (&se, &token, NULL, caf_decl, NULL_TREE,
1043 : code->expr1);
1044 :
1045 84 : if (gfc_is_coindexed (code->expr1))
1046 30 : image_index = gfc_caf_get_image_index (&se.pre, code->expr1, caf_decl);
1047 : else
1048 54 : image_index = integer_zero_node;
1049 :
1050 : /* For arrays, obtain the array index. */
1051 84 : if (gfc_expr_attr (code->expr1).dimension)
1052 : {
1053 52 : tree desc, tmp, extent, lbound, ubound;
1054 52 : gfc_array_ref *ar, ar2;
1055 52 : int i, rank;
1056 :
1057 : /* TODO: Extend this, once DT components are supported. */
1058 52 : ar = &code->expr1->ref->u.ar;
1059 52 : ar2 = *ar;
1060 52 : memset (ar, '\0', sizeof (*ar));
1061 52 : ar->as = ar2.as;
1062 52 : ar->type = AR_FULL;
1063 52 : rank = code->expr1->rank;
1064 52 : code->expr1->rank = ar->as->rank;
1065 :
1066 52 : gfc_init_se (&argse, NULL);
1067 52 : argse.descriptor_only = 1;
1068 52 : gfc_conv_expr_descriptor (&argse, code->expr1);
1069 52 : gfc_add_block_to_block (&se.pre, &argse.pre);
1070 52 : desc = argse.expr;
1071 52 : *ar = ar2;
1072 52 : code->expr1->rank = rank;
1073 :
1074 52 : extent = build_one_cst (gfc_array_index_type);
1075 182 : for (i = 0; i < ar->dimen; i++)
1076 : {
1077 78 : gfc_init_se (&argse, NULL);
1078 78 : gfc_conv_expr_type (&argse, ar->start[i], gfc_array_index_type);
1079 78 : gfc_add_block_to_block (&argse.pre, &argse.pre);
1080 78 : lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]);
1081 78 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
1082 78 : TREE_TYPE (lbound), argse.expr, lbound);
1083 78 : tmp = fold_build2_loc (input_location, MULT_EXPR,
1084 78 : TREE_TYPE (tmp), extent, tmp);
1085 78 : index = fold_build2_loc (input_location, PLUS_EXPR,
1086 78 : TREE_TYPE (tmp), index, tmp);
1087 78 : if (i < ar->dimen - 1)
1088 : {
1089 26 : ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[i]);
1090 26 : tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
1091 26 : extent = fold_build2_loc (input_location, MULT_EXPR,
1092 26 : TREE_TYPE (tmp), extent, tmp);
1093 : }
1094 : }
1095 : }
1096 :
1097 : /* errmsg. */
1098 84 : if (code->expr3)
1099 : {
1100 0 : gfc_init_se (&argse, NULL);
1101 0 : argse.want_pointer = 1;
1102 0 : gfc_conv_expr (&argse, code->expr3);
1103 0 : gfc_add_block_to_block (&se.pre, &argse.pre);
1104 0 : errmsg = argse.expr;
1105 0 : errmsg_len = fold_convert (size_type_node, argse.string_length);
1106 : }
1107 : else
1108 : {
1109 84 : errmsg = null_pointer_node;
1110 84 : errmsg_len = build_zero_cst (size_type_node);
1111 : }
1112 :
1113 84 : if (stat != null_pointer_node && TREE_TYPE (stat) != integer_type_node)
1114 : {
1115 0 : stat2 = stat;
1116 0 : stat = gfc_create_var (integer_type_node, "stat");
1117 : }
1118 :
1119 84 : if (lock_acquired != null_pointer_node
1120 84 : && TREE_TYPE (lock_acquired) != integer_type_node)
1121 : {
1122 14 : lock_acquired2 = lock_acquired;
1123 14 : lock_acquired = gfc_create_var (integer_type_node, "acquired");
1124 : }
1125 :
1126 84 : index = fold_convert (size_type_node, index);
1127 84 : if (op == EXEC_LOCK)
1128 42 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_lock, 7,
1129 : token, index, image_index,
1130 42 : lock_acquired != null_pointer_node
1131 14 : ? gfc_build_addr_expr (NULL, lock_acquired)
1132 : : lock_acquired,
1133 42 : stat != null_pointer_node
1134 14 : ? gfc_build_addr_expr (NULL, stat) : stat,
1135 : errmsg, errmsg_len);
1136 : else
1137 42 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_unlock, 6,
1138 : token, index, image_index,
1139 42 : stat != null_pointer_node
1140 14 : ? gfc_build_addr_expr (NULL, stat) : stat,
1141 : errmsg, errmsg_len);
1142 84 : gfc_add_expr_to_block (&se.pre, tmp);
1143 :
1144 : /* It guarantees memory consistency within the same segment */
1145 84 : tmp = gfc_build_string_const (strlen ("memory")+1, "memory"),
1146 84 : tmp = build5_loc (input_location, ASM_EXPR, void_type_node,
1147 : gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE,
1148 : tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE);
1149 84 : ASM_VOLATILE_P (tmp) = 1;
1150 :
1151 84 : gfc_add_expr_to_block (&se.pre, tmp);
1152 :
1153 84 : if (stat2 != NULL_TREE)
1154 0 : gfc_add_modify (&se.pre, stat2,
1155 0 : fold_convert (TREE_TYPE (stat2), stat));
1156 :
1157 84 : if (lock_acquired2 != NULL_TREE)
1158 14 : gfc_add_modify (&se.pre, lock_acquired2,
1159 14 : fold_convert (TREE_TYPE (lock_acquired2),
1160 : lock_acquired));
1161 :
1162 84 : return gfc_finish_block (&se.pre);
1163 : }
1164 :
1165 18 : if (stat != NULL_TREE)
1166 12 : gfc_add_modify (&se.pre, stat, build_int_cst (TREE_TYPE (stat), 0));
1167 :
1168 18 : if (lock_acquired != NULL_TREE)
1169 6 : gfc_add_modify (&se.pre, lock_acquired,
1170 6 : fold_convert (TREE_TYPE (lock_acquired),
1171 : boolean_true_node));
1172 :
1173 18 : return gfc_finish_block (&se.pre);
1174 : }
1175 :
1176 : tree
1177 58 : gfc_trans_event_post_wait (gfc_code *code, gfc_exec_op op)
1178 : {
1179 58 : gfc_se se, argse;
1180 58 : tree stat = NULL_TREE, stat2 = NULL_TREE;
1181 58 : tree until_count = NULL_TREE;
1182 :
1183 58 : if (code->expr2)
1184 : {
1185 12 : gcc_assert (code->expr2->expr_type == EXPR_VARIABLE);
1186 12 : gfc_init_se (&argse, NULL);
1187 12 : gfc_conv_expr_val (&argse, code->expr2);
1188 12 : stat = argse.expr;
1189 : }
1190 46 : else if (flag_coarray == GFC_FCOARRAY_LIB)
1191 31 : stat = null_pointer_node;
1192 :
1193 58 : if (code->expr4)
1194 : {
1195 18 : gfc_init_se (&argse, NULL);
1196 18 : gfc_conv_expr_val (&argse, code->expr4);
1197 18 : until_count = fold_convert (integer_type_node, argse.expr);
1198 : }
1199 : else
1200 40 : until_count = integer_one_node;
1201 :
1202 58 : if (flag_coarray != GFC_FCOARRAY_LIB)
1203 : {
1204 19 : gfc_start_block (&se.pre);
1205 19 : gfc_init_se (&argse, NULL);
1206 19 : gfc_conv_expr_val (&argse, code->expr1);
1207 :
1208 19 : if (op == EXEC_EVENT_POST)
1209 22 : gfc_add_modify (&se.pre, argse.expr,
1210 : fold_build2_loc (input_location, PLUS_EXPR,
1211 11 : TREE_TYPE (argse.expr), argse.expr,
1212 11 : build_int_cst (TREE_TYPE (argse.expr), 1)));
1213 : else
1214 16 : gfc_add_modify (&se.pre, argse.expr,
1215 : fold_build2_loc (input_location, MINUS_EXPR,
1216 8 : TREE_TYPE (argse.expr), argse.expr,
1217 8 : fold_convert (TREE_TYPE (argse.expr),
1218 : until_count)));
1219 19 : if (stat != NULL_TREE)
1220 4 : gfc_add_modify (&se.pre, stat, build_int_cst (TREE_TYPE (stat), 0));
1221 :
1222 19 : return gfc_finish_block (&se.pre);
1223 : }
1224 :
1225 39 : gfc_start_block (&se.pre);
1226 39 : tree tmp, token, image_index, errmsg, errmsg_len;
1227 39 : tree index = build_zero_cst (gfc_array_index_type);
1228 39 : tree caf_decl = gfc_get_tree_for_caf_expr (code->expr1);
1229 :
1230 39 : if (code->expr1->symtree->n.sym->ts.type != BT_DERIVED
1231 39 : || code->expr1->symtree->n.sym->ts.u.derived->from_intmod
1232 : != INTMOD_ISO_FORTRAN_ENV
1233 39 : || code->expr1->symtree->n.sym->ts.u.derived->intmod_sym_id
1234 : != ISOFORTRAN_EVENT_TYPE)
1235 : {
1236 0 : gfc_error ("Sorry, the event component of derived type at %L is not "
1237 : "yet supported", &code->expr1->where);
1238 0 : return NULL_TREE;
1239 : }
1240 :
1241 39 : gfc_init_se (&argse, NULL);
1242 39 : gfc_get_caf_token_offset (&argse, &token, NULL, caf_decl, NULL_TREE,
1243 : code->expr1);
1244 39 : gfc_add_block_to_block (&se.pre, &argse.pre);
1245 :
1246 39 : if (gfc_is_coindexed (code->expr1))
1247 11 : image_index = gfc_caf_get_image_index (&se.pre, code->expr1, caf_decl);
1248 : else
1249 28 : image_index = integer_zero_node;
1250 :
1251 : /* For arrays, obtain the array index. */
1252 39 : if (gfc_expr_attr (code->expr1).dimension)
1253 : {
1254 14 : tree desc, tmp, extent, lbound, ubound;
1255 14 : gfc_array_ref *ar, ar2;
1256 14 : int i;
1257 :
1258 : /* TODO: Extend this, once DT components are supported. */
1259 14 : ar = &code->expr1->ref->u.ar;
1260 14 : ar2 = *ar;
1261 14 : memset (ar, '\0', sizeof (*ar));
1262 14 : ar->as = ar2.as;
1263 14 : ar->type = AR_FULL;
1264 :
1265 14 : gfc_init_se (&argse, NULL);
1266 14 : argse.descriptor_only = 1;
1267 14 : gfc_conv_expr_descriptor (&argse, code->expr1);
1268 14 : gfc_add_block_to_block (&se.pre, &argse.pre);
1269 14 : desc = argse.expr;
1270 14 : *ar = ar2;
1271 :
1272 14 : extent = build_one_cst (gfc_array_index_type);
1273 42 : for (i = 0; i < ar->dimen; i++)
1274 : {
1275 14 : gfc_init_se (&argse, NULL);
1276 14 : gfc_conv_expr_type (&argse, ar->start[i], gfc_array_index_type);
1277 14 : gfc_add_block_to_block (&argse.pre, &argse.pre);
1278 14 : lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]);
1279 14 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
1280 14 : TREE_TYPE (lbound), argse.expr, lbound);
1281 14 : tmp = fold_build2_loc (input_location, MULT_EXPR,
1282 14 : TREE_TYPE (tmp), extent, tmp);
1283 14 : index = fold_build2_loc (input_location, PLUS_EXPR,
1284 14 : TREE_TYPE (tmp), index, tmp);
1285 14 : if (i < ar->dimen - 1)
1286 : {
1287 0 : ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[i]);
1288 0 : tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
1289 0 : extent = fold_build2_loc (input_location, MULT_EXPR,
1290 0 : TREE_TYPE (tmp), extent, tmp);
1291 : }
1292 : }
1293 : }
1294 :
1295 : /* errmsg. */
1296 39 : if (code->expr3)
1297 : {
1298 0 : gfc_init_se (&argse, NULL);
1299 0 : argse.want_pointer = 1;
1300 0 : gfc_conv_expr (&argse, code->expr3);
1301 0 : gfc_add_block_to_block (&se.pre, &argse.pre);
1302 0 : errmsg = argse.expr;
1303 0 : errmsg_len = fold_convert (size_type_node, argse.string_length);
1304 : }
1305 : else
1306 : {
1307 39 : errmsg = null_pointer_node;
1308 39 : errmsg_len = build_zero_cst (size_type_node);
1309 : }
1310 :
1311 39 : if (stat != null_pointer_node && TREE_TYPE (stat) != integer_type_node)
1312 : {
1313 0 : stat2 = stat;
1314 0 : stat = gfc_create_var (integer_type_node, "stat");
1315 : }
1316 :
1317 39 : index = fold_convert (size_type_node, index);
1318 39 : if (op == EXEC_EVENT_POST)
1319 23 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_event_post, 6,
1320 : token, index, image_index,
1321 23 : stat != null_pointer_node
1322 4 : ? gfc_build_addr_expr (NULL, stat) : stat,
1323 : errmsg, errmsg_len);
1324 : else
1325 16 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_event_wait, 6,
1326 : token, index, until_count,
1327 16 : stat != null_pointer_node
1328 4 : ? gfc_build_addr_expr (NULL, stat) : stat,
1329 : errmsg, errmsg_len);
1330 39 : gfc_add_expr_to_block (&se.pre, tmp);
1331 :
1332 : /* It guarantees memory consistency within the same segment */
1333 39 : tmp = gfc_build_string_const (strlen ("memory")+1, "memory"),
1334 39 : tmp = build5_loc (input_location, ASM_EXPR, void_type_node,
1335 : gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE,
1336 : tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE);
1337 39 : ASM_VOLATILE_P (tmp) = 1;
1338 39 : gfc_add_expr_to_block (&se.pre, tmp);
1339 :
1340 39 : if (stat2 != NULL_TREE)
1341 0 : gfc_add_modify (&se.pre, stat2, fold_convert (TREE_TYPE (stat2), stat));
1342 :
1343 39 : return gfc_finish_block (&se.pre);
1344 : }
1345 :
1346 : tree
1347 1405 : gfc_trans_sync (gfc_code *code, gfc_exec_op type)
1348 : {
1349 1405 : gfc_se se, argse;
1350 1405 : tree tmp;
1351 1405 : tree images = NULL_TREE, stat = NULL_TREE,
1352 1405 : errmsg = NULL_TREE, errmsglen = NULL_TREE;
1353 :
1354 : /* Short cut: For single images without bound checking or without STAT=,
1355 : return early. (ERRMSG= is always untouched for -fcoarray=single.) */
1356 1405 : if (!code->expr2 && !(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
1357 1212 : && flag_coarray != GFC_FCOARRAY_LIB)
1358 : return NULL_TREE;
1359 :
1360 963 : gfc_init_se (&se, NULL);
1361 963 : gfc_start_block (&se.pre);
1362 :
1363 963 : if (code->expr1 && code->expr1->rank == 0)
1364 : {
1365 37 : gfc_init_se (&argse, NULL);
1366 37 : gfc_conv_expr_val (&argse, code->expr1);
1367 37 : images = gfc_trans_force_lval (&argse.pre, argse.expr);
1368 37 : gfc_add_block_to_block (&se.pre, &argse.pre);
1369 : }
1370 :
1371 963 : if (code->expr2)
1372 : {
1373 148 : gcc_assert (code->expr2->expr_type == EXPR_VARIABLE
1374 : || code->expr2->expr_type == EXPR_FUNCTION);
1375 148 : gfc_init_se (&argse, NULL);
1376 148 : gfc_conv_expr_val (&argse, code->expr2);
1377 148 : stat = argse.expr;
1378 148 : gfc_add_block_to_block (&se.pre, &argse.pre);
1379 : }
1380 : else
1381 815 : stat = null_pointer_node;
1382 :
1383 963 : if (code->expr3 && flag_coarray == GFC_FCOARRAY_LIB)
1384 : {
1385 28 : gcc_assert (code->expr3->expr_type == EXPR_VARIABLE
1386 : || code->expr3->expr_type == EXPR_FUNCTION);
1387 28 : gfc_init_se (&argse, NULL);
1388 28 : argse.want_pointer = 1;
1389 28 : gfc_conv_expr (&argse, code->expr3);
1390 28 : gfc_conv_string_parameter (&argse);
1391 28 : errmsg = argse.expr;
1392 28 : errmsglen = fold_convert (size_type_node, argse.string_length);
1393 28 : gfc_add_block_to_block (&se.pre, &argse.pre);
1394 : }
1395 935 : else if (flag_coarray == GFC_FCOARRAY_LIB)
1396 : {
1397 854 : errmsg = null_pointer_node;
1398 854 : errmsglen = build_int_cst (size_type_node, 0);
1399 : }
1400 :
1401 : /* Check SYNC IMAGES(imageset) for valid image index.
1402 : FIXME: Add a check for image-set arrays. */
1403 963 : if (code->expr1 && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
1404 24 : && code->expr1->rank == 0)
1405 : {
1406 18 : tree images2 = fold_convert (integer_type_node, images);
1407 18 : tree cond;
1408 18 : if (flag_coarray != GFC_FCOARRAY_LIB)
1409 5 : cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
1410 5 : images, build_int_cst (TREE_TYPE (images), 1));
1411 : else
1412 : {
1413 13 : tree cond2;
1414 13 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images,
1415 : 2, null_pointer_node, null_pointer_node);
1416 13 : cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
1417 : images2, tmp);
1418 13 : cond2 = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
1419 : images,
1420 13 : build_int_cst (TREE_TYPE (images), 1));
1421 13 : cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
1422 : logical_type_node, cond, cond2);
1423 : }
1424 18 : gfc_trans_runtime_check (true, false, cond, &se.pre,
1425 18 : &code->expr1->where, "Invalid image number "
1426 : "%d in SYNC IMAGES", images2);
1427 : }
1428 :
1429 : /* Per F2008, 8.5.1, a SYNC MEMORY is implied by calling the
1430 : image control statements SYNC IMAGES and SYNC ALL. */
1431 963 : if (flag_coarray == GFC_FCOARRAY_LIB)
1432 : {
1433 882 : tmp = gfc_build_string_const (strlen ("memory")+1, "memory"),
1434 882 : tmp = build5_loc (input_location, ASM_EXPR, void_type_node,
1435 : gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE,
1436 : tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE);
1437 882 : ASM_VOLATILE_P (tmp) = 1;
1438 882 : gfc_add_expr_to_block (&se.pre, tmp);
1439 : }
1440 :
1441 963 : if (flag_coarray != GFC_FCOARRAY_LIB)
1442 : {
1443 : /* Set STAT to zero. */
1444 81 : if (code->expr2)
1445 67 : gfc_add_modify (&se.pre, stat, build_int_cst (TREE_TYPE (stat), 0));
1446 : }
1447 882 : else if (type == EXEC_SYNC_ALL || type == EXEC_SYNC_MEMORY)
1448 : {
1449 : /* SYNC ALL => stat == null_pointer_node
1450 : SYNC ALL(stat=s) => stat has an integer type
1451 :
1452 : If "stat" has the wrong integer type, use a temp variable of
1453 : the right type and later cast the result back into "stat". */
1454 815 : if (stat == null_pointer_node || TREE_TYPE (stat) == integer_type_node)
1455 : {
1456 815 : if (TREE_TYPE (stat) == integer_type_node)
1457 51 : stat = gfc_build_addr_expr (NULL, stat);
1458 :
1459 815 : if(type == EXEC_SYNC_MEMORY)
1460 24 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_memory,
1461 : 3, stat, errmsg, errmsglen);
1462 : else
1463 791 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_all,
1464 : 3, stat, errmsg, errmsglen);
1465 :
1466 815 : gfc_add_expr_to_block (&se.pre, tmp);
1467 : }
1468 : else
1469 : {
1470 0 : tree tmp_stat = gfc_create_var (integer_type_node, "stat");
1471 :
1472 0 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_all,
1473 : 3, gfc_build_addr_expr (NULL, tmp_stat),
1474 : errmsg, errmsglen);
1475 0 : gfc_add_expr_to_block (&se.pre, tmp);
1476 :
1477 0 : gfc_add_modify (&se.pre, stat,
1478 0 : fold_convert (TREE_TYPE (stat), tmp_stat));
1479 : }
1480 : }
1481 : else
1482 : {
1483 67 : tree len;
1484 :
1485 67 : gcc_assert (type == EXEC_SYNC_IMAGES);
1486 :
1487 67 : if (!code->expr1)
1488 : {
1489 14 : len = build_int_cst (integer_type_node, -1);
1490 14 : images = null_pointer_node;
1491 : }
1492 53 : else if (code->expr1->rank == 0)
1493 : {
1494 31 : len = integer_one_node;
1495 31 : images = gfc_build_addr_expr (NULL_TREE, images);
1496 : }
1497 : else
1498 : {
1499 : /* FIXME. */
1500 22 : if (code->expr1->ts.kind != gfc_c_int_kind)
1501 0 : gfc_fatal_error ("Sorry, only support for integer kind %d "
1502 : "implemented for image-set at %L",
1503 : gfc_c_int_kind, &code->expr1->where);
1504 :
1505 22 : gfc_conv_array_parameter (&se, code->expr1, true, NULL, NULL, &len);
1506 22 : images = se.expr;
1507 :
1508 22 : tmp = gfc_typenode_for_spec (&code->expr1->ts);
1509 22 : if (GFC_ARRAY_TYPE_P (tmp) || GFC_DESCRIPTOR_TYPE_P (tmp))
1510 0 : tmp = gfc_get_element_type (tmp);
1511 :
1512 44 : len = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
1513 22 : TREE_TYPE (len), len,
1514 22 : fold_convert (TREE_TYPE (len),
1515 : TYPE_SIZE_UNIT (tmp)));
1516 22 : len = fold_convert (integer_type_node, len);
1517 : }
1518 :
1519 : /* SYNC IMAGES(imgs) => stat == null_pointer_node
1520 : SYNC IMAGES(imgs,stat=s) => stat has an integer type
1521 :
1522 : If "stat" has the wrong integer type, use a temp variable of
1523 : the right type and later cast the result back into "stat". */
1524 67 : if (stat == null_pointer_node || TREE_TYPE (stat) == integer_type_node)
1525 : {
1526 67 : if (TREE_TYPE (stat) == integer_type_node)
1527 30 : stat = gfc_build_addr_expr (NULL, stat);
1528 :
1529 67 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_images,
1530 : 5, fold_convert (integer_type_node, len),
1531 : images, stat, errmsg, errmsglen);
1532 67 : gfc_add_expr_to_block (&se.pre, tmp);
1533 : }
1534 : else
1535 : {
1536 0 : tree tmp_stat = gfc_create_var (integer_type_node, "stat");
1537 :
1538 0 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_images,
1539 : 5, fold_convert (integer_type_node, len),
1540 : images, gfc_build_addr_expr (NULL, tmp_stat),
1541 : errmsg, errmsglen);
1542 0 : gfc_add_expr_to_block (&se.pre, tmp);
1543 :
1544 0 : gfc_add_modify (&se.pre, stat,
1545 0 : fold_convert (TREE_TYPE (stat), tmp_stat));
1546 : }
1547 : }
1548 :
1549 963 : return gfc_finish_block (&se.pre);
1550 : }
1551 :
1552 :
1553 : /* Generate GENERIC for the IF construct. This function also deals with
1554 : the simple IF statement, because the front end translates the IF
1555 : statement into an IF construct.
1556 :
1557 : We translate:
1558 :
1559 : IF (cond) THEN
1560 : then_clause
1561 : ELSEIF (cond2)
1562 : elseif_clause
1563 : ELSE
1564 : else_clause
1565 : ENDIF
1566 :
1567 : into:
1568 :
1569 : pre_cond_s;
1570 : if (cond_s)
1571 : {
1572 : then_clause;
1573 : }
1574 : else
1575 : {
1576 : pre_cond_s
1577 : if (cond_s)
1578 : {
1579 : elseif_clause
1580 : }
1581 : else
1582 : {
1583 : else_clause;
1584 : }
1585 : }
1586 :
1587 : where COND_S is the simplified version of the predicate. PRE_COND_S
1588 : are the pre side-effects produced by the translation of the
1589 : conditional.
1590 : We need to build the chain recursively otherwise we run into
1591 : problems with folding incomplete statements. */
1592 :
1593 : static tree
1594 251277 : gfc_trans_if_1 (gfc_code * code)
1595 : {
1596 251277 : gfc_se if_se;
1597 251277 : tree stmt, elsestmt;
1598 251277 : location_t loc, saved_loc = UNKNOWN_LOCATION;
1599 :
1600 : /* Check for an unconditional ELSE clause. */
1601 251277 : if (!code->expr1)
1602 6885 : return gfc_trans_code (code->next);
1603 :
1604 : /* Initialize a statement builder for each block. Puts in NULL_TREEs. */
1605 244392 : gfc_init_se (&if_se, NULL);
1606 244392 : gfc_start_block (&if_se.pre);
1607 :
1608 : /* Calculate the IF condition expression. */
1609 244392 : if (GFC_LOCUS_IS_SET (code->expr1->where))
1610 : {
1611 244392 : saved_loc = input_location;
1612 244392 : input_location = gfc_get_location (&code->expr1->where);
1613 : }
1614 :
1615 244392 : gfc_conv_expr_val (&if_se, code->expr1);
1616 :
1617 244392 : if (saved_loc != UNKNOWN_LOCATION)
1618 244392 : input_location = saved_loc;
1619 :
1620 : /* Translate the THEN clause. */
1621 244392 : stmt = gfc_trans_code (code->next);
1622 :
1623 : /* Translate the ELSE clause. */
1624 244392 : if (code->block)
1625 7130 : elsestmt = gfc_trans_if_1 (code->block);
1626 : else
1627 237262 : elsestmt = build_empty_stmt (input_location);
1628 :
1629 : /* Build the condition expression and add it to the condition block. */
1630 488154 : loc = (GFC_LOCUS_IS_SET (code->expr1->where)
1631 488154 : ? gfc_get_location (&code->expr1->where) : input_location);
1632 244392 : stmt = fold_build3_loc (loc, COND_EXPR, void_type_node, if_se.expr, stmt,
1633 : elsestmt);
1634 :
1635 244392 : gfc_add_expr_to_block (&if_se.pre, stmt);
1636 :
1637 : /* Finish off this statement. */
1638 244392 : return gfc_finish_block (&if_se.pre);
1639 : }
1640 :
1641 : tree
1642 244147 : gfc_trans_if (gfc_code * code)
1643 : {
1644 244147 : stmtblock_t body;
1645 244147 : tree exit_label;
1646 :
1647 : /* Create exit label so it is available for trans'ing the body code. */
1648 244147 : exit_label = gfc_build_label_decl (NULL_TREE);
1649 244147 : code->exit_label = exit_label;
1650 :
1651 : /* Translate the actual code in code->block. */
1652 244147 : gfc_init_block (&body);
1653 244147 : gfc_add_expr_to_block (&body, gfc_trans_if_1 (code->block));
1654 :
1655 : /* Add exit label. */
1656 244147 : gfc_add_expr_to_block (&body, build1_v (LABEL_EXPR, exit_label));
1657 :
1658 244147 : return gfc_finish_block (&body);
1659 : }
1660 :
1661 :
1662 : /* Translate an arithmetic IF expression.
1663 :
1664 : IF (cond) label1, label2, label3 translates to
1665 :
1666 : if (cond <= 0)
1667 : {
1668 : if (cond < 0)
1669 : goto label1;
1670 : else // cond == 0
1671 : goto label2;
1672 : }
1673 : else // cond > 0
1674 : goto label3;
1675 :
1676 : An optimized version can be generated in case of equal labels.
1677 : E.g., if label1 is equal to label2, we can translate it to
1678 :
1679 : if (cond <= 0)
1680 : goto label1;
1681 : else
1682 : goto label3;
1683 : */
1684 :
1685 : tree
1686 64 : gfc_trans_arithmetic_if (gfc_code * code)
1687 : {
1688 64 : gfc_se se;
1689 64 : tree tmp;
1690 64 : tree branch1;
1691 64 : tree branch2;
1692 64 : tree zero;
1693 :
1694 : /* Start a new block. */
1695 64 : gfc_init_se (&se, NULL);
1696 64 : gfc_start_block (&se.pre);
1697 :
1698 : /* Pre-evaluate COND. */
1699 64 : gfc_conv_expr_val (&se, code->expr1);
1700 64 : se.expr = gfc_evaluate_now (se.expr, &se.pre);
1701 :
1702 : /* Build something to compare with. */
1703 64 : zero = gfc_build_const (TREE_TYPE (se.expr), integer_zero_node);
1704 :
1705 64 : if (code->label1->value != code->label2->value)
1706 : {
1707 : /* If (cond < 0) take branch1 else take branch2.
1708 : First build jumps to the COND .LT. 0 and the COND .EQ. 0 cases. */
1709 49 : branch1 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label1));
1710 49 : branch2 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label2));
1711 :
1712 49 : if (code->label1->value != code->label3->value)
1713 36 : tmp = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
1714 : se.expr, zero);
1715 : else
1716 13 : tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
1717 : se.expr, zero);
1718 :
1719 49 : branch1 = fold_build3_loc (input_location, COND_EXPR, void_type_node,
1720 : tmp, branch1, branch2);
1721 : }
1722 : else
1723 15 : branch1 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label1));
1724 :
1725 64 : if (code->label1->value != code->label3->value
1726 45 : && code->label2->value != code->label3->value)
1727 : {
1728 : /* if (cond <= 0) take branch1 else take branch2. */
1729 37 : branch2 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label3));
1730 37 : tmp = fold_build2_loc (input_location, LE_EXPR, logical_type_node,
1731 : se.expr, zero);
1732 37 : branch1 = fold_build3_loc (input_location, COND_EXPR, void_type_node,
1733 : tmp, branch1, branch2);
1734 : }
1735 :
1736 : /* Append the COND_EXPR to the evaluation of COND, and return. */
1737 64 : gfc_add_expr_to_block (&se.pre, branch1);
1738 64 : return gfc_finish_block (&se.pre);
1739 : }
1740 :
1741 :
1742 : /* Translate a CRITICAL block. */
1743 :
1744 : tree
1745 37 : gfc_trans_critical (gfc_code *code)
1746 : {
1747 37 : stmtblock_t block;
1748 37 : tree tmp, token = NULL_TREE;
1749 37 : tree stat = NULL_TREE, errmsg, errmsg_len;
1750 :
1751 37 : gfc_start_block (&block);
1752 :
1753 37 : if (flag_coarray == GFC_FCOARRAY_LIB)
1754 : {
1755 21 : gfc_se se;
1756 :
1757 21 : gfc_init_se (&se, NULL);
1758 21 : gfc_trans_sync_stat (&code->ext.sync_stat, &se, &stat, &errmsg,
1759 : &errmsg_len);
1760 21 : gfc_add_block_to_block (&block, &se.pre);
1761 :
1762 21 : token = gfc_get_symbol_decl (code->resolved_sym);
1763 21 : token = GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (token));
1764 21 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_lock, 7,
1765 : token, integer_zero_node, integer_one_node,
1766 : null_pointer_node, stat, errmsg, errmsg_len);
1767 21 : gfc_add_expr_to_block (&block, tmp);
1768 21 : gfc_add_block_to_block (&block, &se.post);
1769 :
1770 : /* It guarantees memory consistency within the same segment. */
1771 21 : tmp = gfc_build_string_const (strlen ("memory") + 1, "memory"),
1772 21 : tmp = build5_loc (input_location, ASM_EXPR, void_type_node,
1773 : gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE,
1774 : tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE);
1775 21 : ASM_VOLATILE_P (tmp) = 1;
1776 :
1777 21 : gfc_add_expr_to_block (&block, tmp);
1778 : }
1779 :
1780 37 : tmp = gfc_trans_code (code->block->next);
1781 37 : gfc_add_expr_to_block (&block, tmp);
1782 :
1783 37 : if (flag_coarray == GFC_FCOARRAY_LIB)
1784 : {
1785 : /* END CRITICAL does not accept STAT or ERRMSG arguments.
1786 : * If STAT= is specified for CRITICAL, pass a stat argument to
1787 : * _gfortran_caf_lock_unlock to prevent termination in the event of an
1788 : * error, but ignore any value assigned to it.
1789 : */
1790 21 : tmp = build_call_expr_loc (
1791 : input_location, gfor_fndecl_caf_unlock, 6, token, integer_zero_node,
1792 : integer_one_node,
1793 21 : stat != NULL_TREE
1794 21 : ? gfc_build_addr_expr (NULL,
1795 : gfc_create_var (integer_type_node, "stat"))
1796 : : null_pointer_node,
1797 : null_pointer_node, integer_zero_node);
1798 21 : gfc_add_expr_to_block (&block, tmp);
1799 :
1800 : /* It guarantees memory consistency within the same segment */
1801 21 : tmp = gfc_build_string_const (strlen ("memory")+1, "memory"),
1802 21 : tmp = build5_loc (input_location, ASM_EXPR, void_type_node,
1803 : gfc_build_string_const (1, ""),
1804 : NULL_TREE, NULL_TREE,
1805 : tree_cons (NULL_TREE, tmp, NULL_TREE),
1806 : NULL_TREE);
1807 21 : ASM_VOLATILE_P (tmp) = 1;
1808 :
1809 21 : gfc_add_expr_to_block (&block, tmp);
1810 : }
1811 :
1812 37 : return gfc_finish_block (&block);
1813 : }
1814 :
1815 :
1816 : /* Return true, when the class has a _len component. */
1817 :
1818 : static bool
1819 851 : class_has_len_component (gfc_symbol *sym)
1820 : {
1821 851 : gfc_component *comp = sym->ts.u.derived->components;
1822 2483 : while (comp)
1823 : {
1824 2125 : if (strcmp (comp->name, "_len") == 0)
1825 : return true;
1826 1632 : comp = comp->next;
1827 : }
1828 : return false;
1829 : }
1830 :
1831 :
1832 : /* Do proper initialization for ASSOCIATE names. */
1833 :
1834 : static void
1835 7826 : trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
1836 : {
1837 7826 : gfc_expr *e;
1838 7826 : tree tmp;
1839 7826 : bool class_target;
1840 7826 : bool unlimited;
1841 7826 : tree desc;
1842 7826 : tree charlen;
1843 7826 : bool need_len_assign;
1844 7826 : bool whole_array = true;
1845 7826 : bool same_class;
1846 7826 : gfc_ref *ref;
1847 7826 : gfc_symbol *sym2;
1848 :
1849 7826 : gcc_assert (sym->assoc);
1850 7826 : e = sym->assoc->target;
1851 :
1852 7826 : class_target = (e->expr_type == EXPR_VARIABLE)
1853 6879 : && e->ts.type == BT_CLASS
1854 10592 : && (gfc_is_class_scalar_expr (e)
1855 2172 : || gfc_is_class_array_ref (e, NULL));
1856 2674 : same_class = class_target && sym->ts.type == BT_CLASS
1857 1227 : && strcmp (sym->ts.u.derived->name, e->ts.u.derived->name) == 0;
1858 :
1859 7826 : unlimited = UNLIMITED_POLY (e);
1860 :
1861 16894 : for (ref = e->ref; ref; ref = ref->next)
1862 9128 : if (ref->type == REF_ARRAY && ref->u.ar.type == AR_FULL
1863 3541 : && ref->u.ar.dimen != 0 && ref->next)
1864 : {
1865 : whole_array = false;
1866 : break;
1867 : }
1868 :
1869 : /* Assignments to the string length need to be generated, when
1870 : ( sym is a char array or
1871 : sym has a _len component)
1872 : and the associated expression is unlimited polymorphic, which is
1873 : not (yet) correctly in 'unlimited', because for an already associated
1874 : BT_DERIVED the u-poly flag is not set, i.e.,
1875 : __tmp_CHARACTER_0_1 => w => arg
1876 : ^ generated temp ^ from code, the w does not have the u-poly
1877 : flag set, where UNLIMITED_POLY(e) expects it. */
1878 6346 : need_len_assign = ((unlimited || (e->ts.type == BT_DERIVED
1879 2518 : && e->ts.u.derived->attr.unlimited_polymorphic))
1880 2362 : && (sym->ts.type == BT_CHARACTER
1881 1608 : || ((sym->ts.type == BT_CLASS || sym->ts.type == BT_DERIVED)
1882 851 : && class_has_len_component (sym)))
1883 9073 : && !sym->attr.select_rank_temporary);
1884 :
1885 : /* Do a `pointer assignment' with updated descriptor (or assign descriptor
1886 : to array temporary) for arrays with either unknown shape or if associating
1887 : to a variable. Select rank temporaries need somewhat different treatment
1888 : to other associate names and case temporaries. This because the selector
1889 : is assumed rank and so the offset in particular has to be changed. Also,
1890 : the case temporaries carry both allocatable and target attributes if
1891 : present in the selector. This means that an allocatation or change of
1892 : association can occur and so has to be dealt with. */
1893 7826 : if (sym->attr.select_rank_temporary)
1894 : {
1895 1404 : gfc_se se;
1896 1404 : tree class_decl = NULL_TREE;
1897 1404 : int rank = 0;
1898 1404 : bool class_ptr;
1899 :
1900 1404 : sym2 = e->symtree->n.sym;
1901 1404 : gfc_init_se (&se, NULL);
1902 1404 : if (e->ts.type == BT_CLASS)
1903 : {
1904 : /* Go straight to the class data. */
1905 145 : if (sym2->attr.dummy && !sym2->attr.optional)
1906 : {
1907 121 : class_decl = sym2->backend_decl;
1908 121 : if (DECL_LANG_SPECIFIC (class_decl)
1909 121 : && GFC_DECL_SAVED_DESCRIPTOR (class_decl))
1910 0 : class_decl = GFC_DECL_SAVED_DESCRIPTOR (class_decl);
1911 121 : if (POINTER_TYPE_P (TREE_TYPE (class_decl)))
1912 121 : class_decl = build_fold_indirect_ref_loc (input_location,
1913 : class_decl);
1914 121 : gcc_assert (GFC_CLASS_TYPE_P (TREE_TYPE (class_decl)));
1915 121 : se.expr = gfc_class_data_get (class_decl);
1916 : }
1917 : else
1918 : {
1919 24 : class_decl = sym2->backend_decl;
1920 24 : gfc_conv_expr_descriptor (&se, e);
1921 24 : if (POINTER_TYPE_P (TREE_TYPE (se.expr)))
1922 0 : se.expr = build_fold_indirect_ref_loc (input_location,
1923 : se.expr);
1924 : }
1925 :
1926 145 : if (CLASS_DATA (sym)->as && CLASS_DATA (sym)->as->rank > 0)
1927 145 : rank = CLASS_DATA (sym)->as->rank;
1928 : }
1929 : else
1930 : {
1931 1259 : gfc_conv_expr_descriptor (&se, e);
1932 1259 : if (sym->as && sym->as->rank > 0)
1933 1210 : rank = sym->as->rank;
1934 : }
1935 :
1936 1404 : desc = sym->backend_decl;
1937 :
1938 : /* The SELECT TYPE mechanisms turn class temporaries into pointers, which
1939 : point to the selector. */
1940 1404 : class_ptr = class_decl != NULL_TREE && POINTER_TYPE_P (TREE_TYPE (desc));
1941 : if (class_ptr)
1942 : {
1943 145 : tmp = gfc_create_var (TREE_TYPE (TREE_TYPE (desc)), "class");
1944 145 : tmp = gfc_build_addr_expr (NULL, tmp);
1945 145 : gfc_add_modify (&se.pre, desc, tmp);
1946 :
1947 145 : tmp = gfc_class_vptr_get (class_decl);
1948 145 : gfc_add_modify (&se.pre, gfc_class_vptr_get (desc), tmp);
1949 145 : if (UNLIMITED_POLY (sym))
1950 101 : gfc_add_modify (&se.pre, gfc_class_len_get (desc),
1951 : gfc_class_len_get (class_decl));
1952 :
1953 145 : desc = gfc_class_data_get (desc);
1954 : }
1955 :
1956 : /* SELECT RANK temporaries can carry the allocatable and pointer
1957 : attributes so the selector descriptor must be copied in and
1958 : copied out. */
1959 1404 : if (rank > 0)
1960 1324 : gfc_copy_descriptor (&se.pre, desc, se.expr, rank);
1961 : else
1962 : {
1963 80 : tmp = gfc_conv_descriptor_data_get (se.expr);
1964 80 : gfc_add_modify (&se.pre, desc,
1965 80 : fold_convert (TREE_TYPE (desc), tmp));
1966 : }
1967 :
1968 : /* Deal with associate_name => selector. Class associate names are
1969 : treated in the same way as in SELECT TYPE. */
1970 1404 : sym2 = sym->assoc->target->symtree->n.sym;
1971 1404 : if (sym2->assoc && sym->assoc->target && sym2->ts.type != BT_CLASS)
1972 : {
1973 54 : sym2 = sym2->assoc->target->symtree->n.sym;
1974 54 : se.expr = sym2->backend_decl;
1975 :
1976 54 : if (POINTER_TYPE_P (TREE_TYPE (se.expr)))
1977 54 : se.expr = build_fold_indirect_ref_loc (input_location,
1978 : se.expr);
1979 : }
1980 :
1981 : /* There could have been reallocation. Copy descriptor back to the
1982 : selector and update the offset. */
1983 1404 : if (sym->attr.allocatable || sym->attr.pointer
1984 1022 : || (sym->ts.type == BT_CLASS
1985 127 : && (CLASS_DATA (sym)->attr.allocatable
1986 79 : || CLASS_DATA (sym)->attr.pointer)))
1987 : {
1988 509 : if (rank > 0)
1989 454 : gfc_copy_descriptor (&se.post, se.expr, desc, rank);
1990 : else
1991 55 : gfc_conv_descriptor_data_set (&se.post, se.expr, desc);
1992 :
1993 : /* The dynamic type could have changed too. */
1994 509 : if (sym->ts.type == BT_CLASS)
1995 : {
1996 145 : tmp = sym->backend_decl;
1997 145 : if (class_ptr)
1998 145 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
1999 145 : gfc_add_modify (&se.post, gfc_class_vptr_get (class_decl),
2000 : gfc_class_vptr_get (tmp));
2001 145 : if (UNLIMITED_POLY (sym))
2002 101 : gfc_add_modify (&se.post, gfc_class_len_get (class_decl),
2003 : gfc_class_len_get (tmp));
2004 : }
2005 : }
2006 :
2007 1404 : tmp = gfc_finish_block (&se.post);
2008 :
2009 1404 : gfc_add_init_cleanup (block, gfc_finish_block (&se.pre), tmp);
2010 : }
2011 :
2012 : /* Now all the other kinds of associate variable. */
2013 :
2014 : /* First we do the F202y ASSOCIATE construct with an assumed rank selector.
2015 : Since this requires rank remapping, the simplest implementation builds an
2016 : array reference, using the array ref attached to the association_list,
2017 : followed by gfc_trans_pointer_assignment. */
2018 6422 : else if (e->rank == -1 && sym->assoc->ar)
2019 : {
2020 24 : gfc_array_ref *ar;
2021 24 : gfc_expr *expr1 = gfc_lval_expr_from_sym (sym);
2022 24 : stmtblock_t init;
2023 24 : gfc_init_block (&init);
2024 :
2025 : /* Build the array reference and add to expr1. */
2026 24 : gfc_free_ref_list (expr1->ref);
2027 24 : expr1->ref = gfc_get_ref();
2028 24 : expr1->ref->type = REF_ARRAY;
2029 24 : ar = gfc_copy_array_ref (sym->assoc->ar);
2030 24 : expr1->ref->u.ar = *ar;
2031 24 : expr1->ref->u.ar.type = AR_SECTION;
2032 :
2033 : /* For class objects, insert the _data component reference. Since the
2034 : associate-name is a pointer, it needs a target, which is created using
2035 : its typespec. If unlimited polymorphic, the _len field will be filled
2036 : by the pointer assignment. */
2037 24 : if (expr1->ts.type == BT_CLASS)
2038 : {
2039 12 : need_len_assign = false;
2040 12 : gfc_ref *ref;
2041 12 : gfc_find_component (expr1->ts.u.derived, "_data", true, true, &ref);
2042 12 : ref->next = expr1->ref;
2043 12 : expr1->ref = ref;
2044 12 : expr1->rank = CLASS_DATA (sym)->as->rank;
2045 12 : tmp = gfc_create_var (gfc_typenode_for_spec (&sym->ts), "class");
2046 12 : tmp = gfc_build_addr_expr (NULL_TREE, tmp);
2047 12 : gfc_add_modify (&init, sym->backend_decl, tmp);
2048 : }
2049 :
2050 : /* Do the pointer assignment and clean up. */
2051 24 : gfc_expr *expr2 = gfc_copy_expr (e);
2052 24 : gfc_add_expr_to_block (&init,
2053 : gfc_trans_pointer_assignment (expr1, expr2));
2054 24 : gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL);
2055 24 : gfc_free_expr (expr1);
2056 24 : gfc_free_expr (expr2);
2057 24 : }
2058 : /* PDT array and string components are separately allocated for each element
2059 : of a PDT array. Therefore, there is no choice but to copy in and copy out
2060 : the target expression. */
2061 6398 : else if (e && is_subref_array (e)
2062 472 : && (gfc_expr_attr (e).pdt_array || gfc_expr_attr (e).pdt_string))
2063 : {
2064 18 : gfc_se init;
2065 18 : gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (sym->backend_decl)));
2066 18 : gfc_init_se (&init, NULL);
2067 18 : gfc_conv_subref_array_arg (&init, e, false, INTENT_INOUT,
2068 18 : sym && sym->attr.pointer);
2069 18 : init.expr = build_fold_indirect_ref_loc (input_location, init.expr);
2070 18 : gfc_add_modify (&init.pre, sym->backend_decl, init.expr);
2071 18 : gfc_add_init_cleanup (block, gfc_finish_block (&init.pre),
2072 : gfc_finish_block (&init.post));
2073 : }
2074 6380 : else if ((sym->attr.dimension || sym->attr.codimension) && !class_target
2075 690 : && (sym->as->type == AS_DEFERRED || sym->assoc->variable))
2076 : {
2077 690 : gfc_se se;
2078 690 : tree desc;
2079 690 : bool cst_array_ctor;
2080 690 : stmtblock_t init;
2081 690 : gfc_init_block (&init);
2082 :
2083 690 : desc = sym->backend_decl;
2084 1380 : cst_array_ctor = e->expr_type == EXPR_ARRAY
2085 97 : && gfc_constant_array_constructor_p (e->value.constructor)
2086 708 : && e->ts.type != BT_CHARACTER;
2087 :
2088 : /* If association is to an expression, evaluate it and create temporary.
2089 : Otherwise, get descriptor of target for pointer assignment. */
2090 690 : gfc_init_se (&se, NULL);
2091 :
2092 690 : if (sym->assoc->variable || cst_array_ctor)
2093 : {
2094 435 : se.direct_byref = 1;
2095 435 : se.expr = desc;
2096 435 : GFC_DECL_PTR_ARRAY_P (sym->backend_decl) = 1;
2097 : }
2098 :
2099 690 : if (sym->attr.codimension)
2100 16 : se.want_coarray = 1;
2101 :
2102 690 : gfc_conv_expr_descriptor (&se, e);
2103 :
2104 690 : if (flag_coarray == GFC_FCOARRAY_LIB && sym->attr.codimension)
2105 : {
2106 7 : tree token = gfc_conv_descriptor_token (se.expr),
2107 : size
2108 7 : = sym->attr.dimension
2109 7 : ? fold_build2 (MULT_EXPR, gfc_array_index_type,
2110 : gfc_conv_descriptor_size (se.expr, e->rank),
2111 : gfc_conv_descriptor_span_get (se.expr))
2112 6 : : gfc_conv_descriptor_span_get (se.expr);
2113 : /* Create a new token, because in the token the modified descriptor
2114 : is stored. The modified descriptor is needed for accesses on the
2115 : remote image. In the scalar case, the base address needs to be
2116 : associated correctly, which also needs a new token.
2117 : The token is freed automatically be the end team statement. */
2118 7 : gfc_add_expr_to_block (
2119 : &se.pre,
2120 : build_call_expr_loc (
2121 : input_location, gfor_fndecl_caf_register, 7, size,
2122 : build_int_cst (integer_type_node, GFC_CAF_COARRAY_MAP_EXISTING),
2123 : gfc_build_addr_expr (pvoid_type_node, token),
2124 : gfc_build_addr_expr (NULL_TREE, se.expr), null_pointer_node,
2125 : null_pointer_node, integer_zero_node));
2126 : }
2127 :
2128 690 : if (sym->ts.type == BT_CHARACTER
2129 273 : && !sym->attr.select_type_temporary
2130 273 : && sym->ts.u.cl->backend_decl
2131 273 : && VAR_P (sym->ts.u.cl->backend_decl)
2132 229 : && se.string_length
2133 229 : && se.string_length != sym->ts.u.cl->backend_decl)
2134 : {
2135 : /* When the target is a variable, its length is already known. */
2136 229 : tree len = fold_convert (TREE_TYPE (sym->ts.u.cl->backend_decl),
2137 : se.string_length);
2138 229 : if (e->expr_type == EXPR_VARIABLE)
2139 135 : gfc_add_modify (&init, sym->ts.u.cl->backend_decl, len);
2140 : else
2141 94 : gfc_add_modify (&se.pre, sym->ts.u.cl->backend_decl, len);
2142 : }
2143 :
2144 : /* If we didn't already do the pointer assignment, set associate-name
2145 : descriptor to the one generated for the temporary. */
2146 690 : if ((!sym->assoc->variable && !cst_array_ctor)
2147 435 : || !whole_array)
2148 : {
2149 255 : int dim;
2150 :
2151 255 : if (whole_array)
2152 255 : gfc_add_modify (&se.pre, desc, se.expr);
2153 :
2154 : /* The generated descriptor has lower bound zero (as array
2155 : temporary), shift bounds so we get lower bounds of 1. */
2156 629 : for (dim = 0; dim < e->rank; ++dim)
2157 326 : gfc_conv_shift_descriptor_lbound (&se.pre, desc,
2158 : dim, gfc_index_one_node);
2159 : }
2160 :
2161 690 : if (e->expr_type == EXPR_FUNCTION && IS_PDT (e))
2162 : {
2163 0 : tmp = gfc_deallocate_pdt_comp (sym->ts.u.derived, se.expr,
2164 0 : sym->as->rank);
2165 0 : gfc_add_expr_to_block (&se.post, tmp);
2166 : }
2167 :
2168 : /* Done, register stuff as init / cleanup code. */
2169 690 : gfc_add_block_to_block (&init, &se.pre);
2170 690 : gfc_add_init_cleanup (block, gfc_finish_block (&init),
2171 : gfc_finish_block (&se.post));
2172 690 : }
2173 :
2174 : /* Temporaries, arising from TYPE IS, just need the descriptor of class
2175 : arrays to be assigned directly. */
2176 5690 : else if (class_target && (sym->attr.dimension || sym->attr.codimension)
2177 1447 : && (sym->ts.type == BT_DERIVED || unlimited))
2178 : {
2179 1447 : gfc_se se;
2180 :
2181 1447 : gfc_init_se (&se, NULL);
2182 1447 : se.descriptor_only = 1;
2183 : /* In a select type the (temporary) associate variable shall point to
2184 : a standard fortran array (lower bound == 1), but conv_expr ()
2185 : just maps to the input array in the class object, whose lbound may
2186 : be arbitrary. conv_expr_descriptor solves this by inserting a
2187 : temporary array descriptor. */
2188 1447 : gfc_conv_expr_descriptor (&se, e);
2189 :
2190 1447 : gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr))
2191 : || GFC_ARRAY_TYPE_P (TREE_TYPE (se.expr)));
2192 1447 : gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (sym->backend_decl)));
2193 :
2194 1447 : if (sym->ts.type == BT_CHARACTER)
2195 : {
2196 : /* Emit a DECL_EXPR for the variable sized array type in so the
2197 : gimplification of its type sizes works correctly. */
2198 314 : tree arraytype;
2199 314 : tmp = TREE_TYPE (sym->backend_decl);
2200 314 : arraytype = TREE_TYPE (GFC_TYPE_ARRAY_DATAPTR_TYPE (tmp));
2201 314 : if (! TYPE_NAME (arraytype))
2202 63 : TYPE_NAME (arraytype) = build_decl (UNKNOWN_LOCATION, TYPE_DECL,
2203 : NULL_TREE, arraytype);
2204 314 : gfc_add_expr_to_block (&se.pre, build1 (DECL_EXPR,
2205 314 : arraytype, TYPE_NAME (arraytype)));
2206 : }
2207 :
2208 1447 : if (GFC_ARRAY_TYPE_P (TREE_TYPE (se.expr)))
2209 : {
2210 0 : if (INDIRECT_REF_P (se.expr))
2211 0 : tmp = TREE_OPERAND (se.expr, 0);
2212 : else
2213 : tmp = se.expr;
2214 :
2215 0 : gfc_add_modify (&se.pre, sym->backend_decl,
2216 0 : gfc_class_data_get (GFC_DECL_SAVED_DESCRIPTOR (tmp)));
2217 : }
2218 : else
2219 1447 : gfc_add_modify (&se.pre, sym->backend_decl, se.expr);
2220 :
2221 1447 : if (unlimited)
2222 : {
2223 : /* Recover the dtype, which has been overwritten by the
2224 : assignment from an unlimited polymorphic object. */
2225 907 : tree dtype_val = gfc_get_dtype (TREE_TYPE (sym->backend_decl));
2226 907 : gfc_conv_descriptor_dtype_set (&se.pre, sym->backend_decl, dtype_val);
2227 : }
2228 :
2229 1447 : gfc_add_init_cleanup (block, gfc_finish_block (&se.pre),
2230 : gfc_finish_block (&se.post));
2231 1447 : }
2232 :
2233 : /* Do a scalar pointer assignment; this is for scalar variable targets. */
2234 4243 : else if (gfc_is_associate_pointer (sym))
2235 : {
2236 3663 : gfc_se se;
2237 :
2238 3663 : gcc_assert (!sym->attr.dimension && !sym->attr.codimension);
2239 :
2240 3663 : gfc_init_se (&se, NULL);
2241 :
2242 : /* Class associate-names come this way because they are
2243 : unconditionally associate pointers and the symbol is scalar. */
2244 3663 : if (sym->ts.type == BT_CLASS && e->expr_type == EXPR_FUNCTION)
2245 : {
2246 105 : gfc_conv_expr (&se, e);
2247 105 : se.expr = gfc_evaluate_now (se.expr, &se.pre);
2248 : /* Finalize the expression and free if it is allocatable. */
2249 105 : gfc_finalize_tree_expr (&se, NULL, gfc_expr_attr (e), e->rank);
2250 105 : gfc_add_block_to_block (&se.post, &se.finalblock);
2251 105 : need_len_assign = false;
2252 : }
2253 3558 : else if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.dimension)
2254 : {
2255 507 : tree target_expr;
2256 : /* For a class array we need a descriptor for the selector. */
2257 507 : gfc_conv_expr_descriptor (&se, e);
2258 : /* Needed to get/set the _len component below. */
2259 507 : target_expr = se.expr;
2260 :
2261 : /* Obtain a temporary class container for the result. */
2262 507 : gfc_conv_class_to_class (&se, e, sym->ts, false, true, false, false);
2263 507 : se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
2264 :
2265 507 : desc = gfc_class_data_get (se.expr);
2266 :
2267 507 : if (need_len_assign)
2268 : {
2269 224 : if (e->symtree
2270 224 : && DECL_LANG_SPECIFIC (e->symtree->n.sym->backend_decl)
2271 90 : && GFC_DECL_SAVED_DESCRIPTOR (e->symtree->n.sym->backend_decl)
2272 254 : && TREE_CODE (target_expr) != COMPONENT_REF)
2273 : /* Use the original class descriptor stored in the saved
2274 : descriptor to get the target_expr. */
2275 36 : target_expr =
2276 18 : GFC_DECL_SAVED_DESCRIPTOR (e->symtree->n.sym->backend_decl);
2277 206 : else if (TREE_CODE (target_expr) == COMPONENT_REF)
2278 : /* Strip the _data component from the target_expr. */
2279 182 : target_expr = TREE_OPERAND (target_expr, 0);
2280 : else
2281 : /* An array section selector yields a bare descriptor; get the
2282 : class container from the selector expression. */
2283 24 : target_expr = gfc_get_class_from_gfc_expr (e);
2284 : /* Add a reference to the _len comp to the target expr. */
2285 224 : tmp = gfc_class_len_get (target_expr);
2286 : /* Get the component-ref for the temp structure's _len comp. */
2287 224 : charlen = gfc_class_len_get (se.expr);
2288 : /* Add the assign to the beginning of the block... */
2289 224 : gfc_add_modify (&se.pre, charlen,
2290 224 : fold_convert (TREE_TYPE (charlen), tmp));
2291 : /* and the opposite way at the end of the block, to hand changes
2292 : on the string length back. */
2293 224 : gfc_add_modify (&se.post, tmp,
2294 224 : fold_convert (TREE_TYPE (tmp), charlen));
2295 : /* Length assignment done, prevent adding it again below. */
2296 224 : need_len_assign = false;
2297 : }
2298 : }
2299 3051 : else if (sym->ts.type == BT_CLASS && e->ts.type == BT_CLASS
2300 674 : && CLASS_DATA (e)->attr.dimension)
2301 : {
2302 : /* This is bound to be a class array element. */
2303 92 : gfc_conv_expr_reference (&se, e);
2304 : /* Obtain a temporary class container for the result. */
2305 92 : gfc_conv_derived_to_class (&se, e, sym, se.expr, false, false,
2306 92 : e->symtree->name);
2307 92 : need_len_assign = false;
2308 : }
2309 2959 : else if (whole_array && (same_class || unlimited)
2310 302 : && e->ts.type == BT_CLASS && CLASS_DATA (e)->attr.codimension)
2311 : {
2312 10 : gfc_expr *class_e = gfc_find_and_cut_at_last_class_ref (e);
2313 10 : gfc_conv_expr (&se, class_e);
2314 10 : gfc_free_expr (class_e);
2315 10 : need_len_assign = false;
2316 10 : }
2317 : else
2318 : {
2319 : /* For BT_CLASS and BT_DERIVED, this boils down to a pointer assign,
2320 : which has the string length included. For CHARACTERS it is still
2321 : needed and will be done at the end of this routine. */
2322 2949 : gfc_conv_expr (&se, e);
2323 2949 : need_len_assign = need_len_assign && sym->ts.type == BT_CHARACTER;
2324 : }
2325 :
2326 3663 : if (sym->ts.type == BT_CHARACTER
2327 579 : && !sym->attr.select_type_temporary
2328 139 : && VAR_P (sym->ts.u.cl->backend_decl)
2329 79 : && se.string_length != sym->ts.u.cl->backend_decl)
2330 : {
2331 79 : gfc_add_modify (&se.pre, sym->ts.u.cl->backend_decl,
2332 79 : fold_convert (TREE_TYPE (sym->ts.u.cl->backend_decl),
2333 : se.string_length));
2334 79 : if (e->expr_type == EXPR_FUNCTION && gfc_expr_attr (e).pointer)
2335 : {
2336 : /* For an allocatable function result, the result temporary
2337 : is already freed by the procedure call's cleanup code;
2338 : freeing it again here would be a double free. A pointer
2339 : result is not freed there, so do it here. */
2340 6 : tmp = gfc_call_free (sym->backend_decl);
2341 6 : gfc_add_expr_to_block (&se.post, tmp);
2342 : }
2343 : }
2344 :
2345 579 : if (sym->ts.type == BT_CHARACTER && e->ts.type == BT_CHARACTER
2346 3802 : && POINTER_TYPE_P (TREE_TYPE (se.expr)))
2347 : {
2348 : /* These are pointer types already. */
2349 109 : tmp = fold_convert (TREE_TYPE (sym->backend_decl), se.expr);
2350 : }
2351 : else
2352 : {
2353 3554 : tree ctree = gfc_get_class_from_expr (se.expr);
2354 3554 : tmp = TREE_TYPE (sym->backend_decl);
2355 :
2356 3554 : if (sym->ts.type == BT_CLASS && e->ts.type == BT_CLASS)
2357 : {
2358 : /* F2018:19.5.1.6 "If a selector has the POINTER attribute,
2359 : it shall be associated; the associate name is associated
2360 : with the target of the pointer and does not have the
2361 : POINTER attribute." */
2362 719 : if (e->rank == 0 && ctree
2363 1992 : && (!GFC_CLASS_TYPE_P (TREE_TYPE (se.expr))
2364 624 : || CLASS_DATA (e)->attr.class_pointer))
2365 : {
2366 310 : tree stmp;
2367 310 : tree dtmp;
2368 310 : tree ctmp;
2369 :
2370 310 : ctmp = ctree;
2371 310 : dtmp = TREE_TYPE (TREE_TYPE (sym->backend_decl));
2372 310 : ctree = gfc_create_var (dtmp, "class");
2373 :
2374 310 : if (IS_INFERRED_TYPE (e)
2375 6 : && !GFC_CLASS_TYPE_P (TREE_TYPE (se.expr)))
2376 : stmp = se.expr;
2377 : else
2378 310 : stmp = gfc_class_data_get (ctmp);
2379 :
2380 310 : if (!CLASS_DATA (sym)->attr.codimension
2381 310 : && !POINTER_TYPE_P (TREE_TYPE (stmp)))
2382 0 : stmp = gfc_build_addr_expr (NULL, stmp);
2383 :
2384 310 : dtmp = gfc_class_data_get (ctree);
2385 310 : stmp = build1 (VIEW_CONVERT_EXPR, TREE_TYPE (dtmp), stmp);
2386 310 : gfc_add_modify (&se.pre, dtmp, stmp);
2387 310 : stmp = gfc_class_vptr_get (ctmp);
2388 310 : dtmp = gfc_class_vptr_get (ctree);
2389 310 : stmp = fold_convert (TREE_TYPE (dtmp), stmp);
2390 310 : gfc_add_modify (&se.pre, dtmp, stmp);
2391 310 : if (UNLIMITED_POLY (sym))
2392 : {
2393 78 : stmp = gfc_class_len_get (ctmp);
2394 78 : dtmp = gfc_class_len_get (ctree);
2395 78 : stmp = fold_convert (TREE_TYPE (dtmp), stmp);
2396 78 : gfc_add_modify (&se.pre, dtmp, stmp);
2397 78 : need_len_assign = false;
2398 : }
2399 310 : se.expr = ctree;
2400 : }
2401 963 : else if (CLASS_DATA (sym)->attr.codimension)
2402 : {
2403 28 : gfc_conv_class_to_class (&se, e, sym->ts, false, false, false,
2404 : false);
2405 28 : tmp = se.expr;
2406 : }
2407 : }
2408 : /* For non-pointer types in se.expr, the first condition holds.
2409 : For pointer or reference types in se.expr, a double TREE_TYPE ()
2410 : is possible and an associate variable always is a pointer. */
2411 7079 : if (!POINTER_TYPE_P (TREE_TYPE (se.expr))
2412 3554 : || TREE_TYPE (TREE_TYPE (se.expr))
2413 29 : != TREE_TYPE (TREE_TYPE (sym->backend_decl)))
2414 3526 : tmp = gfc_build_addr_expr (tmp, se.expr);
2415 : }
2416 :
2417 3663 : gfc_add_modify (&se.pre, sym->backend_decl, tmp);
2418 :
2419 3663 : gfc_add_init_cleanup (block, gfc_finish_block( &se.pre),
2420 : gfc_finish_block (&se.post));
2421 : }
2422 :
2423 : /* Do a simple assignment. This is for scalar expressions, where we
2424 : can simply use expression assignment. */
2425 : else
2426 : {
2427 580 : gfc_expr *lhs;
2428 580 : tree res;
2429 580 : gfc_se se;
2430 580 : stmtblock_t final_block;
2431 :
2432 580 : gfc_init_se (&se, NULL);
2433 :
2434 : /* resolve.cc converts some associate names to allocatable so that
2435 : allocation can take place automatically in gfc_trans_assignment.
2436 : The frontend prevents them from being either allocated,
2437 : deallocated or reallocated. */
2438 580 : if (sym->ts.type == BT_DERIVED
2439 130 : && sym->ts.u.derived->attr.alloc_comp)
2440 : {
2441 26 : tmp = sym->backend_decl;
2442 26 : tmp = gfc_nullify_alloc_comp (sym->ts.u.derived, tmp,
2443 26 : sym->attr.dimension ? sym->as->rank : 0);
2444 26 : gfc_add_expr_to_block (&se.pre, tmp);
2445 : }
2446 :
2447 580 : if (sym->attr.allocatable)
2448 : {
2449 12 : tmp = sym->backend_decl;
2450 12 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
2451 0 : gfc_conv_descriptor_data_set (&se.pre, tmp, null_pointer_node);
2452 : else
2453 12 : gfc_add_modify (&se.pre, tmp,
2454 12 : fold_convert (TREE_TYPE (tmp), null_pointer_node));
2455 : }
2456 :
2457 580 : lhs = gfc_lval_expr_from_sym (sym);
2458 580 : lhs->must_finalize = 0;
2459 580 : res = gfc_trans_assignment (lhs, e, false, true);
2460 580 : gfc_add_expr_to_block (&se.pre, res);
2461 :
2462 580 : gfc_init_block (&final_block);
2463 :
2464 580 : if (sym->attr.associate_var
2465 580 : && sym->ts.type == BT_DERIVED
2466 130 : && sym->ts.u.derived->attr.defined_assign_comp
2467 0 : && gfc_may_be_finalized (sym->ts)
2468 580 : && e->expr_type == EXPR_FUNCTION)
2469 : {
2470 0 : gfc_expr *ef;
2471 0 : ef = gfc_lval_expr_from_sym (sym);
2472 0 : gfc_add_finalizer_call (&final_block, ef);
2473 0 : gfc_free_expr (ef);
2474 : }
2475 :
2476 580 : if (sym->ts.type == BT_DERIVED
2477 130 : && sym->ts.u.derived->attr.alloc_comp)
2478 : {
2479 26 : tmp = sym->backend_decl;
2480 26 : tmp = gfc_deallocate_alloc_comp (sym->ts.u.derived,
2481 : tmp, 0);
2482 26 : gfc_add_expr_to_block (&final_block, tmp);
2483 : }
2484 :
2485 580 : tmp = sym->backend_decl;
2486 580 : if (e->expr_type == EXPR_FUNCTION && IS_PDT (sym))
2487 : {
2488 15 : tmp = gfc_deallocate_pdt_comp (sym->ts.u.derived, tmp,
2489 : 0);
2490 : }
2491 565 : else if (e->expr_type == EXPR_FUNCTION && IS_CLASS_PDT (sym))
2492 : {
2493 0 : tmp = gfc_class_data_get (tmp);
2494 0 : tmp = gfc_deallocate_pdt_comp (CLASS_DATA (sym)->ts.u.derived,
2495 : tmp, 0);
2496 : }
2497 565 : else if (sym->attr.allocatable)
2498 : {
2499 12 : tmp = sym->backend_decl;
2500 :
2501 12 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
2502 0 : tmp = gfc_conv_descriptor_data_get (tmp);
2503 :
2504 : /* A simple call to free suffices here. */
2505 12 : tmp = gfc_call_free (tmp);
2506 :
2507 : /* Make sure that reallocation on assignment cannot occur. */
2508 12 : sym->attr.allocatable = 0;
2509 : }
2510 : else
2511 : tmp = NULL_TREE;
2512 :
2513 580 : gfc_add_expr_to_block (&final_block, tmp);
2514 580 : tmp = gfc_finish_block (&final_block);
2515 580 : res = gfc_finish_block (&se.pre);
2516 580 : gfc_add_init_cleanup (block, res, tmp);
2517 580 : gfc_free_expr (lhs);
2518 : }
2519 :
2520 : /* Set the stringlength, when needed. */
2521 7826 : if (need_len_assign)
2522 : {
2523 754 : gfc_se se;
2524 754 : gfc_init_se (&se, NULL);
2525 754 : if (e->symtree->n.sym->ts.type == BT_CHARACTER)
2526 : {
2527 : /* Deferred strings are dealt with in the preceding. */
2528 0 : gcc_assert (!e->symtree->n.sym->ts.deferred);
2529 0 : tmp = e->symtree->n.sym->ts.u.cl->backend_decl;
2530 : }
2531 754 : else if (e->symtree->n.sym->attr.function
2532 12 : && e->symtree->n.sym == e->symtree->n.sym->result)
2533 : {
2534 12 : tmp = gfc_get_fake_result_decl (e->symtree->n.sym, 0);
2535 12 : tmp = gfc_class_len_get (tmp);
2536 : }
2537 : else
2538 742 : tmp = gfc_class_len_get (gfc_get_symbol_decl (e->symtree->n.sym));
2539 754 : gfc_get_symbol_decl (sym);
2540 754 : charlen = sym->ts.type == BT_CHARACTER ? sym->ts.u.cl->backend_decl
2541 0 : : gfc_class_len_get (sym->backend_decl);
2542 : /* Prevent adding a noop len= len. */
2543 754 : if (tmp != charlen)
2544 : {
2545 754 : gfc_add_modify (&se.pre, charlen,
2546 754 : fold_convert (TREE_TYPE (charlen), tmp));
2547 754 : gfc_add_init_cleanup (block, gfc_finish_block (&se.pre),
2548 : gfc_finish_block (&se.post));
2549 : }
2550 : }
2551 7826 : }
2552 :
2553 :
2554 : /* Translate a BLOCK construct. This is basically what we would do for a
2555 : procedure body. */
2556 :
2557 : tree
2558 14826 : gfc_trans_block_construct (gfc_code* code)
2559 : {
2560 14826 : gfc_namespace* ns;
2561 14826 : gfc_symbol* sym;
2562 14826 : gfc_wrapped_block block;
2563 14826 : tree exit_label;
2564 14826 : stmtblock_t body;
2565 14826 : gfc_association_list *ass;
2566 14826 : tree translated_body;
2567 :
2568 14826 : ns = code->ext.block.ns;
2569 14826 : gcc_assert (ns);
2570 14826 : sym = ns->proc_name;
2571 14826 : gcc_assert (sym);
2572 :
2573 : /* Process local variables. */
2574 14826 : gcc_assert (!sym->tlink);
2575 14826 : sym->tlink = sym;
2576 14826 : gfc_process_block_locals (ns);
2577 :
2578 : /* Generate code including exit-label. */
2579 14826 : gfc_init_block (&body);
2580 14826 : exit_label = gfc_build_label_decl (NULL_TREE);
2581 14826 : code->exit_label = exit_label;
2582 :
2583 14826 : finish_oacc_declare (ns, sym, true);
2584 :
2585 14826 : translated_body = gfc_trans_code (ns->code);
2586 14826 : if (ns->omp_structured_block)
2587 457 : translated_body = build1 (OMP_STRUCTURED_BLOCK, void_type_node,
2588 : translated_body);
2589 14826 : gfc_add_expr_to_block (&body, translated_body);
2590 14826 : gfc_add_expr_to_block (&body, build1_v (LABEL_EXPR, exit_label));
2591 :
2592 : /* Finish everything. */
2593 14826 : gfc_start_wrapped_block (&block, gfc_finish_block (&body));
2594 14826 : gfc_trans_deferred_vars (sym, &block);
2595 22652 : for (ass = code->ext.block.assoc; ass; ass = ass->next)
2596 7826 : trans_associate_var (ass->st->n.sym, &block);
2597 :
2598 14826 : return gfc_finish_wrapped_block (&block);
2599 : }
2600 :
2601 : /* Translate the simple DO construct in a C-style manner.
2602 : This is where the loop variable has integer type and step +-1.
2603 : Following code will generate infinite loop in case where TO is INT_MAX
2604 : (for +1 step) or INT_MIN (for -1 step)
2605 :
2606 : We translate a do loop from:
2607 :
2608 : DO dovar = from, to, step
2609 : body
2610 : END DO
2611 :
2612 : to:
2613 :
2614 : [Evaluate loop bounds and step]
2615 : dovar = from;
2616 : for (;;)
2617 : {
2618 : if (dovar > to)
2619 : goto end_label;
2620 : body;
2621 : cycle_label:
2622 : dovar += step;
2623 : }
2624 : end_label:
2625 :
2626 : This helps the optimizers by avoiding the extra pre-header condition and
2627 : we save a register as we just compare the updated IV (not a value in
2628 : previous step). */
2629 :
2630 : static tree
2631 27798 : gfc_trans_simple_do (gfc_code * code, stmtblock_t *pblock, tree dovar,
2632 : tree from, tree to, tree step, tree exit_cond)
2633 : {
2634 27798 : stmtblock_t body;
2635 27798 : tree type;
2636 27798 : tree cond;
2637 27798 : tree tmp;
2638 27798 : tree saved_dovar = NULL;
2639 27798 : tree cycle_label;
2640 27798 : tree exit_label;
2641 27798 : location_t loc;
2642 27798 : type = TREE_TYPE (dovar);
2643 27798 : bool is_step_positive = tree_int_cst_sgn (step) > 0;
2644 :
2645 27798 : loc = gfc_get_location (&code->ext.iterator->start->where);
2646 :
2647 : /* Initialize the DO variable: dovar = from. */
2648 27798 : gfc_add_modify_loc (loc, pblock, dovar,
2649 27798 : fold_convert (TREE_TYPE (dovar), from));
2650 :
2651 : /* Save value for do-tinkering checking. */
2652 27798 : if (gfc_option.rtcheck & GFC_RTCHECK_DO)
2653 : {
2654 191 : saved_dovar = gfc_create_var (type, ".saved_dovar");
2655 191 : gfc_add_modify_loc (loc, pblock, saved_dovar, dovar);
2656 : }
2657 :
2658 : /* Cycle and exit statements are implemented with gotos. */
2659 27798 : cycle_label = gfc_build_label_decl (NULL_TREE);
2660 27798 : exit_label = gfc_build_label_decl (NULL_TREE);
2661 :
2662 : /* Put the labels where they can be found later. See gfc_trans_do(). */
2663 27798 : code->cycle_label = cycle_label;
2664 27798 : code->exit_label = exit_label;
2665 :
2666 : /* Loop body. */
2667 27798 : gfc_start_block (&body);
2668 :
2669 : /* Exit the loop if there is an I/O result condition or error. */
2670 27798 : if (exit_cond)
2671 : {
2672 322 : tmp = build1_v (GOTO_EXPR, exit_label);
2673 322 : tmp = fold_build3_loc (loc, COND_EXPR, void_type_node,
2674 : exit_cond, tmp,
2675 : build_empty_stmt (loc));
2676 322 : gfc_add_expr_to_block (&body, tmp);
2677 : }
2678 :
2679 : /* Evaluate the loop condition. */
2680 27798 : if (is_step_positive)
2681 27684 : cond = fold_build2_loc (loc, GT_EXPR, logical_type_node, dovar,
2682 : fold_convert (type, to));
2683 : else
2684 114 : cond = fold_build2_loc (loc, LT_EXPR, logical_type_node, dovar,
2685 : fold_convert (type, to));
2686 :
2687 27798 : cond = gfc_evaluate_now_loc (loc, cond, &body);
2688 27798 : if (code->ext.iterator->annot.unroll && cond != error_mark_node)
2689 12 : cond
2690 12 : = build3 (ANNOTATE_EXPR, TREE_TYPE (cond), cond,
2691 : build_int_cst (integer_type_node, annot_expr_unroll_kind),
2692 : build_int_cst (integer_type_node,
2693 12 : code->ext.iterator->annot.unroll));
2694 :
2695 27798 : if (code->ext.iterator->annot.ivdep && cond != error_mark_node)
2696 2 : cond = build3 (ANNOTATE_EXPR, TREE_TYPE (cond), cond,
2697 : build_int_cst (integer_type_node, annot_expr_ivdep_kind),
2698 : integer_zero_node);
2699 27798 : if (code->ext.iterator->annot.vector && cond != error_mark_node)
2700 2 : cond = build3 (ANNOTATE_EXPR, TREE_TYPE (cond), cond,
2701 : build_int_cst (integer_type_node, annot_expr_vector_kind),
2702 : integer_zero_node);
2703 27798 : if (code->ext.iterator->annot.novector && cond != error_mark_node)
2704 2 : cond = build3 (ANNOTATE_EXPR, TREE_TYPE (cond), cond,
2705 : build_int_cst (integer_type_node, annot_expr_no_vector_kind),
2706 : integer_zero_node);
2707 :
2708 : /* The loop exit. */
2709 27798 : tmp = fold_build1_loc (loc, GOTO_EXPR, void_type_node, exit_label);
2710 27798 : TREE_USED (exit_label) = 1;
2711 27798 : tmp = fold_build3_loc (loc, COND_EXPR, void_type_node,
2712 : cond, tmp, build_empty_stmt (loc));
2713 27798 : gfc_add_expr_to_block (&body, tmp);
2714 :
2715 : /* Check whether the induction variable is equal to INT_MAX
2716 : (respectively to INT_MIN). */
2717 27798 : if (gfc_option.rtcheck & GFC_RTCHECK_DO)
2718 : {
2719 191 : tree boundary = is_step_positive ? TYPE_MAX_VALUE (type)
2720 191 : : TYPE_MIN_VALUE (type);
2721 :
2722 191 : tmp = fold_build2_loc (loc, EQ_EXPR, logical_type_node,
2723 : dovar, boundary);
2724 191 : gfc_trans_runtime_check (true, false, tmp, &body, &code->loc,
2725 : "Loop iterates infinitely");
2726 : }
2727 :
2728 : /* Main loop body. */
2729 27798 : tmp = gfc_trans_code_cond (code->block->next, exit_cond);
2730 27798 : gfc_add_expr_to_block (&body, tmp);
2731 :
2732 : /* Label for cycle statements (if needed). */
2733 27798 : if (TREE_USED (cycle_label))
2734 : {
2735 27798 : tmp = build1_v (LABEL_EXPR, cycle_label);
2736 27798 : gfc_add_expr_to_block (&body, tmp);
2737 : }
2738 :
2739 : /* Check whether someone has modified the loop variable. */
2740 27798 : if (gfc_option.rtcheck & GFC_RTCHECK_DO)
2741 : {
2742 191 : tmp = fold_build2_loc (loc, NE_EXPR, logical_type_node,
2743 : dovar, saved_dovar);
2744 191 : gfc_trans_runtime_check (true, false, tmp, &body, &code->loc,
2745 : "Loop variable has been modified");
2746 : }
2747 :
2748 : /* Increment the loop variable. */
2749 27798 : tmp = fold_build2_loc (loc, PLUS_EXPR, type, dovar, step);
2750 27798 : gfc_add_modify_loc (loc, &body, dovar, tmp);
2751 :
2752 27798 : if (gfc_option.rtcheck & GFC_RTCHECK_DO)
2753 191 : gfc_add_modify_loc (loc, &body, saved_dovar, dovar);
2754 :
2755 : /* Finish the loop body. */
2756 27798 : tmp = gfc_finish_block (&body);
2757 27798 : tmp = fold_build1_loc (loc, LOOP_EXPR, void_type_node, tmp);
2758 :
2759 27798 : gfc_add_expr_to_block (pblock, tmp);
2760 :
2761 : /* Add the exit label. */
2762 27798 : tmp = build1_v (LABEL_EXPR, exit_label);
2763 27798 : gfc_add_expr_to_block (pblock, tmp);
2764 :
2765 27798 : return gfc_finish_block (pblock);
2766 : }
2767 :
2768 : /* Translate the DO construct. This obviously is one of the most
2769 : important ones to get right with any compiler, but especially
2770 : so for Fortran.
2771 :
2772 : We special case some loop forms as described in gfc_trans_simple_do.
2773 : For other cases we implement them with a separate loop count,
2774 : as described in the standard.
2775 :
2776 : We translate a do loop from:
2777 :
2778 : DO dovar = from, to, step
2779 : body
2780 : END DO
2781 :
2782 : to:
2783 :
2784 : [evaluate loop bounds and step]
2785 : empty = (step > 0 ? to < from : to > from);
2786 : countm1 = (to - from) / step;
2787 : dovar = from;
2788 : if (empty) goto exit_label;
2789 : for (;;)
2790 : {
2791 : body;
2792 : cycle_label:
2793 : dovar += step
2794 : countm1t = countm1;
2795 : countm1--;
2796 : if (countm1t == 0) goto exit_label;
2797 : }
2798 : exit_label:
2799 :
2800 : countm1 is an unsigned integer. It is equal to the loop count minus one,
2801 : because the loop count itself can overflow. */
2802 :
2803 : tree
2804 28912 : gfc_trans_do (gfc_code * code, tree exit_cond)
2805 : {
2806 28912 : gfc_se se;
2807 28912 : tree dovar;
2808 28912 : tree saved_dovar = NULL;
2809 28912 : tree from;
2810 28912 : tree to;
2811 28912 : tree step;
2812 28912 : tree countm1;
2813 28912 : tree type;
2814 28912 : tree utype;
2815 28912 : tree cond;
2816 28912 : tree cycle_label;
2817 28912 : tree exit_label;
2818 28912 : tree tmp;
2819 28912 : stmtblock_t block;
2820 28912 : stmtblock_t body;
2821 28912 : location_t loc;
2822 :
2823 28912 : gfc_start_block (&block);
2824 :
2825 28912 : loc = gfc_get_location (&code->ext.iterator->start->where);
2826 :
2827 : /* Evaluate all the expressions in the iterator. */
2828 28912 : gfc_init_se (&se, NULL);
2829 28912 : gfc_conv_expr_lhs (&se, code->ext.iterator->var);
2830 28912 : gfc_add_block_to_block (&block, &se.pre);
2831 28912 : dovar = se.expr;
2832 28912 : type = TREE_TYPE (dovar);
2833 :
2834 28912 : gfc_init_se (&se, NULL);
2835 28912 : gfc_conv_expr_val (&se, code->ext.iterator->start);
2836 28912 : gfc_add_block_to_block (&block, &se.pre);
2837 28912 : from = gfc_evaluate_now (se.expr, &block);
2838 :
2839 28912 : gfc_init_se (&se, NULL);
2840 28912 : gfc_conv_expr_val (&se, code->ext.iterator->end);
2841 28912 : gfc_add_block_to_block (&block, &se.pre);
2842 28912 : to = gfc_evaluate_now (se.expr, &block);
2843 :
2844 28912 : gfc_init_se (&se, NULL);
2845 28912 : gfc_conv_expr_val (&se, code->ext.iterator->step);
2846 28912 : gfc_add_block_to_block (&block, &se.pre);
2847 28912 : step = gfc_evaluate_now (se.expr, &block);
2848 :
2849 28912 : if (gfc_option.rtcheck & GFC_RTCHECK_DO)
2850 : {
2851 203 : tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, step,
2852 : build_zero_cst (type));
2853 203 : gfc_trans_runtime_check (true, false, tmp, &block, &code->loc,
2854 : "DO step value is zero");
2855 : }
2856 :
2857 : /* Special case simple loops. */
2858 28912 : if (TREE_CODE (type) == INTEGER_TYPE
2859 28912 : && (integer_onep (step)
2860 1116 : || tree_int_cst_equal (step, integer_minus_one_node)))
2861 27798 : return gfc_trans_simple_do (code, &block, dovar, from, to, step,
2862 27798 : exit_cond);
2863 :
2864 1114 : if (TREE_CODE (type) == INTEGER_TYPE)
2865 1002 : utype = unsigned_type_for (type);
2866 : else
2867 112 : utype = unsigned_type_for (gfc_array_index_type);
2868 1114 : countm1 = gfc_create_var (utype, "countm1");
2869 :
2870 : /* Cycle and exit statements are implemented with gotos. */
2871 1114 : cycle_label = gfc_build_label_decl (NULL_TREE);
2872 1114 : exit_label = gfc_build_label_decl (NULL_TREE);
2873 1114 : TREE_USED (exit_label) = 1;
2874 :
2875 : /* Put these labels where they can be found later. */
2876 1114 : code->cycle_label = cycle_label;
2877 1114 : code->exit_label = exit_label;
2878 :
2879 : /* Initialize the DO variable: dovar = from. */
2880 1114 : gfc_add_modify (&block, dovar, from);
2881 :
2882 : /* Save value for do-tinkering checking. */
2883 1114 : if (gfc_option.rtcheck & GFC_RTCHECK_DO)
2884 : {
2885 12 : saved_dovar = gfc_create_var (type, ".saved_dovar");
2886 12 : gfc_add_modify_loc (loc, &block, saved_dovar, dovar);
2887 : }
2888 :
2889 : /* Initialize loop count and jump to exit label if the loop is empty.
2890 : This code is executed before we enter the loop body. We generate:
2891 : if (step > 0)
2892 : {
2893 : countm1 = (to - from) / step;
2894 : if (to < from)
2895 : goto exit_label;
2896 : }
2897 : else
2898 : {
2899 : countm1 = (from - to) / -step;
2900 : if (to > from)
2901 : goto exit_label;
2902 : }
2903 : */
2904 :
2905 1114 : if (TREE_CODE (type) == INTEGER_TYPE)
2906 : {
2907 1002 : tree pos, neg, tou, fromu, stepu, tmp2;
2908 :
2909 : /* The distance from FROM to TO cannot always be represented in a signed
2910 : type, thus use unsigned arithmetic, also to avoid any undefined
2911 : overflow issues. */
2912 1002 : tou = fold_convert (utype, to);
2913 1002 : fromu = fold_convert (utype, from);
2914 1002 : stepu = fold_convert (utype, step);
2915 :
2916 : /* For a positive step, when to < from, exit, otherwise compute
2917 : countm1 = ((unsigned)to - (unsigned)from) / (unsigned)step */
2918 1002 : tmp = fold_build2_loc (loc, LT_EXPR, logical_type_node, to, from);
2919 1002 : tmp2 = fold_build2_loc (loc, TRUNC_DIV_EXPR, utype,
2920 : fold_build2_loc (loc, MINUS_EXPR, utype,
2921 : tou, fromu),
2922 : stepu);
2923 1002 : pos = build2 (COMPOUND_EXPR, void_type_node,
2924 : fold_build2 (MODIFY_EXPR, void_type_node,
2925 : countm1, tmp2),
2926 : build3_loc (loc, COND_EXPR, void_type_node,
2927 : gfc_unlikely (tmp, PRED_FORTRAN_LOOP_PREHEADER),
2928 : build1_loc (loc, GOTO_EXPR, void_type_node,
2929 : exit_label), NULL_TREE));
2930 :
2931 : /* For a negative step, when to > from, exit, otherwise compute
2932 : countm1 = ((unsigned)from - (unsigned)to) / -(unsigned)step */
2933 1002 : tmp = fold_build2_loc (loc, GT_EXPR, logical_type_node, to, from);
2934 1002 : tmp2 = fold_build2_loc (loc, TRUNC_DIV_EXPR, utype,
2935 : fold_build2_loc (loc, MINUS_EXPR, utype,
2936 : fromu, tou),
2937 : fold_build1_loc (loc, NEGATE_EXPR, utype, stepu));
2938 1002 : neg = build2 (COMPOUND_EXPR, void_type_node,
2939 : fold_build2 (MODIFY_EXPR, void_type_node,
2940 : countm1, tmp2),
2941 : build3_loc (loc, COND_EXPR, void_type_node,
2942 : gfc_unlikely (tmp, PRED_FORTRAN_LOOP_PREHEADER),
2943 : build1_loc (loc, GOTO_EXPR, void_type_node,
2944 : exit_label), NULL_TREE));
2945 :
2946 1002 : tmp = fold_build2_loc (loc, LT_EXPR, logical_type_node, step,
2947 1002 : build_int_cst (TREE_TYPE (step), 0));
2948 1002 : tmp = fold_build3_loc (loc, COND_EXPR, void_type_node, tmp, neg, pos);
2949 :
2950 1002 : gfc_add_expr_to_block (&block, tmp);
2951 : }
2952 : else
2953 : {
2954 112 : tree pos_step;
2955 :
2956 : /* TODO: We could use the same width as the real type.
2957 : This would probably cause more problems that it solves
2958 : when we implement "long double" types. */
2959 :
2960 112 : tmp = fold_build2_loc (loc, MINUS_EXPR, type, to, from);
2961 112 : tmp = fold_build2_loc (loc, RDIV_EXPR, type, tmp, step);
2962 112 : tmp = fold_build1_loc (loc, FIX_TRUNC_EXPR, utype, tmp);
2963 112 : gfc_add_modify (&block, countm1, tmp);
2964 :
2965 : /* We need a special check for empty loops:
2966 : empty = (step > 0 ? to < from : to > from); */
2967 112 : pos_step = fold_build2_loc (loc, GT_EXPR, logical_type_node, step,
2968 : build_zero_cst (type));
2969 112 : tmp = fold_build3_loc (loc, COND_EXPR, logical_type_node, pos_step,
2970 : fold_build2_loc (loc, LT_EXPR,
2971 : logical_type_node, to, from),
2972 : fold_build2_loc (loc, GT_EXPR,
2973 : logical_type_node, to, from));
2974 : /* If the loop is empty, go directly to the exit label. */
2975 112 : tmp = fold_build3_loc (loc, COND_EXPR, void_type_node, tmp,
2976 : build1_v (GOTO_EXPR, exit_label),
2977 : build_empty_stmt (input_location));
2978 112 : gfc_add_expr_to_block (&block, tmp);
2979 : }
2980 :
2981 : /* Loop body. */
2982 1114 : gfc_start_block (&body);
2983 :
2984 : /* Main loop body. */
2985 1114 : tmp = gfc_trans_code_cond (code->block->next, exit_cond);
2986 1114 : gfc_add_expr_to_block (&body, tmp);
2987 :
2988 : /* Label for cycle statements (if needed). */
2989 1114 : if (TREE_USED (cycle_label))
2990 : {
2991 1114 : tmp = build1_v (LABEL_EXPR, cycle_label);
2992 1114 : gfc_add_expr_to_block (&body, tmp);
2993 : }
2994 :
2995 : /* Check whether someone has modified the loop variable. */
2996 1114 : if (gfc_option.rtcheck & GFC_RTCHECK_DO)
2997 : {
2998 12 : tmp = fold_build2_loc (loc, NE_EXPR, logical_type_node, dovar,
2999 : saved_dovar);
3000 12 : gfc_trans_runtime_check (true, false, tmp, &body, &code->loc,
3001 : "Loop variable has been modified");
3002 : }
3003 :
3004 : /* Exit the loop if there is an I/O result condition or error. */
3005 1114 : if (exit_cond)
3006 : {
3007 1 : tmp = build1_v (GOTO_EXPR, exit_label);
3008 1 : tmp = fold_build3_loc (loc, COND_EXPR, void_type_node,
3009 : exit_cond, tmp,
3010 : build_empty_stmt (input_location));
3011 1 : gfc_add_expr_to_block (&body, tmp);
3012 : }
3013 :
3014 : /* Increment the loop variable. */
3015 1114 : tmp = fold_build2_loc (loc, PLUS_EXPR, type, dovar, step);
3016 1114 : gfc_add_modify_loc (loc, &body, dovar, tmp);
3017 :
3018 1114 : if (gfc_option.rtcheck & GFC_RTCHECK_DO)
3019 12 : gfc_add_modify_loc (loc, &body, saved_dovar, dovar);
3020 :
3021 : /* Initialize countm1t. */
3022 1114 : tree countm1t = gfc_create_var (utype, "countm1t");
3023 1114 : gfc_add_modify_loc (loc, &body, countm1t, countm1);
3024 :
3025 : /* Decrement the loop count. */
3026 1114 : tmp = fold_build2_loc (loc, MINUS_EXPR, utype, countm1,
3027 : build_int_cst (utype, 1));
3028 1114 : gfc_add_modify_loc (loc, &body, countm1, tmp);
3029 :
3030 : /* End with the loop condition. Loop until countm1t == 0. */
3031 1114 : cond = fold_build2_loc (loc, EQ_EXPR, logical_type_node, countm1t,
3032 : build_int_cst (utype, 0));
3033 1114 : if (code->ext.iterator->annot.unroll && cond != error_mark_node)
3034 3 : cond
3035 3 : = build3 (ANNOTATE_EXPR, TREE_TYPE (cond), cond,
3036 : build_int_cst (integer_type_node, annot_expr_unroll_kind),
3037 : build_int_cst (integer_type_node,
3038 3 : code->ext.iterator->annot.unroll));
3039 :
3040 1114 : if (code->ext.iterator->annot.ivdep && cond != error_mark_node)
3041 0 : cond = build3 (ANNOTATE_EXPR, TREE_TYPE (cond), cond,
3042 : build_int_cst (integer_type_node, annot_expr_ivdep_kind),
3043 : integer_zero_node);
3044 1114 : if (code->ext.iterator->annot.vector && cond != error_mark_node)
3045 0 : cond = build3 (ANNOTATE_EXPR, TREE_TYPE (cond), cond,
3046 : build_int_cst (integer_type_node, annot_expr_vector_kind),
3047 : integer_zero_node);
3048 1114 : if (code->ext.iterator->annot.novector && cond != error_mark_node)
3049 0 : cond = build3 (ANNOTATE_EXPR, TREE_TYPE (cond), cond,
3050 : build_int_cst (integer_type_node, annot_expr_no_vector_kind),
3051 : integer_zero_node);
3052 :
3053 1114 : tmp = fold_build1_loc (loc, GOTO_EXPR, void_type_node, exit_label);
3054 1114 : tmp = fold_build3_loc (loc, COND_EXPR, void_type_node,
3055 : cond, tmp, build_empty_stmt (loc));
3056 1114 : gfc_add_expr_to_block (&body, tmp);
3057 :
3058 : /* End of loop body. */
3059 1114 : tmp = gfc_finish_block (&body);
3060 :
3061 : /* The for loop itself. */
3062 1114 : tmp = fold_build1_loc (loc, LOOP_EXPR, void_type_node, tmp);
3063 1114 : gfc_add_expr_to_block (&block, tmp);
3064 :
3065 : /* Add the exit label. */
3066 1114 : tmp = build1_v (LABEL_EXPR, exit_label);
3067 1114 : gfc_add_expr_to_block (&block, tmp);
3068 :
3069 1114 : return gfc_finish_block (&block);
3070 : }
3071 :
3072 :
3073 : /* Translate the DO WHILE construct.
3074 :
3075 : We translate
3076 :
3077 : DO WHILE (cond)
3078 : body
3079 : END DO
3080 :
3081 : to:
3082 :
3083 : for ( ; ; )
3084 : {
3085 : pre_cond;
3086 : if (! cond) goto exit_label;
3087 : body;
3088 : cycle_label:
3089 : }
3090 : exit_label:
3091 :
3092 : Because the evaluation of the exit condition `cond' may have side
3093 : effects, we can't do much for empty loop bodies. The backend optimizers
3094 : should be smart enough to eliminate any dead loops. */
3095 :
3096 : tree
3097 523 : gfc_trans_do_while (gfc_code * code)
3098 : {
3099 523 : gfc_se cond;
3100 523 : tree tmp;
3101 523 : tree cycle_label;
3102 523 : tree exit_label;
3103 523 : stmtblock_t block;
3104 :
3105 : /* Everything we build here is part of the loop body. */
3106 523 : gfc_start_block (&block);
3107 :
3108 : /* Cycle and exit statements are implemented with gotos. */
3109 523 : cycle_label = gfc_build_label_decl (NULL_TREE);
3110 523 : exit_label = gfc_build_label_decl (NULL_TREE);
3111 :
3112 : /* Put the labels where they can be found later. See gfc_trans_do(). */
3113 523 : code->cycle_label = cycle_label;
3114 523 : code->exit_label = exit_label;
3115 :
3116 : /* Create a GIMPLE version of the exit condition. */
3117 523 : gfc_init_se (&cond, NULL);
3118 523 : gfc_conv_expr_val (&cond, code->expr1);
3119 523 : gfc_add_block_to_block (&block, &cond.pre);
3120 523 : cond.expr = fold_build1_loc (gfc_get_location (&code->expr1->where),
3121 523 : TRUTH_NOT_EXPR, TREE_TYPE (cond.expr),
3122 : cond.expr);
3123 :
3124 : /* Build "IF (! cond) GOTO exit_label". */
3125 523 : tmp = build1_v (GOTO_EXPR, exit_label);
3126 523 : TREE_USED (exit_label) = 1;
3127 523 : tmp = fold_build3_loc (gfc_get_location (&code->expr1->where), COND_EXPR,
3128 : void_type_node, cond.expr, tmp,
3129 : build_empty_stmt (gfc_get_location (
3130 523 : &code->expr1->where)));
3131 523 : gfc_add_expr_to_block (&block, tmp);
3132 :
3133 : /* The main body of the loop. */
3134 523 : tmp = gfc_trans_code (code->block->next);
3135 523 : gfc_add_expr_to_block (&block, tmp);
3136 :
3137 : /* Label for cycle statements (if needed). */
3138 523 : if (TREE_USED (cycle_label))
3139 : {
3140 523 : tmp = build1_v (LABEL_EXPR, cycle_label);
3141 523 : gfc_add_expr_to_block (&block, tmp);
3142 : }
3143 :
3144 : /* End of loop body. */
3145 523 : tmp = gfc_finish_block (&block);
3146 :
3147 523 : gfc_init_block (&block);
3148 : /* Build the loop. */
3149 523 : tmp = fold_build1_loc (gfc_get_location (&code->expr1->where), LOOP_EXPR,
3150 : void_type_node, tmp);
3151 523 : gfc_add_expr_to_block (&block, tmp);
3152 :
3153 : /* Add the exit label. */
3154 523 : tmp = build1_v (LABEL_EXPR, exit_label);
3155 523 : gfc_add_expr_to_block (&block, tmp);
3156 :
3157 523 : return gfc_finish_block (&block);
3158 : }
3159 :
3160 :
3161 : /* Deal with the particular case of SELECT_TYPE, where the vtable
3162 : addresses are used for the selection. Since these are not sorted,
3163 : the selection has to be made by a series of if statements. */
3164 :
3165 : static tree
3166 3136 : gfc_trans_select_type_cases (gfc_code * code)
3167 : {
3168 3136 : gfc_code *c;
3169 3136 : gfc_case *cp;
3170 3136 : tree tmp;
3171 3136 : tree cond;
3172 3136 : tree low;
3173 3136 : tree high;
3174 3136 : gfc_se se;
3175 3136 : gfc_se cse;
3176 3136 : stmtblock_t block;
3177 3136 : stmtblock_t body;
3178 3136 : bool def = false;
3179 3136 : gfc_expr *e;
3180 3136 : gfc_start_block (&block);
3181 :
3182 : /* Calculate the switch expression. */
3183 3136 : gfc_init_se (&se, NULL);
3184 3136 : gfc_conv_expr_val (&se, code->expr1);
3185 3136 : gfc_add_block_to_block (&block, &se.pre);
3186 :
3187 : /* Generate an expression for the selector hash value, for
3188 : use to resolve character cases. */
3189 3136 : e = gfc_copy_expr (code->expr1->value.function.actual->expr);
3190 3136 : gfc_add_hash_component (e);
3191 :
3192 3136 : TREE_USED (code->exit_label) = 0;
3193 :
3194 6272 : repeat:
3195 17224 : for (c = code->block; c; c = c->block)
3196 : {
3197 10952 : cp = c->ext.block.case_list;
3198 :
3199 : /* Assume it's the default case. */
3200 10952 : low = NULL_TREE;
3201 10952 : high = NULL_TREE;
3202 10952 : tmp = NULL_TREE;
3203 :
3204 : /* Put the default case at the end. */
3205 10952 : if ((!def && !cp->low) || (def && cp->low))
3206 5476 : continue;
3207 :
3208 5476 : if (cp->low && (cp->ts.type == BT_CLASS
3209 3550 : || cp->ts.type == BT_DERIVED))
3210 : {
3211 2039 : gfc_init_se (&cse, NULL);
3212 2039 : gfc_conv_expr_val (&cse, cp->low);
3213 2039 : gfc_add_block_to_block (&block, &cse.pre);
3214 2039 : low = cse.expr;
3215 : }
3216 3437 : else if (cp->ts.type != BT_UNKNOWN)
3217 : {
3218 1511 : gcc_assert (cp->high);
3219 1511 : gfc_init_se (&cse, NULL);
3220 1511 : gfc_conv_expr_val (&cse, cp->high);
3221 1511 : gfc_add_block_to_block (&block, &cse.pre);
3222 1511 : high = cse.expr;
3223 : }
3224 :
3225 5476 : gfc_init_block (&body);
3226 :
3227 : /* Add the statements for this case. */
3228 5476 : tmp = gfc_trans_code (c->next);
3229 5476 : gfc_add_expr_to_block (&body, tmp);
3230 :
3231 : /* Break to the end of the SELECT TYPE construct. The default
3232 : case just falls through. */
3233 5476 : if (!def)
3234 : {
3235 3550 : TREE_USED (code->exit_label) = 1;
3236 3550 : tmp = build1_v (GOTO_EXPR, code->exit_label);
3237 3550 : gfc_add_expr_to_block (&body, tmp);
3238 : }
3239 :
3240 5476 : tmp = gfc_finish_block (&body);
3241 :
3242 5476 : if (low != NULL_TREE)
3243 : {
3244 : /* Compare vtable pointers. */
3245 2039 : cond = fold_build2_loc (input_location, EQ_EXPR,
3246 2039 : TREE_TYPE (se.expr), se.expr, low);
3247 2039 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
3248 : cond, tmp,
3249 : build_empty_stmt (input_location));
3250 : }
3251 3437 : else if (high != NULL_TREE)
3252 : {
3253 : /* Compare hash values for character cases. */
3254 1511 : gfc_init_se (&cse, NULL);
3255 1511 : gfc_conv_expr_val (&cse, e);
3256 1511 : gfc_add_block_to_block (&block, &cse.pre);
3257 :
3258 1511 : cond = fold_build2_loc (input_location, EQ_EXPR,
3259 1511 : TREE_TYPE (se.expr), high, cse.expr);
3260 1511 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
3261 : cond, tmp,
3262 : build_empty_stmt (input_location));
3263 : }
3264 :
3265 5476 : gfc_add_expr_to_block (&block, tmp);
3266 : }
3267 :
3268 6272 : if (!def)
3269 : {
3270 3136 : def = true;
3271 3136 : goto repeat;
3272 : }
3273 :
3274 3136 : gfc_free_expr (e);
3275 :
3276 3136 : return gfc_finish_block (&block);
3277 : }
3278 :
3279 :
3280 : /* Translate the SELECT CASE construct for INTEGER case expressions,
3281 : without killing all potential optimizations. The problem is that
3282 : Fortran allows unbounded cases, but the back-end does not, so we
3283 : need to intercept those before we enter the equivalent SWITCH_EXPR
3284 : we can build.
3285 :
3286 : For example, we translate this,
3287 :
3288 : SELECT CASE (expr)
3289 : CASE (:100,101,105:115)
3290 : block_1
3291 : CASE (190:199,200:)
3292 : block_2
3293 : CASE (300)
3294 : block_3
3295 : CASE DEFAULT
3296 : block_4
3297 : END SELECT
3298 :
3299 : to the GENERIC equivalent,
3300 :
3301 : switch (expr)
3302 : {
3303 : case (minimum value for typeof(expr) ... 100:
3304 : case 101:
3305 : case 105 ... 114:
3306 : block1:
3307 : goto end_label;
3308 :
3309 : case 200 ... (maximum value for typeof(expr):
3310 : case 190 ... 199:
3311 : block2;
3312 : goto end_label;
3313 :
3314 : case 300:
3315 : block_3;
3316 : goto end_label;
3317 :
3318 : default:
3319 : block_4;
3320 : goto end_label;
3321 : }
3322 :
3323 : end_label: */
3324 :
3325 : static tree
3326 1000 : gfc_trans_integer_select (gfc_code * code)
3327 : {
3328 1000 : gfc_code *c;
3329 1000 : gfc_case *cp;
3330 1000 : tree end_label;
3331 1000 : tree tmp;
3332 1000 : gfc_se se;
3333 1000 : stmtblock_t block;
3334 1000 : stmtblock_t body;
3335 :
3336 1000 : gfc_start_block (&block);
3337 :
3338 : /* Calculate the switch expression. */
3339 1000 : gfc_init_se (&se, NULL);
3340 1000 : gfc_conv_expr_val (&se, code->expr1);
3341 1000 : gfc_add_block_to_block (&block, &se.pre);
3342 :
3343 1000 : end_label = gfc_build_label_decl (NULL_TREE);
3344 :
3345 1000 : gfc_init_block (&body);
3346 :
3347 2988 : for (c = code->block; c; c = c->block)
3348 : {
3349 4048 : for (cp = c->ext.block.case_list; cp; cp = cp->next)
3350 : {
3351 2060 : tree low, high;
3352 2060 : tree label;
3353 :
3354 : /* Assume it's the default case. */
3355 2060 : low = high = NULL_TREE;
3356 :
3357 2060 : if (cp->low)
3358 : {
3359 1634 : if (cp->low->ts.type == BT_INTEGER)
3360 1592 : low = gfc_conv_mpz_to_tree (cp->low->value.integer,
3361 : cp->low->ts.kind);
3362 : else
3363 42 : low = gfc_conv_mpz_unsigned_to_tree (cp->low->value.integer,
3364 : cp->low->ts.kind);
3365 :
3366 : /* If there's only a lower bound, set the high bound to the
3367 : maximum value of the case expression. */
3368 1634 : if (!cp->high)
3369 45 : high = TYPE_MAX_VALUE (TREE_TYPE (se.expr));
3370 : }
3371 :
3372 2060 : if (cp->high)
3373 : {
3374 : /* Three cases are possible here:
3375 :
3376 : 1) There is no lower bound, e.g. CASE (:N).
3377 : 2) There is a lower bound .NE. high bound, that is
3378 : a case range, e.g. CASE (N:M) where M>N (we make
3379 : sure that M>N during type resolution).
3380 : 3) There is a lower bound, and it has the same value
3381 : as the high bound, e.g. CASE (N:N). This is our
3382 : internal representation of CASE(N).
3383 :
3384 : In the first and second case, we need to set a value for
3385 : high. In the third case, we don't because the GCC middle
3386 : end represents a single case value by just letting high be
3387 : a NULL_TREE. We can't do that because we need to be able
3388 : to represent unbounded cases. */
3389 :
3390 1633 : if (!cp->low
3391 1589 : || (mpz_cmp (cp->low->value.integer,
3392 1589 : cp->high->value.integer) != 0))
3393 : {
3394 73 : if (cp->high->ts.type == BT_INTEGER)
3395 73 : high = gfc_conv_mpz_to_tree (cp->high->value.integer,
3396 : cp->high->ts.kind);
3397 : else
3398 0 : high
3399 0 : = gfc_conv_mpz_unsigned_to_tree (cp->high->value.integer,
3400 : cp->high->ts.kind);
3401 : }
3402 :
3403 : /* Unbounded case. */
3404 1633 : if (!cp->low)
3405 44 : low = TYPE_MIN_VALUE (TREE_TYPE (se.expr));
3406 : }
3407 :
3408 : /* Build a label. */
3409 2060 : label = gfc_build_label_decl (NULL_TREE);
3410 :
3411 : /* Add this case label.
3412 : Add parameter 'label', make it match GCC backend. */
3413 2060 : tmp = build_case_label (low, high, label);
3414 2060 : gfc_add_expr_to_block (&body, tmp);
3415 : }
3416 :
3417 : /* Add the statements for this case. */
3418 1988 : tmp = gfc_trans_code (c->next);
3419 1988 : gfc_add_expr_to_block (&body, tmp);
3420 :
3421 : /* Break to the end of the construct. */
3422 1988 : tmp = build1_v (GOTO_EXPR, end_label);
3423 1988 : gfc_add_expr_to_block (&body, tmp);
3424 : }
3425 :
3426 1000 : tmp = gfc_finish_block (&body);
3427 1000 : tmp = fold_build2_loc (input_location, SWITCH_EXPR, NULL_TREE, se.expr, tmp);
3428 1000 : gfc_add_expr_to_block (&block, tmp);
3429 :
3430 1000 : tmp = build1_v (LABEL_EXPR, end_label);
3431 1000 : gfc_add_expr_to_block (&block, tmp);
3432 :
3433 1000 : return gfc_finish_block (&block);
3434 : }
3435 :
3436 :
3437 : /* Translate the SELECT CASE construct for LOGICAL case expressions.
3438 :
3439 : There are only two cases possible here, even though the standard
3440 : does allow three cases in a LOGICAL SELECT CASE construct: .TRUE.,
3441 : .FALSE., and DEFAULT.
3442 :
3443 : We never generate more than two blocks here. Instead, we always
3444 : try to eliminate the DEFAULT case. This way, we can translate this
3445 : kind of SELECT construct to a simple
3446 :
3447 : if {} else {};
3448 :
3449 : expression in GENERIC. */
3450 :
3451 : static tree
3452 54 : gfc_trans_logical_select (gfc_code * code)
3453 : {
3454 54 : gfc_code *c;
3455 54 : gfc_code *t, *f, *d;
3456 54 : gfc_case *cp;
3457 54 : gfc_se se;
3458 54 : stmtblock_t block;
3459 :
3460 : /* Assume we don't have any cases at all. */
3461 54 : t = f = d = NULL;
3462 :
3463 : /* Now see which ones we actually do have. We can have at most two
3464 : cases in a single case list: one for .TRUE. and one for .FALSE.
3465 : The default case is always separate. If the cases for .TRUE. and
3466 : .FALSE. are in the same case list, the block for that case list
3467 : always executed, and we don't generate code a COND_EXPR. */
3468 171 : for (c = code->block; c; c = c->block)
3469 : {
3470 243 : for (cp = c->ext.block.case_list; cp; cp = cp->next)
3471 : {
3472 126 : if (cp->low)
3473 : {
3474 72 : if (cp->low->value.logical == 0) /* .FALSE. */
3475 : f = c;
3476 : else /* if (cp->value.logical != 0), thus .TRUE. */
3477 36 : t = c;
3478 : }
3479 : else
3480 : d = c;
3481 : }
3482 : }
3483 :
3484 : /* Start a new block. */
3485 54 : gfc_start_block (&block);
3486 :
3487 : /* Calculate the switch expression. We always need to do this
3488 : because it may have side effects. */
3489 54 : gfc_init_se (&se, NULL);
3490 54 : gfc_conv_expr_val (&se, code->expr1);
3491 54 : gfc_add_block_to_block (&block, &se.pre);
3492 :
3493 54 : if (t == f && t != NULL)
3494 : {
3495 : /* Cases for .TRUE. and .FALSE. are in the same block. Just
3496 : translate the code for these cases, append it to the current
3497 : block. */
3498 9 : gfc_add_expr_to_block (&block, gfc_trans_code (t->next));
3499 : }
3500 : else
3501 : {
3502 45 : tree true_tree, false_tree, stmt;
3503 :
3504 45 : true_tree = build_empty_stmt (input_location);
3505 45 : false_tree = build_empty_stmt (input_location);
3506 :
3507 : /* If we have a case for .TRUE. and for .FALSE., discard the default case.
3508 : Otherwise, if .TRUE. or .FALSE. is missing and there is a default case,
3509 : make the missing case the default case. */
3510 45 : if (t != NULL && f != NULL)
3511 63 : d = NULL;
3512 36 : else if (d != NULL)
3513 : {
3514 36 : if (t == NULL)
3515 : t = d;
3516 : else
3517 : f = d;
3518 : }
3519 :
3520 : /* Translate the code for each of these blocks, and append it to
3521 : the current block. */
3522 18 : if (t != NULL)
3523 45 : true_tree = gfc_trans_code (t->next);
3524 :
3525 45 : if (f != NULL)
3526 45 : false_tree = gfc_trans_code (f->next);
3527 :
3528 45 : stmt = fold_build3_loc (input_location, COND_EXPR, void_type_node,
3529 : se.expr, true_tree, false_tree);
3530 45 : gfc_add_expr_to_block (&block, stmt);
3531 : }
3532 :
3533 54 : return gfc_finish_block (&block);
3534 : }
3535 :
3536 :
3537 : /* The jump table types are stored in static variables to avoid
3538 : constructing them from scratch every single time. */
3539 : static GTY(()) tree select_struct[2];
3540 :
3541 : /* Translate the SELECT CASE construct for CHARACTER case expressions.
3542 : Instead of generating compares and jumps, it is far simpler to
3543 : generate a data structure describing the cases in order and call a
3544 : library subroutine that locates the right case.
3545 : This is particularly true because this is the only case where we
3546 : might have to dispose of a temporary.
3547 : The library subroutine returns a pointer to jump to or NULL if no
3548 : branches are to be taken. */
3549 :
3550 : static tree
3551 75 : gfc_trans_character_select (gfc_code *code)
3552 : {
3553 75 : tree init, end_label, tmp, type, case_num, label, fndecl;
3554 75 : stmtblock_t block, body;
3555 75 : gfc_case *cp, *d;
3556 75 : gfc_code *c;
3557 75 : gfc_se se, expr1se;
3558 75 : int n, k;
3559 75 : vec<constructor_elt, va_gc> *inits = NULL;
3560 :
3561 75 : tree pchartype = gfc_get_pchar_type (code->expr1->ts.kind);
3562 :
3563 : /* The jump table types are stored in static variables to avoid
3564 : constructing them from scratch every single time. */
3565 75 : static tree ss_string1[2], ss_string1_len[2];
3566 75 : static tree ss_string2[2], ss_string2_len[2];
3567 75 : static tree ss_target[2];
3568 :
3569 75 : cp = code->block->ext.block.case_list;
3570 241 : while (cp->left != NULL)
3571 : cp = cp->left;
3572 :
3573 : /* Generate the body */
3574 75 : gfc_start_block (&block);
3575 75 : gfc_init_se (&expr1se, NULL);
3576 75 : gfc_conv_expr_reference (&expr1se, code->expr1);
3577 :
3578 75 : gfc_add_block_to_block (&block, &expr1se.pre);
3579 :
3580 75 : end_label = gfc_build_label_decl (NULL_TREE);
3581 :
3582 75 : gfc_init_block (&body);
3583 :
3584 : /* Attempt to optimize length 1 selects. */
3585 75 : if (integer_onep (expr1se.string_length))
3586 : {
3587 126 : for (d = cp; d; d = d->right)
3588 : {
3589 110 : gfc_charlen_t i;
3590 110 : if (d->low)
3591 : {
3592 100 : gcc_assert (d->low->expr_type == EXPR_CONSTANT
3593 : && d->low->ts.type == BT_CHARACTER);
3594 100 : if (d->low->value.character.length > 1)
3595 : {
3596 2 : for (i = 1; i < d->low->value.character.length; i++)
3597 2 : if (d->low->value.character.string[i] != ' ')
3598 : break;
3599 2 : if (i != d->low->value.character.length)
3600 : {
3601 2 : if (optimize && d->high && i == 1)
3602 : {
3603 2 : gcc_assert (d->high->expr_type == EXPR_CONSTANT
3604 : && d->high->ts.type == BT_CHARACTER);
3605 2 : if (d->high->value.character.length > 1
3606 2 : && (d->low->value.character.string[0]
3607 2 : == d->high->value.character.string[0])
3608 2 : && d->high->value.character.string[1] != ' '
3609 4 : && ((d->low->value.character.string[1] < ' ')
3610 : == (d->high->value.character.string[1]
3611 2 : < ' ')))
3612 2 : continue;
3613 : }
3614 : break;
3615 : }
3616 : }
3617 : }
3618 108 : if (d->high)
3619 : {
3620 98 : gcc_assert (d->high->expr_type == EXPR_CONSTANT
3621 : && d->high->ts.type == BT_CHARACTER);
3622 98 : if (d->high->value.character.length > 1)
3623 : {
3624 3 : for (i = 1; i < d->high->value.character.length; i++)
3625 2 : if (d->high->value.character.string[i] != ' ')
3626 : break;
3627 1 : if (i != d->high->value.character.length)
3628 : break;
3629 : }
3630 : }
3631 : }
3632 16 : if (d == NULL)
3633 : {
3634 16 : tree ctype = gfc_get_char_type (code->expr1->ts.kind);
3635 :
3636 58 : for (c = code->block; c; c = c->block)
3637 : {
3638 152 : for (cp = c->ext.block.case_list; cp; cp = cp->next)
3639 : {
3640 110 : tree low, high;
3641 110 : tree label;
3642 110 : gfc_char_t r;
3643 :
3644 : /* Assume it's the default case. */
3645 110 : low = high = NULL_TREE;
3646 :
3647 110 : if (cp->low)
3648 : {
3649 : /* CASE ('ab') or CASE ('ab':'az') will never match
3650 : any length 1 character. */
3651 100 : if (cp->low->value.character.length > 1
3652 2 : && cp->low->value.character.string[1] != ' ')
3653 2 : continue;
3654 :
3655 98 : if (cp->low->value.character.length > 0)
3656 97 : r = cp->low->value.character.string[0];
3657 : else
3658 : r = ' ';
3659 98 : low = build_int_cst (ctype, r);
3660 :
3661 : /* If there's only a lower bound, set the high bound
3662 : to the maximum value of the case expression. */
3663 98 : if (!cp->high)
3664 0 : high = TYPE_MAX_VALUE (ctype);
3665 : }
3666 :
3667 108 : if (cp->high)
3668 : {
3669 98 : if (!cp->low
3670 98 : || (cp->low->value.character.string[0]
3671 98 : != cp->high->value.character.string[0]))
3672 : {
3673 2 : if (cp->high->value.character.length > 0)
3674 2 : r = cp->high->value.character.string[0];
3675 : else
3676 : r = ' ';
3677 2 : high = build_int_cst (ctype, r);
3678 : }
3679 :
3680 : /* Unbounded case. */
3681 98 : if (!cp->low)
3682 0 : low = TYPE_MIN_VALUE (ctype);
3683 : }
3684 :
3685 : /* Build a label. */
3686 108 : label = gfc_build_label_decl (NULL_TREE);
3687 :
3688 : /* Add this case label.
3689 : Add parameter 'label', make it match GCC backend. */
3690 108 : tmp = build_case_label (low, high, label);
3691 108 : gfc_add_expr_to_block (&body, tmp);
3692 : }
3693 :
3694 : /* Add the statements for this case. */
3695 42 : tmp = gfc_trans_code (c->next);
3696 42 : gfc_add_expr_to_block (&body, tmp);
3697 :
3698 : /* Break to the end of the construct. */
3699 42 : tmp = build1_v (GOTO_EXPR, end_label);
3700 42 : gfc_add_expr_to_block (&body, tmp);
3701 : }
3702 :
3703 32 : tmp = gfc_string_to_single_character (expr1se.string_length,
3704 : expr1se.expr,
3705 16 : code->expr1->ts.kind);
3706 16 : case_num = gfc_create_var (ctype, "case_num");
3707 16 : gfc_add_modify (&block, case_num, tmp);
3708 :
3709 16 : gfc_add_block_to_block (&block, &expr1se.post);
3710 :
3711 16 : tmp = gfc_finish_block (&body);
3712 16 : tmp = fold_build2_loc (input_location, SWITCH_EXPR, NULL_TREE,
3713 : case_num, tmp);
3714 16 : gfc_add_expr_to_block (&block, tmp);
3715 :
3716 16 : tmp = build1_v (LABEL_EXPR, end_label);
3717 16 : gfc_add_expr_to_block (&block, tmp);
3718 :
3719 16 : return gfc_finish_block (&block);
3720 : }
3721 : }
3722 :
3723 59 : if (code->expr1->ts.kind == 1)
3724 : k = 0;
3725 6 : else if (code->expr1->ts.kind == 4)
3726 : k = 1;
3727 : else
3728 0 : gcc_unreachable ();
3729 :
3730 59 : if (select_struct[k] == NULL)
3731 : {
3732 53 : tree *chain = NULL;
3733 53 : select_struct[k] = make_node (RECORD_TYPE);
3734 :
3735 53 : if (code->expr1->ts.kind == 1)
3736 47 : TYPE_NAME (select_struct[k]) = get_identifier ("_jump_struct_char1");
3737 6 : else if (code->expr1->ts.kind == 4)
3738 6 : TYPE_NAME (select_struct[k]) = get_identifier ("_jump_struct_char4");
3739 : else
3740 0 : gcc_unreachable ();
3741 :
3742 : #undef ADD_FIELD
3743 : #define ADD_FIELD(NAME, TYPE) \
3744 : ss_##NAME[k] = gfc_add_field_to_struct (select_struct[k], \
3745 : get_identifier (stringize(NAME)), \
3746 : TYPE, \
3747 : &chain)
3748 :
3749 53 : ADD_FIELD (string1, pchartype);
3750 53 : ADD_FIELD (string1_len, gfc_charlen_type_node);
3751 :
3752 53 : ADD_FIELD (string2, pchartype);
3753 53 : ADD_FIELD (string2_len, gfc_charlen_type_node);
3754 :
3755 53 : ADD_FIELD (target, integer_type_node);
3756 : #undef ADD_FIELD
3757 :
3758 53 : gfc_finish_type (select_struct[k]);
3759 : }
3760 :
3761 59 : n = 0;
3762 311 : for (d = cp; d; d = d->right)
3763 252 : d->n = n++;
3764 :
3765 263 : for (c = code->block; c; c = c->block)
3766 : {
3767 456 : for (d = c->ext.block.case_list; d; d = d->next)
3768 : {
3769 252 : label = gfc_build_label_decl (NULL_TREE);
3770 452 : tmp = build_case_label ((d->low == NULL && d->high == NULL)
3771 : ? NULL
3772 200 : : build_int_cst (integer_type_node, d->n),
3773 : NULL, label);
3774 252 : gfc_add_expr_to_block (&body, tmp);
3775 : }
3776 :
3777 204 : tmp = gfc_trans_code (c->next);
3778 204 : gfc_add_expr_to_block (&body, tmp);
3779 :
3780 204 : tmp = build1_v (GOTO_EXPR, end_label);
3781 204 : gfc_add_expr_to_block (&body, tmp);
3782 : }
3783 :
3784 : /* Generate the structure describing the branches */
3785 311 : for (d = cp; d; d = d->right)
3786 : {
3787 252 : vec<constructor_elt, va_gc> *node = NULL;
3788 :
3789 252 : gfc_init_se (&se, NULL);
3790 :
3791 252 : if (d->low == NULL)
3792 : {
3793 52 : CONSTRUCTOR_APPEND_ELT (node, ss_string1[k], null_pointer_node);
3794 52 : CONSTRUCTOR_APPEND_ELT (node, ss_string1_len[k], build_zero_cst (gfc_charlen_type_node));
3795 : }
3796 : else
3797 : {
3798 200 : gfc_conv_expr_reference (&se, d->low);
3799 :
3800 200 : CONSTRUCTOR_APPEND_ELT (node, ss_string1[k], se.expr);
3801 200 : CONSTRUCTOR_APPEND_ELT (node, ss_string1_len[k], se.string_length);
3802 : }
3803 :
3804 252 : if (d->high == NULL)
3805 : {
3806 52 : CONSTRUCTOR_APPEND_ELT (node, ss_string2[k], null_pointer_node);
3807 52 : CONSTRUCTOR_APPEND_ELT (node, ss_string2_len[k], build_zero_cst (gfc_charlen_type_node));
3808 : }
3809 : else
3810 : {
3811 200 : gfc_init_se (&se, NULL);
3812 200 : gfc_conv_expr_reference (&se, d->high);
3813 :
3814 200 : CONSTRUCTOR_APPEND_ELT (node, ss_string2[k], se.expr);
3815 200 : CONSTRUCTOR_APPEND_ELT (node, ss_string2_len[k], se.string_length);
3816 : }
3817 :
3818 252 : CONSTRUCTOR_APPEND_ELT (node, ss_target[k],
3819 : build_int_cst (integer_type_node, d->n));
3820 :
3821 252 : tmp = build_constructor (select_struct[k], node);
3822 252 : CONSTRUCTOR_APPEND_ELT (inits, NULL_TREE, tmp);
3823 : }
3824 :
3825 59 : type = build_array_type (select_struct[k],
3826 59 : build_index_type (size_int (n-1)));
3827 :
3828 59 : init = build_constructor (type, inits);
3829 59 : TREE_CONSTANT (init) = 1;
3830 59 : TREE_STATIC (init) = 1;
3831 : /* Create a static variable to hold the jump table. */
3832 59 : tmp = gfc_create_var (type, "jumptable");
3833 59 : TREE_CONSTANT (tmp) = 1;
3834 59 : TREE_STATIC (tmp) = 1;
3835 59 : TREE_READONLY (tmp) = 1;
3836 59 : DECL_INITIAL (tmp) = init;
3837 59 : init = tmp;
3838 :
3839 : /* Build the library call */
3840 59 : init = gfc_build_addr_expr (pvoid_type_node, init);
3841 :
3842 59 : if (code->expr1->ts.kind == 1)
3843 53 : fndecl = gfor_fndecl_select_string;
3844 6 : else if (code->expr1->ts.kind == 4)
3845 6 : fndecl = gfor_fndecl_select_string_char4;
3846 : else
3847 0 : gcc_unreachable ();
3848 :
3849 59 : tmp = build_call_expr_loc (input_location,
3850 : fndecl, 4, init,
3851 59 : build_int_cst (gfc_charlen_type_node, n),
3852 : expr1se.expr, expr1se.string_length);
3853 59 : case_num = gfc_create_var (integer_type_node, "case_num");
3854 59 : gfc_add_modify (&block, case_num, tmp);
3855 :
3856 59 : gfc_add_block_to_block (&block, &expr1se.post);
3857 :
3858 59 : tmp = gfc_finish_block (&body);
3859 59 : tmp = fold_build2_loc (input_location, SWITCH_EXPR, NULL_TREE,
3860 : case_num, tmp);
3861 59 : gfc_add_expr_to_block (&block, tmp);
3862 :
3863 59 : tmp = build1_v (LABEL_EXPR, end_label);
3864 59 : gfc_add_expr_to_block (&block, tmp);
3865 :
3866 59 : return gfc_finish_block (&block);
3867 : }
3868 :
3869 :
3870 : /* Translate the three variants of the SELECT CASE construct.
3871 :
3872 : SELECT CASEs with INTEGER case expressions can be translated to an
3873 : equivalent GENERIC switch statement, and for LOGICAL case
3874 : expressions we build one or two if-else compares.
3875 :
3876 : SELECT CASEs with CHARACTER case expressions are a whole different
3877 : story, because they don't exist in GENERIC. So we sort them and
3878 : do a binary search at runtime.
3879 :
3880 : Fortran has no BREAK statement, and it does not allow jumps from
3881 : one case block to another. That makes things a lot easier for
3882 : the optimizers. */
3883 :
3884 : tree
3885 1131 : gfc_trans_select (gfc_code * code)
3886 : {
3887 1131 : stmtblock_t block;
3888 1131 : tree body;
3889 1131 : tree exit_label;
3890 :
3891 1131 : gcc_assert (code && code->expr1);
3892 1131 : gfc_init_block (&block);
3893 :
3894 : /* Build the exit label and hang it in. */
3895 1131 : exit_label = gfc_build_label_decl (NULL_TREE);
3896 1131 : code->exit_label = exit_label;
3897 :
3898 : /* Empty SELECT constructs are legal. */
3899 1131 : if (code->block == NULL)
3900 2 : body = build_empty_stmt (input_location);
3901 :
3902 : /* Select the correct translation function. */
3903 : else
3904 1129 : switch (code->expr1->ts.type)
3905 : {
3906 54 : case BT_LOGICAL:
3907 54 : body = gfc_trans_logical_select (code);
3908 54 : break;
3909 :
3910 1000 : case BT_INTEGER:
3911 1000 : case BT_UNSIGNED:
3912 1000 : body = gfc_trans_integer_select (code);
3913 1000 : break;
3914 :
3915 75 : case BT_CHARACTER:
3916 75 : body = gfc_trans_character_select (code);
3917 75 : break;
3918 :
3919 0 : default:
3920 0 : gfc_internal_error ("gfc_trans_select(): Bad type for case expr.");
3921 : /* Not reached */
3922 : }
3923 :
3924 : /* Build everything together. */
3925 1131 : gfc_add_expr_to_block (&block, body);
3926 1131 : gfc_add_expr_to_block (&block, build1_v (LABEL_EXPR, exit_label));
3927 :
3928 1131 : return gfc_finish_block (&block);
3929 : }
3930 :
3931 : tree
3932 3136 : gfc_trans_select_type (gfc_code * code)
3933 : {
3934 3136 : stmtblock_t block;
3935 3136 : tree body;
3936 3136 : tree exit_label;
3937 :
3938 3136 : gcc_assert (code && code->expr1);
3939 3136 : gfc_init_block (&block);
3940 :
3941 : /* Build the exit label and hang it in. */
3942 3136 : exit_label = gfc_build_label_decl (NULL_TREE);
3943 3136 : code->exit_label = exit_label;
3944 :
3945 : /* Empty SELECT constructs are legal. */
3946 3136 : if (code->block == NULL)
3947 0 : body = build_empty_stmt (input_location);
3948 : else
3949 3136 : body = gfc_trans_select_type_cases (code);
3950 :
3951 : /* Build everything together. */
3952 3136 : gfc_add_expr_to_block (&block, body);
3953 :
3954 3136 : if (TREE_USED (exit_label))
3955 2909 : gfc_add_expr_to_block (&block, build1_v (LABEL_EXPR, exit_label));
3956 :
3957 3136 : return gfc_finish_block (&block);
3958 : }
3959 :
3960 :
3961 : static tree
3962 1030 : gfc_trans_select_rank_cases (gfc_code * code)
3963 : {
3964 1030 : gfc_code *c;
3965 1030 : gfc_case *cp;
3966 1030 : tree tmp;
3967 1030 : tree cond;
3968 1030 : tree low;
3969 1030 : tree rank;
3970 1030 : gfc_se se;
3971 1030 : gfc_se cse;
3972 1030 : stmtblock_t block;
3973 1030 : stmtblock_t body;
3974 1030 : bool def = false;
3975 :
3976 1030 : gfc_start_block (&block);
3977 :
3978 : /* Calculate the switch expression. */
3979 1030 : gfc_init_se (&se, NULL);
3980 1030 : gfc_conv_expr_descriptor (&se, code->expr1);
3981 1030 : rank = fold_convert_loc (input_location, signed_char_type_node,
3982 : gfc_conv_descriptor_rank_get (se.expr));
3983 1030 : rank = gfc_evaluate_now (rank, &block);
3984 1030 : symbol_attribute attr = gfc_expr_attr (code->expr1);
3985 1030 : if (!attr.pointer && !attr.allocatable)
3986 : {
3987 : /* Special case for assumed-rank ('rank(*)', internally -1):
3988 : rank = (rank == 0 || ubound[rank-1] != -1) ? rank : -1. */
3989 794 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
3990 794 : rank, build_int_cst (TREE_TYPE (rank), 0));
3991 794 : tmp = fold_build2_loc (input_location, MINUS_EXPR, signed_char_type_node,
3992 : rank, build_one_cst (signed_char_type_node));
3993 794 : tmp = gfc_conv_descriptor_ubound_get (se.expr, tmp);
3994 794 : tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
3995 794 : tmp, build_int_cst (TREE_TYPE (tmp), -1));
3996 794 : cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
3997 : logical_type_node, cond, tmp);
3998 794 : tmp = fold_build3_loc (input_location, COND_EXPR, signed_char_type_node,
3999 : cond, rank,
4000 : build_minus_one_cst (signed_char_type_node));
4001 794 : rank = gfc_evaluate_now (tmp, &block);
4002 : }
4003 1030 : TREE_USED (code->exit_label) = 0;
4004 :
4005 2060 : repeat:
4006 6746 : for (c = code->block; c; c = c->block)
4007 : {
4008 4686 : cp = c->ext.block.case_list;
4009 :
4010 : /* Assume it's the default case. */
4011 4686 : low = NULL_TREE;
4012 4686 : tmp = NULL_TREE;
4013 :
4014 : /* Put the default case at the end. */
4015 4686 : if ((!def && !cp->low) || (def && cp->low))
4016 2343 : continue;
4017 :
4018 2343 : if (cp->low)
4019 : {
4020 1404 : gfc_init_se (&cse, NULL);
4021 1404 : gfc_conv_expr_val (&cse, cp->low);
4022 1404 : gfc_add_block_to_block (&block, &cse.pre);
4023 1404 : low = cse.expr;
4024 : }
4025 :
4026 2343 : gfc_init_block (&body);
4027 :
4028 : /* Add the statements for this case. */
4029 2343 : tmp = gfc_trans_code (c->next);
4030 2343 : gfc_add_expr_to_block (&body, tmp);
4031 :
4032 : /* Break to the end of the SELECT RANK construct. The default
4033 : case just falls through. */
4034 2343 : if (!def)
4035 : {
4036 1404 : TREE_USED (code->exit_label) = 1;
4037 1404 : tmp = build1_v (GOTO_EXPR, code->exit_label);
4038 1404 : gfc_add_expr_to_block (&body, tmp);
4039 : }
4040 :
4041 2343 : tmp = gfc_finish_block (&body);
4042 :
4043 2343 : if (low != NULL_TREE)
4044 : {
4045 2808 : cond = fold_build2_loc (input_location, EQ_EXPR,
4046 1404 : TREE_TYPE (rank), rank,
4047 1404 : fold_convert (TREE_TYPE (rank), low));
4048 1404 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
4049 : cond, tmp,
4050 : build_empty_stmt (input_location));
4051 : }
4052 :
4053 2343 : gfc_add_expr_to_block (&block, tmp);
4054 : }
4055 :
4056 2060 : if (!def)
4057 : {
4058 1030 : def = true;
4059 1030 : goto repeat;
4060 : }
4061 :
4062 1030 : return gfc_finish_block (&block);
4063 : }
4064 :
4065 :
4066 : tree
4067 1031 : gfc_trans_select_rank (gfc_code * code)
4068 : {
4069 1031 : stmtblock_t block;
4070 1031 : tree body;
4071 1031 : tree exit_label;
4072 :
4073 1031 : gcc_assert (code && code->expr1);
4074 1031 : gfc_init_block (&block);
4075 :
4076 : /* Build the exit label and hang it in. */
4077 1031 : exit_label = gfc_build_label_decl (NULL_TREE);
4078 1031 : code->exit_label = exit_label;
4079 :
4080 : /* Empty SELECT constructs are legal. */
4081 1031 : if (code->block == NULL)
4082 1 : body = build_empty_stmt (input_location);
4083 : else
4084 1030 : body = gfc_trans_select_rank_cases (code);
4085 :
4086 : /* Build everything together. */
4087 1031 : gfc_add_expr_to_block (&block, body);
4088 :
4089 1031 : if (TREE_USED (exit_label))
4090 1031 : gfc_add_expr_to_block (&block, build1_v (LABEL_EXPR, exit_label));
4091 :
4092 1031 : return gfc_finish_block (&block);
4093 : }
4094 :
4095 :
4096 : /* Traversal function to substitute a replacement symtree if the symbol
4097 : in the expression is the same as that passed. f == 2 signals that
4098 : that variable itself is not to be checked - only the references.
4099 : This group of functions is used when the variable expression in a
4100 : FORALL assignment has internal references. For example:
4101 : FORALL (i = 1:4) p(p(i)) = i
4102 : The only recourse here is to store a copy of 'p' for the index
4103 : expression. */
4104 :
4105 : static gfc_symtree *new_symtree;
4106 : static gfc_symtree *old_symtree;
4107 :
4108 : static bool
4109 710 : forall_replace (gfc_expr *expr, gfc_symbol *sym, int *f)
4110 : {
4111 710 : if (expr->expr_type != EXPR_VARIABLE)
4112 : return false;
4113 :
4114 406 : if (*f == 2)
4115 62 : *f = 1;
4116 344 : else if (expr->symtree->n.sym == sym)
4117 72 : expr->symtree = new_symtree;
4118 :
4119 : return false;
4120 : }
4121 :
4122 : static void
4123 124 : forall_replace_symtree (gfc_expr *e, gfc_symbol *sym, int f)
4124 : {
4125 0 : gfc_traverse_expr (e, sym, forall_replace, f);
4126 0 : }
4127 :
4128 : static bool
4129 710 : forall_restore (gfc_expr *expr,
4130 : gfc_symbol *sym ATTRIBUTE_UNUSED,
4131 : int *f ATTRIBUTE_UNUSED)
4132 : {
4133 710 : if (expr->expr_type != EXPR_VARIABLE)
4134 : return false;
4135 :
4136 406 : if (expr->symtree == new_symtree)
4137 72 : expr->symtree = old_symtree;
4138 :
4139 : return false;
4140 : }
4141 :
4142 : static void
4143 124 : forall_restore_symtree (gfc_expr *e)
4144 : {
4145 0 : gfc_traverse_expr (e, NULL, forall_restore, 0);
4146 0 : }
4147 :
4148 : static void
4149 62 : forall_make_variable_temp (gfc_code *c, stmtblock_t *pre, stmtblock_t *post)
4150 : {
4151 62 : gfc_se tse;
4152 62 : gfc_se rse;
4153 62 : gfc_expr *e;
4154 62 : gfc_symbol *new_sym;
4155 62 : gfc_symbol *old_sym;
4156 62 : gfc_symtree *root;
4157 62 : tree tmp;
4158 :
4159 : /* Build a copy of the lvalue. */
4160 62 : old_symtree = c->expr1->symtree;
4161 62 : old_sym = old_symtree->n.sym;
4162 62 : e = gfc_lval_expr_from_sym (old_sym);
4163 62 : if (old_sym->attr.dimension)
4164 : {
4165 30 : gfc_init_se (&tse, NULL);
4166 30 : gfc_conv_subref_array_arg (&tse, e, 0, INTENT_IN, false);
4167 30 : gfc_add_block_to_block (pre, &tse.pre);
4168 30 : gfc_add_block_to_block (post, &tse.post);
4169 30 : tse.expr = build_fold_indirect_ref_loc (input_location, tse.expr);
4170 :
4171 30 : if (c->expr1->ref->u.ar.type != AR_SECTION)
4172 : {
4173 : /* Use the variable offset for the temporary. */
4174 24 : tmp = gfc_conv_array_offset (old_sym->backend_decl);
4175 24 : gfc_conv_descriptor_offset_set (pre, tse.expr, tmp);
4176 : }
4177 : }
4178 : else
4179 : {
4180 32 : gfc_init_se (&tse, NULL);
4181 32 : gfc_init_se (&rse, NULL);
4182 32 : gfc_conv_expr (&rse, e);
4183 32 : if (e->ts.type == BT_CHARACTER)
4184 : {
4185 32 : tse.string_length = rse.string_length;
4186 32 : tmp = gfc_get_character_type_len (gfc_default_character_kind,
4187 : tse.string_length);
4188 32 : tse.expr = gfc_conv_string_tmp (&tse, build_pointer_type (tmp),
4189 : rse.string_length);
4190 32 : gfc_add_block_to_block (pre, &tse.pre);
4191 32 : gfc_add_block_to_block (post, &tse.post);
4192 : }
4193 : else
4194 : {
4195 0 : tmp = gfc_typenode_for_spec (&e->ts);
4196 0 : tse.expr = gfc_create_var (tmp, "temp");
4197 : }
4198 :
4199 64 : tmp = gfc_trans_scalar_assign (&tse, &rse, e->ts,
4200 32 : e->expr_type == EXPR_VARIABLE, false);
4201 32 : gfc_add_expr_to_block (pre, tmp);
4202 : }
4203 62 : gfc_free_expr (e);
4204 :
4205 : /* Create a new symbol to represent the lvalue. */
4206 62 : new_sym = gfc_new_symbol (old_sym->name, NULL);
4207 62 : new_sym->ts = old_sym->ts;
4208 62 : new_sym->attr.referenced = 1;
4209 62 : new_sym->attr.temporary = 1;
4210 62 : new_sym->attr.dimension = old_sym->attr.dimension;
4211 62 : new_sym->attr.flavor = old_sym->attr.flavor;
4212 :
4213 : /* Use the temporary as the backend_decl. */
4214 62 : new_sym->backend_decl = tse.expr;
4215 :
4216 : /* Create a fake symtree for it. */
4217 62 : root = NULL;
4218 62 : new_symtree = gfc_new_symtree (&root, old_sym->name);
4219 62 : new_symtree->n.sym = new_sym;
4220 62 : gcc_assert (new_symtree == root);
4221 :
4222 : /* Go through the expression reference replacing the old_symtree
4223 : with the new. */
4224 62 : forall_replace_symtree (c->expr1, old_sym, 2);
4225 :
4226 : /* Now we have made this temporary, we might as well use it for
4227 : the right hand side. */
4228 62 : forall_replace_symtree (c->expr2, old_sym, 1);
4229 62 : }
4230 :
4231 :
4232 : /* Handles dependencies in forall assignments. */
4233 : static int
4234 1826 : check_forall_dependencies (gfc_code *c, stmtblock_t *pre, stmtblock_t *post)
4235 : {
4236 1826 : gfc_ref *lref;
4237 1826 : gfc_ref *rref;
4238 1826 : int need_temp;
4239 1826 : gfc_symbol *lsym;
4240 :
4241 1826 : lsym = c->expr1->symtree->n.sym;
4242 1826 : need_temp = gfc_check_dependency (c->expr1, c->expr2, 0);
4243 :
4244 : /* Now check for dependencies within the 'variable'
4245 : expression itself. These are treated by making a complete
4246 : copy of variable and changing all the references to it
4247 : point to the copy instead. Note that the shallow copy of
4248 : the variable will not suffice for derived types with
4249 : pointer components. We therefore leave these to their
4250 : own devices. Likewise for allocatable components. */
4251 1826 : if (lsym->ts.type == BT_DERIVED
4252 149 : && (lsym->ts.u.derived->attr.pointer_comp
4253 139 : || lsym->ts.u.derived->attr.alloc_comp))
4254 : return need_temp;
4255 :
4256 1731 : new_symtree = NULL;
4257 1731 : if (find_forall_index (c->expr1, lsym, 2))
4258 : {
4259 12 : forall_make_variable_temp (c, pre, post);
4260 12 : need_temp = 0;
4261 : }
4262 :
4263 : /* Substrings with dependencies are treated in the same
4264 : way. */
4265 1731 : if (c->expr1->ts.type == BT_CHARACTER
4266 685 : && c->expr1->ref
4267 685 : && c->expr2->expr_type == EXPR_VARIABLE
4268 492 : && lsym == c->expr2->symtree->n.sym)
4269 : {
4270 124 : for (lref = c->expr1->ref; lref; lref = lref->next)
4271 117 : if (lref->type == REF_SUBSTRING)
4272 : break;
4273 124 : for (rref = c->expr2->ref; rref; rref = rref->next)
4274 117 : if (rref->type == REF_SUBSTRING)
4275 : break;
4276 :
4277 81 : if (rref && lref
4278 81 : && gfc_dep_compare_expr (rref->u.ss.start, lref->u.ss.start) < 0)
4279 : {
4280 50 : forall_make_variable_temp (c, pre, post);
4281 50 : need_temp = 0;
4282 : }
4283 : }
4284 : return need_temp;
4285 : }
4286 :
4287 :
4288 : static void
4289 62 : cleanup_forall_symtrees (gfc_code *c)
4290 : {
4291 62 : forall_restore_symtree (c->expr1);
4292 62 : forall_restore_symtree (c->expr2);
4293 62 : free (new_symtree->n.sym);
4294 62 : free (new_symtree);
4295 62 : }
4296 :
4297 :
4298 : /* Generate the loops for a FORALL block, specified by FORALL_TMP. BODY
4299 : is the contents of the FORALL block/stmt to be iterated. MASK_FLAG
4300 : indicates whether we should generate code to test the FORALLs mask
4301 : array. OUTER is the loop header to be used for initializing mask
4302 : indices.
4303 :
4304 : The generated loop format is:
4305 : count = (end - start + step) / step
4306 : loopvar = start
4307 : while (1)
4308 : {
4309 : if (count <=0 )
4310 : goto end_of_loop
4311 : <body>
4312 : loopvar += step
4313 : count --
4314 : }
4315 : end_of_loop: */
4316 :
4317 : static tree
4318 3673 : gfc_trans_forall_loop (forall_info *forall_tmp, tree body,
4319 : int mask_flag, stmtblock_t *outer)
4320 : {
4321 3673 : int n, nvar;
4322 3673 : tree tmp;
4323 3673 : tree cond;
4324 3673 : stmtblock_t block;
4325 3673 : tree exit_label;
4326 3673 : tree count;
4327 3673 : tree var, start, end, step;
4328 3673 : iter_info *iter;
4329 :
4330 : /* Initialize the mask index outside the FORALL nest. */
4331 3673 : if (mask_flag && forall_tmp->mask)
4332 1071 : gfc_add_modify (outer, forall_tmp->maskindex, gfc_index_zero_node);
4333 :
4334 3673 : iter = forall_tmp->this_loop;
4335 3673 : nvar = forall_tmp->nvar;
4336 10025 : for (n = 0; n < nvar; n++)
4337 : {
4338 6352 : var = iter->var;
4339 6352 : start = iter->start;
4340 6352 : end = iter->end;
4341 6352 : step = iter->step;
4342 :
4343 6352 : exit_label = gfc_build_label_decl (NULL_TREE);
4344 6352 : TREE_USED (exit_label) = 1;
4345 :
4346 : /* The loop counter. */
4347 6352 : count = gfc_create_var (TREE_TYPE (var), "count");
4348 :
4349 : /* The body of the loop. */
4350 6352 : gfc_init_block (&block);
4351 :
4352 : /* The exit condition. */
4353 6352 : cond = fold_build2_loc (input_location, LE_EXPR, logical_type_node,
4354 6352 : count, build_int_cst (TREE_TYPE (count), 0));
4355 :
4356 : /* PR 83064 means that we cannot use annot_expr_parallel_kind until
4357 : the autoparallelizer can handle this. */
4358 6352 : if (forall_tmp->do_concurrent || iter->annot.ivdep)
4359 305 : cond = build3 (ANNOTATE_EXPR, TREE_TYPE (cond), cond,
4360 : build_int_cst (integer_type_node,
4361 : annot_expr_ivdep_kind),
4362 : integer_zero_node);
4363 :
4364 6352 : if (iter->annot.unroll && cond != error_mark_node)
4365 1 : cond = build3 (ANNOTATE_EXPR, TREE_TYPE (cond), cond,
4366 : build_int_cst (integer_type_node,
4367 : annot_expr_unroll_kind),
4368 1 : build_int_cst (integer_type_node, iter->annot.unroll));
4369 :
4370 6352 : if (iter->annot.vector && cond != error_mark_node)
4371 1 : cond = build3 (ANNOTATE_EXPR, TREE_TYPE (cond), cond,
4372 : build_int_cst (integer_type_node,
4373 : annot_expr_vector_kind),
4374 : integer_zero_node);
4375 :
4376 6352 : if (iter->annot.novector && cond != error_mark_node)
4377 2 : cond = build3 (ANNOTATE_EXPR, TREE_TYPE (cond), cond,
4378 : build_int_cst (integer_type_node,
4379 : annot_expr_no_vector_kind),
4380 : integer_zero_node);
4381 :
4382 6352 : tmp = build1_v (GOTO_EXPR, exit_label);
4383 6352 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
4384 : cond, tmp, build_empty_stmt (input_location));
4385 6352 : gfc_add_expr_to_block (&block, tmp);
4386 :
4387 : /* The main loop body. */
4388 6352 : gfc_add_expr_to_block (&block, body);
4389 :
4390 : /* Increment the loop variable. */
4391 6352 : tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (var), var,
4392 : step);
4393 6352 : gfc_add_modify (&block, var, tmp);
4394 :
4395 : /* Advance to the next mask element. Only do this for the
4396 : innermost loop. */
4397 6352 : if (n == 0 && mask_flag && forall_tmp->mask)
4398 : {
4399 1071 : tree maskindex = forall_tmp->maskindex;
4400 1071 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
4401 : maskindex, gfc_index_one_node);
4402 1071 : gfc_add_modify (&block, maskindex, tmp);
4403 : }
4404 :
4405 : /* Decrement the loop counter. */
4406 6352 : tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (var), count,
4407 6352 : build_int_cst (TREE_TYPE (var), 1));
4408 6352 : gfc_add_modify (&block, count, tmp);
4409 :
4410 6352 : body = gfc_finish_block (&block);
4411 :
4412 : /* Loop var initialization. */
4413 6352 : gfc_init_block (&block);
4414 6352 : gfc_add_modify (&block, var, start);
4415 :
4416 :
4417 : /* Initialize the loop counter. */
4418 6352 : tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (var), step,
4419 : start);
4420 6352 : tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (var), end,
4421 : tmp);
4422 6352 : tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR, TREE_TYPE (var),
4423 : tmp, step);
4424 6352 : gfc_add_modify (&block, count, tmp);
4425 :
4426 : /* The loop expression. */
4427 6352 : tmp = build1_v (LOOP_EXPR, body);
4428 6352 : gfc_add_expr_to_block (&block, tmp);
4429 :
4430 : /* The exit label. */
4431 6352 : tmp = build1_v (LABEL_EXPR, exit_label);
4432 6352 : gfc_add_expr_to_block (&block, tmp);
4433 :
4434 6352 : body = gfc_finish_block (&block);
4435 6352 : iter = iter->next;
4436 : }
4437 3673 : return body;
4438 : }
4439 :
4440 :
4441 : /* Generate the body and loops according to MASK_FLAG. If MASK_FLAG
4442 : is nonzero, the body is controlled by all masks in the forall nest.
4443 : Otherwise, the innermost loop is not controlled by it's mask. This
4444 : is used for initializing that mask. */
4445 :
4446 : static tree
4447 3473 : gfc_trans_nested_forall_loop (forall_info * nested_forall_info, tree body,
4448 : int mask_flag)
4449 : {
4450 3473 : tree tmp;
4451 3473 : stmtblock_t header;
4452 3473 : forall_info *forall_tmp;
4453 3473 : tree mask, maskindex;
4454 :
4455 3473 : gfc_start_block (&header);
4456 :
4457 3473 : forall_tmp = nested_forall_info;
4458 10619 : while (forall_tmp != NULL)
4459 : {
4460 : /* Generate body with masks' control. */
4461 3673 : if (mask_flag)
4462 : {
4463 2948 : mask = forall_tmp->mask;
4464 2948 : maskindex = forall_tmp->maskindex;
4465 :
4466 : /* If a mask was specified make the assignment conditional. */
4467 2948 : if (mask)
4468 : {
4469 1071 : tmp = gfc_build_array_ref (mask, maskindex, NULL);
4470 1071 : body = build3_v (COND_EXPR, tmp, body,
4471 : build_empty_stmt (input_location));
4472 : }
4473 : }
4474 3673 : body = gfc_trans_forall_loop (forall_tmp, body, mask_flag, &header);
4475 3673 : forall_tmp = forall_tmp->prev_nest;
4476 3673 : mask_flag = 1;
4477 : }
4478 :
4479 3473 : gfc_add_expr_to_block (&header, body);
4480 3473 : return gfc_finish_block (&header);
4481 : }
4482 :
4483 :
4484 : /* Allocate data for holding a temporary array. Returns either a local
4485 : temporary array or a pointer variable. */
4486 :
4487 : static tree
4488 1384 : gfc_do_allocate (tree bytesize, tree size, tree * pdata, stmtblock_t * pblock,
4489 : tree elem_type)
4490 : {
4491 1384 : tree tmpvar;
4492 1384 : tree type;
4493 1384 : tree tmp;
4494 :
4495 1384 : if (INTEGER_CST_P (size))
4496 1140 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
4497 : size, gfc_index_one_node);
4498 : else
4499 : tmp = NULL_TREE;
4500 :
4501 1384 : type = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp);
4502 1384 : type = build_array_type (elem_type, type);
4503 1384 : if (gfc_can_put_var_on_stack (bytesize) && INTEGER_CST_P (size))
4504 : {
4505 1140 : tmpvar = gfc_create_var (type, "temp");
4506 1140 : *pdata = NULL_TREE;
4507 : }
4508 : else
4509 : {
4510 244 : tmpvar = gfc_create_var (build_pointer_type (type), "temp");
4511 244 : *pdata = convert (pvoid_type_node, tmpvar);
4512 :
4513 244 : tmp = gfc_call_malloc (pblock, TREE_TYPE (tmpvar), bytesize);
4514 244 : gfc_add_modify (pblock, tmpvar, tmp);
4515 : }
4516 1384 : return tmpvar;
4517 : }
4518 :
4519 :
4520 : /* Generate codes to copy the temporary to the actual lhs. */
4521 :
4522 : static tree
4523 224 : generate_loop_for_temp_to_lhs (gfc_expr *expr, tree tmp1, tree count3,
4524 : tree count1,
4525 : gfc_ss *lss, gfc_ss *rss,
4526 : tree wheremask, bool invert)
4527 : {
4528 224 : stmtblock_t block, body1;
4529 224 : gfc_loopinfo loop;
4530 224 : gfc_se lse;
4531 224 : gfc_se rse;
4532 224 : tree tmp;
4533 224 : tree wheremaskexpr;
4534 :
4535 224 : (void) rss; /* TODO: unused. */
4536 :
4537 224 : gfc_start_block (&block);
4538 :
4539 224 : gfc_init_se (&rse, NULL);
4540 224 : gfc_init_se (&lse, NULL);
4541 :
4542 224 : if (lss == gfc_ss_terminator)
4543 : {
4544 149 : gfc_init_block (&body1);
4545 149 : gfc_conv_expr (&lse, expr);
4546 149 : rse.expr = gfc_build_array_ref (tmp1, count1, NULL);
4547 : }
4548 : else
4549 : {
4550 : /* Initialize the loop. */
4551 75 : gfc_init_loopinfo (&loop);
4552 :
4553 : /* We may need LSS to determine the shape of the expression. */
4554 75 : gfc_add_ss_to_loop (&loop, lss);
4555 :
4556 75 : gfc_conv_ss_startstride (&loop);
4557 75 : gfc_conv_loop_setup (&loop, &expr->where);
4558 :
4559 75 : gfc_mark_ss_chain_used (lss, 1);
4560 : /* Start the loop body. */
4561 75 : gfc_start_scalarized_body (&loop, &body1);
4562 :
4563 : /* Translate the expression. */
4564 75 : gfc_copy_loopinfo_to_se (&lse, &loop);
4565 75 : lse.ss = lss;
4566 75 : gfc_conv_expr (&lse, expr);
4567 :
4568 : /* Form the expression of the temporary. */
4569 75 : rse.expr = gfc_build_array_ref (tmp1, count1, NULL);
4570 : }
4571 :
4572 : /* Use the scalar assignment. */
4573 224 : rse.string_length = lse.string_length;
4574 448 : tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts,
4575 224 : expr->expr_type == EXPR_VARIABLE, false);
4576 :
4577 : /* Form the mask expression according to the mask tree list. */
4578 224 : if (wheremask)
4579 : {
4580 27 : wheremaskexpr = gfc_build_array_ref (wheremask, count3, NULL);
4581 27 : if (invert)
4582 0 : wheremaskexpr = fold_build1_loc (input_location, TRUTH_NOT_EXPR,
4583 0 : TREE_TYPE (wheremaskexpr),
4584 : wheremaskexpr);
4585 27 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
4586 : wheremaskexpr, tmp,
4587 : build_empty_stmt (input_location));
4588 : }
4589 :
4590 224 : gfc_add_expr_to_block (&body1, tmp);
4591 :
4592 224 : tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (count1),
4593 : count1, gfc_index_one_node);
4594 224 : gfc_add_modify (&body1, count1, tmp);
4595 :
4596 224 : if (lss == gfc_ss_terminator)
4597 149 : gfc_add_block_to_block (&block, &body1);
4598 : else
4599 : {
4600 : /* Increment count3. */
4601 75 : if (count3)
4602 : {
4603 27 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
4604 : gfc_array_index_type,
4605 : count3, gfc_index_one_node);
4606 27 : gfc_add_modify (&body1, count3, tmp);
4607 : }
4608 :
4609 : /* Generate the copying loops. */
4610 75 : gfc_trans_scalarizing_loops (&loop, &body1);
4611 :
4612 75 : gfc_add_block_to_block (&block, &loop.pre);
4613 75 : gfc_add_block_to_block (&block, &loop.post);
4614 :
4615 75 : gfc_cleanup_loop (&loop);
4616 : /* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful
4617 : as tree nodes in SS may not be valid in different scope. */
4618 : }
4619 :
4620 224 : tmp = gfc_finish_block (&block);
4621 224 : return tmp;
4622 : }
4623 :
4624 :
4625 : /* Generate codes to copy rhs to the temporary. TMP1 is the address of
4626 : temporary, LSS and RSS are formed in function compute_inner_temp_size(),
4627 : and should not be freed. WHEREMASK is the conditional execution mask
4628 : whose sense may be inverted by INVERT. */
4629 :
4630 : static tree
4631 224 : generate_loop_for_rhs_to_temp (gfc_expr *expr2, tree tmp1, tree count3,
4632 : tree count1, gfc_ss *lss, gfc_ss *rss,
4633 : tree wheremask, bool invert)
4634 : {
4635 224 : stmtblock_t block, body1;
4636 224 : gfc_loopinfo loop;
4637 224 : gfc_se lse;
4638 224 : gfc_se rse;
4639 224 : tree tmp;
4640 224 : tree wheremaskexpr;
4641 :
4642 224 : gfc_start_block (&block);
4643 :
4644 224 : gfc_init_se (&rse, NULL);
4645 224 : gfc_init_se (&lse, NULL);
4646 :
4647 224 : if (lss == gfc_ss_terminator)
4648 : {
4649 149 : gfc_init_block (&body1);
4650 149 : gfc_conv_expr (&rse, expr2);
4651 149 : lse.expr = gfc_build_array_ref (tmp1, count1, NULL);
4652 : }
4653 : else
4654 : {
4655 : /* Initialize the loop. */
4656 75 : gfc_init_loopinfo (&loop);
4657 :
4658 : /* We may need LSS to determine the shape of the expression. */
4659 75 : gfc_add_ss_to_loop (&loop, lss);
4660 75 : gfc_add_ss_to_loop (&loop, rss);
4661 :
4662 75 : gfc_conv_ss_startstride (&loop);
4663 75 : gfc_conv_loop_setup (&loop, &expr2->where);
4664 :
4665 75 : gfc_mark_ss_chain_used (rss, 1);
4666 : /* Start the loop body. */
4667 75 : gfc_start_scalarized_body (&loop, &body1);
4668 :
4669 : /* Translate the expression. */
4670 75 : gfc_copy_loopinfo_to_se (&rse, &loop);
4671 75 : rse.ss = rss;
4672 75 : gfc_conv_expr (&rse, expr2);
4673 :
4674 : /* Form the expression of the temporary. */
4675 75 : lse.expr = gfc_build_array_ref (tmp1, count1, NULL);
4676 : }
4677 :
4678 : /* Use the scalar assignment. */
4679 224 : lse.string_length = rse.string_length;
4680 448 : tmp = gfc_trans_scalar_assign (&lse, &rse, expr2->ts,
4681 224 : expr2->expr_type == EXPR_VARIABLE, false);
4682 :
4683 : /* Form the mask expression according to the mask tree list. */
4684 224 : if (wheremask)
4685 : {
4686 27 : wheremaskexpr = gfc_build_array_ref (wheremask, count3, NULL);
4687 27 : if (invert)
4688 0 : wheremaskexpr = fold_build1_loc (input_location, TRUTH_NOT_EXPR,
4689 0 : TREE_TYPE (wheremaskexpr),
4690 : wheremaskexpr);
4691 27 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
4692 : wheremaskexpr, tmp,
4693 : build_empty_stmt (input_location));
4694 : }
4695 :
4696 224 : gfc_add_expr_to_block (&body1, tmp);
4697 :
4698 224 : if (lss == gfc_ss_terminator)
4699 : {
4700 149 : gfc_add_block_to_block (&block, &body1);
4701 :
4702 : /* Increment count1. */
4703 149 : tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (count1),
4704 : count1, gfc_index_one_node);
4705 149 : gfc_add_modify (&block, count1, tmp);
4706 : }
4707 : else
4708 : {
4709 : /* Increment count1. */
4710 75 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
4711 : count1, gfc_index_one_node);
4712 75 : gfc_add_modify (&body1, count1, tmp);
4713 :
4714 : /* Increment count3. */
4715 75 : if (count3)
4716 : {
4717 27 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
4718 : gfc_array_index_type,
4719 : count3, gfc_index_one_node);
4720 27 : gfc_add_modify (&body1, count3, tmp);
4721 : }
4722 :
4723 : /* Generate the copying loops. */
4724 75 : gfc_trans_scalarizing_loops (&loop, &body1);
4725 :
4726 75 : gfc_add_block_to_block (&block, &loop.pre);
4727 75 : gfc_add_block_to_block (&block, &loop.post);
4728 :
4729 75 : gfc_cleanup_loop (&loop);
4730 : /* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful
4731 : as tree nodes in SS may not be valid in different scope. */
4732 : }
4733 :
4734 224 : tmp = gfc_finish_block (&block);
4735 224 : return tmp;
4736 : }
4737 :
4738 :
4739 : /* Calculate the size of temporary needed in the assignment inside forall.
4740 : LSS and RSS are filled in this function. */
4741 :
4742 : static tree
4743 780 : compute_inner_temp_size (gfc_expr *expr1, gfc_expr *expr2,
4744 : stmtblock_t * pblock,
4745 : gfc_ss **lss, gfc_ss **rss)
4746 : {
4747 780 : gfc_loopinfo loop;
4748 780 : tree size;
4749 780 : int i;
4750 780 : int save_flag;
4751 780 : tree tmp;
4752 :
4753 780 : *lss = gfc_walk_expr (expr1);
4754 780 : *rss = NULL;
4755 :
4756 780 : size = gfc_index_one_node;
4757 780 : if (*lss != gfc_ss_terminator)
4758 : {
4759 482 : gfc_init_loopinfo (&loop);
4760 :
4761 : /* Walk the RHS of the expression. */
4762 482 : *rss = gfc_walk_expr (expr2);
4763 482 : if (*rss == gfc_ss_terminator)
4764 : /* The rhs is scalar. Add a ss for the expression. */
4765 0 : *rss = gfc_get_scalar_ss (gfc_ss_terminator, expr2);
4766 :
4767 : /* Associate the SS with the loop. */
4768 482 : gfc_add_ss_to_loop (&loop, *lss);
4769 : /* We don't actually need to add the rhs at this point, but it might
4770 : make guessing the loop bounds a bit easier. */
4771 482 : gfc_add_ss_to_loop (&loop, *rss);
4772 :
4773 : /* We only want the shape of the expression, not rest of the junk
4774 : generated by the scalarizer. */
4775 482 : loop.array_parameter = 1;
4776 :
4777 : /* Calculate the bounds of the scalarization. */
4778 482 : save_flag = gfc_option.rtcheck;
4779 482 : gfc_option.rtcheck &= ~GFC_RTCHECK_BOUNDS;
4780 482 : gfc_conv_ss_startstride (&loop);
4781 482 : gfc_option.rtcheck = save_flag;
4782 482 : gfc_conv_loop_setup (&loop, &expr2->where);
4783 :
4784 : /* Figure out how many elements we need. */
4785 1477 : for (i = 0; i < loop.dimen; i++)
4786 : {
4787 513 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
4788 : gfc_array_index_type,
4789 : gfc_index_one_node, loop.from[i]);
4790 513 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
4791 : gfc_array_index_type, tmp, loop.to[i]);
4792 513 : size = fold_build2_loc (input_location, MULT_EXPR,
4793 : gfc_array_index_type, size, tmp);
4794 : }
4795 482 : gfc_add_block_to_block (pblock, &loop.pre);
4796 482 : size = gfc_evaluate_now (size, pblock);
4797 482 : gfc_add_block_to_block (pblock, &loop.post);
4798 :
4799 : /* TODO: write a function that cleans up a loopinfo without freeing
4800 : the SS chains. Currently a NOP. */
4801 : }
4802 :
4803 780 : return size;
4804 : }
4805 :
4806 :
4807 : /* Calculate the overall iterator number of the nested forall construct.
4808 : This routine actually calculates the number of times the body of the
4809 : nested forall specified by NESTED_FORALL_INFO is executed and multiplies
4810 : that by the expression INNER_SIZE. The BLOCK argument specifies the
4811 : block in which to calculate the result, and the optional INNER_SIZE_BODY
4812 : argument contains any statements that need to executed (inside the loop)
4813 : to initialize or calculate INNER_SIZE. */
4814 :
4815 : static tree
4816 1301 : compute_overall_iter_number (forall_info *nested_forall_info, tree inner_size,
4817 : stmtblock_t *inner_size_body, stmtblock_t *block)
4818 : {
4819 1301 : forall_info *forall_tmp = nested_forall_info;
4820 1301 : tree tmp, number;
4821 1301 : stmtblock_t body;
4822 :
4823 : /* We can eliminate the innermost unconditional loops with constant
4824 : array bounds. */
4825 1301 : if (INTEGER_CST_P (inner_size))
4826 : {
4827 : while (forall_tmp
4828 268 : && !forall_tmp->mask
4829 1508 : && INTEGER_CST_P (forall_tmp->size))
4830 : {
4831 117 : inner_size = fold_build2_loc (input_location, MULT_EXPR,
4832 : gfc_array_index_type,
4833 : inner_size, forall_tmp->size);
4834 117 : forall_tmp = forall_tmp->prev_nest;
4835 : }
4836 :
4837 : /* If there are no loops left, we have our constant result. */
4838 1209 : if (!forall_tmp)
4839 : return inner_size;
4840 : }
4841 :
4842 : /* Otherwise, create a temporary variable to compute the result. */
4843 243 : number = gfc_create_var (gfc_array_index_type, "num");
4844 243 : gfc_add_modify (block, number, gfc_index_zero_node);
4845 :
4846 243 : gfc_start_block (&body);
4847 243 : if (inner_size_body)
4848 189 : gfc_add_block_to_block (&body, inner_size_body);
4849 243 : if (forall_tmp)
4850 226 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
4851 : gfc_array_index_type, number, inner_size);
4852 : else
4853 : tmp = inner_size;
4854 243 : gfc_add_modify (&body, number, tmp);
4855 243 : tmp = gfc_finish_block (&body);
4856 :
4857 : /* Generate loops. */
4858 243 : if (forall_tmp != NULL)
4859 226 : tmp = gfc_trans_nested_forall_loop (forall_tmp, tmp, 1);
4860 :
4861 243 : gfc_add_expr_to_block (block, tmp);
4862 :
4863 243 : return number;
4864 : }
4865 :
4866 :
4867 : /* Allocate temporary for forall construct. SIZE is the size of temporary
4868 : needed. PTEMP1 is returned for space free. */
4869 :
4870 : static tree
4871 1384 : allocate_temp_for_forall_nest_1 (tree type, tree size, stmtblock_t * block,
4872 : tree * ptemp1)
4873 : {
4874 1384 : tree bytesize;
4875 1384 : tree unit;
4876 1384 : tree tmp;
4877 :
4878 1384 : unit = fold_convert (gfc_array_index_type, TYPE_SIZE_UNIT (type));
4879 1384 : if (!integer_onep (unit))
4880 166 : bytesize = fold_build2_loc (input_location, MULT_EXPR,
4881 : gfc_array_index_type, size, unit);
4882 : else
4883 : bytesize = size;
4884 :
4885 1384 : *ptemp1 = NULL;
4886 1384 : tmp = gfc_do_allocate (bytesize, size, ptemp1, block, type);
4887 :
4888 1384 : if (*ptemp1)
4889 244 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
4890 1384 : return tmp;
4891 : }
4892 :
4893 :
4894 : /* Allocate temporary for forall construct according to the information in
4895 : nested_forall_info. INNER_SIZE is the size of temporary needed in the
4896 : assignment inside forall. PTEMP1 is returned for space free. */
4897 :
4898 : static tree
4899 969 : allocate_temp_for_forall_nest (forall_info * nested_forall_info, tree type,
4900 : tree inner_size, stmtblock_t * inner_size_body,
4901 : stmtblock_t * block, tree * ptemp1)
4902 : {
4903 969 : tree size;
4904 :
4905 : /* Calculate the total size of temporary needed in forall construct. */
4906 969 : size = compute_overall_iter_number (nested_forall_info, inner_size,
4907 : inner_size_body, block);
4908 :
4909 969 : return allocate_temp_for_forall_nest_1 (type, size, block, ptemp1);
4910 : }
4911 :
4912 :
4913 : /* Handle assignments inside forall which need temporary.
4914 :
4915 : forall (i=start:end:stride; maskexpr)
4916 : e<i> = f<i>
4917 : end forall
4918 : (where e,f<i> are arbitrary expressions possibly involving i
4919 : and there is a dependency between e<i> and f<i>)
4920 : Translates to:
4921 : masktmp(:) = maskexpr(:)
4922 :
4923 : maskindex = 0;
4924 : count1 = 0;
4925 : num = 0;
4926 : for (i = start; i <= end; i += stride)
4927 : num += SIZE (f<i>)
4928 : count1 = 0;
4929 : ALLOCATE (tmp(num))
4930 : for (i = start; i <= end; i += stride)
4931 : {
4932 : if (masktmp[maskindex++])
4933 : tmp[count1++] = f<i>
4934 : }
4935 : maskindex = 0;
4936 : count1 = 0;
4937 : for (i = start; i <= end; i += stride)
4938 : {
4939 : if (masktmp[maskindex++])
4940 : e<i> = tmp[count1++]
4941 : }
4942 : DEALLOCATE (tmp)
4943 : */
4944 : static void
4945 224 : gfc_trans_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2,
4946 : tree wheremask, bool invert,
4947 : forall_info * nested_forall_info,
4948 : stmtblock_t * block)
4949 : {
4950 224 : tree type;
4951 224 : tree inner_size;
4952 224 : gfc_ss *lss, *rss;
4953 224 : tree count, count1;
4954 224 : tree tmp, tmp1;
4955 224 : tree ptemp1;
4956 224 : stmtblock_t inner_size_body;
4957 :
4958 : /* Create vars. count1 is the current iterator number of the nested
4959 : forall. */
4960 224 : count1 = gfc_create_var (gfc_array_index_type, "count1");
4961 :
4962 : /* Count is the wheremask index. */
4963 224 : if (wheremask)
4964 : {
4965 27 : count = gfc_create_var (gfc_array_index_type, "count");
4966 27 : gfc_add_modify (block, count, gfc_index_zero_node);
4967 : }
4968 : else
4969 : count = NULL;
4970 :
4971 : /* Initialize count1. */
4972 224 : gfc_add_modify (block, count1, gfc_index_zero_node);
4973 :
4974 : /* Calculate the size of temporary needed in the assignment. Return loop, lss
4975 : and rss which are used in function generate_loop_for_rhs_to_temp(). */
4976 : /* The type of LHS. Used in function allocate_temp_for_forall_nest */
4977 224 : if (expr1->ts.type == BT_CHARACTER)
4978 : {
4979 103 : type = NULL;
4980 103 : if (expr1->ref && expr1->ref->type == REF_SUBSTRING)
4981 : {
4982 72 : gfc_se ssse;
4983 72 : gfc_init_se (&ssse, NULL);
4984 72 : gfc_conv_expr (&ssse, expr1);
4985 72 : type = gfc_get_character_type_len (gfc_default_character_kind,
4986 : ssse.string_length);
4987 72 : }
4988 : else
4989 : {
4990 31 : if (!expr1->ts.u.cl->backend_decl)
4991 : {
4992 6 : gfc_se tse;
4993 6 : gcc_assert (expr1->ts.u.cl->length);
4994 6 : gfc_init_se (&tse, NULL);
4995 6 : gfc_conv_expr (&tse, expr1->ts.u.cl->length);
4996 6 : expr1->ts.u.cl->backend_decl = tse.expr;
4997 : }
4998 31 : type = gfc_get_character_type_len (gfc_default_character_kind,
4999 31 : expr1->ts.u.cl->backend_decl);
5000 : }
5001 : }
5002 : else
5003 121 : type = gfc_typenode_for_spec (&expr1->ts);
5004 :
5005 224 : gfc_init_block (&inner_size_body);
5006 224 : inner_size = compute_inner_temp_size (expr1, expr2, &inner_size_body,
5007 : &lss, &rss);
5008 :
5009 : /* Allocate temporary for nested forall construct according to the
5010 : information in nested_forall_info and inner_size. */
5011 224 : tmp1 = allocate_temp_for_forall_nest (nested_forall_info, type, inner_size,
5012 : &inner_size_body, block, &ptemp1);
5013 :
5014 : /* Generate codes to copy rhs to the temporary . */
5015 224 : tmp = generate_loop_for_rhs_to_temp (expr2, tmp1, count, count1, lss, rss,
5016 : wheremask, invert);
5017 :
5018 : /* Generate body and loops according to the information in
5019 : nested_forall_info. */
5020 224 : tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
5021 224 : gfc_add_expr_to_block (block, tmp);
5022 :
5023 : /* Reset count1. */
5024 224 : gfc_add_modify (block, count1, gfc_index_zero_node);
5025 :
5026 : /* Reset count. */
5027 224 : if (wheremask)
5028 27 : gfc_add_modify (block, count, gfc_index_zero_node);
5029 :
5030 : /* TODO: Second call to compute_inner_temp_size to initialize lss and
5031 : rss; there must be a better way. */
5032 224 : inner_size = compute_inner_temp_size (expr1, expr2, &inner_size_body,
5033 : &lss, &rss);
5034 :
5035 : /* Generate codes to copy the temporary to lhs. */
5036 224 : tmp = generate_loop_for_temp_to_lhs (expr1, tmp1, count, count1,
5037 : lss, rss,
5038 : wheremask, invert);
5039 :
5040 : /* Generate body and loops according to the information in
5041 : nested_forall_info. */
5042 224 : tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
5043 224 : gfc_add_expr_to_block (block, tmp);
5044 :
5045 224 : if (ptemp1)
5046 : {
5047 : /* Free the temporary. */
5048 145 : tmp = gfc_call_free (ptemp1);
5049 145 : gfc_add_expr_to_block (block, tmp);
5050 : }
5051 224 : }
5052 :
5053 :
5054 : /* Translate pointer assignment inside FORALL which need temporary. */
5055 :
5056 : static void
5057 20 : gfc_trans_pointer_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2,
5058 : forall_info * nested_forall_info,
5059 : stmtblock_t * block)
5060 : {
5061 20 : tree type;
5062 20 : tree inner_size;
5063 20 : gfc_ss *lss, *rss;
5064 20 : gfc_se lse;
5065 20 : gfc_se rse;
5066 20 : gfc_array_info *info;
5067 20 : gfc_loopinfo loop;
5068 20 : tree desc;
5069 20 : tree parm;
5070 20 : tree parmtype;
5071 20 : stmtblock_t body;
5072 20 : tree count;
5073 20 : tree tmp, tmp1, ptemp1;
5074 :
5075 20 : count = gfc_create_var (gfc_array_index_type, "count");
5076 20 : gfc_add_modify (block, count, gfc_index_zero_node);
5077 :
5078 20 : inner_size = gfc_index_one_node;
5079 20 : lss = gfc_walk_expr (expr1);
5080 20 : rss = gfc_walk_expr (expr2);
5081 20 : if (lss == gfc_ss_terminator)
5082 : {
5083 11 : type = gfc_typenode_for_spec (&expr1->ts);
5084 11 : type = build_pointer_type (type);
5085 :
5086 : /* Allocate temporary for nested forall construct according to the
5087 : information in nested_forall_info and inner_size. */
5088 11 : tmp1 = allocate_temp_for_forall_nest (nested_forall_info, type,
5089 : inner_size, NULL, block, &ptemp1);
5090 11 : gfc_start_block (&body);
5091 11 : gfc_init_se (&lse, NULL);
5092 11 : lse.expr = gfc_build_array_ref (tmp1, count, NULL);
5093 11 : gfc_init_se (&rse, NULL);
5094 11 : rse.want_pointer = 1;
5095 11 : gfc_conv_expr (&rse, expr2);
5096 11 : gfc_add_block_to_block (&body, &rse.pre);
5097 11 : gfc_add_modify (&body, lse.expr,
5098 11 : fold_convert (TREE_TYPE (lse.expr), rse.expr));
5099 11 : gfc_add_block_to_block (&body, &rse.post);
5100 :
5101 : /* Increment count. */
5102 11 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
5103 : count, gfc_index_one_node);
5104 11 : gfc_add_modify (&body, count, tmp);
5105 :
5106 11 : tmp = gfc_finish_block (&body);
5107 :
5108 : /* Generate body and loops according to the information in
5109 : nested_forall_info. */
5110 11 : tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
5111 11 : gfc_add_expr_to_block (block, tmp);
5112 :
5113 : /* Reset count. */
5114 11 : gfc_add_modify (block, count, gfc_index_zero_node);
5115 :
5116 11 : gfc_start_block (&body);
5117 11 : gfc_init_se (&lse, NULL);
5118 11 : gfc_init_se (&rse, NULL);
5119 11 : rse.expr = gfc_build_array_ref (tmp1, count, NULL);
5120 11 : lse.want_pointer = 1;
5121 11 : gfc_conv_expr (&lse, expr1);
5122 11 : gfc_add_block_to_block (&body, &lse.pre);
5123 11 : gfc_add_modify (&body, lse.expr, rse.expr);
5124 11 : gfc_add_block_to_block (&body, &lse.post);
5125 : /* Increment count. */
5126 11 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
5127 : count, gfc_index_one_node);
5128 11 : gfc_add_modify (&body, count, tmp);
5129 11 : tmp = gfc_finish_block (&body);
5130 :
5131 : /* Generate body and loops according to the information in
5132 : nested_forall_info. */
5133 11 : tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
5134 11 : gfc_add_expr_to_block (block, tmp);
5135 : }
5136 : else
5137 : {
5138 9 : gfc_init_loopinfo (&loop);
5139 :
5140 : /* Associate the SS with the loop. */
5141 9 : gfc_add_ss_to_loop (&loop, rss);
5142 :
5143 : /* Setup the scalarizing loops and bounds. */
5144 9 : gfc_conv_ss_startstride (&loop);
5145 :
5146 9 : gfc_conv_loop_setup (&loop, &expr2->where);
5147 :
5148 9 : info = &rss->info->data.array;
5149 9 : desc = info->descriptor;
5150 :
5151 : /* Make a new descriptor. */
5152 9 : parmtype = gfc_get_element_type (TREE_TYPE (desc));
5153 9 : parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen, 0,
5154 : loop.from, loop.to, 1,
5155 : GFC_ARRAY_UNKNOWN, true);
5156 :
5157 : /* Allocate temporary for nested forall construct. */
5158 9 : tmp1 = allocate_temp_for_forall_nest (nested_forall_info, parmtype,
5159 : inner_size, NULL, block, &ptemp1);
5160 9 : gfc_start_block (&body);
5161 9 : gfc_init_se (&lse, NULL);
5162 9 : lse.expr = gfc_build_array_ref (tmp1, count, NULL);
5163 9 : lse.direct_byref = 1;
5164 9 : gfc_conv_expr_descriptor (&lse, expr2);
5165 :
5166 9 : gfc_add_block_to_block (&body, &lse.pre);
5167 9 : gfc_add_block_to_block (&body, &lse.post);
5168 :
5169 : /* Increment count. */
5170 9 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
5171 : count, gfc_index_one_node);
5172 9 : gfc_add_modify (&body, count, tmp);
5173 :
5174 9 : tmp = gfc_finish_block (&body);
5175 :
5176 : /* Generate body and loops according to the information in
5177 : nested_forall_info. */
5178 9 : tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
5179 9 : gfc_add_expr_to_block (block, tmp);
5180 :
5181 : /* Reset count. */
5182 9 : gfc_add_modify (block, count, gfc_index_zero_node);
5183 :
5184 9 : parm = gfc_build_array_ref (tmp1, count, NULL);
5185 9 : gfc_init_se (&lse, NULL);
5186 9 : gfc_conv_expr_descriptor (&lse, expr1);
5187 9 : gfc_add_modify (&lse.pre, lse.expr, parm);
5188 9 : gfc_start_block (&body);
5189 9 : gfc_add_block_to_block (&body, &lse.pre);
5190 9 : gfc_add_block_to_block (&body, &lse.post);
5191 :
5192 : /* Increment count. */
5193 9 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
5194 : count, gfc_index_one_node);
5195 9 : gfc_add_modify (&body, count, tmp);
5196 :
5197 9 : tmp = gfc_finish_block (&body);
5198 :
5199 9 : tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
5200 9 : gfc_add_expr_to_block (block, tmp);
5201 : }
5202 : /* Free the temporary. */
5203 20 : if (ptemp1)
5204 : {
5205 1 : tmp = gfc_call_free (ptemp1);
5206 1 : gfc_add_expr_to_block (block, tmp);
5207 : }
5208 20 : }
5209 :
5210 : /* For saving the outer-variable data when doing
5211 : LOCAL and LOCAL_INIT substitution. */
5212 : struct symbol_and_tree_t
5213 : {
5214 : gfc_symbol *sym;
5215 : gfc_expr *value;
5216 : tree decl;
5217 : symbol_attribute attr;
5218 : };
5219 :
5220 : /* Handle the LOCAL and LOCAL_INIT locality specifiers. This has to be
5221 : called twice, once with after_body=false - and then after the loop
5222 : body has been processed with after_body=true.
5223 :
5224 : Creates a copy of the variables that appear in the LOCAL and LOCAL_INIT
5225 : locality specifiers of 'do concurrent' - and use it in the original
5226 : gfc_symbol. The declaration is then reset by after_body=true.
5227 :
5228 : Variables in LOCAL_INIT are set in every loop iteration. */
5229 :
5230 : void
5231 576 : gfc_trans_concurrent_locality_spec (bool after_body, stmtblock_t *body,
5232 : std::vector<symbol_and_tree_t> *saved_decls,
5233 : gfc_expr_list **locality_list)
5234 : {
5235 576 : if (!locality_list[LOCALITY_LOCAL] && !locality_list[LOCALITY_LOCAL_INIT])
5236 : return;
5237 :
5238 96 : if (after_body)
5239 : {
5240 205 : for (unsigned i = 0; i < saved_decls->size (); i++)
5241 : {
5242 157 : (*saved_decls)[i].sym->backend_decl = (*saved_decls)[i].decl;
5243 157 : (*saved_decls)[i].sym->attr = (*saved_decls)[i].attr;
5244 157 : (*saved_decls)[i].sym->value = (*saved_decls)[i].value;
5245 : }
5246 : return;
5247 : }
5248 :
5249 : gfc_expr_list *el;
5250 : int cnt = 0;
5251 144 : for (int i = 0; i <= 1; i++)
5252 96 : for (el = locality_list[i == 0 ? LOCALITY_LOCAL : LOCALITY_LOCAL_INIT];
5253 253 : el; el = el->next)
5254 : {
5255 157 : gfc_symbol *outer_sym = el->expr->symtree->n.sym;
5256 157 : if (!outer_sym->backend_decl)
5257 0 : outer_sym->backend_decl = gfc_get_symbol_decl (outer_sym);
5258 157 : cnt++;
5259 : }
5260 48 : saved_decls->resize (cnt);
5261 :
5262 : /* The variables have to be created in the scope of the loop body. */
5263 48 : if (!body->has_scope)
5264 : {
5265 48 : gcc_checking_assert (body->head == NULL_TREE);
5266 48 : gfc_start_block (body);
5267 : }
5268 48 : gfc_start_saved_local_decls ();
5269 :
5270 48 : cnt = 0;
5271 48 : static_assert (LOCALITY_LOCAL_INIT - LOCALITY_LOCAL == 1, "locality_type");
5272 144 : for (int type = LOCALITY_LOCAL;
5273 144 : type <= LOCALITY_LOCAL_INIT; type++)
5274 253 : for (el = locality_list[type]; el; el = el->next)
5275 : {
5276 157 : gfc_symbol *sym = el->expr->symtree->n.sym;
5277 157 : (*saved_decls)[cnt].sym = sym;
5278 157 : (*saved_decls)[cnt].attr = sym->attr;
5279 157 : (*saved_decls)[cnt].value = sym->value;
5280 157 : (*saved_decls)[cnt].decl = sym->backend_decl;
5281 :
5282 157 : if (sym->attr.dimension && sym->as->type == AS_ASSUMED_SHAPE)
5283 : {
5284 3 : gfc_error ("Sorry, %s specifier at %L for assumed-size array %qs "
5285 : "is not yet supported",
5286 : type == LOCALITY_LOCAL ? "LOCAL" : "LOCAL_INIT",
5287 : &el->expr->where, sym->name);
5288 2 : continue;
5289 : }
5290 :
5291 155 : gfc_symbol outer_sym = *sym;
5292 :
5293 : /* Create the inner local variable. */
5294 155 : sym->backend_decl = NULL;
5295 155 : sym->value = NULL;
5296 155 : sym->attr.save = SAVE_NONE;
5297 155 : sym->attr.value = 0;
5298 155 : sym->attr.dummy = 0;
5299 155 : sym->attr.optional = 0;
5300 :
5301 155 : {
5302 : /* Slightly ugly hack for adding the decl via add_decl_as_local. */
5303 155 : gfc_symbol dummy_block_sym;
5304 155 : dummy_block_sym.attr.flavor = FL_LABEL;
5305 155 : gfc_symbol *saved_proc_name = sym->ns->proc_name;
5306 155 : sym->ns->proc_name = &dummy_block_sym;
5307 :
5308 155 : gfc_get_symbol_decl (sym);
5309 310 : DECL_SOURCE_LOCATION (sym->backend_decl)
5310 155 : = gfc_get_location (&el->expr->where);
5311 :
5312 155 : sym->ns->proc_name = saved_proc_name;
5313 : }
5314 :
5315 155 : symbol_attribute attr = gfc_expr_attr (el->expr);
5316 155 : if (type == LOCALITY_LOCAL
5317 89 : && !attr.pointer
5318 41 : && sym->ts.type == BT_DERIVED
5319 183 : && gfc_has_default_initializer (sym->ts.u.derived))
5320 : /* Cf. PR fortran/ */
5321 4 : gfc_error ("Sorry, LOCAL specifier at %L for %qs of derived type with"
5322 : " default initializer is not yet supported",
5323 4 : &el->expr->where, sym->name);
5324 155 : if (type == LOCALITY_LOCAL_INIT)
5325 : {
5326 : /* LOCAL_INIT: local_var = outer_var. */
5327 66 : gfc_symtree st = *el->expr->symtree;
5328 66 : st.n.sym = &outer_sym;
5329 66 : gfc_expr expr = *el->expr;
5330 66 : expr.symtree = &st;
5331 66 : tree t = (attr.pointer
5332 66 : ? gfc_trans_pointer_assignment (el->expr, &expr)
5333 42 : : gfc_trans_assignment (el->expr, &expr, false, false,
5334 : false, false));
5335 66 : gfc_add_expr_to_block (body, t);
5336 : }
5337 155 : cnt++;
5338 : }
5339 48 : gfc_stop_saved_local_decls ();
5340 : }
5341 :
5342 :
5343 : /* FORALL and WHERE statements are really nasty, especially when you nest
5344 : them. All the rhs of a forall assignment must be evaluated before the
5345 : actual assignments are performed. Presumably this also applies to all the
5346 : assignments in an inner where statement. */
5347 :
5348 : /* Generate code for a FORALL statement. Any temporaries are allocated as a
5349 : linear array, relying on the fact that we process in the same order in all
5350 : loops.
5351 :
5352 : forall (i=start:end:stride; maskexpr)
5353 : e<i> = f<i>
5354 : g<i> = h<i>
5355 : end forall
5356 : (where e,f,g,h<i> are arbitrary expressions possibly involving i)
5357 : Translates to:
5358 : count = ((end + 1 - start) / stride)
5359 : masktmp(:) = maskexpr(:)
5360 :
5361 : maskindex = 0;
5362 : for (i = start; i <= end; i += stride)
5363 : {
5364 : if (masktmp[maskindex++])
5365 : e<i> = f<i>
5366 : }
5367 : maskindex = 0;
5368 : for (i = start; i <= end; i += stride)
5369 : {
5370 : if (masktmp[maskindex++])
5371 : g<i> = h<i>
5372 : }
5373 :
5374 : Note that this code only works when there are no dependencies.
5375 : Forall loop with array assignments and data dependencies are a real pain,
5376 : because the size of the temporary cannot always be determined before the
5377 : loop is executed. This problem is compounded by the presence of nested
5378 : FORALL constructs.
5379 : */
5380 :
5381 : static tree
5382 2254 : gfc_trans_forall_1 (gfc_code * code, forall_info * nested_forall_info)
5383 : {
5384 2254 : stmtblock_t pre;
5385 2254 : stmtblock_t post;
5386 2254 : stmtblock_t block;
5387 2254 : stmtblock_t body;
5388 2254 : tree *var;
5389 2254 : tree *start;
5390 2254 : tree *end;
5391 2254 : tree *step;
5392 2254 : gfc_expr **varexpr;
5393 2254 : tree tmp;
5394 2254 : tree assign;
5395 2254 : tree size;
5396 2254 : tree maskindex;
5397 2254 : tree mask;
5398 2254 : tree pmask;
5399 2254 : tree cycle_label = NULL_TREE;
5400 2254 : int n;
5401 2254 : int nvar;
5402 2254 : int need_temp;
5403 2254 : gfc_forall_iterator *fa;
5404 2254 : gfc_se se;
5405 2254 : gfc_code *c;
5406 2254 : gfc_saved_var *saved_vars;
5407 2254 : iter_info *this_forall;
5408 2254 : forall_info *info;
5409 2254 : bool need_mask;
5410 :
5411 : /* Do nothing if the mask is false. */
5412 2254 : if (code->expr1
5413 727 : && code->expr1->expr_type == EXPR_CONSTANT
5414 2 : && !code->expr1->value.logical)
5415 1 : return build_empty_stmt (input_location);
5416 :
5417 2253 : n = 0;
5418 : /* Count the FORALL index number. */
5419 6417 : for (fa = code->ext.concur.forall_iterator; fa; fa = fa->next)
5420 4164 : n++;
5421 2253 : nvar = n;
5422 :
5423 : /* Allocate the space for var, start, end, step, varexpr. */
5424 2253 : var = XCNEWVEC (tree, nvar);
5425 2253 : start = XCNEWVEC (tree, nvar);
5426 2253 : end = XCNEWVEC (tree, nvar);
5427 2253 : step = XCNEWVEC (tree, nvar);
5428 2253 : varexpr = XCNEWVEC (gfc_expr *, nvar);
5429 2253 : saved_vars = XCNEWVEC (gfc_saved_var, nvar);
5430 :
5431 : /* Allocate the space for info. */
5432 2253 : info = XCNEW (forall_info);
5433 :
5434 2253 : gfc_start_block (&pre);
5435 2253 : gfc_init_block (&post);
5436 2253 : gfc_init_block (&block);
5437 :
5438 2253 : n = 0;
5439 6417 : for (fa = code->ext.concur.forall_iterator; fa; fa = fa->next)
5440 : {
5441 4164 : gfc_symbol *sym = fa->var->symtree->n.sym;
5442 :
5443 : /* Allocate space for this_forall. */
5444 4164 : this_forall = XCNEW (iter_info);
5445 :
5446 : /* Create a temporary variable for the FORALL index. */
5447 4164 : tmp = gfc_typenode_for_spec (&sym->ts);
5448 4164 : var[n] = gfc_create_var (tmp, sym->name);
5449 4164 : gfc_shadow_sym (sym, var[n], &saved_vars[n]);
5450 :
5451 : /* Record it in this_forall. */
5452 4164 : this_forall->var = var[n];
5453 :
5454 : /* Replace the index symbol's backend_decl with the temporary decl. */
5455 4164 : sym->backend_decl = var[n];
5456 :
5457 : /* Work out the start, end and stride for the loop. */
5458 4164 : gfc_init_se (&se, NULL);
5459 4164 : gfc_conv_expr_val (&se, fa->start);
5460 : /* Record it in this_forall. */
5461 4164 : this_forall->start = se.expr;
5462 4164 : gfc_add_block_to_block (&block, &se.pre);
5463 4164 : start[n] = se.expr;
5464 :
5465 4164 : gfc_init_se (&se, NULL);
5466 4164 : gfc_conv_expr_val (&se, fa->end);
5467 : /* Record it in this_forall. */
5468 4164 : this_forall->end = se.expr;
5469 4164 : gfc_make_safe_expr (&se);
5470 4164 : gfc_add_block_to_block (&block, &se.pre);
5471 4164 : end[n] = se.expr;
5472 :
5473 4164 : gfc_init_se (&se, NULL);
5474 4164 : gfc_conv_expr_val (&se, fa->stride);
5475 : /* Record it in this_forall. */
5476 4164 : this_forall->step = se.expr;
5477 4164 : gfc_make_safe_expr (&se);
5478 4164 : gfc_add_block_to_block (&block, &se.pre);
5479 4164 : step[n] = se.expr;
5480 :
5481 : /* Copy loop annotations. */
5482 4164 : this_forall->annot = fa->annot;
5483 :
5484 : /* Set the NEXT field of this_forall to NULL. */
5485 4164 : this_forall->next = NULL;
5486 : /* Link this_forall to the info construct. */
5487 4164 : if (info->this_loop)
5488 : {
5489 : iter_info *iter_tmp = info->this_loop;
5490 2837 : while (iter_tmp->next != NULL)
5491 : iter_tmp = iter_tmp->next;
5492 1911 : iter_tmp->next = this_forall;
5493 : }
5494 : else
5495 2253 : info->this_loop = this_forall;
5496 :
5497 4164 : n++;
5498 : }
5499 2253 : nvar = n;
5500 :
5501 : /* Calculate the size needed for the current forall level. */
5502 2253 : size = gfc_index_one_node;
5503 6417 : for (n = 0; n < nvar; n++)
5504 : {
5505 : /* size = (end + step - start) / step. */
5506 4164 : tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (start[n]),
5507 4164 : step[n], start[n]);
5508 4164 : tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (end[n]),
5509 4164 : end[n], tmp);
5510 4164 : tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR, TREE_TYPE (tmp),
5511 : tmp, step[n]);
5512 4164 : tmp = convert (gfc_array_index_type, tmp);
5513 :
5514 4164 : size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
5515 : size, tmp);
5516 : }
5517 :
5518 : /* Record the nvar and size of current forall level. */
5519 2253 : info->nvar = nvar;
5520 2253 : info->size = size;
5521 :
5522 2253 : if (code->expr1)
5523 : {
5524 : /* If the mask is .true., consider the FORALL unconditional. */
5525 726 : if (code->expr1->expr_type == EXPR_CONSTANT
5526 1 : && code->expr1->value.logical)
5527 : need_mask = false;
5528 : else
5529 725 : need_mask = true;
5530 : }
5531 : else
5532 : need_mask = false;
5533 :
5534 : /* First we need to allocate the mask. */
5535 725 : if (need_mask)
5536 : {
5537 : /* As the mask array can be very big, prefer compact boolean types. */
5538 725 : tree mask_type = gfc_get_logical_type (gfc_logical_kinds[0].kind);
5539 725 : mask = allocate_temp_for_forall_nest (nested_forall_info, mask_type,
5540 : size, NULL, &block, &pmask);
5541 725 : maskindex = gfc_create_var_np (gfc_array_index_type, "mi");
5542 :
5543 : /* Record them in the info structure. */
5544 725 : info->maskindex = maskindex;
5545 725 : info->mask = mask;
5546 : }
5547 : else
5548 : {
5549 : /* No mask was specified. */
5550 1528 : maskindex = NULL_TREE;
5551 1528 : mask = pmask = NULL_TREE;
5552 : }
5553 :
5554 : /* Link the current forall level to nested_forall_info. */
5555 2253 : info->prev_nest = nested_forall_info;
5556 2253 : nested_forall_info = info;
5557 :
5558 : /* Copy the mask into a temporary variable if required.
5559 : For now we assume a mask temporary is needed. */
5560 2253 : if (need_mask)
5561 : {
5562 : /* As the mask array can be very big, prefer compact boolean types. */
5563 725 : tree mask_type = gfc_get_logical_type (gfc_logical_kinds[0].kind);
5564 :
5565 725 : gfc_add_modify (&block, maskindex, gfc_index_zero_node);
5566 :
5567 : /* Start of mask assignment loop body. */
5568 725 : gfc_start_block (&body);
5569 :
5570 : /* Evaluate the mask expression. */
5571 725 : gfc_init_se (&se, NULL);
5572 725 : gfc_conv_expr_val (&se, code->expr1);
5573 725 : gfc_add_block_to_block (&body, &se.pre);
5574 :
5575 : /* Store the mask. */
5576 725 : se.expr = convert (mask_type, se.expr);
5577 :
5578 725 : tmp = gfc_build_array_ref (mask, maskindex, NULL);
5579 725 : gfc_add_modify (&body, tmp, se.expr);
5580 :
5581 : /* Advance to the next mask element. */
5582 725 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
5583 : maskindex, gfc_index_one_node);
5584 725 : gfc_add_modify (&body, maskindex, tmp);
5585 :
5586 : /* Generate the loops. */
5587 725 : tmp = gfc_finish_block (&body);
5588 725 : tmp = gfc_trans_nested_forall_loop (info, tmp, 0);
5589 725 : gfc_add_expr_to_block (&block, tmp);
5590 : }
5591 :
5592 2253 : if (code->op == EXEC_DO_CONCURRENT)
5593 : {
5594 288 : gfc_init_block (&body);
5595 288 : cycle_label = gfc_build_label_decl (NULL_TREE);
5596 288 : code->cycle_label = cycle_label;
5597 :
5598 : /* Handle LOCAL and LOCAL_INIT. */
5599 288 : std::vector<symbol_and_tree_t> saved_decls;
5600 288 : gfc_trans_concurrent_locality_spec (false, &body, &saved_decls,
5601 288 : code->ext.concur.locality);
5602 :
5603 : /* Translate the body. */
5604 288 : tmp = gfc_trans_code (code->block->next);
5605 288 : gfc_add_expr_to_block (&body, tmp);
5606 :
5607 : /* Reset locality variables. */
5608 288 : gfc_trans_concurrent_locality_spec (true, &body, &saved_decls,
5609 : code->ext.concur.locality);
5610 288 : if (TREE_USED (cycle_label))
5611 : {
5612 288 : tmp = build1_v (LABEL_EXPR, cycle_label);
5613 288 : gfc_add_expr_to_block (&body, tmp);
5614 : }
5615 :
5616 288 : tmp = gfc_finish_block (&body);
5617 288 : nested_forall_info->do_concurrent = true;
5618 288 : tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
5619 288 : gfc_add_expr_to_block (&block, tmp);
5620 288 : goto done;
5621 288 : }
5622 :
5623 1965 : c = code->block->next;
5624 :
5625 : /* TODO: loop merging in FORALL statements. */
5626 : /* Now that we've got a copy of the mask, generate the assignment loops. */
5627 3947 : while (c)
5628 : {
5629 1982 : switch (c->op)
5630 : {
5631 1826 : case EXEC_ASSIGN:
5632 : /* A scalar or array assignment. DO the simple check for
5633 : lhs to rhs dependencies. These make a temporary for the
5634 : rhs and form a second forall block to copy to variable. */
5635 1826 : need_temp = check_forall_dependencies(c, &pre, &post);
5636 :
5637 : /* Temporaries due to array assignment data dependencies introduce
5638 : no end of problems. */
5639 1826 : if (need_temp || flag_test_forall_temp)
5640 197 : gfc_trans_assign_need_temp (c->expr1, c->expr2, NULL, false,
5641 : nested_forall_info, &block);
5642 : else
5643 : {
5644 : /* Use the normal assignment copying routines. */
5645 1629 : assign = gfc_trans_assignment (c->expr1, c->expr2, false, true);
5646 :
5647 : /* Generate body and loops. */
5648 1629 : tmp = gfc_trans_nested_forall_loop (nested_forall_info,
5649 : assign, 1);
5650 1629 : gfc_add_expr_to_block (&block, tmp);
5651 : }
5652 :
5653 : /* Cleanup any temporary symtrees that have been made to deal
5654 : with dependencies. */
5655 1826 : if (new_symtree)
5656 62 : cleanup_forall_symtrees (c);
5657 :
5658 : break;
5659 :
5660 47 : case EXEC_WHERE:
5661 : /* Translate WHERE or WHERE construct nested in FORALL. */
5662 47 : gfc_trans_where_2 (c, NULL, false, nested_forall_info, &block);
5663 47 : break;
5664 :
5665 : /* Pointer assignment inside FORALL. */
5666 27 : case EXEC_POINTER_ASSIGN:
5667 27 : need_temp = gfc_check_dependency (c->expr1, c->expr2, 0);
5668 : /* Avoid cases where a temporary would never be needed and where
5669 : the temp code is guaranteed to fail. */
5670 27 : if (need_temp
5671 7 : || (flag_test_forall_temp
5672 0 : && c->expr2->expr_type != EXPR_CONSTANT
5673 0 : && c->expr2->expr_type != EXPR_NULL))
5674 20 : gfc_trans_pointer_assign_need_temp (c->expr1, c->expr2,
5675 : nested_forall_info, &block);
5676 : else
5677 : {
5678 : /* Use the normal assignment copying routines. */
5679 7 : assign = gfc_trans_pointer_assignment (c->expr1, c->expr2);
5680 :
5681 : /* Generate body and loops. */
5682 7 : tmp = gfc_trans_nested_forall_loop (nested_forall_info,
5683 : assign, 1);
5684 7 : gfc_add_expr_to_block (&block, tmp);
5685 : }
5686 : break;
5687 :
5688 76 : case EXEC_FORALL:
5689 76 : tmp = gfc_trans_forall_1 (c, nested_forall_info);
5690 76 : gfc_add_expr_to_block (&block, tmp);
5691 76 : break;
5692 :
5693 : /* Explicit subroutine calls are prevented by the frontend but interface
5694 : assignments can legitimately produce them. */
5695 6 : case EXEC_ASSIGN_CALL:
5696 6 : assign = gfc_trans_call (c, true, NULL_TREE, NULL_TREE, false);
5697 6 : tmp = gfc_trans_nested_forall_loop (nested_forall_info, assign, 1);
5698 6 : gfc_add_expr_to_block (&block, tmp);
5699 6 : break;
5700 :
5701 0 : default:
5702 0 : gcc_unreachable ();
5703 : }
5704 :
5705 1982 : c = c->next;
5706 : }
5707 :
5708 1965 : done:
5709 : /* Restore the original index variables. */
5710 6417 : for (fa = code->ext.concur.forall_iterator, n = 0; fa; fa = fa->next, n++)
5711 4164 : gfc_restore_sym (fa->var->symtree->n.sym, &saved_vars[n]);
5712 :
5713 : /* Free the space for var, start, end, step, varexpr. */
5714 2253 : free (var);
5715 2253 : free (start);
5716 2253 : free (end);
5717 2253 : free (step);
5718 2253 : free (varexpr);
5719 2253 : free (saved_vars);
5720 :
5721 6417 : for (this_forall = info->this_loop; this_forall;)
5722 : {
5723 4164 : iter_info *next = this_forall->next;
5724 4164 : free (this_forall);
5725 4164 : this_forall = next;
5726 : }
5727 :
5728 : /* Free the space for this forall_info. */
5729 2253 : free (info);
5730 :
5731 2253 : if (pmask)
5732 : {
5733 : /* Free the temporary for the mask. */
5734 53 : tmp = gfc_call_free (pmask);
5735 53 : gfc_add_expr_to_block (&block, tmp);
5736 : }
5737 2253 : if (maskindex)
5738 725 : pushdecl (maskindex);
5739 :
5740 2253 : gfc_add_block_to_block (&pre, &block);
5741 2253 : gfc_add_block_to_block (&pre, &post);
5742 :
5743 2253 : return gfc_finish_block (&pre);
5744 : }
5745 :
5746 :
5747 : /* Translate the FORALL statement or construct. */
5748 :
5749 1890 : tree gfc_trans_forall (gfc_code * code)
5750 : {
5751 1890 : return gfc_trans_forall_1 (code, NULL);
5752 : }
5753 :
5754 :
5755 : /* Translate the DO CONCURRENT construct. */
5756 :
5757 288 : tree gfc_trans_do_concurrent (gfc_code * code)
5758 : {
5759 288 : return gfc_trans_forall_1 (code, NULL);
5760 : }
5761 :
5762 :
5763 : /* Evaluate the WHERE mask expression, copy its value to a temporary.
5764 : If the WHERE construct is nested in FORALL, compute the overall temporary
5765 : needed by the WHERE mask expression multiplied by the iterator number of
5766 : the nested forall.
5767 : ME is the WHERE mask expression.
5768 : MASK is the current execution mask upon input, whose sense may or may
5769 : not be inverted as specified by the INVERT argument.
5770 : CMASK is the updated execution mask on output, or NULL if not required.
5771 : PMASK is the pending execution mask on output, or NULL if not required.
5772 : BLOCK is the block in which to place the condition evaluation loops. */
5773 :
5774 : static void
5775 528 : gfc_evaluate_where_mask (gfc_expr * me, forall_info * nested_forall_info,
5776 : tree mask, bool invert, tree cmask, tree pmask,
5777 : tree mask_type, stmtblock_t * block)
5778 : {
5779 528 : tree tmp, tmp1;
5780 528 : gfc_ss *lss, *rss;
5781 528 : gfc_loopinfo loop;
5782 528 : stmtblock_t body, body1;
5783 528 : tree count, cond, mtmp;
5784 528 : gfc_se lse, rse;
5785 :
5786 528 : gfc_init_loopinfo (&loop);
5787 :
5788 528 : lss = gfc_walk_expr (me);
5789 528 : rss = gfc_walk_expr (me);
5790 :
5791 : /* Variable to index the temporary. */
5792 528 : count = gfc_create_var (gfc_array_index_type, "count");
5793 : /* Initialize count. */
5794 528 : gfc_add_modify (block, count, gfc_index_zero_node);
5795 :
5796 528 : gfc_start_block (&body);
5797 :
5798 528 : gfc_init_se (&rse, NULL);
5799 528 : gfc_init_se (&lse, NULL);
5800 :
5801 528 : if (lss == gfc_ss_terminator)
5802 : {
5803 0 : gfc_init_block (&body1);
5804 : }
5805 : else
5806 : {
5807 : /* Initialize the loop. */
5808 528 : gfc_init_loopinfo (&loop);
5809 :
5810 : /* We may need LSS to determine the shape of the expression. */
5811 528 : gfc_add_ss_to_loop (&loop, lss);
5812 528 : gfc_add_ss_to_loop (&loop, rss);
5813 :
5814 528 : gfc_conv_ss_startstride (&loop);
5815 528 : gfc_conv_loop_setup (&loop, &me->where);
5816 :
5817 528 : gfc_mark_ss_chain_used (rss, 1);
5818 : /* Start the loop body. */
5819 528 : gfc_start_scalarized_body (&loop, &body1);
5820 :
5821 : /* Translate the expression. */
5822 528 : gfc_copy_loopinfo_to_se (&rse, &loop);
5823 528 : rse.ss = rss;
5824 528 : gfc_conv_expr (&rse, me);
5825 : }
5826 :
5827 : /* Variable to evaluate mask condition. */
5828 528 : cond = gfc_create_var (mask_type, "cond");
5829 528 : if (mask && (cmask || pmask))
5830 234 : mtmp = gfc_create_var (mask_type, "mask");
5831 : else mtmp = NULL_TREE;
5832 :
5833 528 : gfc_add_block_to_block (&body1, &lse.pre);
5834 528 : gfc_add_block_to_block (&body1, &rse.pre);
5835 :
5836 528 : gfc_add_modify (&body1, cond, fold_convert (mask_type, rse.expr));
5837 :
5838 528 : if (mask && (cmask || pmask))
5839 : {
5840 234 : tmp = gfc_build_array_ref (mask, count, NULL);
5841 234 : if (invert)
5842 99 : tmp = fold_build1_loc (input_location, TRUTH_NOT_EXPR, mask_type, tmp);
5843 234 : gfc_add_modify (&body1, mtmp, tmp);
5844 : }
5845 :
5846 528 : if (cmask)
5847 : {
5848 510 : tmp1 = gfc_build_array_ref (cmask, count, NULL);
5849 510 : tmp = cond;
5850 510 : if (mask)
5851 234 : tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, mask_type,
5852 : mtmp, tmp);
5853 510 : gfc_add_modify (&body1, tmp1, tmp);
5854 : }
5855 :
5856 528 : if (pmask)
5857 : {
5858 146 : tmp1 = gfc_build_array_ref (pmask, count, NULL);
5859 146 : tmp = fold_build1_loc (input_location, TRUTH_NOT_EXPR, mask_type, cond);
5860 146 : if (mask)
5861 146 : tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, mask_type, mtmp,
5862 : tmp);
5863 146 : gfc_add_modify (&body1, tmp1, tmp);
5864 : }
5865 :
5866 528 : gfc_add_block_to_block (&body1, &lse.post);
5867 528 : gfc_add_block_to_block (&body1, &rse.post);
5868 :
5869 528 : if (lss == gfc_ss_terminator)
5870 : {
5871 0 : gfc_add_block_to_block (&body, &body1);
5872 : }
5873 : else
5874 : {
5875 : /* Increment count. */
5876 528 : tmp1 = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
5877 : count, gfc_index_one_node);
5878 528 : gfc_add_modify (&body1, count, tmp1);
5879 :
5880 : /* Generate the copying loops. */
5881 528 : gfc_trans_scalarizing_loops (&loop, &body1);
5882 :
5883 528 : gfc_add_block_to_block (&body, &loop.pre);
5884 528 : gfc_add_block_to_block (&body, &loop.post);
5885 :
5886 528 : gfc_cleanup_loop (&loop);
5887 : /* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful
5888 : as tree nodes in SS may not be valid in different scope. */
5889 : }
5890 :
5891 528 : tmp1 = gfc_finish_block (&body);
5892 : /* If the WHERE construct is inside FORALL, fill the full temporary. */
5893 528 : if (nested_forall_info != NULL)
5894 65 : tmp1 = gfc_trans_nested_forall_loop (nested_forall_info, tmp1, 1);
5895 :
5896 528 : gfc_add_expr_to_block (block, tmp1);
5897 528 : }
5898 :
5899 :
5900 : /* Translate an assignment statement in a WHERE statement or construct
5901 : statement. The MASK expression is used to control which elements
5902 : of EXPR1 shall be assigned. The sense of MASK is specified by
5903 : INVERT. */
5904 :
5905 : static tree
5906 545 : gfc_trans_where_assign (gfc_expr *expr1, gfc_expr *expr2,
5907 : tree mask, bool invert,
5908 : tree count1, tree count2,
5909 : gfc_code *cnext)
5910 : {
5911 545 : gfc_se lse;
5912 545 : gfc_se rse;
5913 545 : gfc_ss *lss;
5914 545 : gfc_ss *lss_section;
5915 545 : gfc_ss *rss;
5916 :
5917 545 : gfc_loopinfo loop;
5918 545 : tree tmp;
5919 545 : stmtblock_t block;
5920 545 : stmtblock_t body;
5921 545 : tree index, maskexpr;
5922 :
5923 : /* A defined assignment. */
5924 545 : if (cnext && cnext->resolved_sym)
5925 44 : return gfc_trans_call (cnext, true, mask, count1, invert);
5926 :
5927 : #if 0
5928 : /* TODO: handle this special case.
5929 : Special case a single function returning an array. */
5930 : if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
5931 : {
5932 : tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
5933 : if (tmp)
5934 : return tmp;
5935 : }
5936 : #endif
5937 :
5938 : /* Assignment of the form lhs = rhs. */
5939 501 : gfc_start_block (&block);
5940 :
5941 501 : gfc_init_se (&lse, NULL);
5942 501 : gfc_init_se (&rse, NULL);
5943 :
5944 : /* Walk the lhs. */
5945 501 : lss = gfc_walk_expr (expr1);
5946 501 : rss = NULL;
5947 :
5948 : /* In each where-assign-stmt, the mask-expr and the variable being
5949 : defined shall be arrays of the same shape. */
5950 501 : gcc_assert (lss != gfc_ss_terminator);
5951 :
5952 : /* The assignment needs scalarization. */
5953 : lss_section = lss;
5954 :
5955 : /* Find a non-scalar SS from the lhs. */
5956 : while (lss_section != gfc_ss_terminator
5957 501 : && lss_section->info->type != GFC_SS_SECTION)
5958 0 : lss_section = lss_section->next;
5959 :
5960 501 : gcc_assert (lss_section != gfc_ss_terminator);
5961 :
5962 : /* Initialize the scalarizer. */
5963 501 : gfc_init_loopinfo (&loop);
5964 :
5965 : /* Walk the rhs. */
5966 501 : rss = gfc_walk_expr (expr2);
5967 501 : if (rss == gfc_ss_terminator)
5968 : {
5969 : /* The rhs is scalar. Add a ss for the expression. */
5970 343 : rss = gfc_get_scalar_ss (gfc_ss_terminator, expr2);
5971 343 : rss->info->where = 1;
5972 : }
5973 :
5974 : /* Associate the SS with the loop. */
5975 501 : gfc_add_ss_to_loop (&loop, lss);
5976 501 : gfc_add_ss_to_loop (&loop, rss);
5977 :
5978 : /* Calculate the bounds of the scalarization. */
5979 501 : gfc_conv_ss_startstride (&loop);
5980 :
5981 : /* Resolve any data dependencies in the statement. */
5982 501 : gfc_conv_resolve_dependencies (&loop, lss_section, rss);
5983 :
5984 : /* Setup the scalarizing loops. */
5985 501 : gfc_conv_loop_setup (&loop, &expr2->where);
5986 :
5987 : /* Setup the gfc_se structures. */
5988 501 : gfc_copy_loopinfo_to_se (&lse, &loop);
5989 501 : gfc_copy_loopinfo_to_se (&rse, &loop);
5990 :
5991 501 : rse.ss = rss;
5992 501 : gfc_mark_ss_chain_used (rss, 1);
5993 501 : if (loop.temp_ss == NULL)
5994 : {
5995 422 : lse.ss = lss;
5996 422 : gfc_mark_ss_chain_used (lss, 1);
5997 : }
5998 : else
5999 : {
6000 79 : lse.ss = loop.temp_ss;
6001 79 : gfc_mark_ss_chain_used (lss, 3);
6002 79 : gfc_mark_ss_chain_used (loop.temp_ss, 3);
6003 : }
6004 :
6005 : /* Start the scalarized loop body. */
6006 501 : gfc_start_scalarized_body (&loop, &body);
6007 :
6008 : /* Translate the expression. */
6009 501 : gfc_conv_expr (&rse, expr2);
6010 501 : if (lss != gfc_ss_terminator && loop.temp_ss != NULL)
6011 79 : gfc_conv_tmp_array_ref (&lse);
6012 : else
6013 422 : gfc_conv_expr (&lse, expr1);
6014 :
6015 : /* Form the mask expression according to the mask. */
6016 501 : index = count1;
6017 501 : maskexpr = gfc_build_array_ref (mask, index, NULL);
6018 501 : if (invert)
6019 24 : maskexpr = fold_build1_loc (input_location, TRUTH_NOT_EXPR,
6020 24 : TREE_TYPE (maskexpr), maskexpr);
6021 :
6022 : /* Use the scalar assignment as is. */
6023 1002 : tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
6024 501 : false, loop.temp_ss == NULL);
6025 :
6026 501 : tmp = build3_v (COND_EXPR, maskexpr, tmp, build_empty_stmt (input_location));
6027 :
6028 501 : gfc_add_expr_to_block (&body, tmp);
6029 :
6030 501 : if (lss == gfc_ss_terminator)
6031 : {
6032 : /* Increment count1. */
6033 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
6034 : count1, gfc_index_one_node);
6035 : gfc_add_modify (&body, count1, tmp);
6036 :
6037 : /* Use the scalar assignment as is. */
6038 : gfc_add_block_to_block (&block, &body);
6039 : }
6040 : else
6041 : {
6042 501 : gcc_assert (lse.ss == gfc_ss_terminator
6043 : && rse.ss == gfc_ss_terminator);
6044 :
6045 501 : if (loop.temp_ss != NULL)
6046 : {
6047 : /* Increment count1 before finish the main body of a scalarized
6048 : expression. */
6049 79 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
6050 : gfc_array_index_type, count1, gfc_index_one_node);
6051 79 : gfc_add_modify (&body, count1, tmp);
6052 79 : gfc_trans_scalarized_loop_boundary (&loop, &body);
6053 :
6054 : /* We need to copy the temporary to the actual lhs. */
6055 79 : gfc_init_se (&lse, NULL);
6056 79 : gfc_init_se (&rse, NULL);
6057 79 : gfc_copy_loopinfo_to_se (&lse, &loop);
6058 79 : gfc_copy_loopinfo_to_se (&rse, &loop);
6059 :
6060 79 : rse.ss = loop.temp_ss;
6061 79 : lse.ss = lss;
6062 :
6063 79 : gfc_conv_tmp_array_ref (&rse);
6064 79 : gfc_conv_expr (&lse, expr1);
6065 :
6066 79 : gcc_assert (lse.ss == gfc_ss_terminator
6067 : && rse.ss == gfc_ss_terminator);
6068 :
6069 : /* Form the mask expression according to the mask tree list. */
6070 79 : index = count2;
6071 79 : maskexpr = gfc_build_array_ref (mask, index, NULL);
6072 79 : if (invert)
6073 0 : maskexpr = fold_build1_loc (input_location, TRUTH_NOT_EXPR,
6074 0 : TREE_TYPE (maskexpr), maskexpr);
6075 :
6076 : /* Use the scalar assignment as is. */
6077 79 : tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts, false, true);
6078 79 : tmp = build3_v (COND_EXPR, maskexpr, tmp,
6079 : build_empty_stmt (input_location));
6080 79 : gfc_add_expr_to_block (&body, tmp);
6081 :
6082 : /* Increment count2. */
6083 79 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
6084 : gfc_array_index_type, count2,
6085 : gfc_index_one_node);
6086 79 : gfc_add_modify (&body, count2, tmp);
6087 : }
6088 : else
6089 : {
6090 : /* Increment count1. */
6091 422 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
6092 : gfc_array_index_type, count1,
6093 : gfc_index_one_node);
6094 422 : gfc_add_modify (&body, count1, tmp);
6095 : }
6096 :
6097 : /* Generate the copying loops. */
6098 501 : gfc_trans_scalarizing_loops (&loop, &body);
6099 :
6100 : /* Wrap the whole thing up. */
6101 501 : gfc_add_block_to_block (&block, &loop.pre);
6102 501 : gfc_add_block_to_block (&block, &loop.post);
6103 501 : gfc_cleanup_loop (&loop);
6104 : }
6105 :
6106 501 : return gfc_finish_block (&block);
6107 : }
6108 :
6109 :
6110 : /* Translate the WHERE construct or statement.
6111 : This function can be called iteratively to translate the nested WHERE
6112 : construct or statement.
6113 : MASK is the control mask. */
6114 :
6115 : static void
6116 350 : gfc_trans_where_2 (gfc_code * code, tree mask, bool invert,
6117 : forall_info * nested_forall_info, stmtblock_t * block)
6118 : {
6119 350 : stmtblock_t inner_size_body;
6120 350 : tree inner_size, size;
6121 350 : gfc_ss *lss, *rss;
6122 350 : tree mask_type;
6123 350 : gfc_expr *expr1;
6124 350 : gfc_expr *expr2;
6125 350 : gfc_code *cblock;
6126 350 : gfc_code *cnext;
6127 350 : tree tmp;
6128 350 : tree cond;
6129 350 : tree count1, count2;
6130 350 : bool need_cmask;
6131 350 : bool need_pmask;
6132 350 : int need_temp;
6133 350 : tree pcmask = NULL_TREE;
6134 350 : tree ppmask = NULL_TREE;
6135 350 : tree cmask = NULL_TREE;
6136 350 : tree pmask = NULL_TREE;
6137 350 : gfc_actual_arglist *arg;
6138 :
6139 : /* the WHERE statement or the WHERE construct statement. */
6140 350 : cblock = code->block;
6141 :
6142 : /* As the mask array can be very big, prefer compact boolean types. */
6143 350 : mask_type = gfc_get_logical_type (gfc_logical_kinds[0].kind);
6144 :
6145 : /* Determine which temporary masks are needed. */
6146 350 : if (!cblock->block)
6147 : {
6148 : /* One clause: No ELSEWHEREs. */
6149 169 : need_cmask = (cblock->next != 0);
6150 169 : need_pmask = false;
6151 : }
6152 181 : else if (cblock->block->block)
6153 : {
6154 : /* Three or more clauses: Conditional ELSEWHEREs. */
6155 : need_cmask = true;
6156 : need_pmask = true;
6157 : }
6158 102 : else if (cblock->next)
6159 : {
6160 : /* Two clauses, the first non-empty. */
6161 84 : need_cmask = true;
6162 84 : need_pmask = (mask != NULL_TREE
6163 84 : && cblock->block->next != 0);
6164 : }
6165 18 : else if (!cblock->block->next)
6166 : {
6167 : /* Two clauses, both empty. */
6168 : need_cmask = false;
6169 : need_pmask = false;
6170 : }
6171 : /* Two clauses, the first empty, the second non-empty. */
6172 9 : else if (mask)
6173 : {
6174 0 : need_cmask = (cblock->block->expr1 != 0);
6175 0 : need_pmask = true;
6176 : }
6177 : else
6178 : {
6179 : need_cmask = true;
6180 : need_pmask = false;
6181 : }
6182 :
6183 169 : if (need_cmask || need_pmask)
6184 : {
6185 : /* Calculate the size of temporary needed by the mask-expr. */
6186 332 : gfc_init_block (&inner_size_body);
6187 332 : inner_size = compute_inner_temp_size (cblock->expr1, cblock->expr1,
6188 : &inner_size_body, &lss, &rss);
6189 :
6190 332 : gfc_free_ss_chain (lss);
6191 332 : gfc_free_ss_chain (rss);
6192 :
6193 : /* Calculate the total size of temporary needed. */
6194 332 : size = compute_overall_iter_number (nested_forall_info, inner_size,
6195 : &inner_size_body, block);
6196 :
6197 : /* Check whether the size is negative. */
6198 332 : cond = fold_build2_loc (input_location, LE_EXPR, logical_type_node, size,
6199 : gfc_index_zero_node);
6200 332 : size = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type,
6201 : cond, gfc_index_zero_node, size);
6202 332 : size = gfc_evaluate_now (size, block);
6203 :
6204 : /* Allocate temporary for WHERE mask if needed. */
6205 332 : if (need_cmask)
6206 332 : cmask = allocate_temp_for_forall_nest_1 (mask_type, size, block,
6207 : &pcmask);
6208 :
6209 : /* Allocate temporary for !mask if needed. */
6210 332 : if (need_pmask)
6211 83 : pmask = allocate_temp_for_forall_nest_1 (mask_type, size, block,
6212 : &ppmask);
6213 : }
6214 :
6215 996 : while (cblock)
6216 : {
6217 : /* Each time around this loop, the where clause is conditional
6218 : on the value of mask and invert, which are updated at the
6219 : bottom of the loop. */
6220 :
6221 : /* Has mask-expr. */
6222 646 : if (cblock->expr1)
6223 : {
6224 : /* Ensure that the WHERE mask will be evaluated exactly once.
6225 : If there are no statements in this WHERE/ELSEWHERE clause,
6226 : then we don't need to update the control mask (cmask).
6227 : If this is the last clause of the WHERE construct, then
6228 : we don't need to update the pending control mask (pmask). */
6229 528 : if (mask)
6230 234 : gfc_evaluate_where_mask (cblock->expr1, nested_forall_info,
6231 : mask, invert,
6232 234 : cblock->next ? cmask : NULL_TREE,
6233 234 : cblock->block ? pmask : NULL_TREE,
6234 : mask_type, block);
6235 : else
6236 294 : gfc_evaluate_where_mask (cblock->expr1, nested_forall_info,
6237 : NULL_TREE, false,
6238 294 : (cblock->next || cblock->block)
6239 : ? cmask : NULL_TREE,
6240 : NULL_TREE, mask_type, block);
6241 :
6242 : invert = false;
6243 : }
6244 : /* It's a final elsewhere-stmt. No mask-expr is present. */
6245 : else
6246 : cmask = mask;
6247 :
6248 : /* The body of this where clause are controlled by cmask with
6249 : sense specified by invert. */
6250 :
6251 : /* Get the assignment statement of a WHERE statement, or the first
6252 : statement in where-body-construct of a WHERE construct. */
6253 646 : cnext = cblock->next;
6254 1274 : while (cnext)
6255 : {
6256 628 : switch (cnext->op)
6257 : {
6258 : /* WHERE assignment statement. */
6259 44 : case EXEC_ASSIGN_CALL:
6260 :
6261 44 : arg = cnext->ext.actual;
6262 44 : expr1 = expr2 = NULL;
6263 132 : for (; arg; arg = arg->next)
6264 : {
6265 88 : if (!arg->expr)
6266 0 : continue;
6267 88 : if (expr1 == NULL)
6268 : expr1 = arg->expr;
6269 : else
6270 44 : expr2 = arg->expr;
6271 : }
6272 44 : goto evaluate;
6273 :
6274 528 : case EXEC_ASSIGN:
6275 528 : expr1 = cnext->expr1;
6276 528 : expr2 = cnext->expr2;
6277 572 : evaluate:
6278 572 : if (nested_forall_info != NULL)
6279 : {
6280 66 : need_temp = gfc_check_dependency (expr1, expr2, 0);
6281 66 : if ((need_temp || flag_test_forall_temp)
6282 28 : && cnext->op != EXEC_ASSIGN_CALL)
6283 27 : gfc_trans_assign_need_temp (expr1, expr2,
6284 : cmask, invert,
6285 : nested_forall_info, block);
6286 : else
6287 : {
6288 : /* Variables to control maskexpr. */
6289 39 : count1 = gfc_create_var (gfc_array_index_type, "count1");
6290 39 : count2 = gfc_create_var (gfc_array_index_type, "count2");
6291 39 : gfc_add_modify (block, count1, gfc_index_zero_node);
6292 39 : gfc_add_modify (block, count2, gfc_index_zero_node);
6293 :
6294 39 : tmp = gfc_trans_where_assign (expr1, expr2,
6295 : cmask, invert,
6296 : count1, count2,
6297 : cnext);
6298 :
6299 39 : tmp = gfc_trans_nested_forall_loop (nested_forall_info,
6300 : tmp, 1);
6301 39 : gfc_add_expr_to_block (block, tmp);
6302 : }
6303 : }
6304 : else
6305 : {
6306 : /* Variables to control maskexpr. */
6307 506 : count1 = gfc_create_var (gfc_array_index_type, "count1");
6308 506 : count2 = gfc_create_var (gfc_array_index_type, "count2");
6309 506 : gfc_add_modify (block, count1, gfc_index_zero_node);
6310 506 : gfc_add_modify (block, count2, gfc_index_zero_node);
6311 :
6312 506 : tmp = gfc_trans_where_assign (expr1, expr2,
6313 : cmask, invert,
6314 : count1, count2,
6315 : cnext);
6316 506 : gfc_add_expr_to_block (block, tmp);
6317 :
6318 : }
6319 : break;
6320 :
6321 : /* WHERE or WHERE construct is part of a where-body-construct. */
6322 56 : case EXEC_WHERE:
6323 56 : gfc_trans_where_2 (cnext, cmask, invert,
6324 : nested_forall_info, block);
6325 56 : break;
6326 :
6327 0 : default:
6328 0 : gcc_unreachable ();
6329 : }
6330 :
6331 : /* The next statement within the same where-body-construct. */
6332 628 : cnext = cnext->next;
6333 : }
6334 : /* The next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt. */
6335 646 : cblock = cblock->block;
6336 646 : if (mask == NULL_TREE)
6337 : {
6338 : /* If we're the initial WHERE, we can simply invert the sense
6339 : of the current mask to obtain the "mask" for the remaining
6340 : ELSEWHEREs. */
6341 : invert = true;
6342 : mask = cmask;
6343 : }
6344 : else
6345 : {
6346 : /* Otherwise, for nested WHERE's we need to use the pending mask. */
6347 343 : invert = false;
6348 343 : mask = pmask;
6349 : }
6350 : }
6351 :
6352 : /* If we allocated a pending mask array, deallocate it now. */
6353 350 : if (ppmask)
6354 : {
6355 1 : tmp = gfc_call_free (ppmask);
6356 1 : gfc_add_expr_to_block (block, tmp);
6357 : }
6358 :
6359 : /* If we allocated a current mask array, deallocate it now. */
6360 350 : if (pcmask)
6361 : {
6362 44 : tmp = gfc_call_free (pcmask);
6363 44 : gfc_add_expr_to_block (block, tmp);
6364 : }
6365 350 : }
6366 :
6367 : /* Translate a simple WHERE construct or statement without dependencies.
6368 : CBLOCK is the "then" clause of the WHERE statement, where CBLOCK->EXPR
6369 : is the mask condition, and EBLOCK if non-NULL is the "else" clause.
6370 : Currently both CBLOCK and EBLOCK are restricted to single assignments. */
6371 :
6372 : static tree
6373 102 : gfc_trans_where_3 (gfc_code * cblock, gfc_code * eblock)
6374 : {
6375 102 : stmtblock_t block, body;
6376 102 : gfc_expr *cond, *tdst, *tsrc, *edst, *esrc;
6377 102 : tree tmp, cexpr, tstmt, estmt;
6378 102 : gfc_ss *css, *tdss, *tsss;
6379 102 : gfc_se cse, tdse, tsse, edse, esse;
6380 102 : gfc_loopinfo loop;
6381 102 : gfc_ss *edss = 0;
6382 102 : gfc_ss *esss = 0;
6383 102 : bool maybe_workshare = false;
6384 :
6385 : /* Allow the scalarizer to workshare simple where loops. */
6386 102 : if ((ompws_flags & (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_BODY))
6387 : == OMPWS_WORKSHARE_FLAG)
6388 : {
6389 13 : maybe_workshare = true;
6390 13 : ompws_flags |= OMPWS_SCALARIZER_WS | OMPWS_SCALARIZER_BODY;
6391 : }
6392 :
6393 102 : cond = cblock->expr1;
6394 102 : tdst = cblock->next->expr1;
6395 102 : tsrc = cblock->next->expr2;
6396 102 : edst = eblock ? eblock->next->expr1 : NULL;
6397 13 : esrc = eblock ? eblock->next->expr2 : NULL;
6398 :
6399 102 : gfc_start_block (&block);
6400 102 : gfc_init_loopinfo (&loop);
6401 :
6402 : /* Handle the condition. */
6403 102 : gfc_init_se (&cse, NULL);
6404 102 : css = gfc_walk_expr (cond);
6405 102 : gfc_add_ss_to_loop (&loop, css);
6406 :
6407 : /* Handle the then-clause. */
6408 102 : gfc_init_se (&tdse, NULL);
6409 102 : gfc_init_se (&tsse, NULL);
6410 102 : tdss = gfc_walk_expr (tdst);
6411 102 : tsss = gfc_walk_expr (tsrc);
6412 102 : if (tsss == gfc_ss_terminator)
6413 : {
6414 58 : tsss = gfc_get_scalar_ss (gfc_ss_terminator, tsrc);
6415 58 : tsss->info->where = 1;
6416 : }
6417 102 : gfc_add_ss_to_loop (&loop, tdss);
6418 102 : gfc_add_ss_to_loop (&loop, tsss);
6419 :
6420 102 : if (eblock)
6421 : {
6422 : /* Handle the else clause. */
6423 13 : gfc_init_se (&edse, NULL);
6424 13 : gfc_init_se (&esse, NULL);
6425 13 : edss = gfc_walk_expr (edst);
6426 13 : esss = gfc_walk_expr (esrc);
6427 13 : if (esss == gfc_ss_terminator)
6428 : {
6429 13 : esss = gfc_get_scalar_ss (gfc_ss_terminator, esrc);
6430 13 : esss->info->where = 1;
6431 : }
6432 13 : gfc_add_ss_to_loop (&loop, edss);
6433 13 : gfc_add_ss_to_loop (&loop, esss);
6434 : }
6435 :
6436 102 : gfc_conv_ss_startstride (&loop);
6437 102 : gfc_conv_loop_setup (&loop, &tdst->where);
6438 :
6439 102 : gfc_mark_ss_chain_used (css, 1);
6440 102 : gfc_mark_ss_chain_used (tdss, 1);
6441 102 : gfc_mark_ss_chain_used (tsss, 1);
6442 102 : if (eblock)
6443 : {
6444 13 : gfc_mark_ss_chain_used (edss, 1);
6445 13 : gfc_mark_ss_chain_used (esss, 1);
6446 : }
6447 :
6448 102 : gfc_start_scalarized_body (&loop, &body);
6449 :
6450 102 : gfc_copy_loopinfo_to_se (&cse, &loop);
6451 102 : gfc_copy_loopinfo_to_se (&tdse, &loop);
6452 102 : gfc_copy_loopinfo_to_se (&tsse, &loop);
6453 102 : cse.ss = css;
6454 102 : tdse.ss = tdss;
6455 102 : tsse.ss = tsss;
6456 102 : if (eblock)
6457 : {
6458 13 : gfc_copy_loopinfo_to_se (&edse, &loop);
6459 13 : gfc_copy_loopinfo_to_se (&esse, &loop);
6460 13 : edse.ss = edss;
6461 13 : esse.ss = esss;
6462 : }
6463 :
6464 102 : gfc_conv_expr (&cse, cond);
6465 102 : gfc_add_block_to_block (&body, &cse.pre);
6466 102 : cexpr = cse.expr;
6467 :
6468 102 : gfc_conv_expr (&tsse, tsrc);
6469 102 : if (tdss != gfc_ss_terminator && loop.temp_ss != NULL)
6470 0 : gfc_conv_tmp_array_ref (&tdse);
6471 : else
6472 102 : gfc_conv_expr (&tdse, tdst);
6473 :
6474 102 : if (eblock)
6475 : {
6476 13 : gfc_conv_expr (&esse, esrc);
6477 13 : if (edss != gfc_ss_terminator && loop.temp_ss != NULL)
6478 0 : gfc_conv_tmp_array_ref (&edse);
6479 : else
6480 13 : gfc_conv_expr (&edse, edst);
6481 : }
6482 :
6483 102 : tstmt = gfc_trans_scalar_assign (&tdse, &tsse, tdst->ts, false, true);
6484 102 : estmt = eblock ? gfc_trans_scalar_assign (&edse, &esse, edst->ts,
6485 : false, true)
6486 89 : : build_empty_stmt (input_location);
6487 102 : tmp = build3_v (COND_EXPR, cexpr, tstmt, estmt);
6488 102 : gfc_add_expr_to_block (&body, tmp);
6489 102 : gfc_add_block_to_block (&body, &cse.post);
6490 :
6491 102 : if (maybe_workshare)
6492 13 : ompws_flags &= ~OMPWS_SCALARIZER_BODY;
6493 102 : gfc_trans_scalarizing_loops (&loop, &body);
6494 102 : gfc_add_block_to_block (&block, &loop.pre);
6495 102 : gfc_add_block_to_block (&block, &loop.post);
6496 102 : gfc_cleanup_loop (&loop);
6497 :
6498 102 : return gfc_finish_block (&block);
6499 : }
6500 :
6501 : /* As the WHERE or WHERE construct statement can be nested, we call
6502 : gfc_trans_where_2 to do the translation, and pass the initial
6503 : NULL values for both the control mask and the pending control mask. */
6504 :
6505 : tree
6506 349 : gfc_trans_where (gfc_code * code)
6507 : {
6508 349 : stmtblock_t block;
6509 349 : gfc_code *cblock;
6510 349 : gfc_code *eblock;
6511 :
6512 349 : cblock = code->block;
6513 349 : if (cblock->next
6514 322 : && cblock->next->op == EXEC_ASSIGN
6515 277 : && !cblock->next->next)
6516 : {
6517 275 : eblock = cblock->block;
6518 275 : if (!eblock)
6519 : {
6520 : /* A simple "WHERE (cond) x = y" statement or block is
6521 : dependence free if cond is not dependent upon writing x,
6522 : and the source y is unaffected by the destination x. */
6523 170 : if (!gfc_check_dependency (cblock->next->expr1,
6524 : cblock->expr1, 0)
6525 284 : && !gfc_check_dependency (cblock->next->expr1,
6526 114 : cblock->next->expr2, 0))
6527 89 : return gfc_trans_where_3 (cblock, NULL);
6528 : }
6529 105 : else if (!eblock->expr1
6530 35 : && !eblock->block
6531 35 : && eblock->next
6532 26 : && eblock->next->op == EXEC_ASSIGN
6533 25 : && !eblock->next->next)
6534 : {
6535 : /* A simple "WHERE (cond) x1 = y1 ELSEWHERE x2 = y2 ENDWHERE"
6536 : block is dependence free if cond is not dependent on writes
6537 : to x1 and x2, y1 is not dependent on writes to x2, and y2
6538 : is not dependent on writes to x1, and both y's are not
6539 : dependent upon their own x's. In addition to this, the
6540 : final two dependency checks below exclude all but the same
6541 : array reference if the where and elswhere destinations
6542 : are the same. In short, this is VERY conservative and this
6543 : is needed because the two loops, required by the standard
6544 : are coalesced in gfc_trans_where_3. */
6545 25 : if (!gfc_check_dependency (cblock->next->expr1,
6546 : cblock->expr1, 0)
6547 25 : && !gfc_check_dependency (eblock->next->expr1,
6548 : cblock->expr1, 0)
6549 25 : && !gfc_check_dependency (cblock->next->expr1,
6550 25 : eblock->next->expr2, 1)
6551 19 : && !gfc_check_dependency (eblock->next->expr1,
6552 19 : cblock->next->expr2, 1)
6553 19 : && !gfc_check_dependency (cblock->next->expr1,
6554 19 : cblock->next->expr2, 1)
6555 19 : && !gfc_check_dependency (eblock->next->expr1,
6556 19 : eblock->next->expr2, 1)
6557 19 : && !gfc_check_dependency (cblock->next->expr1,
6558 19 : eblock->next->expr1, 0)
6559 44 : && !gfc_check_dependency (eblock->next->expr1,
6560 19 : cblock->next->expr1, 0))
6561 13 : return gfc_trans_where_3 (cblock, eblock);
6562 : }
6563 : }
6564 :
6565 247 : gfc_start_block (&block);
6566 :
6567 247 : gfc_trans_where_2 (code, NULL, false, NULL, &block);
6568 :
6569 247 : return gfc_finish_block (&block);
6570 : }
6571 :
6572 :
6573 : /* CYCLE a DO loop. The label decl has already been created by
6574 : gfc_trans_do(), it's in TREE_PURPOSE (backend_decl) of the gfc_code
6575 : node at the head of the loop. We must mark the label as used. */
6576 :
6577 : tree
6578 123 : gfc_trans_cycle (gfc_code * code)
6579 : {
6580 123 : tree cycle_label;
6581 :
6582 123 : cycle_label = code->ext.which_construct->cycle_label;
6583 123 : gcc_assert (cycle_label);
6584 :
6585 123 : TREE_USED (cycle_label) = 1;
6586 123 : return build1_v (GOTO_EXPR, cycle_label);
6587 : }
6588 :
6589 :
6590 : /* EXIT a DO loop. Similar to CYCLE, but now the label is in
6591 : TREE_VALUE (backend_decl) of the gfc_code node at the head of the
6592 : loop. */
6593 :
6594 : tree
6595 720 : gfc_trans_exit (gfc_code * code)
6596 : {
6597 720 : tree exit_label;
6598 :
6599 720 : exit_label = code->ext.which_construct->exit_label;
6600 720 : gcc_assert (exit_label);
6601 :
6602 720 : TREE_USED (exit_label) = 1;
6603 720 : return build1_v (GOTO_EXPR, exit_label);
6604 : }
6605 :
6606 :
6607 : /* Add the type parameter list to a PDT structure expression. */
6608 :
6609 : static void
6610 0 : convert_structure_to_type_list (gfc_symbol *derived, gfc_expr *init)
6611 : {
6612 0 : gfc_constructor *ctr;
6613 0 : gfc_component *cmp;
6614 0 : gfc_actual_arglist *parms = NULL;
6615 0 : ctr = gfc_constructor_first (init->value.constructor);
6616 0 : cmp = derived->components;
6617 0 : init->param_list = NULL;
6618 0 : for (; ctr && cmp; ctr = gfc_constructor_next (ctr), cmp = cmp->next)
6619 : {
6620 0 : if (!cmp->attr.pdt_kind && !cmp->attr.pdt_len)
6621 : break;
6622 0 : if (!init->param_list)
6623 0 : init->param_list = parms = gfc_get_actual_arglist ();
6624 : else
6625 : {
6626 0 : parms->next = gfc_get_actual_arglist ();
6627 0 : parms = parms->next;
6628 : }
6629 0 : parms->name = cmp->name;
6630 0 : parms->spec_type = ctr->expr ? SPEC_EXPLICIT : SPEC_ASSUMED;
6631 0 : parms->expr = gfc_copy_expr (ctr->expr);
6632 : }
6633 0 : }
6634 :
6635 :
6636 : /* Build param_list from explicit allocation parameters. */
6637 :
6638 : static void
6639 24 : build_param_list_from_expr (gfc_expr *init, gfc_actual_arglist *expr_param_list,
6640 : gfc_symbol *derived)
6641 : {
6642 24 : gfc_component *cmp;
6643 24 : gfc_actual_arglist *param, *parms = NULL;
6644 :
6645 24 : if (!expr_param_list)
6646 : return;
6647 :
6648 24 : init->param_list = NULL;
6649 24 : cmp = derived->components;
6650 24 : param = expr_param_list;
6651 :
6652 : /* Build param_list using explicit parameters, matching components. */
6653 72 : for (; cmp && param; cmp = cmp->next)
6654 : {
6655 48 : if (!cmp->attr.pdt_kind && !cmp->attr.pdt_len)
6656 : break;
6657 :
6658 48 : if (!init->param_list)
6659 24 : init->param_list = parms = gfc_get_actual_arglist ();
6660 : else
6661 : {
6662 24 : parms->next = gfc_get_actual_arglist ();
6663 24 : parms = parms->next;
6664 : }
6665 48 : parms->name = cmp->name;
6666 48 : parms->spec_type = param->spec_type;
6667 48 : parms->expr = gfc_copy_expr (param->expr);
6668 48 : param = param->next;
6669 : }
6670 : }
6671 :
6672 :
6673 : /* Get the initializer expression for the code and expr of an allocate.
6674 : When no initializer is needed return NULL. */
6675 :
6676 : static gfc_expr *
6677 13826 : allocate_get_initializer (gfc_code * code, gfc_expr * expr)
6678 : {
6679 13826 : if (!gfc_bt_struct (expr->ts.type) && expr->ts.type != BT_CLASS)
6680 : return NULL;
6681 :
6682 : /* An explicit type was given in allocate ( T:: object). */
6683 4117 : if (code->ext.alloc.ts.type == BT_DERIVED
6684 4117 : && (code->ext.alloc.ts.u.derived->attr.alloc_comp
6685 572 : || gfc_has_default_initializer (code->ext.alloc.ts.u.derived)))
6686 : {
6687 392 : gfc_expr *init = gfc_default_initializer (&code->ext.alloc.ts);
6688 392 : if (code->ext.alloc.ts.u.derived->attr.pdt_type
6689 24 : && init && init->expr_type == EXPR_STRUCTURE)
6690 : {
6691 : /* Use explicit parameters from the allocate statement if available,
6692 : otherwise extract from the structure constructor. */
6693 24 : if (expr && expr->param_list)
6694 24 : build_param_list_from_expr (init, expr->param_list,
6695 : code->ext.alloc.ts.u.derived);
6696 : else
6697 0 : convert_structure_to_type_list (code->ext.alloc.ts.u.derived, init);
6698 : }
6699 : return init;
6700 : }
6701 :
6702 641 : if (gfc_bt_struct (expr->ts.type)
6703 3725 : && (expr->ts.u.derived->attr.alloc_comp
6704 1929 : || gfc_has_default_initializer (expr->ts.u.derived)))
6705 1611 : return gfc_default_initializer (&expr->ts);
6706 :
6707 2114 : if (expr->ts.type == BT_CLASS
6708 2114 : && (CLASS_DATA (expr)->ts.u.derived->attr.alloc_comp
6709 539 : || gfc_has_default_initializer (CLASS_DATA (expr)->ts.u.derived)))
6710 187 : return gfc_default_initializer (&CLASS_DATA (expr)->ts);
6711 :
6712 : return NULL;
6713 : }
6714 :
6715 : /* Translate the ALLOCATE statement. */
6716 :
6717 : tree
6718 14826 : gfc_trans_allocate (gfc_code * code, gfc_omp_namelist *omp_allocate)
6719 : {
6720 14826 : gfc_alloc *al;
6721 14826 : gfc_expr *expr, *e3rhs = NULL, *init_expr;
6722 14826 : gfc_se se, se_sz;
6723 14826 : tree tmp;
6724 14826 : tree parm;
6725 14826 : tree stat;
6726 14826 : tree errmsg;
6727 14826 : tree errlen;
6728 14826 : tree label_errmsg;
6729 14826 : tree label_finish;
6730 14826 : tree memsz;
6731 14826 : tree al_vptr, al_len;
6732 : /* If an expr3 is present, then store the tree for accessing its
6733 : _vptr, and _len components in the variables, respectively. The
6734 : element size, i.e. _vptr%size, is stored in expr3_esize. Any of
6735 : the trees may be the NULL_TREE indicating that this is not
6736 : available for expr3's type. */
6737 14826 : tree expr3, expr3_vptr, expr3_len, expr3_esize;
6738 : /* Classify what expr3 stores. */
6739 14826 : enum { E3_UNSET = 0, E3_SOURCE, E3_MOLD, E3_DESC } e3_is;
6740 14826 : stmtblock_t block;
6741 14826 : stmtblock_t post;
6742 14826 : stmtblock_t final_block;
6743 14826 : bool upoly_expr, tmp_expr3_len_flag = false, al_len_needs_set, is_coarray;
6744 14826 : bool needs_caf_sync, caf_refs_comp;
6745 14826 : bool e3_has_nodescriptor = false;
6746 14826 : gfc_symtree *newsym = NULL;
6747 14826 : symbol_attribute caf_attr;
6748 14826 : gfc_actual_arglist *param_list;
6749 14826 : tree ts_string_length = NULL_TREE;
6750 :
6751 14826 : if (!code->ext.alloc.list)
6752 : return NULL_TREE;
6753 :
6754 14826 : stat = tmp = memsz = al_vptr = al_len = NULL_TREE;
6755 14826 : expr3 = expr3_vptr = expr3_len = expr3_esize = NULL_TREE;
6756 14826 : label_errmsg = label_finish = errmsg = errlen = NULL_TREE;
6757 14826 : e3_is = E3_UNSET;
6758 14826 : is_coarray = needs_caf_sync = false;
6759 :
6760 14826 : gfc_init_block (&block);
6761 14826 : gfc_init_block (&post);
6762 14826 : gfc_init_block (&final_block);
6763 :
6764 : /* STAT= (and maybe ERRMSG=) is present. */
6765 14826 : if (code->expr1)
6766 : {
6767 : /* STAT=. */
6768 296 : tree gfc_int4_type_node = gfc_get_int_type (4);
6769 296 : stat = gfc_create_var (gfc_int4_type_node, "stat");
6770 :
6771 : /* ERRMSG= only makes sense with STAT=. */
6772 296 : if (code->expr2)
6773 : {
6774 72 : gfc_init_se (&se, NULL);
6775 72 : se.want_pointer = 1;
6776 72 : gfc_conv_expr_lhs (&se, code->expr2);
6777 72 : errmsg = se.expr;
6778 72 : errlen = se.string_length;
6779 : }
6780 : else
6781 : {
6782 224 : errmsg = null_pointer_node;
6783 224 : errlen = build_int_cst (gfc_charlen_type_node, 0);
6784 : }
6785 :
6786 : /* GOTO destinations. */
6787 296 : label_errmsg = gfc_build_label_decl (NULL_TREE);
6788 296 : label_finish = gfc_build_label_decl (NULL_TREE);
6789 296 : TREE_USED (label_finish) = 0;
6790 : }
6791 :
6792 : /* When an expr3 is present evaluate it only once. The standards prevent a
6793 : dependency of expr3 on the objects in the allocate list. An expr3 can
6794 : be pre-evaluated in all cases. One just has to make sure, to use the
6795 : correct way, i.e., to get the descriptor or to get a reference
6796 : expression. */
6797 14826 : if (code->expr3)
6798 : {
6799 4007 : bool vtab_needed = false, temp_var_needed = false,
6800 4007 : temp_obj_created = false;
6801 :
6802 4007 : is_coarray = gfc_is_coarray (code->expr3);
6803 :
6804 293 : if (code->expr3->expr_type == EXPR_FUNCTION && !code->expr3->mold
6805 4264 : && (gfc_is_class_array_function (code->expr3)
6806 227 : || gfc_is_alloc_class_scalar_function (code->expr3)))
6807 78 : code->expr3->must_finalize = 1;
6808 :
6809 : /* Figure whether we need the vtab from expr3. */
6810 8028 : for (al = code->ext.alloc.list; !vtab_needed && al != NULL;
6811 4021 : al = al->next)
6812 4021 : vtab_needed = (al->expr->ts.type == BT_CLASS);
6813 :
6814 4007 : gfc_init_se (&se, NULL);
6815 : /* When expr3 is a variable, i.e., a very simple expression, then
6816 : convert it once here. If one has a source expression that has
6817 : substring references, part-refs, or %re/%im inquiries, wrap the
6818 : entity in parentheses to force evaluation of the expression. */
6819 4007 : if (code->expr3->expr_type == EXPR_VARIABLE
6820 4007 : && is_subref_array (code->expr3))
6821 60 : code->expr3 = gfc_get_parentheses (code->expr3);
6822 :
6823 4007 : if (code->expr3->expr_type == EXPR_VARIABLE
6824 2678 : || code->expr3->expr_type == EXPR_ARRAY
6825 1602 : || code->expr3->expr_type == EXPR_CONSTANT)
6826 : {
6827 2873 : if (!code->expr3->mold
6828 247 : || code->expr3->ts.type == BT_CHARACTER
6829 119 : || vtab_needed
6830 71 : || code->ext.alloc.arr_spec_from_expr3)
6831 : {
6832 : /* Convert expr3 to a tree. For all "simple" expression just
6833 : get the descriptor or the reference, respectively, depending
6834 : on the rank of the expr. */
6835 2873 : if (code->ext.alloc.arr_spec_from_expr3 || code->expr3->rank != 0)
6836 1659 : gfc_conv_expr_descriptor (&se, code->expr3);
6837 : else
6838 : {
6839 1214 : gfc_conv_expr_reference (&se, code->expr3);
6840 :
6841 : /* gfc_conv_expr_reference wraps POINTER_PLUS_EXPR in a
6842 : NOP_EXPR, which prevents gfortran from getting the vptr
6843 : from the source=-expression. Remove the NOP_EXPR and go
6844 : with the POINTER_PLUS_EXPR in this case. */
6845 1214 : if (code->expr3->ts.type == BT_CLASS
6846 256 : && TREE_CODE (se.expr) == NOP_EXPR
6847 1370 : && (TREE_CODE (TREE_OPERAND (se.expr, 0))
6848 : == POINTER_PLUS_EXPR
6849 138 : || is_coarray))
6850 30 : se.expr = TREE_OPERAND (se.expr, 0);
6851 : }
6852 : /* Create a temp variable only for component refs to prevent
6853 : having to go through the full deref-chain each time and to
6854 : simplify computation of array properties. */
6855 2873 : temp_var_needed = TREE_CODE (se.expr) == COMPONENT_REF;
6856 : }
6857 : }
6858 : else
6859 : {
6860 : /* In all other cases evaluate the expr3. */
6861 1134 : symbol_attribute attr;
6862 : /* Get the descriptor for all arrays, that are not allocatable or
6863 : pointer, because the latter are descriptors already.
6864 : The exception are function calls returning a class object:
6865 : The descriptor is stored in their results _data component, which
6866 : is easier to access, when first a temporary variable for the
6867 : result is created and the descriptor retrieved from there. */
6868 1134 : attr = gfc_expr_attr (code->expr3);
6869 1134 : if (code->expr3->rank != 0
6870 248 : && ((!attr.allocatable && !attr.pointer)
6871 71 : || (code->expr3->expr_type == EXPR_FUNCTION
6872 71 : && (code->expr3->ts.type != BT_CLASS
6873 53 : || (code->expr3->value.function.isym
6874 12 : && code->expr3->value.function.isym
6875 12 : ->transformational)))))
6876 207 : gfc_conv_expr_descriptor (&se, code->expr3);
6877 : else
6878 927 : gfc_conv_expr_reference (&se, code->expr3);
6879 1134 : if (code->expr3->ts.type == BT_CLASS)
6880 132 : gfc_conv_class_to_class (&se, code->expr3,
6881 : code->expr3->ts,
6882 : false, true,
6883 : false, false);
6884 1134 : temp_obj_created = temp_var_needed = !VAR_P (se.expr);
6885 : }
6886 4007 : gfc_add_block_to_block (&block, &se.pre);
6887 4007 : if (code->expr3->must_finalize)
6888 : {
6889 78 : gfc_add_block_to_block (&final_block, &se.finalblock);
6890 78 : gfc_add_block_to_block (&final_block, &se.post);
6891 : }
6892 : else
6893 3929 : gfc_add_block_to_block (&post, &se.post);
6894 :
6895 : /* Special case when string in expr3 is scalar and has length zero. */
6896 4007 : if (code->expr3->ts.type == BT_CHARACTER
6897 851 : && code->expr3->rank == 0
6898 4509 : && integer_zerop (se.string_length))
6899 : {
6900 6 : gfc_init_se (&se, NULL);
6901 6 : temp_var_needed = false;
6902 6 : expr3_len = build_zero_cst (gfc_charlen_type_node);
6903 6 : e3_is = E3_MOLD;
6904 : }
6905 : /* Prevent aliasing, i.e., se.expr may be already a
6906 : variable declaration. */
6907 4001 : else if (se.expr != NULL_TREE && temp_var_needed)
6908 : {
6909 988 : tree var, desc;
6910 988 : tmp = (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr))
6911 926 : || is_coarray
6912 914 : || (code->expr3->ts.type == BT_CHARACTER
6913 1010 : && code->expr3->rank == 0)) ?
6914 : se.expr
6915 892 : : build_fold_indirect_ref_loc (input_location, se.expr);
6916 :
6917 : /* Get the array descriptor and prepare it to be assigned to the
6918 : temporary variable var. For classes the array descriptor is
6919 : in the _data component and the object goes into the
6920 : GFC_DECL_SAVED_DESCRIPTOR. */
6921 988 : if (code->expr3->ts.type == BT_CLASS
6922 187 : && code->expr3->rank != 0)
6923 : {
6924 : /* When an array_ref was in expr3, then the descriptor is the
6925 : first operand. */
6926 96 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)) || is_coarray)
6927 : {
6928 49 : desc = TREE_OPERAND (tmp, 0);
6929 : }
6930 : else
6931 : {
6932 47 : desc = tmp;
6933 47 : tmp = gfc_class_data_get (tmp);
6934 : }
6935 96 : if (code->ext.alloc.arr_spec_from_expr3)
6936 39 : e3_is = E3_DESC;
6937 : }
6938 : else
6939 904 : desc = !is_coarray ? se.expr
6940 12 : : TREE_OPERAND (TREE_OPERAND (se.expr, 0), 0);
6941 : /* We need a regular (non-UID) symbol here, therefore give a
6942 : prefix. */
6943 988 : var = gfc_create_var (TREE_TYPE (tmp), "source");
6944 988 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)) || is_coarray)
6945 : {
6946 121 : gfc_allocate_lang_decl (var);
6947 121 : GFC_DECL_SAVED_DESCRIPTOR (var) = desc;
6948 : }
6949 988 : gfc_add_modify_loc (input_location, &block, var, tmp);
6950 :
6951 988 : expr3 = var;
6952 988 : if (se.string_length)
6953 : /* Evaluate it assuming that it also is complicated like expr3. */
6954 29 : expr3_len = gfc_evaluate_now (se.string_length, &block);
6955 : }
6956 : else
6957 : {
6958 3013 : expr3 = se.expr;
6959 3013 : expr3_len = se.string_length;
6960 : }
6961 :
6962 : /* Deallocate any allocatable components in expressions that use a
6963 : temporary object, i.e. are not a simple alias of to an EXPR_VARIABLE.
6964 : E.g. temporaries of a function call need freeing of their components
6965 : here. Explicit derived type allocation of class entities uses expr3
6966 : to carry the default initializer. This must not be deallocated or
6967 : finalized. */
6968 4007 : if ((code->expr3->ts.type == BT_DERIVED
6969 2632 : || code->expr3->ts.type == BT_CLASS)
6970 1920 : && (code->expr3->expr_type != EXPR_VARIABLE || temp_obj_created)
6971 1301 : && (code->expr3->ts.u.derived->attr.alloc_comp
6972 945 : || code->expr3->ts.u.derived->attr.pdt_type)
6973 398 : && !code->expr3->must_finalize
6974 4129 : && !gfc_expr_attr (code->expr3).pointer
6975 4387 : && !code->ext.alloc.expr3_not_explicit)
6976 : {
6977 516 : tmp = gfc_deallocate_alloc_comp (code->expr3->ts.u.derived,
6978 258 : expr3, code->expr3->rank);
6979 258 : gfc_prepend_expr_to_block (&post, tmp);
6980 : }
6981 :
6982 : /* Store what the expr3 is to be used for. */
6983 4007 : if (e3_is == E3_UNSET)
6984 6504 : e3_is = expr3 != NULL_TREE ?
6985 3962 : (code->ext.alloc.arr_spec_from_expr3 ?
6986 : E3_DESC
6987 2758 : : (code->expr3->mold ? E3_MOLD : E3_SOURCE))
6988 : : E3_UNSET;
6989 :
6990 : /* Figure how to get the _vtab entry. This also obtains the tree
6991 : expression for accessing the _len component, because only
6992 : unlimited polymorphic objects, which are a subcategory of class
6993 : types, have a _len component. */
6994 4007 : if (code->expr3->ts.type == BT_CLASS)
6995 : {
6996 545 : gfc_expr *rhs;
6997 801 : tmp = expr3 != NULL_TREE && POINTER_TYPE_P (TREE_TYPE (expr3)) ?
6998 256 : build_fold_indirect_ref (expr3): expr3;
6999 : /* Polymorphic SOURCE: VPTR must be determined at run time.
7000 : expr3 may be a temporary array declaration, therefore check for
7001 : GFC_CLASS_TYPE_P before trying to get the _vptr component. */
7002 545 : if (tmp != NULL_TREE
7003 545 : && (e3_is == E3_DESC
7004 440 : || (GFC_CLASS_TYPE_P (TREE_TYPE (tmp))
7005 280 : && (VAR_P (tmp) || !code->expr3->ref))
7006 186 : || (VAR_P (tmp) && DECL_LANG_SPECIFIC (tmp))))
7007 464 : tmp = gfc_class_vptr_get (expr3);
7008 : else
7009 : {
7010 81 : rhs = gfc_find_and_cut_at_last_class_ref (code->expr3);
7011 81 : gfc_add_vptr_component (rhs);
7012 81 : gfc_init_se (&se, NULL);
7013 81 : se.want_pointer = 1;
7014 81 : gfc_conv_expr (&se, rhs);
7015 81 : tmp = se.expr;
7016 81 : gfc_free_expr (rhs);
7017 : }
7018 : /* Set the element size. */
7019 545 : expr3_esize = gfc_vptr_size_get (tmp);
7020 545 : if (vtab_needed)
7021 539 : expr3_vptr = tmp;
7022 : /* Initialize the ref to the _len component. */
7023 545 : if (expr3_len == NULL_TREE && UNLIMITED_POLY (code->expr3))
7024 : {
7025 : /* Same like for retrieving the _vptr. */
7026 182 : if (expr3 != NULL_TREE && !code->expr3->ref)
7027 92 : expr3_len = gfc_class_len_get (expr3);
7028 : else
7029 : {
7030 90 : rhs = gfc_find_and_cut_at_last_class_ref (code->expr3);
7031 90 : gfc_add_len_component (rhs);
7032 90 : gfc_init_se (&se, NULL);
7033 90 : gfc_conv_expr (&se, rhs);
7034 90 : expr3_len = se.expr;
7035 90 : gfc_free_expr (rhs);
7036 : }
7037 : }
7038 : }
7039 : else
7040 : {
7041 : /* When the object to allocate is polymorphic type, then it
7042 : needs its vtab set correctly, so deduce the required _vtab
7043 : and _len from the source expression. */
7044 3462 : if (vtab_needed)
7045 : {
7046 : /* VPTR is fixed at compile time. */
7047 1279 : gfc_symbol *vtab;
7048 :
7049 1279 : vtab = gfc_find_vtab (&code->expr3->ts);
7050 1279 : gcc_assert (vtab);
7051 1279 : expr3_vptr = gfc_get_symbol_decl (vtab);
7052 1279 : expr3_vptr = gfc_build_addr_expr (NULL_TREE,
7053 : expr3_vptr);
7054 : }
7055 : /* _len component needs to be set, when ts is a character
7056 : array. */
7057 3462 : if (expr3_len == NULL_TREE
7058 2611 : && code->expr3->ts.type == BT_CHARACTER)
7059 : {
7060 0 : if (code->expr3->ts.u.cl
7061 0 : && code->expr3->ts.u.cl->length)
7062 : {
7063 0 : gfc_init_se (&se, NULL);
7064 0 : gfc_conv_expr (&se, code->expr3->ts.u.cl->length);
7065 0 : gfc_add_block_to_block (&block, &se.pre);
7066 0 : expr3_len = gfc_evaluate_now (se.expr, &block);
7067 : }
7068 0 : gcc_assert (expr3_len);
7069 : }
7070 : /* For character arrays only the kind's size is needed, because
7071 : the array mem_size is _len * (elem_size = kind_size).
7072 : For all other get the element size in the normal way. */
7073 3462 : if (code->expr3->ts.type == BT_CHARACTER)
7074 851 : expr3_esize = TYPE_SIZE_UNIT (
7075 : gfc_get_char_type (code->expr3->ts.kind));
7076 : else
7077 2611 : expr3_esize = TYPE_SIZE_UNIT (
7078 : gfc_typenode_for_spec (&code->expr3->ts));
7079 : }
7080 4007 : gcc_assert (expr3_esize);
7081 4007 : expr3_esize = fold_convert (sizetype, expr3_esize);
7082 4007 : if (e3_is == E3_MOLD)
7083 : /* The expr3 is no longer valid after this point. */
7084 222 : expr3 = NULL_TREE;
7085 : }
7086 10819 : else if (code->ext.alloc.ts.type != BT_UNKNOWN)
7087 : {
7088 : /* Compute the explicit typespec given only once for all objects
7089 : to allocate. */
7090 1336 : if (code->ext.alloc.ts.type != BT_CHARACTER)
7091 863 : expr3_esize = TYPE_SIZE_UNIT (
7092 : gfc_typenode_for_spec (&code->ext.alloc.ts));
7093 473 : else if (code->ext.alloc.ts.u.cl->length != NULL)
7094 : {
7095 467 : gfc_expr *sz;
7096 467 : sz = gfc_copy_expr (code->ext.alloc.ts.u.cl->length);
7097 467 : gfc_init_se (&se_sz, NULL);
7098 467 : gfc_conv_expr (&se_sz, sz);
7099 467 : gfc_free_expr (sz);
7100 467 : ts_string_length = fold_convert (gfc_charlen_type_node, se_sz.expr);
7101 467 : tmp = gfc_get_char_type (code->ext.alloc.ts.kind);
7102 467 : tmp = TYPE_SIZE_UNIT (tmp);
7103 467 : tmp = fold_convert (TREE_TYPE (se_sz.expr), tmp);
7104 467 : gfc_add_block_to_block (&block, &se_sz.pre);
7105 467 : expr3_esize = fold_build2_loc (input_location, MULT_EXPR,
7106 467 : TREE_TYPE (se_sz.expr),
7107 : tmp, se_sz.expr);
7108 467 : expr3_esize = gfc_evaluate_now (expr3_esize, &block);
7109 : }
7110 : else
7111 : expr3_esize = NULL_TREE;
7112 : }
7113 :
7114 : /* The routine gfc_trans_assignment () already implements all
7115 : techniques needed. Unfortunately we may have a temporary
7116 : variable for the source= expression here. When that is the
7117 : case convert this variable into a temporary gfc_expr of type
7118 : EXPR_VARIABLE and used it as rhs for the assignment. The
7119 : advantage is, that we get scalarizer support for free,
7120 : don't have to take care about scalar to array treatment and
7121 : will benefit of every enhancements gfc_trans_assignment ()
7122 : gets.
7123 : No need to check whether e3_is is E3_UNSET, because that is
7124 : done by expr3 != NULL_TREE.
7125 : Exclude variables since the following block does not handle
7126 : array sections. In any case, there is no harm in sending
7127 : variables to gfc_trans_assignment because there is no
7128 : evaluation of variables. */
7129 14826 : if (code->expr3)
7130 : {
7131 4007 : if (code->expr3->expr_type != EXPR_VARIABLE
7132 2678 : && e3_is != E3_MOLD && expr3 != NULL_TREE
7133 6581 : && DECL_P (expr3) && DECL_ARTIFICIAL (expr3))
7134 : {
7135 : /* Build a temporary symtree and symbol. Do not add it to the current
7136 : namespace to prevent accidentally modifying a colliding
7137 : symbol's as. */
7138 : /* The name of the symtree should be unique, because gfc_create_var ()
7139 : took care about generating the identifier. */
7140 2146 : if (DECL_NAME (expr3) && IDENTIFIER_POINTER (DECL_NAME (expr3)))
7141 : {
7142 2134 : const char *name = IDENTIFIER_POINTER (DECL_NAME (expr3));
7143 2134 : newsym = XCNEW (gfc_symtree);
7144 2134 : newsym->name = gfc_get_string ("%s", name);
7145 : }
7146 : else
7147 12 : newsym = gfc_get_unique_symtree (NULL);
7148 2146 : newsym->n.sym = gfc_new_symbol (newsym->name, NULL);
7149 : /* The backend_decl is known. It is expr3, which is inserted
7150 : here. */
7151 2146 : newsym->n.sym->backend_decl = expr3;
7152 2146 : e3rhs = gfc_get_expr ();
7153 2146 : e3rhs->rank = code->expr3->rank;
7154 2146 : e3rhs->corank = code->expr3->corank;
7155 2146 : e3rhs->symtree = newsym;
7156 : /* Mark the symbol referenced or gfc_trans_assignment will bug. */
7157 2146 : newsym->n.sym->attr.referenced = 1;
7158 2146 : e3rhs->expr_type = EXPR_VARIABLE;
7159 2146 : e3rhs->where = code->expr3->where;
7160 : /* Set the symbols type, upto it was BT_UNKNOWN. */
7161 2146 : if (IS_CLASS_ARRAY (code->expr3)
7162 54 : && code->expr3->expr_type == EXPR_FUNCTION
7163 42 : && code->expr3->value.function.isym
7164 12 : && code->expr3->value.function.isym->transformational)
7165 : {
7166 12 : e3rhs->ts = CLASS_DATA (code->expr3)->ts;
7167 : }
7168 2134 : else if (code->expr3->ts.type == BT_CLASS
7169 2134 : && !GFC_CLASS_TYPE_P (TREE_TYPE (expr3)))
7170 46 : e3rhs->ts = CLASS_DATA (code->expr3)->ts;
7171 : else
7172 2088 : e3rhs->ts = code->expr3->ts;
7173 2146 : newsym->n.sym->ts = e3rhs->ts;
7174 : /* Check whether the expr3 is array valued. */
7175 2146 : if (e3rhs->rank)
7176 : {
7177 1317 : gfc_array_spec *arr;
7178 1317 : arr = gfc_get_array_spec ();
7179 1317 : arr->rank = e3rhs->rank;
7180 1317 : arr->corank = e3rhs->corank;
7181 1317 : arr->type = AS_DEFERRED;
7182 : /* Set the dimension and pointer attribute for arrays
7183 : to be on the safe side. */
7184 1317 : newsym->n.sym->attr.dimension = 1;
7185 1317 : newsym->n.sym->attr.pointer = 1;
7186 1317 : newsym->n.sym->as = arr;
7187 1317 : if (IS_CLASS_ARRAY (code->expr3)
7188 54 : && code->expr3->expr_type == EXPR_FUNCTION
7189 42 : && code->expr3->value.function.isym
7190 12 : && code->expr3->value.function.isym->transformational)
7191 : {
7192 12 : gfc_array_spec *tarr;
7193 12 : tarr = gfc_get_array_spec ();
7194 12 : *tarr = *arr;
7195 12 : e3rhs->ts.u.derived->as = tarr;
7196 : }
7197 1317 : gfc_add_full_array_ref (e3rhs, arr);
7198 : }
7199 829 : else if (POINTER_TYPE_P (TREE_TYPE (expr3)))
7200 57 : newsym->n.sym->attr.pointer = 1;
7201 : /* The string length is known, too. Set it for char arrays. */
7202 2146 : if (e3rhs->ts.type == BT_CHARACTER)
7203 331 : newsym->n.sym->ts.u.cl->backend_decl = expr3_len;
7204 2146 : gfc_commit_symbol (newsym->n.sym);
7205 : }
7206 : else
7207 1861 : e3rhs = gfc_copy_expr (code->expr3);
7208 :
7209 : // We need to propagate the bounds of the expr3 for source=/mold=.
7210 : // However, for non-named arrays, the lbound has to be 1 and neither the
7211 : // bound used inside the called function even when returning an
7212 : // allocatable/pointer nor the zero used internally.
7213 4007 : if (e3_is == E3_DESC
7214 1243 : && code->expr3->expr_type != EXPR_VARIABLE)
7215 14826 : e3_has_nodescriptor = true;
7216 : }
7217 :
7218 : /* Loop over all objects to allocate. */
7219 32649 : for (al = code->ext.alloc.list; al != NULL; al = al->next)
7220 : {
7221 17823 : expr = gfc_copy_expr (al->expr);
7222 : /* UNLIMITED_POLY () needs the _data component to be set, when
7223 : expr is a unlimited polymorphic object. But the _data component
7224 : has not been set yet, so check the derived type's attr for the
7225 : unlimited polymorphic flag to be safe. */
7226 17823 : upoly_expr = UNLIMITED_POLY (expr)
7227 34980 : || (expr->ts.type == BT_DERIVED
7228 2780 : && expr->ts.u.derived->attr.unlimited_polymorphic);
7229 17823 : gfc_init_se (&se, NULL);
7230 :
7231 : /* For class types prepare the expressions to ref the _vptr
7232 : and the _len component. The latter for unlimited polymorphic
7233 : types only. */
7234 17823 : if (expr->ts.type == BT_CLASS)
7235 : {
7236 3714 : gfc_expr *expr_ref_vptr, *expr_ref_len;
7237 3714 : gfc_add_data_component (expr);
7238 : /* Prep the vptr handle. */
7239 3714 : expr_ref_vptr = gfc_copy_expr (al->expr);
7240 3714 : gfc_add_vptr_component (expr_ref_vptr);
7241 3714 : se.want_pointer = 1;
7242 3714 : gfc_conv_expr (&se, expr_ref_vptr);
7243 3714 : al_vptr = se.expr;
7244 3714 : se.want_pointer = 0;
7245 3714 : gfc_free_expr (expr_ref_vptr);
7246 : /* Allocated unlimited polymorphic objects always have a _len
7247 : component. */
7248 3714 : if (upoly_expr)
7249 : {
7250 666 : expr_ref_len = gfc_copy_expr (al->expr);
7251 666 : gfc_add_len_component (expr_ref_len);
7252 666 : gfc_conv_expr (&se, expr_ref_len);
7253 666 : al_len = se.expr;
7254 666 : gfc_free_expr (expr_ref_len);
7255 : }
7256 : else
7257 : /* In a loop ensure that all loop variable dependent variables
7258 : are initialized at the same spot in all execution paths. */
7259 : al_len = NULL_TREE;
7260 : }
7261 : else
7262 : al_vptr = al_len = NULL_TREE;
7263 :
7264 17823 : se.want_pointer = 1;
7265 17823 : se.descriptor_only = 1;
7266 :
7267 17823 : gfc_conv_expr (&se, expr);
7268 17823 : if (expr->ts.type == BT_CHARACTER && expr->ts.deferred)
7269 : /* se.string_length now stores the .string_length variable of expr
7270 : needed to allocate character(len=:) arrays. */
7271 1110 : al_len = se.string_length;
7272 :
7273 17823 : al_len_needs_set = al_len != NULL_TREE;
7274 : /* When allocating an array one cannot use much of the
7275 : pre-evaluated expr3 expressions, because for most of them the
7276 : scalarizer is needed which is not available in the pre-evaluation
7277 : step. Therefore gfc_array_allocate () is responsible (and able)
7278 : to handle the complete array allocation. Only the element size
7279 : needs to be provided, which is done most of the time by the
7280 : pre-evaluation step. */
7281 17823 : if (expr3_len && (code->expr3->ts.type == BT_CHARACTER
7282 1039 : || code->expr3->ts.type == BT_CLASS))
7283 : {
7284 : /* When al is an array, then the element size for each element
7285 : in the array is needed, which is the product of the len and
7286 : esize for char arrays. For unlimited polymorphics len can be
7287 : zero, therefore take the maximum of len and one. */
7288 1039 : tree lhs_len;
7289 :
7290 : /* If an allocatable character variable has fixed length, use it.
7291 : Otherwise use source length. As different lengths are not
7292 : allowed by the standard, generate a runtime check. */
7293 1039 : if (expr->ts.type == BT_CHARACTER && !expr->ts.deferred)
7294 : {
7295 135 : gfc_trans_same_strlen_check ("ALLOCATE with SOURCE= or MOLD=",
7296 : &code->expr3->where,
7297 : se.string_length, expr3_len,
7298 : &block);
7299 135 : lhs_len = fold_convert (TREE_TYPE (expr3_len), se.string_length);
7300 : }
7301 : else
7302 : lhs_len = expr3_len;
7303 :
7304 2078 : tmp = fold_build2_loc (input_location, MAX_EXPR,
7305 1039 : TREE_TYPE (expr3_len),
7306 1039 : lhs_len, fold_convert (TREE_TYPE (expr3_len),
7307 : integer_one_node));
7308 2078 : tmp = fold_build2_loc (input_location, MULT_EXPR,
7309 1039 : TREE_TYPE (expr3_esize), expr3_esize,
7310 1039 : fold_convert (TREE_TYPE (expr3_esize), tmp));
7311 1039 : }
7312 : else
7313 : tmp = expr3_esize;
7314 :
7315 : /* Create runtime check for ALLOCATE of character with type-spec. */
7316 17823 : if (expr->ts.type == BT_CHARACTER && !expr->ts.deferred
7317 782 : && ts_string_length
7318 19 : && se.string_length)
7319 19 : gfc_trans_same_strlen_check ("ALLOCATE with type-spec",
7320 19 : &al->expr->where,
7321 : ts_string_length, se.string_length,
7322 : &block);
7323 :
7324 17823 : gfc_omp_namelist *omp_alloc_item = NULL;
7325 17823 : if (omp_allocate)
7326 : {
7327 : gfc_omp_namelist *n = NULL;
7328 : gfc_omp_namelist *n_null = NULL;
7329 130 : for (n = omp_allocate; n; n = n->next)
7330 : {
7331 88 : if (n->sym == NULL)
7332 : {
7333 41 : n_null = n;
7334 41 : continue;
7335 : }
7336 47 : if (expr->expr_type == EXPR_VARIABLE
7337 47 : && expr->symtree->n.sym == n->sym)
7338 : {
7339 25 : gfc_ref *ref;
7340 38 : for (ref = expr->ref; ref; ref = ref->next)
7341 16 : if (ref->type == REF_COMPONENT)
7342 : break;
7343 : if (ref == NULL)
7344 : break;
7345 : }
7346 : }
7347 64 : omp_alloc_item = n ? n : n_null;
7348 :
7349 : }
7350 :
7351 17823 : if (!gfc_array_allocate (&se, expr, stat, errmsg, errlen, label_finish,
7352 : tmp, e3rhs ? e3rhs : code->expr3,
7353 : e3_is == E3_DESC ? expr3 : NULL_TREE,
7354 : e3_has_nodescriptor, omp_alloc_item,
7355 17823 : code->ext.alloc.ts.type != BT_UNKNOWN))
7356 : {
7357 : /* A scalar or derived type. First compute the size to
7358 : allocate.
7359 :
7360 : expr3_len is set when expr3 is an unlimited polymorphic
7361 : object or a deferred length string.
7362 :
7363 : If an allocatable character variable has fixed length, use it.
7364 : Otherwise use source length. As different lengths are not
7365 : allowed by the standard, a runtime check was inserted
7366 : above. */
7367 5350 : if (expr3_len != NULL_TREE)
7368 : {
7369 545 : tree lhs_len;
7370 545 : if (expr->ts.type == BT_CHARACTER && !expr->ts.deferred)
7371 56 : lhs_len = fold_convert (TREE_TYPE (expr3_len),
7372 : se.string_length);
7373 : else
7374 : lhs_len = expr3_len;
7375 :
7376 545 : tmp = fold_convert (TREE_TYPE (expr3_esize), lhs_len);
7377 545 : tmp = fold_build2_loc (input_location, MULT_EXPR,
7378 545 : TREE_TYPE (expr3_esize),
7379 : expr3_esize, tmp);
7380 545 : if (code->expr3->ts.type != BT_CLASS)
7381 : /* expr3 is a deferred length string, i.e., we are
7382 : done. */
7383 : memsz = tmp;
7384 : else
7385 : {
7386 : /* For unlimited polymorphic enties build
7387 : (len > 0) ? element_size * len : element_size
7388 : to compute the number of bytes to allocate.
7389 : This allows the allocation of unlimited polymorphic
7390 : objects from an expr3 that is also unlimited
7391 : polymorphic and stores a _len dependent object,
7392 : e.g., a string. */
7393 98 : memsz = fold_build2_loc (input_location, GT_EXPR,
7394 : logical_type_node, expr3_len,
7395 : build_zero_cst
7396 98 : (TREE_TYPE (expr3_len)));
7397 98 : memsz = fold_build3_loc (input_location, COND_EXPR,
7398 98 : TREE_TYPE (expr3_esize),
7399 : memsz, tmp, expr3_esize);
7400 : }
7401 : }
7402 4805 : else if (expr3_esize != NULL_TREE)
7403 : /* Any other object in expr3 just needs element size in
7404 : bytes. */
7405 : memsz = expr3_esize;
7406 2911 : else if ((expr->ts.type == BT_CHARACTER && expr->ts.deferred)
7407 2911 : || (upoly_expr
7408 0 : && code->ext.alloc.ts.type == BT_CHARACTER))
7409 : {
7410 : /* Allocating deferred length char arrays need the length
7411 : to allocate in the alloc_type_spec. But also unlimited
7412 : polymorphic objects may be allocated as char arrays.
7413 : Both are handled here. */
7414 0 : gfc_init_se (&se_sz, NULL);
7415 0 : gfc_conv_expr (&se_sz, code->ext.alloc.ts.u.cl->length);
7416 0 : gfc_add_block_to_block (&se.pre, &se_sz.pre);
7417 0 : se_sz.expr = gfc_evaluate_now (se_sz.expr, &se.pre);
7418 0 : gfc_add_block_to_block (&se.pre, &se_sz.post);
7419 0 : expr3_len = se_sz.expr;
7420 0 : tmp_expr3_len_flag = true;
7421 0 : tmp = TYPE_SIZE_UNIT (
7422 : gfc_get_char_type (code->ext.alloc.ts.kind));
7423 0 : memsz = fold_build2_loc (input_location, MULT_EXPR,
7424 0 : TREE_TYPE (tmp),
7425 0 : fold_convert (TREE_TYPE (tmp),
7426 : expr3_len),
7427 : tmp);
7428 : }
7429 2911 : else if (expr->ts.type == BT_CHARACTER)
7430 : {
7431 : /* Compute the number of bytes needed to allocate a fixed
7432 : length char array. */
7433 176 : gcc_assert (se.string_length != NULL_TREE);
7434 176 : tmp = TYPE_SIZE_UNIT (gfc_get_char_type (expr->ts.kind));
7435 352 : memsz = fold_build2_loc (input_location, MULT_EXPR,
7436 176 : TREE_TYPE (tmp), tmp,
7437 176 : fold_convert (TREE_TYPE (tmp),
7438 : se.string_length));
7439 : }
7440 2735 : else if (code->ext.alloc.ts.type != BT_UNKNOWN)
7441 : /* Handle all types, where the alloc_type_spec is set. */
7442 0 : memsz = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->ext.alloc.ts));
7443 : else
7444 : /* Handle size computation of the type declared to alloc. */
7445 2735 : memsz = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (se.expr)));
7446 :
7447 5350 : bool use_coarray_alloc
7448 5350 : = (flag_coarray == GFC_FCOARRAY_LIB
7449 5350 : && (caf_attr = gfc_caf_attr (expr, true, &caf_refs_comp))
7450 77 : .codimension);
7451 5350 : tree omp_cond = NULL_TREE;
7452 5350 : tree omp_alt_alloc = NULL_TREE;
7453 5350 : tree succ_add_expr = NULL_TREE;
7454 5350 : if (!use_coarray_alloc && omp_alloc_item)
7455 : {
7456 28 : tree align, alloc, sz;
7457 28 : gfc_se se2;
7458 :
7459 28 : omp_cond = boolean_true_node;
7460 28 : if (omp_alloc_item->u2.allocator)
7461 : {
7462 2 : gfc_init_se (&se2, NULL);
7463 2 : gfc_conv_expr (&se2, omp_alloc_item->u2.allocator);
7464 2 : gfc_add_block_to_block (&se.pre, &se2.pre);
7465 2 : alloc = gfc_evaluate_now (se2.expr, &se.pre);
7466 2 : gfc_add_block_to_block (&se.pre, &se2.post);
7467 : }
7468 : else
7469 26 : alloc = build_zero_cst (ptr_type_node);
7470 28 : tmp = TREE_TYPE (TREE_TYPE (se.expr));
7471 28 : if (tmp == void_type_node)
7472 3 : tmp = gfc_typenode_for_spec (&expr->ts, 0);
7473 28 : if (omp_alloc_item->u.align)
7474 : {
7475 14 : gfc_init_se (&se2, NULL);
7476 14 : gfc_conv_expr (&se2, omp_alloc_item->u.align);
7477 14 : gcc_assert (CONSTANT_CLASS_P (se2.expr)
7478 : && se2.pre.head == NULL
7479 : && se2.post.head == NULL);
7480 14 : align = build_int_cst (size_type_node,
7481 14 : MAX (tree_to_uhwi (se2.expr),
7482 : TYPE_ALIGN_UNIT (tmp)));
7483 : }
7484 : else
7485 14 : align = build_int_cst (size_type_node, TYPE_ALIGN_UNIT (tmp));
7486 28 : sz = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
7487 : fold_convert (size_type_node, memsz),
7488 : build_int_cst (size_type_node, 1));
7489 28 : omp_alt_alloc = builtin_decl_explicit (BUILT_IN_GOMP_ALLOC);
7490 28 : DECL_ATTRIBUTES (omp_alt_alloc)
7491 28 : = tree_cons (get_identifier ("omp allocator"),
7492 : build_tree_list (NULL_TREE, alloc),
7493 28 : DECL_ATTRIBUTES (omp_alt_alloc));
7494 28 : omp_alt_alloc = build_call_expr (omp_alt_alloc, 3, align, sz, alloc);
7495 28 : succ_add_expr = gfc_omp_call_add_alloc (se.expr);
7496 : }
7497 :
7498 : /* Store the caf-attributes for latter use. */
7499 5350 : if (use_coarray_alloc)
7500 : {
7501 : /* Scalar allocatable components in coarray'ed derived types make
7502 : it here and are treated now. */
7503 68 : tree caf_decl, token;
7504 68 : gfc_se caf_se;
7505 :
7506 68 : is_coarray = true;
7507 : /* Set flag, to add synchronize after the allocate. */
7508 136 : needs_caf_sync = needs_caf_sync
7509 68 : || caf_attr.coarray_comp || !caf_refs_comp;
7510 :
7511 68 : gfc_init_se (&caf_se, NULL);
7512 :
7513 68 : caf_decl = gfc_get_tree_for_caf_expr (expr);
7514 68 : gfc_get_caf_token_offset (&caf_se, &token, NULL, caf_decl,
7515 : NULL_TREE, NULL);
7516 68 : gfc_add_block_to_block (&se.pre, &caf_se.pre);
7517 68 : gfc_allocate_allocatable (&se.pre, se.expr, memsz,
7518 : gfc_build_addr_expr (NULL_TREE, token),
7519 : NULL_TREE, NULL_TREE, NULL_TREE,
7520 : label_finish, expr, 1);
7521 : }
7522 : /* Allocate - for non-pointers with re-alloc checking. */
7523 5282 : else if (gfc_expr_attr (expr).allocatable)
7524 3687 : gfc_allocate_allocatable (&se.pre, se.expr, memsz,
7525 : NULL_TREE, stat, errmsg, errlen,
7526 : label_finish, expr, 0,
7527 : omp_cond, omp_alt_alloc, succ_add_expr);
7528 : else
7529 1595 : gfc_allocate_using_malloc (&se.pre, se.expr, memsz, stat,
7530 : omp_cond, omp_alt_alloc, succ_add_expr);
7531 : }
7532 : else
7533 : {
7534 : /* Allocating coarrays needs a sync after the allocate executed.
7535 : Set the flag to add the sync after all objects are allocated. */
7536 12473 : if (flag_coarray == GFC_FCOARRAY_LIB
7537 12473 : && (caf_attr = gfc_caf_attr (expr, true, &caf_refs_comp))
7538 515 : .codimension)
7539 : {
7540 451 : is_coarray = true;
7541 451 : needs_caf_sync = needs_caf_sync
7542 451 : || caf_attr.coarray_comp || !caf_refs_comp;
7543 : }
7544 :
7545 12473 : if (expr->ts.type == BT_CHARACTER && al_len != NULL_TREE
7546 1103 : && expr3_len != NULL_TREE)
7547 : {
7548 : /* Arrays need to have a _len set before the array
7549 : descriptor is filled. */
7550 310 : gfc_add_modify (&block, al_len,
7551 310 : fold_convert (TREE_TYPE (al_len), expr3_len));
7552 : /* Prevent setting the length twice. */
7553 310 : al_len_needs_set = false;
7554 : }
7555 12163 : else if (expr->ts.type == BT_CHARACTER && al_len != NULL_TREE
7556 253 : && code->ext.alloc.ts.u.cl->length)
7557 : {
7558 : /* Cover the cases where a string length is explicitly
7559 : specified by a type spec for deferred length character
7560 : arrays or unlimited polymorphic objects without a
7561 : source= or mold= expression. */
7562 253 : gfc_init_se (&se_sz, NULL);
7563 253 : gfc_conv_expr (&se_sz, code->ext.alloc.ts.u.cl->length);
7564 253 : gfc_add_block_to_block (&block, &se_sz.pre);
7565 253 : gfc_add_modify (&block, al_len,
7566 253 : fold_convert (TREE_TYPE (al_len),
7567 : se_sz.expr));
7568 253 : al_len_needs_set = false;
7569 : }
7570 : }
7571 :
7572 17823 : gfc_add_block_to_block (&block, &se.pre);
7573 :
7574 : /* Error checking -- Note: ERRMSG only makes sense with STAT. */
7575 17823 : if (code->expr1)
7576 : {
7577 311 : tmp = build1_v (GOTO_EXPR, label_errmsg);
7578 311 : parm = fold_build2_loc (input_location, NE_EXPR,
7579 : logical_type_node, stat,
7580 311 : build_int_cst (TREE_TYPE (stat), 0));
7581 311 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
7582 : gfc_unlikely (parm, PRED_FORTRAN_FAIL_ALLOC),
7583 : tmp, build_empty_stmt (input_location));
7584 311 : gfc_add_expr_to_block (&block, tmp);
7585 : }
7586 :
7587 : /* Set the vptr only when no source= is set. When source= is set, then
7588 : the trans_assignment below will set the vptr. */
7589 17823 : if (al_vptr != NULL_TREE && (!code->expr3 || code->expr3->mold
7590 1828 : || code->expr3->ts.type == BT_CLASS))
7591 : {
7592 2382 : if (expr3_vptr != NULL_TREE)
7593 : /* The vtab is already known, so just assign it. */
7594 612 : gfc_add_modify (&block, al_vptr,
7595 612 : fold_convert (TREE_TYPE (al_vptr), expr3_vptr));
7596 : else
7597 : {
7598 : /* VPTR is fixed at compile time. */
7599 1770 : gfc_symbol *vtab;
7600 1770 : gfc_typespec *ts;
7601 :
7602 1770 : if (code->expr3)
7603 : /* Although expr3 is pre-evaluated above, it may happen,
7604 : that for arrays or in mold= cases the pre-evaluation
7605 : was not successful. In these rare cases take the vtab
7606 : from the typespec of expr3 here. */
7607 0 : ts = &code->expr3->ts;
7608 1770 : else if (code->ext.alloc.ts.type == BT_DERIVED || upoly_expr)
7609 : /* The alloc_type_spec gives the type to allocate or the
7610 : al is unlimited polymorphic, which enforces the use of
7611 : an alloc_type_spec that is not necessarily a BT_DERIVED. */
7612 793 : ts = &code->ext.alloc.ts;
7613 : else
7614 : /* Prepare for setting the vtab as declared. */
7615 977 : ts = &expr->ts;
7616 :
7617 1770 : vtab = gfc_find_vtab (ts);
7618 1770 : gcc_assert (vtab);
7619 1770 : tmp = gfc_build_addr_expr (NULL_TREE,
7620 : gfc_get_symbol_decl (vtab));
7621 1770 : gfc_add_modify (&block, al_vptr,
7622 1770 : fold_convert (TREE_TYPE (al_vptr), tmp));
7623 : }
7624 : }
7625 :
7626 : /* Add assignment for string length. */
7627 17823 : if (al_len != NULL_TREE && al_len_needs_set)
7628 : {
7629 1213 : if (expr3_len != NULL_TREE)
7630 : {
7631 594 : gfc_add_modify (&block, al_len,
7632 594 : fold_convert (TREE_TYPE (al_len),
7633 : expr3_len));
7634 : /* When tmp_expr3_len_flag is set, then expr3_len is
7635 : abused to carry the length information from the
7636 : alloc_type. Clear it to prevent setting incorrect len
7637 : information in future loop iterations. */
7638 594 : if (tmp_expr3_len_flag)
7639 : /* No need to reset tmp_expr3_len_flag, because the
7640 : presence of an expr3 cannot change within in the
7641 : loop. */
7642 17823 : expr3_len = NULL_TREE;
7643 : }
7644 619 : else if (code->ext.alloc.ts.type == BT_CHARACTER
7645 229 : && code->ext.alloc.ts.u.cl->length)
7646 : {
7647 : /* Cover the cases where a string length is explicitly
7648 : specified by a type spec for deferred length character
7649 : arrays or unlimited polymorphic objects without a
7650 : source= or mold= expression. */
7651 229 : if (expr3_esize == NULL_TREE || code->ext.alloc.ts.kind != 1)
7652 : {
7653 75 : gfc_init_se (&se_sz, NULL);
7654 75 : gfc_conv_expr (&se_sz, code->ext.alloc.ts.u.cl->length);
7655 75 : gfc_add_block_to_block (&block, &se_sz.pre);
7656 75 : gfc_add_modify (&block, al_len,
7657 75 : fold_convert (TREE_TYPE (al_len),
7658 : se_sz.expr));
7659 : }
7660 : else
7661 154 : gfc_add_modify (&block, al_len,
7662 154 : fold_convert (TREE_TYPE (al_len),
7663 : expr3_esize));
7664 : }
7665 : else
7666 : /* No length information needed, because type to allocate
7667 : has no length. Set _len to 0. */
7668 390 : gfc_add_modify (&block, al_len,
7669 390 : fold_convert (TREE_TYPE (al_len),
7670 : integer_zero_node));
7671 : }
7672 :
7673 17823 : init_expr = NULL;
7674 17823 : if (code->expr3 && !code->expr3->mold && e3_is != E3_MOLD)
7675 : {
7676 : /* Initialization via SOURCE block (or static default initializer).
7677 : Switch off automatic reallocation since we have just done the
7678 : ALLOCATE. */
7679 3802 : int realloc_lhs = flag_realloc_lhs;
7680 3802 : gfc_expr *init_expr = gfc_expr_to_initialize (expr);
7681 3802 : gfc_expr *rhs = e3rhs ? e3rhs : gfc_copy_expr (code->expr3);
7682 3802 : flag_realloc_lhs = 0;
7683 :
7684 : /* The handling of code->expr3 above produces a derived type of
7685 : type "STAR", whose size defaults to size(void*). In order to
7686 : have the right type information for the assignment, we must
7687 : reconstruct an unlimited polymorphic rhs. */
7688 3802 : if (UNLIMITED_POLY (code->expr3)
7689 169 : && e3rhs && e3rhs->ts.type == BT_DERIVED
7690 6 : && !strcmp (e3rhs->ts.u.derived->name, "STAR"))
7691 : {
7692 6 : gfc_ref *ref;
7693 6 : gcc_assert (TREE_CODE (expr3_vptr) == COMPONENT_REF);
7694 6 : tmp = gfc_create_var (gfc_typenode_for_spec (&code->expr3->ts),
7695 : "e3");
7696 6 : gfc_add_modify (&block, tmp,
7697 : gfc_get_class_from_expr (expr3_vptr));
7698 6 : rhs->symtree->n.sym->backend_decl = tmp;
7699 6 : rhs->ts = code->expr3->ts;
7700 6 : rhs->symtree->n.sym->ts = rhs->ts;
7701 6 : for (ref = init_expr->ref; ref; ref = ref->next)
7702 : {
7703 : /* Copy over the lhs _data component ref followed by the
7704 : full array reference for source expressions with rank.
7705 : Otherwise, just copy the _data component ref. */
7706 6 : if (code->expr3->rank
7707 6 : && ref && ref->next && !ref->next->next)
7708 : {
7709 6 : rhs->ref = gfc_copy_ref (ref);
7710 6 : break;
7711 : }
7712 0 : else if ((init_expr->rank && !code->expr3->rank
7713 0 : && ref && ref->next && !ref->next->next)
7714 0 : || (ref && !ref->next))
7715 : {
7716 0 : rhs->ref = gfc_copy_ref (ref);
7717 0 : gfc_free_ref_list (rhs->ref->next);
7718 0 : rhs->ref->next = NULL;
7719 0 : break;
7720 : }
7721 : }
7722 : }
7723 :
7724 : /* Set the symbol to be artificial so that the result is not finalized. */
7725 3802 : init_expr->symtree->n.sym->attr.artificial = 1;
7726 3802 : tmp = gfc_trans_assignment (init_expr, rhs, true, false, true,
7727 : false);
7728 3802 : init_expr->symtree->n.sym->attr.artificial = 0;
7729 :
7730 3802 : flag_realloc_lhs = realloc_lhs;
7731 : /* Free the expression allocated for init_expr. */
7732 3802 : gfc_free_expr (init_expr);
7733 3802 : if (rhs != e3rhs)
7734 0 : gfc_free_expr (rhs);
7735 3802 : gfc_add_expr_to_block (&block, tmp);
7736 3802 : }
7737 : /* Set KIND and LEN PDT components and allocate those that are
7738 : parameterized and make sure that allocatable components are
7739 : nullified. */
7740 14021 : else if (IS_PDT (expr) || IS_CLASS_PDT (expr))
7741 : {
7742 : gfc_symbol *declared;
7743 : gfc_symbol *type_spec_dt;
7744 : tree type;
7745 : tree ptr;
7746 :
7747 134 : declared = IS_PDT (expr) ? expr->ts.u.derived
7748 0 : : CLASS_DATA (expr)->ts.u.derived;
7749 :
7750 134 : if (code->ext.alloc.ts.type == BT_DERIVED)
7751 82 : type_spec_dt = code->ext.alloc.ts.u.derived;
7752 : else
7753 : type_spec_dt = NULL;
7754 :
7755 134 : if (code->expr3 && code->expr3->param_list)
7756 : param_list = code->expr3->param_list;
7757 134 : else if (expr->param_list)
7758 : param_list = expr->param_list;
7759 : else
7760 52 : param_list = expr->symtree->n.sym->param_list;
7761 : /* For array allocations the allocate-shape-spec expression has
7762 : rank 0 even though the symbol is an array. Use the rank from
7763 : the array descriptor when se.expr is a GFC descriptor so that
7764 : gfc_allocate_pdt_comp loops over all elements. */
7765 134 : int pdt_rank = (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr))
7766 134 : ? GFC_TYPE_ARRAY_RANK (TREE_TYPE (se.expr))
7767 134 : : expr->rank);
7768 134 : tmp = gfc_allocate_pdt_comp (declared, se.expr,
7769 : pdt_rank, param_list);
7770 134 : gfc_add_expr_to_block (&block, tmp);
7771 :
7772 : /* If this is a CLASS allocation and the declared type does not have
7773 : allocatable components but the explicit type_spec does, nullify
7774 : the allocatable components of the type_spec derived type. */
7775 134 : if (pdt_rank == 0 && type_spec_dt
7776 70 : && !declared->attr.alloc_comp && type_spec_dt->attr.alloc_comp)
7777 : {
7778 12 : type = build_pointer_type (gfc_get_derived_type (type_spec_dt));
7779 12 : ptr = fold_convert (type, se.expr);
7780 12 : tmp = gfc_nullify_alloc_comp (type_spec_dt, ptr, 0);
7781 12 : gfc_add_expr_to_block (&block, tmp);
7782 : }
7783 : }
7784 13887 : else if (code->expr3 && code->expr3->mold
7785 339 : && code->expr3->ts.type == BT_CLASS)
7786 : {
7787 : /* Use class_init_assign to initialize expr. */
7788 61 : gfc_code *ini;
7789 61 : ini = gfc_get_code (EXEC_ALLOCATE);
7790 61 : ini->expr1 = gfc_find_and_cut_at_last_class_ref (expr, true);
7791 61 : tmp = gfc_trans_class_init_assign (ini);
7792 61 : gfc_free_statements (ini);
7793 61 : if (tmp != NULL_TREE)
7794 61 : gfc_add_expr_to_block (&block, tmp);
7795 : }
7796 13826 : else if ((init_expr = allocate_get_initializer (code, expr))
7797 13826 : || (code->expr3 && code->expr3->expr_type == EXPR_STRUCTURE
7798 6 : && code->expr3->mold && IS_PDT (code->expr3)))
7799 : {
7800 : /* Use class_init_assign to initialize expr. */
7801 2196 : gfc_code *ini;
7802 2196 : int realloc_lhs = flag_realloc_lhs;
7803 2196 : tree dealloc_pdt = NULL_TREE;
7804 :
7805 2196 : ini = gfc_get_code (EXEC_INIT_ASSIGN);
7806 2196 : ini->expr1 = gfc_expr_to_initialize (expr);
7807 2196 : flag_realloc_lhs = 0;
7808 :
7809 2196 : if (init_expr == NULL)
7810 : {
7811 6 : init_expr = gfc_copy_expr (code->expr3);
7812 6 : if (!init_expr->param_list)
7813 0 : convert_structure_to_type_list (code->expr3->ts.u.derived,
7814 : init_expr);
7815 : }
7816 :
7817 2196 : if (IS_PDT (init_expr) && init_expr->param_list)
7818 : {
7819 30 : gfc_expr *var;
7820 30 : tree decl;
7821 30 : var = gfc_get_temp_from_expr (init_expr, gfc_current_ns, false);
7822 30 : decl = gfc_get_symbol_decl (var->symtree->n.sym);
7823 30 : tmp = gfc_allocate_pdt_comp (init_expr->ts.u.derived, decl,
7824 : 0, init_expr->param_list);
7825 30 : dealloc_pdt = gfc_deallocate_pdt_comp (init_expr->ts.u.derived,
7826 : decl, 0);
7827 30 : gfc_add_expr_to_block (&block, tmp);
7828 30 : gfc_free_actual_arglist (init_expr->param_list);
7829 30 : init_expr->param_list = NULL;
7830 : /* Deallocate temporary PDT's allocatable components. */
7831 30 : if (var->symtree->n.sym->ts.u.derived->attr.alloc_comp)
7832 : {
7833 0 : gfc_symbol *derived = var->symtree->n.sym->ts.u.derived;
7834 0 : tree var_decl = gfc_get_symbol_decl (var->symtree->n.sym);
7835 0 : tmp = gfc_deallocate_pdt_comp (derived, var_decl, 0);
7836 0 : gfc_add_expr_to_block (&block, tmp);
7837 : }
7838 30 : gfc_replace_expr (init_expr, var);
7839 : }
7840 2196 : ini->expr2 = init_expr;
7841 2196 : tmp= gfc_trans_init_assign (ini);
7842 2196 : flag_realloc_lhs = realloc_lhs;
7843 2196 : gfc_free_statements (ini);
7844 : /* Init_expr is freed by above free_statements, just need to null
7845 : it here. */
7846 2196 : init_expr = NULL;
7847 2196 : gfc_add_expr_to_block (&block, tmp);
7848 2196 : if (dealloc_pdt != NULL_TREE)
7849 30 : gfc_add_expr_to_block (&block, dealloc_pdt);
7850 : }
7851 :
7852 : /* Nullify all pointers in derived type coarrays. This registers a
7853 : token for them which allows their allocation. */
7854 17823 : if (is_coarray)
7855 : {
7856 567 : gfc_symbol *type = NULL;
7857 567 : symbol_attribute caf_attr;
7858 567 : int rank = 0;
7859 567 : if (code->ext.alloc.ts.type == BT_DERIVED
7860 10 : && code->ext.alloc.ts.u.derived->attr.pointer_comp)
7861 : {
7862 0 : type = code->ext.alloc.ts.u.derived;
7863 0 : rank = type->attr.dimension ? type->as->rank : 0;
7864 0 : gfc_clear_attr (&caf_attr);
7865 : }
7866 567 : else if (expr->ts.type == BT_DERIVED
7867 118 : && expr->ts.u.derived->attr.pointer_comp)
7868 : {
7869 16 : type = expr->ts.u.derived;
7870 16 : rank = expr->rank;
7871 16 : caf_attr = gfc_caf_attr (expr, true);
7872 : }
7873 :
7874 : /* Initialize the tokens of pointer components in derived type
7875 : coarrays. */
7876 16 : if (type)
7877 : {
7878 20 : tmp = (caf_attr.codimension && !caf_attr.dimension)
7879 20 : ? gfc_conv_descriptor_data_get (se.expr) : se.expr;
7880 16 : tmp = gfc_nullify_alloc_comp (type, tmp, rank,
7881 : GFC_STRUCTURE_CAF_MODE_IN_COARRAY);
7882 16 : gfc_add_expr_to_block (&block, tmp);
7883 : }
7884 : }
7885 :
7886 17823 : gfc_free_expr (expr);
7887 : } // for-loop
7888 :
7889 14826 : if (e3rhs)
7890 : {
7891 4007 : if (newsym)
7892 : {
7893 2146 : gfc_free_symbol (newsym->n.sym);
7894 2146 : XDELETE (newsym);
7895 : }
7896 4007 : gfc_free_expr (e3rhs);
7897 : }
7898 : /* STAT. */
7899 14826 : if (code->expr1)
7900 : {
7901 296 : tmp = build1_v (LABEL_EXPR, label_errmsg);
7902 296 : gfc_add_expr_to_block (&block, tmp);
7903 : }
7904 :
7905 : /* ERRMSG - only useful if STAT is present. */
7906 14826 : if (code->expr1 && code->expr2)
7907 : {
7908 72 : const char *msg = "Attempt to allocate an allocated object";
7909 72 : const char *oommsg = "Insufficient virtual memory";
7910 72 : tree slen, dlen, errmsg_str, oom_str, oom_loc;
7911 72 : stmtblock_t errmsg_block;
7912 :
7913 72 : gfc_init_block (&errmsg_block);
7914 :
7915 72 : errmsg_str = gfc_create_var (pchar_type_node, "ERRMSG");
7916 72 : gfc_add_modify (&errmsg_block, errmsg_str,
7917 : gfc_build_addr_expr (pchar_type_node,
7918 : gfc_build_localized_cstring_const (msg)));
7919 :
7920 72 : slen = build_int_cst (gfc_charlen_type_node, strlen (msg));
7921 72 : dlen = gfc_get_expr_charlen (code->expr2);
7922 72 : slen = fold_build2_loc (input_location, MIN_EXPR,
7923 72 : TREE_TYPE (slen), dlen, slen);
7924 :
7925 72 : gfc_trans_string_copy (&errmsg_block, dlen, errmsg,
7926 72 : code->expr2->ts.kind,
7927 : slen, errmsg_str,
7928 : gfc_default_character_kind);
7929 72 : dlen = gfc_finish_block (&errmsg_block);
7930 :
7931 72 : tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
7932 72 : stat, build_int_cst (TREE_TYPE (stat),
7933 : LIBERROR_ALLOCATION));
7934 :
7935 72 : tmp = build3_v (COND_EXPR, tmp,
7936 : dlen, build_empty_stmt (input_location));
7937 :
7938 72 : gfc_add_expr_to_block (&block, tmp);
7939 :
7940 72 : oom_str = gfc_create_var (pchar_type_node, "OOMMSG");
7941 72 : oom_loc = gfc_build_localized_cstring_const (oommsg);
7942 72 : gfc_add_modify (&errmsg_block, oom_str,
7943 : gfc_build_addr_expr (pchar_type_node, oom_loc));
7944 :
7945 72 : slen = build_int_cst (gfc_charlen_type_node, strlen (oommsg));
7946 72 : dlen = gfc_get_expr_charlen (code->expr2);
7947 72 : slen = fold_build2_loc (input_location, MIN_EXPR,
7948 72 : TREE_TYPE (slen), dlen, slen);
7949 :
7950 72 : gfc_trans_string_copy (&errmsg_block, dlen, errmsg,
7951 72 : code->expr2->ts.kind,
7952 : slen, oom_str,
7953 : gfc_default_character_kind);
7954 72 : dlen = gfc_finish_block (&errmsg_block);
7955 :
7956 72 : tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
7957 72 : stat, build_int_cst (TREE_TYPE (stat),
7958 : LIBERROR_NO_MEMORY));
7959 :
7960 72 : tmp = build3_v (COND_EXPR, tmp,
7961 : dlen, build_empty_stmt (input_location));
7962 :
7963 72 : gfc_add_expr_to_block (&block, tmp);
7964 : }
7965 :
7966 : /* STAT block. */
7967 14826 : if (code->expr1)
7968 : {
7969 296 : if (TREE_USED (label_finish))
7970 : {
7971 20 : tmp = build1_v (LABEL_EXPR, label_finish);
7972 20 : gfc_add_expr_to_block (&block, tmp);
7973 : }
7974 :
7975 296 : gfc_init_se (&se, NULL);
7976 296 : gfc_conv_expr_lhs (&se, code->expr1);
7977 296 : tmp = convert (TREE_TYPE (se.expr), stat);
7978 296 : gfc_add_modify (&block, se.expr, tmp);
7979 : }
7980 :
7981 14826 : if (needs_caf_sync)
7982 : {
7983 : /* Add a sync all after the allocation has been executed. */
7984 274 : tree zero_size = build_zero_cst (size_type_node);
7985 274 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_all,
7986 : 3, null_pointer_node, null_pointer_node,
7987 : zero_size);
7988 274 : gfc_add_expr_to_block (&post, tmp);
7989 : }
7990 :
7991 14826 : gfc_add_block_to_block (&block, &se.post);
7992 14826 : gfc_add_block_to_block (&block, &post);
7993 14826 : if (code->expr3 && code->expr3->must_finalize)
7994 78 : gfc_add_block_to_block (&block, &final_block);
7995 :
7996 14826 : return gfc_finish_block (&block);
7997 : }
7998 :
7999 :
8000 : /* Translate a DEALLOCATE statement. */
8001 :
8002 : tree
8003 9250 : gfc_trans_deallocate (gfc_code *code)
8004 : {
8005 9250 : gfc_se se;
8006 9250 : gfc_alloc *al;
8007 9250 : tree apstat, pstat, stat, errmsg, errlen, tmp;
8008 9250 : tree label_finish, label_errmsg;
8009 9250 : stmtblock_t block;
8010 :
8011 9250 : pstat = apstat = stat = errmsg = errlen = tmp = NULL_TREE;
8012 9250 : label_finish = label_errmsg = NULL_TREE;
8013 :
8014 9250 : gfc_start_block (&block);
8015 :
8016 : /* Count the number of failed deallocations. If deallocate() was
8017 : called with STAT= , then set STAT to the count. If deallocate
8018 : was called with ERRMSG, then set ERRMG to a string. */
8019 9250 : if (code->expr1)
8020 : {
8021 2894 : tree gfc_int4_type_node = gfc_get_int_type (4);
8022 :
8023 2894 : stat = gfc_create_var (gfc_int4_type_node, "stat");
8024 2894 : pstat = gfc_build_addr_expr (NULL_TREE, stat);
8025 :
8026 : /* GOTO destinations. */
8027 2894 : label_errmsg = gfc_build_label_decl (NULL_TREE);
8028 2894 : label_finish = gfc_build_label_decl (NULL_TREE);
8029 2894 : TREE_USED (label_finish) = 0;
8030 : }
8031 :
8032 : /* Set ERRMSG - only needed if STAT is available. */
8033 9250 : if (code->expr1 && code->expr2)
8034 : {
8035 51 : gfc_init_se (&se, NULL);
8036 51 : se.want_pointer = 1;
8037 51 : gfc_conv_expr_lhs (&se, code->expr2);
8038 51 : errmsg = se.expr;
8039 51 : errlen = se.string_length;
8040 : }
8041 :
8042 20798 : for (al = code->ext.alloc.list; al != NULL; al = al->next)
8043 : {
8044 11548 : gfc_expr *expr = gfc_copy_expr (al->expr);
8045 11548 : bool is_coarray = false, is_coarray_array = false;
8046 11548 : int caf_mode = 0;
8047 11548 : gfc_ref * ref;
8048 11548 : gfc_actual_arglist * param_list;
8049 :
8050 11548 : gcc_assert (expr->expr_type == EXPR_VARIABLE);
8051 :
8052 11548 : if (expr->ts.type == BT_CLASS)
8053 2144 : gfc_add_data_component (expr);
8054 :
8055 11548 : gfc_init_se (&se, NULL);
8056 11548 : gfc_start_block (&se.pre);
8057 :
8058 11548 : se.want_pointer = 1;
8059 11548 : se.descriptor_only = 1;
8060 11548 : gfc_conv_expr (&se, expr);
8061 :
8062 : /* Deallocate PDT components that are parameterized. */
8063 11548 : tmp = NULL;
8064 11548 : param_list = expr->param_list;
8065 11548 : if (!param_list && expr->symtree->n.sym->param_list)
8066 : param_list = expr->symtree->n.sym->param_list;
8067 27653 : for (ref = expr->ref; ref; ref = ref->next)
8068 16105 : if (ref->type == REF_COMPONENT
8069 7407 : && IS_PDT (ref->u.c.component)
8070 125 : && ref->u.c.component->param_list)
8071 16105 : param_list = ref->u.c.component->param_list;
8072 11548 : if (expr->ts.type == BT_DERIVED
8073 3073 : && ((expr->ts.u.derived->attr.pdt_type && param_list)
8074 2895 : || expr->ts.u.derived->attr.pdt_comp))
8075 : {
8076 178 : int pdt_rank = (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr))
8077 178 : ? GFC_TYPE_ARRAY_RANK (TREE_TYPE (se.expr))
8078 178 : : expr->rank);
8079 178 : tmp = gfc_deallocate_pdt_comp (expr->ts.u.derived, se.expr, pdt_rank);
8080 178 : }
8081 11370 : else if (IS_CLASS_PDT (expr) && expr->symtree->n.sym->param_list)
8082 : {
8083 0 : int pdt_rank = (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr))
8084 0 : ? GFC_TYPE_ARRAY_RANK (TREE_TYPE (se.expr))
8085 0 : : expr->rank);
8086 0 : tmp = gfc_deallocate_pdt_comp (CLASS_DATA (expr)->ts.u.derived,
8087 : se.expr, pdt_rank);
8088 : }
8089 :
8090 178 : if (tmp)
8091 : {
8092 78 : tree null_cond, zero;
8093 78 : null_cond = se.expr;
8094 78 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr)))
8095 24 : null_cond = gfc_conv_descriptor_data_get (null_cond);
8096 78 : zero = build_int_cst (TREE_TYPE (null_cond), 0);
8097 78 : null_cond = fold_build2_loc (input_location, NE_EXPR,
8098 : logical_type_node,
8099 : null_cond, zero);
8100 78 : tmp = build3_loc (input_location, COND_EXPR, void_type_node,
8101 : null_cond, tmp,
8102 : build_empty_stmt (input_location));
8103 : }
8104 :
8105 78 : if (tmp)
8106 78 : gfc_add_expr_to_block (&se.pre, tmp);
8107 :
8108 11548 : if (flag_coarray == GFC_FCOARRAY_LIB
8109 11548 : || flag_coarray == GFC_FCOARRAY_SINGLE)
8110 : {
8111 521 : bool comp_ref;
8112 521 : symbol_attribute caf_attr = gfc_caf_attr (expr, false, &comp_ref);
8113 521 : if (caf_attr.codimension)
8114 : {
8115 386 : is_coarray = true;
8116 191 : is_coarray_array = caf_attr.dimension || !comp_ref
8117 460 : || caf_attr.coarray_comp;
8118 :
8119 386 : if (flag_coarray == GFC_FCOARRAY_LIB)
8120 : /* When the expression to deallocate is referencing a
8121 : component, then only deallocate it, but do not
8122 : deregister. */
8123 160 : caf_mode = GFC_STRUCTURE_CAF_MODE_IN_COARRAY
8124 272 : | (comp_ref && !caf_attr.coarray_comp
8125 : ? GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY : 0);
8126 : }
8127 : }
8128 :
8129 11548 : if (expr->rank || is_coarray_array)
8130 : {
8131 8008 : gfc_ref *ref;
8132 : /* class.cc(finalize_component) generates these, when a
8133 : finalizable entity has a non-allocatable derived type array
8134 : component, which has allocatable components. EXPR then has the
8135 : type of its last component, not of the array elements. */
8136 8008 : bool fini_comp_array
8137 8008 : = (TREE_CODE (se.expr) == COMPONENT_REF
8138 3828 : && TREE_CODE (TREE_TYPE (se.expr)) == ARRAY_TYPE
8139 8083 : && TREE_CODE (TREE_TYPE (TREE_TYPE (se.expr))) == RECORD_TYPE);
8140 :
8141 7933 : if (!fini_comp_array
8142 7933 : && gfc_bt_struct (expr->ts.type)
8143 1368 : && expr->ts.u.derived->attr.alloc_comp
8144 727 : && !gfc_is_finalizable (expr->ts.u.derived, NULL))
8145 : {
8146 723 : gfc_ref *last = NULL;
8147 :
8148 1903 : for (ref = expr->ref; ref; ref = ref->next)
8149 1180 : if (ref->type == REF_COMPONENT)
8150 409 : last = ref;
8151 :
8152 : /* Do not deallocate the components of a derived type
8153 : ultimate pointer component. */
8154 723 : if (!(last && last->u.c.component->attr.pointer)
8155 335 : && !(!last && expr->symtree->n.sym->attr.pointer))
8156 : {
8157 30 : if (is_coarray && expr->rank == 0
8158 21 : && (!last || !last->u.c.component->attr.dimension)
8159 720 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr)))
8160 : {
8161 : /* Add the ref to the data member only, when this is not
8162 : a regular array or deallocate_alloc_comp will try to
8163 : add another one. */
8164 21 : tmp = gfc_conv_descriptor_data_get (se.expr);
8165 : }
8166 : else
8167 678 : tmp = se.expr;
8168 699 : tmp = gfc_deallocate_alloc_comp (expr->ts.u.derived, tmp,
8169 : expr->rank, caf_mode);
8170 699 : gfc_add_expr_to_block (&se.pre, tmp);
8171 : }
8172 : }
8173 :
8174 8008 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr)))
8175 : {
8176 7933 : gfc_coarray_deregtype caf_dtype;
8177 :
8178 7933 : if (is_coarray)
8179 614 : caf_dtype = gfc_caf_is_dealloc_only (caf_mode)
8180 343 : ? GFC_CAF_COARRAY_DEALLOCATE_ONLY
8181 : : GFC_CAF_COARRAY_DEREGISTER;
8182 : else
8183 : caf_dtype = GFC_CAF_COARRAY_NOCOARRAY;
8184 7933 : tmp = gfc_deallocate_with_status (se.expr, pstat, errmsg, errlen,
8185 : label_finish, false, expr,
8186 : caf_dtype);
8187 7933 : gfc_add_expr_to_block (&se.pre, tmp);
8188 : }
8189 75 : else if (fini_comp_array)
8190 : {
8191 : /* Obtain the derived type of the array and deallocate the
8192 : allocatable components. */
8193 81 : for (ref = expr->ref; ref; ref = ref->next)
8194 : {
8195 81 : if (ref->u.c.component->attr.dimension
8196 75 : && ref->u.c.component->ts.type == BT_DERIVED)
8197 : break;
8198 : }
8199 :
8200 75 : if (ref && ref->u.c.component->ts.u.derived->attr.alloc_comp
8201 150 : && !gfc_is_finalizable (ref->u.c.component->ts.u.derived,
8202 : NULL))
8203 : {
8204 75 : tmp = gfc_deallocate_alloc_comp
8205 75 : (ref->u.c.component->ts.u.derived,
8206 : se.expr, expr->rank);
8207 75 : gfc_add_expr_to_block (&se.pre, tmp);
8208 : }
8209 : }
8210 :
8211 8008 : if (al->expr->ts.type == BT_CLASS)
8212 : {
8213 1200 : gfc_reset_vptr (&se.pre, al->expr);
8214 1200 : if (UNLIMITED_POLY (al->expr)
8215 778 : || (al->expr->ts.type == BT_DERIVED
8216 0 : && al->expr->ts.u.derived->attr.unlimited_polymorphic))
8217 : /* Clear _len, too. */
8218 422 : gfc_reset_len (&se.pre, al->expr);
8219 : }
8220 : }
8221 : else
8222 : {
8223 7080 : tmp = gfc_deallocate_scalar_with_status (se.expr, pstat, label_finish,
8224 : false, al->expr,
8225 3540 : al->expr->ts, NULL_TREE,
8226 : is_coarray);
8227 3540 : gfc_add_expr_to_block (&se.pre, tmp);
8228 :
8229 : /* Set to zero after deallocation. */
8230 3540 : tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
8231 : se.expr,
8232 3540 : build_int_cst (TREE_TYPE (se.expr), 0));
8233 3540 : gfc_add_expr_to_block (&se.pre, tmp);
8234 :
8235 3540 : if (al->expr->ts.type == BT_CLASS)
8236 : {
8237 944 : gfc_reset_vptr (&se.pre, al->expr);
8238 944 : if (UNLIMITED_POLY (al->expr)
8239 705 : || (al->expr->ts.type == BT_DERIVED
8240 0 : && al->expr->ts.u.derived->attr.unlimited_polymorphic))
8241 : /* Clear _len, too. */
8242 239 : gfc_reset_len (&se.pre, al->expr);
8243 : }
8244 : }
8245 :
8246 11548 : if (code->expr1)
8247 : {
8248 2933 : tree cond;
8249 :
8250 2933 : cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, stat,
8251 2933 : build_int_cst (TREE_TYPE (stat), 0));
8252 2933 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
8253 : gfc_unlikely (cond, PRED_FORTRAN_FAIL_ALLOC),
8254 : build1_v (GOTO_EXPR, label_errmsg),
8255 : build_empty_stmt (input_location));
8256 2933 : gfc_add_expr_to_block (&se.pre, tmp);
8257 : }
8258 :
8259 11548 : tmp = gfc_finish_block (&se.pre);
8260 11548 : gfc_add_expr_to_block (&block, tmp);
8261 11548 : gfc_free_expr (expr);
8262 : }
8263 :
8264 9250 : if (code->expr1)
8265 : {
8266 2894 : tmp = build1_v (LABEL_EXPR, label_errmsg);
8267 2894 : gfc_add_expr_to_block (&block, tmp);
8268 : }
8269 :
8270 : /* Set ERRMSG - only needed if STAT is available. */
8271 9250 : if (code->expr1 && code->expr2)
8272 : {
8273 51 : const char *msg = "Attempt to deallocate an unallocated object";
8274 51 : stmtblock_t errmsg_block;
8275 51 : tree errmsg_str, slen, dlen, cond;
8276 :
8277 51 : gfc_init_block (&errmsg_block);
8278 :
8279 51 : errmsg_str = gfc_create_var (pchar_type_node, "ERRMSG");
8280 51 : gfc_add_modify (&errmsg_block, errmsg_str,
8281 : gfc_build_addr_expr (pchar_type_node,
8282 : gfc_build_localized_cstring_const (msg)));
8283 51 : slen = build_int_cst (gfc_charlen_type_node, strlen (msg));
8284 51 : dlen = gfc_get_expr_charlen (code->expr2);
8285 :
8286 51 : gfc_trans_string_copy (&errmsg_block, dlen, errmsg, code->expr2->ts.kind,
8287 : slen, errmsg_str, gfc_default_character_kind);
8288 51 : tmp = gfc_finish_block (&errmsg_block);
8289 :
8290 51 : cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, stat,
8291 51 : build_int_cst (TREE_TYPE (stat), 0));
8292 51 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
8293 : gfc_unlikely (cond, PRED_FORTRAN_FAIL_ALLOC), tmp,
8294 : build_empty_stmt (input_location));
8295 :
8296 51 : gfc_add_expr_to_block (&block, tmp);
8297 : }
8298 :
8299 9250 : if (code->expr1 && TREE_USED (label_finish))
8300 : {
8301 17 : tmp = build1_v (LABEL_EXPR, label_finish);
8302 17 : gfc_add_expr_to_block (&block, tmp);
8303 : }
8304 :
8305 : /* Set STAT. */
8306 9250 : if (code->expr1)
8307 : {
8308 2894 : gfc_init_se (&se, NULL);
8309 2894 : gfc_conv_expr_lhs (&se, code->expr1);
8310 2894 : tmp = convert (TREE_TYPE (se.expr), stat);
8311 2894 : gfc_add_modify (&block, se.expr, tmp);
8312 : }
8313 :
8314 9250 : return gfc_finish_block (&block);
8315 : }
8316 :
8317 : #include "gt-fortran-trans-stmt.h"
|
