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