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