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 3520 : gfc_trans_label_here (gfc_code * code)
69 : {
70 3520 : 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 79578 : gfc_trans_call (gfc_code * code, bool dependency_check,
436 : tree mask, tree count1, bool invert)
437 : {
438 79578 : gfc_se se;
439 79578 : gfc_ss * ss;
440 79578 : int has_alternate_specifier;
441 79578 : gfc_dep_check check_variable;
442 79578 : tree index = NULL_TREE;
443 79578 : tree maskexpr = NULL_TREE;
444 79578 : tree tmp;
445 79578 : bool is_intrinsic_mvbits;
446 :
447 79578 : 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 79578 : if (flag_openacc
454 2528 : && code->resolved_sym->attr.subroutine
455 2522 : && code->resolved_sym->formal
456 1357 : && 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 79821 : && (!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 79523 : gfc_init_se (&se, NULL);
471 79523 : gfc_start_block (&se.pre);
472 :
473 79523 : ss = gfc_ss_terminator;
474 79523 : 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 159046 : is_intrinsic_mvbits = code->resolved_isym
481 79523 : && code->resolved_isym->id == GFC_ISYM_MVBITS;
482 :
483 : /* Is not an elemental subroutine call with array valued arguments. */
484 79523 : if (ss == gfc_ss_terminator)
485 : {
486 :
487 77067 : 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 76937 : has_alternate_specifier =
496 76937 : 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 76937 : TREE_SIDE_EFFECTS (se.expr) = 1;
501 : }
502 :
503 : /* Chain the pieces together and return the block. */
504 77067 : 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 76927 : gfc_add_expr_to_block (&se.pre, se.expr);
518 :
519 77067 : gfc_add_block_to_block (&se.finalblock, &se.post);
520 77067 : 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 79523 : return gfc_finish_block (&se.pre);
625 : }
626 :
627 :
628 : /* Translate the RETURN statement. */
629 :
630 : tree
631 3163 : gfc_trans_return (gfc_code * code)
632 : {
633 3163 : 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 3113 : 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 218772 : gfc_trans_stop (gfc_code *code, bool error_stop)
727 : {
728 218772 : gfc_se se;
729 218772 : tree tmp;
730 218772 : tree quiet;
731 :
732 : /* Start a new block for this statement. */
733 218772 : gfc_init_se (&se, NULL);
734 218772 : gfc_start_block (&se.pre);
735 :
736 218772 : 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 218747 : quiet = boolean_false_node;
743 :
744 218772 : if (code->expr1 == NULL)
745 : {
746 20425 : tmp = build_int_cst (size_type_node, 0);
747 40850 : 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 962 : : (flag_coarray == GFC_FCOARRAY_LIB
753 962 : ? gfor_fndecl_caf_stop_str
754 : : gfor_fndecl_stop_string),
755 : 3, build_int_cst (pchar_type_node, 0), tmp,
756 : quiet);
757 : }
758 198347 : else if (code->expr1->ts.type == BT_INTEGER)
759 : {
760 197877 : gfc_conv_expr (&se, code->expr1);
761 395754 : 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 178569 : : (flag_coarray == GFC_FCOARRAY_LIB
767 178569 : ? 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 218772 : gfc_add_expr_to_block (&se.pre, tmp);
789 :
790 218772 : gfc_add_block_to_block (&se.pre, &se.post);
791 :
792 218772 : return gfc_finish_block (&se.pre);
793 : }
794 :
795 : tree
796 70 : trans_exit ()
797 : {
798 70 : const char *name = gfc_get_string (PREFIX ("exit_i%d"), 4);
799 70 : gfc_symbol *exsym = gfc_get_intrinsic_sub_symbol (name);
800 70 : tree tmp = gfc_get_symbol_decl (exsym);
801 70 : 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 518 : gfc_trans_sync_stat (struct sync_stat *sync_stat, gfc_se *se, tree *stat,
818 : tree *errmsg, tree *errmsg_len)
819 : {
820 518 : gfc_se argse;
821 :
822 518 : 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 446 : *stat = null_pointer_node;
843 :
844 518 : 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 476 : *errmsg = null_pointer_node;
855 476 : *errmsg_len = build_zero_cst (size_type_node);
856 : }
857 518 : }
858 :
859 : /* Translate the FORM TEAM statement. */
860 :
861 : tree
862 138 : gfc_trans_form_team (gfc_code *code)
863 : {
864 138 : if (flag_coarray == GFC_FCOARRAY_LIB)
865 : {
866 96 : gfc_se se, argse;
867 96 : tree team_id, team_type, new_index, stat, errmsg, errmsg_len, tmp;
868 :
869 96 : gfc_init_se (&se, NULL);
870 96 : gfc_init_se (&argse, NULL);
871 :
872 96 : gfc_conv_expr_val (&argse, code->expr1);
873 96 : team_id = fold_convert (integer_type_node, argse.expr);
874 96 : gfc_conv_expr_reference (&argse, code->expr2);
875 96 : team_type = argse.expr;
876 :
877 : /* NEW_INDEX=. */
878 96 : if (code->expr3)
879 : {
880 24 : gfc_conv_expr_reference (&argse, code->expr3);
881 24 : new_index = argse.expr;
882 : }
883 : else
884 72 : new_index = null_pointer_node;
885 :
886 96 : gfc_add_block_to_block (&se.post, &argse.post);
887 :
888 96 : gfc_trans_sync_stat (&code->ext.sync_stat, &se, &stat, &errmsg,
889 : &errmsg_len);
890 :
891 96 : gfc_add_block_to_block (&se.pre, &argse.pre);
892 :
893 96 : 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 96 : gfc_add_expr_to_block (&se.pre, tmp);
897 96 : gfc_add_block_to_block (&se.pre, &se.post);
898 96 : return gfc_finish_block (&se.pre);
899 : }
900 : else
901 42 : return trans_exit ();
902 : }
903 :
904 : /* Translate the CHANGE TEAM statement. */
905 :
906 : tree
907 78 : gfc_trans_change_team (gfc_code *code)
908 : {
909 78 : if (flag_coarray == GFC_FCOARRAY_LIB)
910 : {
911 53 : stmtblock_t block;
912 53 : gfc_se se;
913 53 : tree team_type, stat, errmsg, errmsg_len, tmp;
914 :
915 53 : gfc_init_se (&se, NULL);
916 53 : gfc_start_block (&block);
917 :
918 53 : gfc_conv_expr_val (&se, code->expr1);
919 53 : team_type = se.expr;
920 :
921 53 : gfc_trans_sync_stat (&code->ext.block.sync_stat, &se, &stat, &errmsg,
922 : &errmsg_len);
923 :
924 53 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_change_team, 4,
925 : team_type, stat, errmsg, errmsg_len);
926 :
927 53 : gfc_add_expr_to_block (&se.pre, tmp);
928 53 : gfc_add_block_to_block (&se.pre, &se.post);
929 53 : gfc_add_block_to_block (&block, &se.pre);
930 53 : gfc_add_expr_to_block (&block, gfc_trans_block_construct (code));
931 53 : return gfc_finish_block (&block);
932 : }
933 : else
934 25 : return trans_exit ();
935 : }
936 :
937 : /* Translate the END TEAM statement. */
938 :
939 : tree
940 53 : gfc_trans_end_team (gfc_code *code)
941 : {
942 53 : if (flag_coarray == GFC_FCOARRAY_LIB)
943 : {
944 53 : gfc_se se;
945 53 : tree stat, errmsg, errmsg_len, tmp;
946 :
947 53 : gfc_init_se (&se, NULL);
948 53 : gfc_start_block (&se.pre);
949 :
950 53 : gfc_trans_sync_stat (&code->ext.sync_stat, &se, &stat, &errmsg,
951 : &errmsg_len);
952 :
953 53 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_end_team, 3,
954 : stat, errmsg, errmsg_len);
955 53 : gfc_add_expr_to_block (&se.pre, tmp);
956 53 : gfc_add_block_to_block (&se.pre, &se.post);
957 53 : 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 247530 : gfc_trans_if_1 (gfc_code * code)
1594 : {
1595 247530 : gfc_se if_se;
1596 247530 : tree stmt, elsestmt;
1597 247530 : location_t loc, saved_loc = UNKNOWN_LOCATION;
1598 :
1599 : /* Check for an unconditional ELSE clause. */
1600 247530 : if (!code->expr1)
1601 6832 : return gfc_trans_code (code->next);
1602 :
1603 : /* Initialize a statement builder for each block. Puts in NULL_TREEs. */
1604 240698 : gfc_init_se (&if_se, NULL);
1605 240698 : gfc_start_block (&if_se.pre);
1606 :
1607 : /* Calculate the IF condition expression. */
1608 240698 : if (GFC_LOCUS_IS_SET (code->expr1->where))
1609 : {
1610 240698 : saved_loc = input_location;
1611 240698 : input_location = gfc_get_location (&code->expr1->where);
1612 : }
1613 :
1614 240698 : gfc_conv_expr_val (&if_se, code->expr1);
1615 :
1616 240698 : if (saved_loc != UNKNOWN_LOCATION)
1617 240698 : input_location = saved_loc;
1618 :
1619 : /* Translate the THEN clause. */
1620 240698 : stmt = gfc_trans_code (code->next);
1621 :
1622 : /* Translate the ELSE clause. */
1623 240698 : if (code->block)
1624 7074 : elsestmt = gfc_trans_if_1 (code->block);
1625 : else
1626 233624 : elsestmt = build_empty_stmt (input_location);
1627 :
1628 : /* Build the condition expression and add it to the condition block. */
1629 480794 : loc = (GFC_LOCUS_IS_SET (code->expr1->where)
1630 480794 : ? gfc_get_location (&code->expr1->where) : input_location);
1631 240698 : stmt = fold_build3_loc (loc, COND_EXPR, void_type_node, if_se.expr, stmt,
1632 : elsestmt);
1633 :
1634 240698 : gfc_add_expr_to_block (&if_se.pre, stmt);
1635 :
1636 : /* Finish off this statement. */
1637 240698 : return gfc_finish_block (&if_se.pre);
1638 : }
1639 :
1640 : tree
1641 240456 : gfc_trans_if (gfc_code * code)
1642 : {
1643 240456 : stmtblock_t body;
1644 240456 : tree exit_label;
1645 :
1646 : /* Create exit label so it is available for trans'ing the body code. */
1647 240456 : exit_label = gfc_build_label_decl (NULL_TREE);
1648 240456 : code->exit_label = exit_label;
1649 :
1650 : /* Translate the actual code in code->block. */
1651 240456 : gfc_init_block (&body);
1652 240456 : gfc_add_expr_to_block (&body, gfc_trans_if_1 (code->block));
1653 :
1654 : /* Add exit label. */
1655 240456 : gfc_add_expr_to_block (&body, build1_v (LABEL_EXPR, exit_label));
1656 :
1657 240456 : 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 : tree dtype_val = gfc_get_dtype (TREE_TYPE (sym->backend_decl));
2225 841 : gfc_conv_descriptor_dtype_set (&se.pre, sym->backend_decl, dtype_val);
2226 : }
2227 :
2228 1381 : gfc_add_init_cleanup (block, gfc_finish_block (&se.pre),
2229 : gfc_finish_block (&se.post));
2230 1381 : }
2231 :
2232 : /* Do a scalar pointer assignment; this is for scalar variable targets. */
2233 3977 : else if (gfc_is_associate_pointer (sym))
2234 : {
2235 3469 : gfc_se se;
2236 :
2237 3469 : gcc_assert (!sym->attr.dimension && !sym->attr.codimension);
2238 :
2239 3469 : gfc_init_se (&se, NULL);
2240 :
2241 : /* Class associate-names come this way because they are
2242 : unconditionally associate pointers and the symbol is scalar. */
2243 3469 : if (sym->ts.type == BT_CLASS && e->expr_type == EXPR_FUNCTION)
2244 : {
2245 99 : gfc_conv_expr (&se, e);
2246 99 : se.expr = gfc_evaluate_now (se.expr, &se.pre);
2247 : /* Finalize the expression and free if it is allocatable. */
2248 99 : gfc_finalize_tree_expr (&se, NULL, gfc_expr_attr (e), e->rank);
2249 99 : gfc_add_block_to_block (&se.post, &se.finalblock);
2250 99 : need_len_assign = false;
2251 : }
2252 3370 : else if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.dimension)
2253 : {
2254 465 : tree target_expr;
2255 : /* For a class array we need a descriptor for the selector. */
2256 465 : gfc_conv_expr_descriptor (&se, e);
2257 : /* Needed to get/set the _len component below. */
2258 465 : target_expr = se.expr;
2259 :
2260 : /* Obtain a temporary class container for the result. */
2261 465 : gfc_conv_class_to_class (&se, e, sym->ts, false, true, false, false);
2262 465 : se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
2263 :
2264 465 : desc = gfc_class_data_get (se.expr);
2265 :
2266 465 : if (need_len_assign)
2267 : {
2268 182 : if (e->symtree
2269 182 : && DECL_LANG_SPECIFIC (e->symtree->n.sym->backend_decl)
2270 90 : && GFC_DECL_SAVED_DESCRIPTOR (e->symtree->n.sym->backend_decl)
2271 212 : && TREE_CODE (target_expr) != COMPONENT_REF)
2272 : /* Use the original class descriptor stored in the saved
2273 : descriptor to get the target_expr. */
2274 36 : target_expr =
2275 18 : GFC_DECL_SAVED_DESCRIPTOR (e->symtree->n.sym->backend_decl);
2276 : else
2277 : /* Strip the _data component from the target_expr. */
2278 164 : target_expr = TREE_OPERAND (target_expr, 0);
2279 : /* Add a reference to the _len comp to the target expr. */
2280 182 : tmp = gfc_class_len_get (target_expr);
2281 : /* Get the component-ref for the temp structure's _len comp. */
2282 182 : charlen = gfc_class_len_get (se.expr);
2283 : /* Add the assign to the beginning of the block... */
2284 182 : gfc_add_modify (&se.pre, charlen,
2285 182 : fold_convert (TREE_TYPE (charlen), tmp));
2286 : /* and the opposite way at the end of the block, to hand changes
2287 : on the string length back. */
2288 182 : gfc_add_modify (&se.post, tmp,
2289 182 : fold_convert (TREE_TYPE (tmp), charlen));
2290 : /* Length assignment done, prevent adding it again below. */
2291 182 : need_len_assign = false;
2292 : }
2293 : }
2294 2905 : else if (sym->ts.type == BT_CLASS && e->ts.type == BT_CLASS
2295 632 : && CLASS_DATA (e)->attr.dimension)
2296 : {
2297 : /* This is bound to be a class array element. */
2298 92 : gfc_conv_expr_reference (&se, e);
2299 : /* Obtain a temporary class container for the result. */
2300 92 : gfc_conv_derived_to_class (&se, e, sym, se.expr, false, false,
2301 92 : e->symtree->name);
2302 92 : need_len_assign = false;
2303 : }
2304 2813 : else if (whole_array && (same_class || unlimited)
2305 278 : && e->ts.type == BT_CLASS && CLASS_DATA (e)->attr.codimension)
2306 : {
2307 10 : gfc_expr *class_e = gfc_find_and_cut_at_last_class_ref (e);
2308 10 : gfc_conv_expr (&se, class_e);
2309 10 : gfc_free_expr (class_e);
2310 10 : need_len_assign = false;
2311 10 : }
2312 : else
2313 : {
2314 : /* For BT_CLASS and BT_DERIVED, this boils down to a pointer assign,
2315 : which has the string length included. For CHARACTERS it is still
2316 : needed and will be done at the end of this routine. */
2317 2803 : gfc_conv_expr (&se, e);
2318 2803 : need_len_assign = need_len_assign && sym->ts.type == BT_CHARACTER;
2319 : }
2320 :
2321 3469 : if (sym->ts.type == BT_CHARACTER
2322 543 : && !sym->attr.select_type_temporary
2323 109 : && VAR_P (sym->ts.u.cl->backend_decl)
2324 61 : && se.string_length != sym->ts.u.cl->backend_decl)
2325 : {
2326 61 : gfc_add_modify (&se.pre, sym->ts.u.cl->backend_decl,
2327 61 : fold_convert (TREE_TYPE (sym->ts.u.cl->backend_decl),
2328 : se.string_length));
2329 61 : if (e->expr_type == EXPR_FUNCTION && gfc_expr_attr (e).pointer)
2330 : {
2331 : /* For an allocatable function result, the result temporary
2332 : is already freed by the procedure call's cleanup code;
2333 : freeing it again here would be a double free. A pointer
2334 : result is not freed there, so do it here. */
2335 6 : tmp = gfc_call_free (sym->backend_decl);
2336 6 : gfc_add_expr_to_block (&se.post, tmp);
2337 : }
2338 : }
2339 :
2340 543 : if (sym->ts.type == BT_CHARACTER && e->ts.type == BT_CHARACTER
2341 3578 : && POINTER_TYPE_P (TREE_TYPE (se.expr)))
2342 : {
2343 : /* These are pointer types already. */
2344 79 : tmp = fold_convert (TREE_TYPE (sym->backend_decl), se.expr);
2345 : }
2346 : else
2347 : {
2348 3390 : tree ctree = gfc_get_class_from_expr (se.expr);
2349 3390 : tmp = TREE_TYPE (sym->backend_decl);
2350 :
2351 3390 : if (sym->ts.type == BT_CLASS && e->ts.type == BT_CLASS)
2352 : {
2353 : /* F2018:19.5.1.6 "If a selector has the POINTER attribute,
2354 : it shall be associated; the associate name is associated
2355 : with the target of the pointer and does not have the
2356 : POINTER attribute." */
2357 677 : if (e->rank == 0 && ctree
2358 1860 : && (!GFC_CLASS_TYPE_P (TREE_TYPE (se.expr))
2359 582 : || CLASS_DATA (e)->attr.class_pointer))
2360 : {
2361 298 : tree stmp;
2362 298 : tree dtmp;
2363 298 : tree ctmp;
2364 :
2365 298 : ctmp = ctree;
2366 298 : dtmp = TREE_TYPE (TREE_TYPE (sym->backend_decl));
2367 298 : ctree = gfc_create_var (dtmp, "class");
2368 :
2369 298 : if (IS_INFERRED_TYPE (e)
2370 6 : && !GFC_CLASS_TYPE_P (TREE_TYPE (se.expr)))
2371 : stmp = se.expr;
2372 : else
2373 298 : stmp = gfc_class_data_get (ctmp);
2374 :
2375 298 : if (!CLASS_DATA (sym)->attr.codimension
2376 298 : && !POINTER_TYPE_P (TREE_TYPE (stmp)))
2377 0 : stmp = gfc_build_addr_expr (NULL, stmp);
2378 :
2379 298 : dtmp = gfc_class_data_get (ctree);
2380 298 : stmp = build1 (VIEW_CONVERT_EXPR, TREE_TYPE (dtmp), stmp);
2381 298 : gfc_add_modify (&se.pre, dtmp, stmp);
2382 298 : stmp = gfc_class_vptr_get (ctmp);
2383 298 : dtmp = gfc_class_vptr_get (ctree);
2384 298 : stmp = fold_convert (TREE_TYPE (dtmp), stmp);
2385 298 : gfc_add_modify (&se.pre, dtmp, stmp);
2386 298 : if (UNLIMITED_POLY (sym))
2387 : {
2388 66 : stmp = gfc_class_len_get (ctmp);
2389 66 : dtmp = gfc_class_len_get (ctree);
2390 66 : stmp = fold_convert (TREE_TYPE (dtmp), stmp);
2391 66 : gfc_add_modify (&se.pre, dtmp, stmp);
2392 66 : need_len_assign = false;
2393 : }
2394 298 : se.expr = ctree;
2395 : }
2396 885 : else if (CLASS_DATA (sym)->attr.codimension)
2397 : {
2398 28 : gfc_conv_class_to_class (&se, e, sym->ts, false, false, false,
2399 : false);
2400 28 : tmp = se.expr;
2401 : }
2402 : }
2403 : /* For non-pointer types in se.expr, the first condition holds.
2404 : For pointer or reference types in se.expr, a double TREE_TYPE ()
2405 : is possible and an associate variable always is a pointer. */
2406 6751 : if (!POINTER_TYPE_P (TREE_TYPE (se.expr))
2407 3390 : || TREE_TYPE (TREE_TYPE (se.expr))
2408 29 : != TREE_TYPE (TREE_TYPE (sym->backend_decl)))
2409 3362 : tmp = gfc_build_addr_expr (tmp, se.expr);
2410 : }
2411 :
2412 3469 : gfc_add_modify (&se.pre, sym->backend_decl, tmp);
2413 :
2414 3469 : gfc_add_init_cleanup (block, gfc_finish_block( &se.pre),
2415 : gfc_finish_block (&se.post));
2416 : }
2417 :
2418 : /* Do a simple assignment. This is for scalar expressions, where we
2419 : can simply use expression assignment. */
2420 : else
2421 : {
2422 508 : gfc_expr *lhs;
2423 508 : tree res;
2424 508 : gfc_se se;
2425 508 : stmtblock_t final_block;
2426 :
2427 508 : gfc_init_se (&se, NULL);
2428 :
2429 : /* resolve.cc converts some associate names to allocatable so that
2430 : allocation can take place automatically in gfc_trans_assignment.
2431 : The frontend prevents them from being either allocated,
2432 : deallocated or reallocated. */
2433 508 : if (sym->ts.type == BT_DERIVED
2434 130 : && sym->ts.u.derived->attr.alloc_comp)
2435 : {
2436 26 : tmp = sym->backend_decl;
2437 26 : tmp = gfc_nullify_alloc_comp (sym->ts.u.derived, tmp,
2438 26 : sym->attr.dimension ? sym->as->rank : 0);
2439 26 : gfc_add_expr_to_block (&se.pre, tmp);
2440 : }
2441 :
2442 508 : if (sym->attr.allocatable)
2443 : {
2444 12 : tmp = sym->backend_decl;
2445 12 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
2446 0 : gfc_conv_descriptor_data_set (&se.pre, tmp, null_pointer_node);
2447 : else
2448 12 : gfc_add_modify (&se.pre, tmp,
2449 12 : fold_convert (TREE_TYPE (tmp), null_pointer_node));
2450 : }
2451 :
2452 508 : lhs = gfc_lval_expr_from_sym (sym);
2453 508 : lhs->must_finalize = 0;
2454 508 : res = gfc_trans_assignment (lhs, e, false, true);
2455 508 : gfc_add_expr_to_block (&se.pre, res);
2456 :
2457 508 : gfc_init_block (&final_block);
2458 :
2459 508 : if (sym->attr.associate_var
2460 508 : && sym->ts.type == BT_DERIVED
2461 130 : && sym->ts.u.derived->attr.defined_assign_comp
2462 0 : && gfc_may_be_finalized (sym->ts)
2463 508 : && e->expr_type == EXPR_FUNCTION)
2464 : {
2465 0 : gfc_expr *ef;
2466 0 : ef = gfc_lval_expr_from_sym (sym);
2467 0 : gfc_add_finalizer_call (&final_block, ef);
2468 0 : gfc_free_expr (ef);
2469 : }
2470 :
2471 508 : if (sym->ts.type == BT_DERIVED
2472 130 : && sym->ts.u.derived->attr.alloc_comp)
2473 : {
2474 26 : tmp = sym->backend_decl;
2475 26 : tmp = gfc_deallocate_alloc_comp (sym->ts.u.derived,
2476 : tmp, 0);
2477 26 : gfc_add_expr_to_block (&final_block, tmp);
2478 : }
2479 :
2480 508 : tmp = sym->backend_decl;
2481 508 : if (e->expr_type == EXPR_FUNCTION && IS_PDT (sym))
2482 : {
2483 15 : tmp = gfc_deallocate_pdt_comp (sym->ts.u.derived, tmp,
2484 : 0);
2485 : }
2486 493 : else if (e->expr_type == EXPR_FUNCTION && IS_CLASS_PDT (sym))
2487 : {
2488 0 : tmp = gfc_class_data_get (tmp);
2489 0 : tmp = gfc_deallocate_pdt_comp (CLASS_DATA (sym)->ts.u.derived,
2490 : tmp, 0);
2491 : }
2492 493 : else if (sym->attr.allocatable)
2493 : {
2494 12 : tmp = sym->backend_decl;
2495 :
2496 12 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
2497 0 : tmp = gfc_conv_descriptor_data_get (tmp);
2498 :
2499 : /* A simple call to free suffices here. */
2500 12 : tmp = gfc_call_free (tmp);
2501 :
2502 : /* Make sure that reallocation on assignment cannot occur. */
2503 12 : sym->attr.allocatable = 0;
2504 : }
2505 : else
2506 : tmp = NULL_TREE;
2507 :
2508 508 : gfc_add_expr_to_block (&final_block, tmp);
2509 508 : tmp = gfc_finish_block (&final_block);
2510 508 : res = gfc_finish_block (&se.pre);
2511 508 : gfc_add_init_cleanup (block, res, tmp);
2512 508 : gfc_free_expr (lhs);
2513 : }
2514 :
2515 : /* Set the stringlength, when needed. */
2516 7434 : if (need_len_assign)
2517 : {
2518 742 : gfc_se se;
2519 742 : gfc_init_se (&se, NULL);
2520 742 : if (e->symtree->n.sym->ts.type == BT_CHARACTER)
2521 : {
2522 : /* Deferred strings are dealt with in the preceding. */
2523 0 : gcc_assert (!e->symtree->n.sym->ts.deferred);
2524 0 : tmp = e->symtree->n.sym->ts.u.cl->backend_decl;
2525 : }
2526 742 : else if (e->symtree->n.sym->attr.function
2527 12 : && e->symtree->n.sym == e->symtree->n.sym->result)
2528 : {
2529 12 : tmp = gfc_get_fake_result_decl (e->symtree->n.sym, 0);
2530 12 : tmp = gfc_class_len_get (tmp);
2531 : }
2532 : else
2533 730 : tmp = gfc_class_len_get (gfc_get_symbol_decl (e->symtree->n.sym));
2534 742 : gfc_get_symbol_decl (sym);
2535 742 : charlen = sym->ts.type == BT_CHARACTER ? sym->ts.u.cl->backend_decl
2536 0 : : gfc_class_len_get (sym->backend_decl);
2537 : /* Prevent adding a noop len= len. */
2538 742 : if (tmp != charlen)
2539 : {
2540 742 : gfc_add_modify (&se.pre, charlen,
2541 742 : fold_convert (TREE_TYPE (charlen), tmp));
2542 742 : gfc_add_init_cleanup (block, gfc_finish_block (&se.pre),
2543 : gfc_finish_block (&se.post));
2544 : }
2545 : }
2546 7434 : }
2547 :
2548 :
2549 : /* Translate a BLOCK construct. This is basically what we would do for a
2550 : procedure body. */
2551 :
2552 : tree
2553 14265 : gfc_trans_block_construct (gfc_code* code)
2554 : {
2555 14265 : gfc_namespace* ns;
2556 14265 : gfc_symbol* sym;
2557 14265 : gfc_wrapped_block block;
2558 14265 : tree exit_label;
2559 14265 : stmtblock_t body;
2560 14265 : gfc_association_list *ass;
2561 14265 : tree translated_body;
2562 :
2563 14265 : ns = code->ext.block.ns;
2564 14265 : gcc_assert (ns);
2565 14265 : sym = ns->proc_name;
2566 14265 : gcc_assert (sym);
2567 :
2568 : /* Process local variables. */
2569 14265 : gcc_assert (!sym->tlink);
2570 14265 : sym->tlink = sym;
2571 14265 : gfc_process_block_locals (ns);
2572 :
2573 : /* Generate code including exit-label. */
2574 14265 : gfc_init_block (&body);
2575 14265 : exit_label = gfc_build_label_decl (NULL_TREE);
2576 14265 : code->exit_label = exit_label;
2577 :
2578 14265 : finish_oacc_declare (ns, sym, true);
2579 :
2580 14265 : translated_body = gfc_trans_code (ns->code);
2581 14265 : if (ns->omp_structured_block)
2582 457 : translated_body = build1 (OMP_STRUCTURED_BLOCK, void_type_node,
2583 : translated_body);
2584 14265 : gfc_add_expr_to_block (&body, translated_body);
2585 14265 : gfc_add_expr_to_block (&body, build1_v (LABEL_EXPR, exit_label));
2586 :
2587 : /* Finish everything. */
2588 14265 : gfc_start_wrapped_block (&block, gfc_finish_block (&body));
2589 14265 : gfc_trans_deferred_vars (sym, &block);
2590 21699 : for (ass = code->ext.block.assoc; ass; ass = ass->next)
2591 7434 : trans_associate_var (ass->st->n.sym, &block);
2592 :
2593 14265 : return gfc_finish_wrapped_block (&block);
2594 : }
2595 :
2596 : /* Translate the simple DO construct in a C-style manner.
2597 : This is where the loop variable has integer type and step +-1.
2598 : Following code will generate infinite loop in case where TO is INT_MAX
2599 : (for +1 step) or INT_MIN (for -1 step)
2600 :
2601 : We translate a do loop from:
2602 :
2603 : DO dovar = from, to, step
2604 : body
2605 : END DO
2606 :
2607 : to:
2608 :
2609 : [Evaluate loop bounds and step]
2610 : dovar = from;
2611 : for (;;)
2612 : {
2613 : if (dovar > to)
2614 : goto end_label;
2615 : body;
2616 : cycle_label:
2617 : dovar += step;
2618 : }
2619 : end_label:
2620 :
2621 : This helps the optimizers by avoiding the extra pre-header condition and
2622 : we save a register as we just compare the updated IV (not a value in
2623 : previous step). */
2624 :
2625 : static tree
2626 27135 : gfc_trans_simple_do (gfc_code * code, stmtblock_t *pblock, tree dovar,
2627 : tree from, tree to, tree step, tree exit_cond)
2628 : {
2629 27135 : stmtblock_t body;
2630 27135 : tree type;
2631 27135 : tree cond;
2632 27135 : tree tmp;
2633 27135 : tree saved_dovar = NULL;
2634 27135 : tree cycle_label;
2635 27135 : tree exit_label;
2636 27135 : location_t loc;
2637 27135 : type = TREE_TYPE (dovar);
2638 27135 : bool is_step_positive = tree_int_cst_sgn (step) > 0;
2639 :
2640 27135 : loc = gfc_get_location (&code->ext.iterator->start->where);
2641 :
2642 : /* Initialize the DO variable: dovar = from. */
2643 27135 : gfc_add_modify_loc (loc, pblock, dovar,
2644 27135 : fold_convert (TREE_TYPE (dovar), from));
2645 :
2646 : /* Save value for do-tinkering checking. */
2647 27135 : if (gfc_option.rtcheck & GFC_RTCHECK_DO)
2648 : {
2649 191 : saved_dovar = gfc_create_var (type, ".saved_dovar");
2650 191 : gfc_add_modify_loc (loc, pblock, saved_dovar, dovar);
2651 : }
2652 :
2653 : /* Cycle and exit statements are implemented with gotos. */
2654 27135 : cycle_label = gfc_build_label_decl (NULL_TREE);
2655 27135 : exit_label = gfc_build_label_decl (NULL_TREE);
2656 :
2657 : /* Put the labels where they can be found later. See gfc_trans_do(). */
2658 27135 : code->cycle_label = cycle_label;
2659 27135 : code->exit_label = exit_label;
2660 :
2661 : /* Loop body. */
2662 27135 : gfc_start_block (&body);
2663 :
2664 : /* Exit the loop if there is an I/O result condition or error. */
2665 27135 : if (exit_cond)
2666 : {
2667 322 : tmp = build1_v (GOTO_EXPR, exit_label);
2668 322 : tmp = fold_build3_loc (loc, COND_EXPR, void_type_node,
2669 : exit_cond, tmp,
2670 : build_empty_stmt (loc));
2671 322 : gfc_add_expr_to_block (&body, tmp);
2672 : }
2673 :
2674 : /* Evaluate the loop condition. */
2675 27135 : if (is_step_positive)
2676 27021 : cond = fold_build2_loc (loc, GT_EXPR, logical_type_node, dovar,
2677 : fold_convert (type, to));
2678 : else
2679 114 : cond = fold_build2_loc (loc, LT_EXPR, logical_type_node, dovar,
2680 : fold_convert (type, to));
2681 :
2682 27135 : cond = gfc_evaluate_now_loc (loc, cond, &body);
2683 27135 : if (code->ext.iterator->annot.unroll && cond != error_mark_node)
2684 12 : cond
2685 12 : = build3 (ANNOTATE_EXPR, TREE_TYPE (cond), cond,
2686 : build_int_cst (integer_type_node, annot_expr_unroll_kind),
2687 : build_int_cst (integer_type_node,
2688 12 : code->ext.iterator->annot.unroll));
2689 :
2690 27135 : if (code->ext.iterator->annot.ivdep && cond != error_mark_node)
2691 2 : cond = build3 (ANNOTATE_EXPR, TREE_TYPE (cond), cond,
2692 : build_int_cst (integer_type_node, annot_expr_ivdep_kind),
2693 : integer_zero_node);
2694 27135 : if (code->ext.iterator->annot.vector && cond != error_mark_node)
2695 2 : cond = build3 (ANNOTATE_EXPR, TREE_TYPE (cond), cond,
2696 : build_int_cst (integer_type_node, annot_expr_vector_kind),
2697 : integer_zero_node);
2698 27135 : if (code->ext.iterator->annot.novector && cond != error_mark_node)
2699 2 : cond = build3 (ANNOTATE_EXPR, TREE_TYPE (cond), cond,
2700 : build_int_cst (integer_type_node, annot_expr_no_vector_kind),
2701 : integer_zero_node);
2702 :
2703 : /* The loop exit. */
2704 27135 : tmp = fold_build1_loc (loc, GOTO_EXPR, void_type_node, exit_label);
2705 27135 : TREE_USED (exit_label) = 1;
2706 27135 : tmp = fold_build3_loc (loc, COND_EXPR, void_type_node,
2707 : cond, tmp, build_empty_stmt (loc));
2708 27135 : gfc_add_expr_to_block (&body, tmp);
2709 :
2710 : /* Check whether the induction variable is equal to INT_MAX
2711 : (respectively to INT_MIN). */
2712 27135 : if (gfc_option.rtcheck & GFC_RTCHECK_DO)
2713 : {
2714 191 : tree boundary = is_step_positive ? TYPE_MAX_VALUE (type)
2715 191 : : TYPE_MIN_VALUE (type);
2716 :
2717 191 : tmp = fold_build2_loc (loc, EQ_EXPR, logical_type_node,
2718 : dovar, boundary);
2719 191 : gfc_trans_runtime_check (true, false, tmp, &body, &code->loc,
2720 : "Loop iterates infinitely");
2721 : }
2722 :
2723 : /* Main loop body. */
2724 27135 : tmp = gfc_trans_code_cond (code->block->next, exit_cond);
2725 27135 : gfc_add_expr_to_block (&body, tmp);
2726 :
2727 : /* Label for cycle statements (if needed). */
2728 27135 : if (TREE_USED (cycle_label))
2729 : {
2730 27135 : tmp = build1_v (LABEL_EXPR, cycle_label);
2731 27135 : gfc_add_expr_to_block (&body, tmp);
2732 : }
2733 :
2734 : /* Check whether someone has modified the loop variable. */
2735 27135 : if (gfc_option.rtcheck & GFC_RTCHECK_DO)
2736 : {
2737 191 : tmp = fold_build2_loc (loc, NE_EXPR, logical_type_node,
2738 : dovar, saved_dovar);
2739 191 : gfc_trans_runtime_check (true, false, tmp, &body, &code->loc,
2740 : "Loop variable has been modified");
2741 : }
2742 :
2743 : /* Increment the loop variable. */
2744 27135 : tmp = fold_build2_loc (loc, PLUS_EXPR, type, dovar, step);
2745 27135 : gfc_add_modify_loc (loc, &body, dovar, tmp);
2746 :
2747 27135 : if (gfc_option.rtcheck & GFC_RTCHECK_DO)
2748 191 : gfc_add_modify_loc (loc, &body, saved_dovar, dovar);
2749 :
2750 : /* Finish the loop body. */
2751 27135 : tmp = gfc_finish_block (&body);
2752 27135 : tmp = fold_build1_loc (loc, LOOP_EXPR, void_type_node, tmp);
2753 :
2754 27135 : gfc_add_expr_to_block (pblock, tmp);
2755 :
2756 : /* Add the exit label. */
2757 27135 : tmp = build1_v (LABEL_EXPR, exit_label);
2758 27135 : gfc_add_expr_to_block (pblock, tmp);
2759 :
2760 27135 : return gfc_finish_block (pblock);
2761 : }
2762 :
2763 : /* Translate the DO construct. This obviously is one of the most
2764 : important ones to get right with any compiler, but especially
2765 : so for Fortran.
2766 :
2767 : We special case some loop forms as described in gfc_trans_simple_do.
2768 : For other cases we implement them with a separate loop count,
2769 : as described in the standard.
2770 :
2771 : We translate a do loop from:
2772 :
2773 : DO dovar = from, to, step
2774 : body
2775 : END DO
2776 :
2777 : to:
2778 :
2779 : [evaluate loop bounds and step]
2780 : empty = (step > 0 ? to < from : to > from);
2781 : countm1 = (to - from) / step;
2782 : dovar = from;
2783 : if (empty) goto exit_label;
2784 : for (;;)
2785 : {
2786 : body;
2787 : cycle_label:
2788 : dovar += step
2789 : countm1t = countm1;
2790 : countm1--;
2791 : if (countm1t == 0) goto exit_label;
2792 : }
2793 : exit_label:
2794 :
2795 : countm1 is an unsigned integer. It is equal to the loop count minus one,
2796 : because the loop count itself can overflow. */
2797 :
2798 : tree
2799 28220 : gfc_trans_do (gfc_code * code, tree exit_cond)
2800 : {
2801 28220 : gfc_se se;
2802 28220 : tree dovar;
2803 28220 : tree saved_dovar = NULL;
2804 28220 : tree from;
2805 28220 : tree to;
2806 28220 : tree step;
2807 28220 : tree countm1;
2808 28220 : tree type;
2809 28220 : tree utype;
2810 28220 : tree cond;
2811 28220 : tree cycle_label;
2812 28220 : tree exit_label;
2813 28220 : tree tmp;
2814 28220 : stmtblock_t block;
2815 28220 : stmtblock_t body;
2816 28220 : location_t loc;
2817 :
2818 28220 : gfc_start_block (&block);
2819 :
2820 28220 : loc = gfc_get_location (&code->ext.iterator->start->where);
2821 :
2822 : /* Evaluate all the expressions in the iterator. */
2823 28220 : gfc_init_se (&se, NULL);
2824 28220 : gfc_conv_expr_lhs (&se, code->ext.iterator->var);
2825 28220 : gfc_add_block_to_block (&block, &se.pre);
2826 28220 : dovar = se.expr;
2827 28220 : type = TREE_TYPE (dovar);
2828 :
2829 28220 : gfc_init_se (&se, NULL);
2830 28220 : gfc_conv_expr_val (&se, code->ext.iterator->start);
2831 28220 : gfc_add_block_to_block (&block, &se.pre);
2832 28220 : from = gfc_evaluate_now (se.expr, &block);
2833 :
2834 28220 : gfc_init_se (&se, NULL);
2835 28220 : gfc_conv_expr_val (&se, code->ext.iterator->end);
2836 28220 : gfc_add_block_to_block (&block, &se.pre);
2837 28220 : to = gfc_evaluate_now (se.expr, &block);
2838 :
2839 28220 : gfc_init_se (&se, NULL);
2840 28220 : gfc_conv_expr_val (&se, code->ext.iterator->step);
2841 28220 : gfc_add_block_to_block (&block, &se.pre);
2842 28220 : step = gfc_evaluate_now (se.expr, &block);
2843 :
2844 28220 : if (gfc_option.rtcheck & GFC_RTCHECK_DO)
2845 : {
2846 203 : tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, step,
2847 : build_zero_cst (type));
2848 203 : gfc_trans_runtime_check (true, false, tmp, &block, &code->loc,
2849 : "DO step value is zero");
2850 : }
2851 :
2852 : /* Special case simple loops. */
2853 28220 : if (TREE_CODE (type) == INTEGER_TYPE
2854 28220 : && (integer_onep (step)
2855 1116 : || tree_int_cst_equal (step, integer_minus_one_node)))
2856 27135 : return gfc_trans_simple_do (code, &block, dovar, from, to, step,
2857 27135 : exit_cond);
2858 :
2859 1085 : if (TREE_CODE (type) == INTEGER_TYPE)
2860 1002 : utype = unsigned_type_for (type);
2861 : else
2862 83 : utype = unsigned_type_for (gfc_array_index_type);
2863 1085 : countm1 = gfc_create_var (utype, "countm1");
2864 :
2865 : /* Cycle and exit statements are implemented with gotos. */
2866 1085 : cycle_label = gfc_build_label_decl (NULL_TREE);
2867 1085 : exit_label = gfc_build_label_decl (NULL_TREE);
2868 1085 : TREE_USED (exit_label) = 1;
2869 :
2870 : /* Put these labels where they can be found later. */
2871 1085 : code->cycle_label = cycle_label;
2872 1085 : code->exit_label = exit_label;
2873 :
2874 : /* Initialize the DO variable: dovar = from. */
2875 1085 : gfc_add_modify (&block, dovar, from);
2876 :
2877 : /* Save value for do-tinkering checking. */
2878 1085 : if (gfc_option.rtcheck & GFC_RTCHECK_DO)
2879 : {
2880 12 : saved_dovar = gfc_create_var (type, ".saved_dovar");
2881 12 : gfc_add_modify_loc (loc, &block, saved_dovar, dovar);
2882 : }
2883 :
2884 : /* Initialize loop count and jump to exit label if the loop is empty.
2885 : This code is executed before we enter the loop body. We generate:
2886 : if (step > 0)
2887 : {
2888 : countm1 = (to - from) / step;
2889 : if (to < from)
2890 : goto exit_label;
2891 : }
2892 : else
2893 : {
2894 : countm1 = (from - to) / -step;
2895 : if (to > from)
2896 : goto exit_label;
2897 : }
2898 : */
2899 :
2900 1085 : if (TREE_CODE (type) == INTEGER_TYPE)
2901 : {
2902 1002 : tree pos, neg, tou, fromu, stepu, tmp2;
2903 :
2904 : /* The distance from FROM to TO cannot always be represented in a signed
2905 : type, thus use unsigned arithmetic, also to avoid any undefined
2906 : overflow issues. */
2907 1002 : tou = fold_convert (utype, to);
2908 1002 : fromu = fold_convert (utype, from);
2909 1002 : stepu = fold_convert (utype, step);
2910 :
2911 : /* For a positive step, when to < from, exit, otherwise compute
2912 : countm1 = ((unsigned)to - (unsigned)from) / (unsigned)step */
2913 1002 : tmp = fold_build2_loc (loc, LT_EXPR, logical_type_node, to, from);
2914 1002 : tmp2 = fold_build2_loc (loc, TRUNC_DIV_EXPR, utype,
2915 : fold_build2_loc (loc, MINUS_EXPR, utype,
2916 : tou, fromu),
2917 : stepu);
2918 1002 : pos = build2 (COMPOUND_EXPR, void_type_node,
2919 : fold_build2 (MODIFY_EXPR, void_type_node,
2920 : countm1, tmp2),
2921 : build3_loc (loc, COND_EXPR, void_type_node,
2922 : gfc_unlikely (tmp, PRED_FORTRAN_LOOP_PREHEADER),
2923 : build1_loc (loc, GOTO_EXPR, void_type_node,
2924 : exit_label), NULL_TREE));
2925 :
2926 : /* For a negative step, when to > from, exit, otherwise compute
2927 : countm1 = ((unsigned)from - (unsigned)to) / -(unsigned)step */
2928 1002 : tmp = fold_build2_loc (loc, GT_EXPR, logical_type_node, to, from);
2929 1002 : tmp2 = fold_build2_loc (loc, TRUNC_DIV_EXPR, utype,
2930 : fold_build2_loc (loc, MINUS_EXPR, utype,
2931 : fromu, tou),
2932 : fold_build1_loc (loc, NEGATE_EXPR, utype, stepu));
2933 1002 : neg = build2 (COMPOUND_EXPR, void_type_node,
2934 : fold_build2 (MODIFY_EXPR, void_type_node,
2935 : countm1, tmp2),
2936 : build3_loc (loc, COND_EXPR, void_type_node,
2937 : gfc_unlikely (tmp, PRED_FORTRAN_LOOP_PREHEADER),
2938 : build1_loc (loc, GOTO_EXPR, void_type_node,
2939 : exit_label), NULL_TREE));
2940 :
2941 1002 : tmp = fold_build2_loc (loc, LT_EXPR, logical_type_node, step,
2942 1002 : build_int_cst (TREE_TYPE (step), 0));
2943 1002 : tmp = fold_build3_loc (loc, COND_EXPR, void_type_node, tmp, neg, pos);
2944 :
2945 1002 : gfc_add_expr_to_block (&block, tmp);
2946 : }
2947 : else
2948 : {
2949 83 : tree pos_step;
2950 :
2951 : /* TODO: We could use the same width as the real type.
2952 : This would probably cause more problems that it solves
2953 : when we implement "long double" types. */
2954 :
2955 83 : tmp = fold_build2_loc (loc, MINUS_EXPR, type, to, from);
2956 83 : tmp = fold_build2_loc (loc, RDIV_EXPR, type, tmp, step);
2957 83 : tmp = fold_build1_loc (loc, FIX_TRUNC_EXPR, utype, tmp);
2958 83 : gfc_add_modify (&block, countm1, tmp);
2959 :
2960 : /* We need a special check for empty loops:
2961 : empty = (step > 0 ? to < from : to > from); */
2962 83 : pos_step = fold_build2_loc (loc, GT_EXPR, logical_type_node, step,
2963 : build_zero_cst (type));
2964 83 : tmp = fold_build3_loc (loc, COND_EXPR, logical_type_node, pos_step,
2965 : fold_build2_loc (loc, LT_EXPR,
2966 : logical_type_node, to, from),
2967 : fold_build2_loc (loc, GT_EXPR,
2968 : logical_type_node, to, from));
2969 : /* If the loop is empty, go directly to the exit label. */
2970 83 : tmp = fold_build3_loc (loc, COND_EXPR, void_type_node, tmp,
2971 : build1_v (GOTO_EXPR, exit_label),
2972 : build_empty_stmt (input_location));
2973 83 : gfc_add_expr_to_block (&block, tmp);
2974 : }
2975 :
2976 : /* Loop body. */
2977 1085 : gfc_start_block (&body);
2978 :
2979 : /* Main loop body. */
2980 1085 : tmp = gfc_trans_code_cond (code->block->next, exit_cond);
2981 1085 : gfc_add_expr_to_block (&body, tmp);
2982 :
2983 : /* Label for cycle statements (if needed). */
2984 1085 : if (TREE_USED (cycle_label))
2985 : {
2986 1085 : tmp = build1_v (LABEL_EXPR, cycle_label);
2987 1085 : gfc_add_expr_to_block (&body, tmp);
2988 : }
2989 :
2990 : /* Check whether someone has modified the loop variable. */
2991 1085 : if (gfc_option.rtcheck & GFC_RTCHECK_DO)
2992 : {
2993 12 : tmp = fold_build2_loc (loc, NE_EXPR, logical_type_node, dovar,
2994 : saved_dovar);
2995 12 : gfc_trans_runtime_check (true, false, tmp, &body, &code->loc,
2996 : "Loop variable has been modified");
2997 : }
2998 :
2999 : /* Exit the loop if there is an I/O result condition or error. */
3000 1085 : if (exit_cond)
3001 : {
3002 1 : tmp = build1_v (GOTO_EXPR, exit_label);
3003 1 : tmp = fold_build3_loc (loc, COND_EXPR, void_type_node,
3004 : exit_cond, tmp,
3005 : build_empty_stmt (input_location));
3006 1 : gfc_add_expr_to_block (&body, tmp);
3007 : }
3008 :
3009 : /* Increment the loop variable. */
3010 1085 : tmp = fold_build2_loc (loc, PLUS_EXPR, type, dovar, step);
3011 1085 : gfc_add_modify_loc (loc, &body, dovar, tmp);
3012 :
3013 1085 : if (gfc_option.rtcheck & GFC_RTCHECK_DO)
3014 12 : gfc_add_modify_loc (loc, &body, saved_dovar, dovar);
3015 :
3016 : /* Initialize countm1t. */
3017 1085 : tree countm1t = gfc_create_var (utype, "countm1t");
3018 1085 : gfc_add_modify_loc (loc, &body, countm1t, countm1);
3019 :
3020 : /* Decrement the loop count. */
3021 1085 : tmp = fold_build2_loc (loc, MINUS_EXPR, utype, countm1,
3022 : build_int_cst (utype, 1));
3023 1085 : gfc_add_modify_loc (loc, &body, countm1, tmp);
3024 :
3025 : /* End with the loop condition. Loop until countm1t == 0. */
3026 1085 : cond = fold_build2_loc (loc, EQ_EXPR, logical_type_node, countm1t,
3027 : build_int_cst (utype, 0));
3028 1085 : if (code->ext.iterator->annot.unroll && cond != error_mark_node)
3029 3 : cond
3030 3 : = build3 (ANNOTATE_EXPR, TREE_TYPE (cond), cond,
3031 : build_int_cst (integer_type_node, annot_expr_unroll_kind),
3032 : build_int_cst (integer_type_node,
3033 3 : code->ext.iterator->annot.unroll));
3034 :
3035 1085 : if (code->ext.iterator->annot.ivdep && cond != error_mark_node)
3036 0 : cond = build3 (ANNOTATE_EXPR, TREE_TYPE (cond), cond,
3037 : build_int_cst (integer_type_node, annot_expr_ivdep_kind),
3038 : integer_zero_node);
3039 1085 : if (code->ext.iterator->annot.vector && cond != error_mark_node)
3040 0 : cond = build3 (ANNOTATE_EXPR, TREE_TYPE (cond), cond,
3041 : build_int_cst (integer_type_node, annot_expr_vector_kind),
3042 : integer_zero_node);
3043 1085 : if (code->ext.iterator->annot.novector && cond != error_mark_node)
3044 0 : cond = build3 (ANNOTATE_EXPR, TREE_TYPE (cond), cond,
3045 : build_int_cst (integer_type_node, annot_expr_no_vector_kind),
3046 : integer_zero_node);
3047 :
3048 1085 : tmp = fold_build1_loc (loc, GOTO_EXPR, void_type_node, exit_label);
3049 1085 : tmp = fold_build3_loc (loc, COND_EXPR, void_type_node,
3050 : cond, tmp, build_empty_stmt (loc));
3051 1085 : gfc_add_expr_to_block (&body, tmp);
3052 :
3053 : /* End of loop body. */
3054 1085 : tmp = gfc_finish_block (&body);
3055 :
3056 : /* The for loop itself. */
3057 1085 : tmp = fold_build1_loc (loc, LOOP_EXPR, void_type_node, tmp);
3058 1085 : gfc_add_expr_to_block (&block, tmp);
3059 :
3060 : /* Add the exit label. */
3061 1085 : tmp = build1_v (LABEL_EXPR, exit_label);
3062 1085 : gfc_add_expr_to_block (&block, tmp);
3063 :
3064 1085 : return gfc_finish_block (&block);
3065 : }
3066 :
3067 :
3068 : /* Translate the DO WHILE construct.
3069 :
3070 : We translate
3071 :
3072 : DO WHILE (cond)
3073 : body
3074 : END DO
3075 :
3076 : to:
3077 :
3078 : for ( ; ; )
3079 : {
3080 : pre_cond;
3081 : if (! cond) goto exit_label;
3082 : body;
3083 : cycle_label:
3084 : }
3085 : exit_label:
3086 :
3087 : Because the evaluation of the exit condition `cond' may have side
3088 : effects, we can't do much for empty loop bodies. The backend optimizers
3089 : should be smart enough to eliminate any dead loops. */
3090 :
3091 : tree
3092 502 : gfc_trans_do_while (gfc_code * code)
3093 : {
3094 502 : gfc_se cond;
3095 502 : tree tmp;
3096 502 : tree cycle_label;
3097 502 : tree exit_label;
3098 502 : stmtblock_t block;
3099 :
3100 : /* Everything we build here is part of the loop body. */
3101 502 : gfc_start_block (&block);
3102 :
3103 : /* Cycle and exit statements are implemented with gotos. */
3104 502 : cycle_label = gfc_build_label_decl (NULL_TREE);
3105 502 : exit_label = gfc_build_label_decl (NULL_TREE);
3106 :
3107 : /* Put the labels where they can be found later. See gfc_trans_do(). */
3108 502 : code->cycle_label = cycle_label;
3109 502 : code->exit_label = exit_label;
3110 :
3111 : /* Create a GIMPLE version of the exit condition. */
3112 502 : gfc_init_se (&cond, NULL);
3113 502 : gfc_conv_expr_val (&cond, code->expr1);
3114 502 : gfc_add_block_to_block (&block, &cond.pre);
3115 502 : cond.expr = fold_build1_loc (gfc_get_location (&code->expr1->where),
3116 502 : TRUTH_NOT_EXPR, TREE_TYPE (cond.expr),
3117 : cond.expr);
3118 :
3119 : /* Build "IF (! cond) GOTO exit_label". */
3120 502 : tmp = build1_v (GOTO_EXPR, exit_label);
3121 502 : TREE_USED (exit_label) = 1;
3122 502 : tmp = fold_build3_loc (gfc_get_location (&code->expr1->where), COND_EXPR,
3123 : void_type_node, cond.expr, tmp,
3124 : build_empty_stmt (gfc_get_location (
3125 502 : &code->expr1->where)));
3126 502 : gfc_add_expr_to_block (&block, tmp);
3127 :
3128 : /* The main body of the loop. */
3129 502 : tmp = gfc_trans_code (code->block->next);
3130 502 : gfc_add_expr_to_block (&block, tmp);
3131 :
3132 : /* Label for cycle statements (if needed). */
3133 502 : if (TREE_USED (cycle_label))
3134 : {
3135 502 : tmp = build1_v (LABEL_EXPR, cycle_label);
3136 502 : gfc_add_expr_to_block (&block, tmp);
3137 : }
3138 :
3139 : /* End of loop body. */
3140 502 : tmp = gfc_finish_block (&block);
3141 :
3142 502 : gfc_init_block (&block);
3143 : /* Build the loop. */
3144 502 : tmp = fold_build1_loc (gfc_get_location (&code->expr1->where), LOOP_EXPR,
3145 : void_type_node, tmp);
3146 502 : gfc_add_expr_to_block (&block, tmp);
3147 :
3148 : /* Add the exit label. */
3149 502 : tmp = build1_v (LABEL_EXPR, exit_label);
3150 502 : gfc_add_expr_to_block (&block, tmp);
3151 :
3152 502 : return gfc_finish_block (&block);
3153 : }
3154 :
3155 :
3156 : /* Deal with the particular case of SELECT_TYPE, where the vtable
3157 : addresses are used for the selection. Since these are not sorted,
3158 : the selection has to be made by a series of if statements. */
3159 :
3160 : static tree
3161 2998 : gfc_trans_select_type_cases (gfc_code * code)
3162 : {
3163 2998 : gfc_code *c;
3164 2998 : gfc_case *cp;
3165 2998 : tree tmp;
3166 2998 : tree cond;
3167 2998 : tree low;
3168 2998 : tree high;
3169 2998 : gfc_se se;
3170 2998 : gfc_se cse;
3171 2998 : stmtblock_t block;
3172 2998 : stmtblock_t body;
3173 2998 : bool def = false;
3174 2998 : gfc_expr *e;
3175 2998 : gfc_start_block (&block);
3176 :
3177 : /* Calculate the switch expression. */
3178 2998 : gfc_init_se (&se, NULL);
3179 2998 : gfc_conv_expr_val (&se, code->expr1);
3180 2998 : gfc_add_block_to_block (&block, &se.pre);
3181 :
3182 : /* Generate an expression for the selector hash value, for
3183 : use to resolve character cases. */
3184 2998 : e = gfc_copy_expr (code->expr1->value.function.actual->expr);
3185 2998 : gfc_add_hash_component (e);
3186 :
3187 2998 : TREE_USED (code->exit_label) = 0;
3188 :
3189 5996 : repeat:
3190 16480 : for (c = code->block; c; c = c->block)
3191 : {
3192 10484 : cp = c->ext.block.case_list;
3193 :
3194 : /* Assume it's the default case. */
3195 10484 : low = NULL_TREE;
3196 10484 : high = NULL_TREE;
3197 10484 : tmp = NULL_TREE;
3198 :
3199 : /* Put the default case at the end. */
3200 10484 : if ((!def && !cp->low) || (def && cp->low))
3201 5242 : continue;
3202 :
3203 5242 : if (cp->low && (cp->ts.type == BT_CLASS
3204 3412 : || cp->ts.type == BT_DERIVED))
3205 : {
3206 1967 : gfc_init_se (&cse, NULL);
3207 1967 : gfc_conv_expr_val (&cse, cp->low);
3208 1967 : gfc_add_block_to_block (&block, &cse.pre);
3209 1967 : low = cse.expr;
3210 : }
3211 3275 : else if (cp->ts.type != BT_UNKNOWN)
3212 : {
3213 1445 : gcc_assert (cp->high);
3214 1445 : gfc_init_se (&cse, NULL);
3215 1445 : gfc_conv_expr_val (&cse, cp->high);
3216 1445 : gfc_add_block_to_block (&block, &cse.pre);
3217 1445 : high = cse.expr;
3218 : }
3219 :
3220 5242 : gfc_init_block (&body);
3221 :
3222 : /* Add the statements for this case. */
3223 5242 : tmp = gfc_trans_code (c->next);
3224 5242 : gfc_add_expr_to_block (&body, tmp);
3225 :
3226 : /* Break to the end of the SELECT TYPE construct. The default
3227 : case just falls through. */
3228 5242 : if (!def)
3229 : {
3230 3412 : TREE_USED (code->exit_label) = 1;
3231 3412 : tmp = build1_v (GOTO_EXPR, code->exit_label);
3232 3412 : gfc_add_expr_to_block (&body, tmp);
3233 : }
3234 :
3235 5242 : tmp = gfc_finish_block (&body);
3236 :
3237 5242 : if (low != NULL_TREE)
3238 : {
3239 : /* Compare vtable pointers. */
3240 1967 : cond = fold_build2_loc (input_location, EQ_EXPR,
3241 1967 : TREE_TYPE (se.expr), se.expr, low);
3242 1967 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
3243 : cond, tmp,
3244 : build_empty_stmt (input_location));
3245 : }
3246 3275 : else if (high != NULL_TREE)
3247 : {
3248 : /* Compare hash values for character cases. */
3249 1445 : gfc_init_se (&cse, NULL);
3250 1445 : gfc_conv_expr_val (&cse, e);
3251 1445 : gfc_add_block_to_block (&block, &cse.pre);
3252 :
3253 1445 : cond = fold_build2_loc (input_location, EQ_EXPR,
3254 1445 : TREE_TYPE (se.expr), high, cse.expr);
3255 1445 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
3256 : cond, tmp,
3257 : build_empty_stmt (input_location));
3258 : }
3259 :
3260 5242 : gfc_add_expr_to_block (&block, tmp);
3261 : }
3262 :
3263 5996 : if (!def)
3264 : {
3265 2998 : def = true;
3266 2998 : goto repeat;
3267 : }
3268 :
3269 2998 : gfc_free_expr (e);
3270 :
3271 2998 : return gfc_finish_block (&block);
3272 : }
3273 :
3274 :
3275 : /* Translate the SELECT CASE construct for INTEGER case expressions,
3276 : without killing all potential optimizations. The problem is that
3277 : Fortran allows unbounded cases, but the back-end does not, so we
3278 : need to intercept those before we enter the equivalent SWITCH_EXPR
3279 : we can build.
3280 :
3281 : For example, we translate this,
3282 :
3283 : SELECT CASE (expr)
3284 : CASE (:100,101,105:115)
3285 : block_1
3286 : CASE (190:199,200:)
3287 : block_2
3288 : CASE (300)
3289 : block_3
3290 : CASE DEFAULT
3291 : block_4
3292 : END SELECT
3293 :
3294 : to the GENERIC equivalent,
3295 :
3296 : switch (expr)
3297 : {
3298 : case (minimum value for typeof(expr) ... 100:
3299 : case 101:
3300 : case 105 ... 114:
3301 : block1:
3302 : goto end_label;
3303 :
3304 : case 200 ... (maximum value for typeof(expr):
3305 : case 190 ... 199:
3306 : block2;
3307 : goto end_label;
3308 :
3309 : case 300:
3310 : block_3;
3311 : goto end_label;
3312 :
3313 : default:
3314 : block_4;
3315 : goto end_label;
3316 : }
3317 :
3318 : end_label: */
3319 :
3320 : static tree
3321 965 : gfc_trans_integer_select (gfc_code * code)
3322 : {
3323 965 : gfc_code *c;
3324 965 : gfc_case *cp;
3325 965 : tree end_label;
3326 965 : tree tmp;
3327 965 : gfc_se se;
3328 965 : stmtblock_t block;
3329 965 : stmtblock_t body;
3330 :
3331 965 : gfc_start_block (&block);
3332 :
3333 : /* Calculate the switch expression. */
3334 965 : gfc_init_se (&se, NULL);
3335 965 : gfc_conv_expr_val (&se, code->expr1);
3336 965 : gfc_add_block_to_block (&block, &se.pre);
3337 :
3338 965 : end_label = gfc_build_label_decl (NULL_TREE);
3339 :
3340 965 : gfc_init_block (&body);
3341 :
3342 2890 : for (c = code->block; c; c = c->block)
3343 : {
3344 3922 : for (cp = c->ext.block.case_list; cp; cp = cp->next)
3345 : {
3346 1997 : tree low, high;
3347 1997 : tree label;
3348 :
3349 : /* Assume it's the default case. */
3350 1997 : low = high = NULL_TREE;
3351 :
3352 1997 : if (cp->low)
3353 : {
3354 1571 : if (cp->low->ts.type == BT_INTEGER)
3355 1529 : low = gfc_conv_mpz_to_tree (cp->low->value.integer,
3356 : cp->low->ts.kind);
3357 : else
3358 42 : low = gfc_conv_mpz_unsigned_to_tree (cp->low->value.integer,
3359 : cp->low->ts.kind);
3360 :
3361 : /* If there's only a lower bound, set the high bound to the
3362 : maximum value of the case expression. */
3363 1571 : if (!cp->high)
3364 45 : high = TYPE_MAX_VALUE (TREE_TYPE (se.expr));
3365 : }
3366 :
3367 1997 : if (cp->high)
3368 : {
3369 : /* Three cases are possible here:
3370 :
3371 : 1) There is no lower bound, e.g. CASE (:N).
3372 : 2) There is a lower bound .NE. high bound, that is
3373 : a case range, e.g. CASE (N:M) where M>N (we make
3374 : sure that M>N during type resolution).
3375 : 3) There is a lower bound, and it has the same value
3376 : as the high bound, e.g. CASE (N:N). This is our
3377 : internal representation of CASE(N).
3378 :
3379 : In the first and second case, we need to set a value for
3380 : high. In the third case, we don't because the GCC middle
3381 : end represents a single case value by just letting high be
3382 : a NULL_TREE. We can't do that because we need to be able
3383 : to represent unbounded cases. */
3384 :
3385 1570 : if (!cp->low
3386 1526 : || (mpz_cmp (cp->low->value.integer,
3387 1526 : cp->high->value.integer) != 0))
3388 : {
3389 73 : if (cp->high->ts.type == BT_INTEGER)
3390 73 : high = gfc_conv_mpz_to_tree (cp->high->value.integer,
3391 : cp->high->ts.kind);
3392 : else
3393 0 : high
3394 0 : = gfc_conv_mpz_unsigned_to_tree (cp->high->value.integer,
3395 : cp->high->ts.kind);
3396 : }
3397 :
3398 : /* Unbounded case. */
3399 1570 : if (!cp->low)
3400 44 : low = TYPE_MIN_VALUE (TREE_TYPE (se.expr));
3401 : }
3402 :
3403 : /* Build a label. */
3404 1997 : label = gfc_build_label_decl (NULL_TREE);
3405 :
3406 : /* Add this case label.
3407 : Add parameter 'label', make it match GCC backend. */
3408 1997 : tmp = build_case_label (low, high, label);
3409 1997 : gfc_add_expr_to_block (&body, tmp);
3410 : }
3411 :
3412 : /* Add the statements for this case. */
3413 1925 : tmp = gfc_trans_code (c->next);
3414 1925 : gfc_add_expr_to_block (&body, tmp);
3415 :
3416 : /* Break to the end of the construct. */
3417 1925 : tmp = build1_v (GOTO_EXPR, end_label);
3418 1925 : gfc_add_expr_to_block (&body, tmp);
3419 : }
3420 :
3421 965 : tmp = gfc_finish_block (&body);
3422 965 : tmp = fold_build2_loc (input_location, SWITCH_EXPR, NULL_TREE, se.expr, tmp);
3423 965 : gfc_add_expr_to_block (&block, tmp);
3424 :
3425 965 : tmp = build1_v (LABEL_EXPR, end_label);
3426 965 : gfc_add_expr_to_block (&block, tmp);
3427 :
3428 965 : return gfc_finish_block (&block);
3429 : }
3430 :
3431 :
3432 : /* Translate the SELECT CASE construct for LOGICAL case expressions.
3433 :
3434 : There are only two cases possible here, even though the standard
3435 : does allow three cases in a LOGICAL SELECT CASE construct: .TRUE.,
3436 : .FALSE., and DEFAULT.
3437 :
3438 : We never generate more than two blocks here. Instead, we always
3439 : try to eliminate the DEFAULT case. This way, we can translate this
3440 : kind of SELECT construct to a simple
3441 :
3442 : if {} else {};
3443 :
3444 : expression in GENERIC. */
3445 :
3446 : static tree
3447 54 : gfc_trans_logical_select (gfc_code * code)
3448 : {
3449 54 : gfc_code *c;
3450 54 : gfc_code *t, *f, *d;
3451 54 : gfc_case *cp;
3452 54 : gfc_se se;
3453 54 : stmtblock_t block;
3454 :
3455 : /* Assume we don't have any cases at all. */
3456 54 : t = f = d = NULL;
3457 :
3458 : /* Now see which ones we actually do have. We can have at most two
3459 : cases in a single case list: one for .TRUE. and one for .FALSE.
3460 : The default case is always separate. If the cases for .TRUE. and
3461 : .FALSE. are in the same case list, the block for that case list
3462 : always executed, and we don't generate code a COND_EXPR. */
3463 171 : for (c = code->block; c; c = c->block)
3464 : {
3465 243 : for (cp = c->ext.block.case_list; cp; cp = cp->next)
3466 : {
3467 126 : if (cp->low)
3468 : {
3469 72 : if (cp->low->value.logical == 0) /* .FALSE. */
3470 : f = c;
3471 : else /* if (cp->value.logical != 0), thus .TRUE. */
3472 36 : t = c;
3473 : }
3474 : else
3475 : d = c;
3476 : }
3477 : }
3478 :
3479 : /* Start a new block. */
3480 54 : gfc_start_block (&block);
3481 :
3482 : /* Calculate the switch expression. We always need to do this
3483 : because it may have side effects. */
3484 54 : gfc_init_se (&se, NULL);
3485 54 : gfc_conv_expr_val (&se, code->expr1);
3486 54 : gfc_add_block_to_block (&block, &se.pre);
3487 :
3488 54 : if (t == f && t != NULL)
3489 : {
3490 : /* Cases for .TRUE. and .FALSE. are in the same block. Just
3491 : translate the code for these cases, append it to the current
3492 : block. */
3493 9 : gfc_add_expr_to_block (&block, gfc_trans_code (t->next));
3494 : }
3495 : else
3496 : {
3497 45 : tree true_tree, false_tree, stmt;
3498 :
3499 45 : true_tree = build_empty_stmt (input_location);
3500 45 : false_tree = build_empty_stmt (input_location);
3501 :
3502 : /* If we have a case for .TRUE. and for .FALSE., discard the default case.
3503 : Otherwise, if .TRUE. or .FALSE. is missing and there is a default case,
3504 : make the missing case the default case. */
3505 45 : if (t != NULL && f != NULL)
3506 63 : d = NULL;
3507 36 : else if (d != NULL)
3508 : {
3509 36 : if (t == NULL)
3510 : t = d;
3511 : else
3512 : f = d;
3513 : }
3514 :
3515 : /* Translate the code for each of these blocks, and append it to
3516 : the current block. */
3517 18 : if (t != NULL)
3518 45 : true_tree = gfc_trans_code (t->next);
3519 :
3520 45 : if (f != NULL)
3521 45 : false_tree = gfc_trans_code (f->next);
3522 :
3523 45 : stmt = fold_build3_loc (input_location, COND_EXPR, void_type_node,
3524 : se.expr, true_tree, false_tree);
3525 45 : gfc_add_expr_to_block (&block, stmt);
3526 : }
3527 :
3528 54 : return gfc_finish_block (&block);
3529 : }
3530 :
3531 :
3532 : /* The jump table types are stored in static variables to avoid
3533 : constructing them from scratch every single time. */
3534 : static GTY(()) tree select_struct[2];
3535 :
3536 : /* Translate the SELECT CASE construct for CHARACTER case expressions.
3537 : Instead of generating compares and jumps, it is far simpler to
3538 : generate a data structure describing the cases in order and call a
3539 : library subroutine that locates the right case.
3540 : This is particularly true because this is the only case where we
3541 : might have to dispose of a temporary.
3542 : The library subroutine returns a pointer to jump to or NULL if no
3543 : branches are to be taken. */
3544 :
3545 : static tree
3546 75 : gfc_trans_character_select (gfc_code *code)
3547 : {
3548 75 : tree init, end_label, tmp, type, case_num, label, fndecl;
3549 75 : stmtblock_t block, body;
3550 75 : gfc_case *cp, *d;
3551 75 : gfc_code *c;
3552 75 : gfc_se se, expr1se;
3553 75 : int n, k;
3554 75 : vec<constructor_elt, va_gc> *inits = NULL;
3555 :
3556 75 : tree pchartype = gfc_get_pchar_type (code->expr1->ts.kind);
3557 :
3558 : /* The jump table types are stored in static variables to avoid
3559 : constructing them from scratch every single time. */
3560 75 : static tree ss_string1[2], ss_string1_len[2];
3561 75 : static tree ss_string2[2], ss_string2_len[2];
3562 75 : static tree ss_target[2];
3563 :
3564 75 : cp = code->block->ext.block.case_list;
3565 241 : while (cp->left != NULL)
3566 : cp = cp->left;
3567 :
3568 : /* Generate the body */
3569 75 : gfc_start_block (&block);
3570 75 : gfc_init_se (&expr1se, NULL);
3571 75 : gfc_conv_expr_reference (&expr1se, code->expr1);
3572 :
3573 75 : gfc_add_block_to_block (&block, &expr1se.pre);
3574 :
3575 75 : end_label = gfc_build_label_decl (NULL_TREE);
3576 :
3577 75 : gfc_init_block (&body);
3578 :
3579 : /* Attempt to optimize length 1 selects. */
3580 75 : if (integer_onep (expr1se.string_length))
3581 : {
3582 126 : for (d = cp; d; d = d->right)
3583 : {
3584 110 : gfc_charlen_t i;
3585 110 : if (d->low)
3586 : {
3587 100 : gcc_assert (d->low->expr_type == EXPR_CONSTANT
3588 : && d->low->ts.type == BT_CHARACTER);
3589 100 : if (d->low->value.character.length > 1)
3590 : {
3591 2 : for (i = 1; i < d->low->value.character.length; i++)
3592 2 : if (d->low->value.character.string[i] != ' ')
3593 : break;
3594 2 : if (i != d->low->value.character.length)
3595 : {
3596 2 : if (optimize && d->high && i == 1)
3597 : {
3598 2 : gcc_assert (d->high->expr_type == EXPR_CONSTANT
3599 : && d->high->ts.type == BT_CHARACTER);
3600 2 : if (d->high->value.character.length > 1
3601 2 : && (d->low->value.character.string[0]
3602 2 : == d->high->value.character.string[0])
3603 2 : && d->high->value.character.string[1] != ' '
3604 4 : && ((d->low->value.character.string[1] < ' ')
3605 : == (d->high->value.character.string[1]
3606 2 : < ' ')))
3607 2 : continue;
3608 : }
3609 : break;
3610 : }
3611 : }
3612 : }
3613 108 : if (d->high)
3614 : {
3615 98 : gcc_assert (d->high->expr_type == EXPR_CONSTANT
3616 : && d->high->ts.type == BT_CHARACTER);
3617 98 : if (d->high->value.character.length > 1)
3618 : {
3619 3 : for (i = 1; i < d->high->value.character.length; i++)
3620 2 : if (d->high->value.character.string[i] != ' ')
3621 : break;
3622 1 : if (i != d->high->value.character.length)
3623 : break;
3624 : }
3625 : }
3626 : }
3627 16 : if (d == NULL)
3628 : {
3629 16 : tree ctype = gfc_get_char_type (code->expr1->ts.kind);
3630 :
3631 58 : for (c = code->block; c; c = c->block)
3632 : {
3633 152 : for (cp = c->ext.block.case_list; cp; cp = cp->next)
3634 : {
3635 110 : tree low, high;
3636 110 : tree label;
3637 110 : gfc_char_t r;
3638 :
3639 : /* Assume it's the default case. */
3640 110 : low = high = NULL_TREE;
3641 :
3642 110 : if (cp->low)
3643 : {
3644 : /* CASE ('ab') or CASE ('ab':'az') will never match
3645 : any length 1 character. */
3646 100 : if (cp->low->value.character.length > 1
3647 2 : && cp->low->value.character.string[1] != ' ')
3648 2 : continue;
3649 :
3650 98 : if (cp->low->value.character.length > 0)
3651 97 : r = cp->low->value.character.string[0];
3652 : else
3653 : r = ' ';
3654 98 : low = build_int_cst (ctype, r);
3655 :
3656 : /* If there's only a lower bound, set the high bound
3657 : to the maximum value of the case expression. */
3658 98 : if (!cp->high)
3659 0 : high = TYPE_MAX_VALUE (ctype);
3660 : }
3661 :
3662 108 : if (cp->high)
3663 : {
3664 98 : if (!cp->low
3665 98 : || (cp->low->value.character.string[0]
3666 98 : != cp->high->value.character.string[0]))
3667 : {
3668 2 : if (cp->high->value.character.length > 0)
3669 2 : r = cp->high->value.character.string[0];
3670 : else
3671 : r = ' ';
3672 2 : high = build_int_cst (ctype, r);
3673 : }
3674 :
3675 : /* Unbounded case. */
3676 98 : if (!cp->low)
3677 0 : low = TYPE_MIN_VALUE (ctype);
3678 : }
3679 :
3680 : /* Build a label. */
3681 108 : label = gfc_build_label_decl (NULL_TREE);
3682 :
3683 : /* Add this case label.
3684 : Add parameter 'label', make it match GCC backend. */
3685 108 : tmp = build_case_label (low, high, label);
3686 108 : gfc_add_expr_to_block (&body, tmp);
3687 : }
3688 :
3689 : /* Add the statements for this case. */
3690 42 : tmp = gfc_trans_code (c->next);
3691 42 : gfc_add_expr_to_block (&body, tmp);
3692 :
3693 : /* Break to the end of the construct. */
3694 42 : tmp = build1_v (GOTO_EXPR, end_label);
3695 42 : gfc_add_expr_to_block (&body, tmp);
3696 : }
3697 :
3698 32 : tmp = gfc_string_to_single_character (expr1se.string_length,
3699 : expr1se.expr,
3700 16 : code->expr1->ts.kind);
3701 16 : case_num = gfc_create_var (ctype, "case_num");
3702 16 : gfc_add_modify (&block, case_num, tmp);
3703 :
3704 16 : gfc_add_block_to_block (&block, &expr1se.post);
3705 :
3706 16 : tmp = gfc_finish_block (&body);
3707 16 : tmp = fold_build2_loc (input_location, SWITCH_EXPR, NULL_TREE,
3708 : case_num, tmp);
3709 16 : gfc_add_expr_to_block (&block, tmp);
3710 :
3711 16 : tmp = build1_v (LABEL_EXPR, end_label);
3712 16 : gfc_add_expr_to_block (&block, tmp);
3713 :
3714 16 : return gfc_finish_block (&block);
3715 : }
3716 : }
3717 :
3718 59 : if (code->expr1->ts.kind == 1)
3719 : k = 0;
3720 6 : else if (code->expr1->ts.kind == 4)
3721 : k = 1;
3722 : else
3723 0 : gcc_unreachable ();
3724 :
3725 59 : if (select_struct[k] == NULL)
3726 : {
3727 53 : tree *chain = NULL;
3728 53 : select_struct[k] = make_node (RECORD_TYPE);
3729 :
3730 53 : if (code->expr1->ts.kind == 1)
3731 47 : TYPE_NAME (select_struct[k]) = get_identifier ("_jump_struct_char1");
3732 6 : else if (code->expr1->ts.kind == 4)
3733 6 : TYPE_NAME (select_struct[k]) = get_identifier ("_jump_struct_char4");
3734 : else
3735 0 : gcc_unreachable ();
3736 :
3737 : #undef ADD_FIELD
3738 : #define ADD_FIELD(NAME, TYPE) \
3739 : ss_##NAME[k] = gfc_add_field_to_struct (select_struct[k], \
3740 : get_identifier (stringize(NAME)), \
3741 : TYPE, \
3742 : &chain)
3743 :
3744 53 : ADD_FIELD (string1, pchartype);
3745 53 : ADD_FIELD (string1_len, gfc_charlen_type_node);
3746 :
3747 53 : ADD_FIELD (string2, pchartype);
3748 53 : ADD_FIELD (string2_len, gfc_charlen_type_node);
3749 :
3750 53 : ADD_FIELD (target, integer_type_node);
3751 : #undef ADD_FIELD
3752 :
3753 53 : gfc_finish_type (select_struct[k]);
3754 : }
3755 :
3756 : n = 0;
3757 311 : for (d = cp; d; d = d->right)
3758 252 : d->n = n++;
3759 :
3760 263 : for (c = code->block; c; c = c->block)
3761 : {
3762 456 : for (d = c->ext.block.case_list; d; d = d->next)
3763 : {
3764 252 : label = gfc_build_label_decl (NULL_TREE);
3765 452 : tmp = build_case_label ((d->low == NULL && d->high == NULL)
3766 : ? NULL
3767 200 : : build_int_cst (integer_type_node, d->n),
3768 : NULL, label);
3769 252 : gfc_add_expr_to_block (&body, tmp);
3770 : }
3771 :
3772 204 : tmp = gfc_trans_code (c->next);
3773 204 : gfc_add_expr_to_block (&body, tmp);
3774 :
3775 204 : tmp = build1_v (GOTO_EXPR, end_label);
3776 204 : gfc_add_expr_to_block (&body, tmp);
3777 : }
3778 :
3779 : /* Generate the structure describing the branches */
3780 311 : for (d = cp; d; d = d->right)
3781 : {
3782 252 : vec<constructor_elt, va_gc> *node = NULL;
3783 :
3784 252 : gfc_init_se (&se, NULL);
3785 :
3786 252 : if (d->low == NULL)
3787 : {
3788 52 : CONSTRUCTOR_APPEND_ELT (node, ss_string1[k], null_pointer_node);
3789 52 : CONSTRUCTOR_APPEND_ELT (node, ss_string1_len[k], build_zero_cst (gfc_charlen_type_node));
3790 : }
3791 : else
3792 : {
3793 200 : gfc_conv_expr_reference (&se, d->low);
3794 :
3795 200 : CONSTRUCTOR_APPEND_ELT (node, ss_string1[k], se.expr);
3796 200 : CONSTRUCTOR_APPEND_ELT (node, ss_string1_len[k], se.string_length);
3797 : }
3798 :
3799 252 : if (d->high == NULL)
3800 : {
3801 52 : CONSTRUCTOR_APPEND_ELT (node, ss_string2[k], null_pointer_node);
3802 52 : CONSTRUCTOR_APPEND_ELT (node, ss_string2_len[k], build_zero_cst (gfc_charlen_type_node));
3803 : }
3804 : else
3805 : {
3806 200 : gfc_init_se (&se, NULL);
3807 200 : gfc_conv_expr_reference (&se, d->high);
3808 :
3809 200 : CONSTRUCTOR_APPEND_ELT (node, ss_string2[k], se.expr);
3810 200 : CONSTRUCTOR_APPEND_ELT (node, ss_string2_len[k], se.string_length);
3811 : }
3812 :
3813 252 : CONSTRUCTOR_APPEND_ELT (node, ss_target[k],
3814 : build_int_cst (integer_type_node, d->n));
3815 :
3816 252 : tmp = build_constructor (select_struct[k], node);
3817 252 : CONSTRUCTOR_APPEND_ELT (inits, NULL_TREE, tmp);
3818 : }
3819 :
3820 59 : type = build_array_type (select_struct[k],
3821 59 : build_index_type (size_int (n-1)));
3822 :
3823 59 : init = build_constructor (type, inits);
3824 59 : TREE_CONSTANT (init) = 1;
3825 59 : TREE_STATIC (init) = 1;
3826 : /* Create a static variable to hold the jump table. */
3827 59 : tmp = gfc_create_var (type, "jumptable");
3828 59 : TREE_CONSTANT (tmp) = 1;
3829 59 : TREE_STATIC (tmp) = 1;
3830 59 : TREE_READONLY (tmp) = 1;
3831 59 : DECL_INITIAL (tmp) = init;
3832 59 : init = tmp;
3833 :
3834 : /* Build the library call */
3835 59 : init = gfc_build_addr_expr (pvoid_type_node, init);
3836 :
3837 59 : if (code->expr1->ts.kind == 1)
3838 53 : fndecl = gfor_fndecl_select_string;
3839 6 : else if (code->expr1->ts.kind == 4)
3840 6 : fndecl = gfor_fndecl_select_string_char4;
3841 : else
3842 0 : gcc_unreachable ();
3843 :
3844 59 : tmp = build_call_expr_loc (input_location,
3845 : fndecl, 4, init,
3846 59 : build_int_cst (gfc_charlen_type_node, n),
3847 : expr1se.expr, expr1se.string_length);
3848 59 : case_num = gfc_create_var (integer_type_node, "case_num");
3849 59 : gfc_add_modify (&block, case_num, tmp);
3850 :
3851 59 : gfc_add_block_to_block (&block, &expr1se.post);
3852 :
3853 59 : tmp = gfc_finish_block (&body);
3854 59 : tmp = fold_build2_loc (input_location, SWITCH_EXPR, NULL_TREE,
3855 : case_num, tmp);
3856 59 : gfc_add_expr_to_block (&block, tmp);
3857 :
3858 59 : tmp = build1_v (LABEL_EXPR, end_label);
3859 59 : gfc_add_expr_to_block (&block, tmp);
3860 :
3861 59 : return gfc_finish_block (&block);
3862 : }
3863 :
3864 :
3865 : /* Translate the three variants of the SELECT CASE construct.
3866 :
3867 : SELECT CASEs with INTEGER case expressions can be translated to an
3868 : equivalent GENERIC switch statement, and for LOGICAL case
3869 : expressions we build one or two if-else compares.
3870 :
3871 : SELECT CASEs with CHARACTER case expressions are a whole different
3872 : story, because they don't exist in GENERIC. So we sort them and
3873 : do a binary search at runtime.
3874 :
3875 : Fortran has no BREAK statement, and it does not allow jumps from
3876 : one case block to another. That makes things a lot easier for
3877 : the optimizers. */
3878 :
3879 : tree
3880 1096 : gfc_trans_select (gfc_code * code)
3881 : {
3882 1096 : stmtblock_t block;
3883 1096 : tree body;
3884 1096 : tree exit_label;
3885 :
3886 1096 : gcc_assert (code && code->expr1);
3887 1096 : gfc_init_block (&block);
3888 :
3889 : /* Build the exit label and hang it in. */
3890 1096 : exit_label = gfc_build_label_decl (NULL_TREE);
3891 1096 : code->exit_label = exit_label;
3892 :
3893 : /* Empty SELECT constructs are legal. */
3894 1096 : if (code->block == NULL)
3895 2 : body = build_empty_stmt (input_location);
3896 :
3897 : /* Select the correct translation function. */
3898 : else
3899 1094 : switch (code->expr1->ts.type)
3900 : {
3901 54 : case BT_LOGICAL:
3902 54 : body = gfc_trans_logical_select (code);
3903 54 : break;
3904 :
3905 965 : case BT_INTEGER:
3906 965 : case BT_UNSIGNED:
3907 965 : body = gfc_trans_integer_select (code);
3908 965 : break;
3909 :
3910 75 : case BT_CHARACTER:
3911 75 : body = gfc_trans_character_select (code);
3912 75 : break;
3913 :
3914 0 : default:
3915 0 : gfc_internal_error ("gfc_trans_select(): Bad type for case expr.");
3916 : /* Not reached */
3917 : }
3918 :
3919 : /* Build everything together. */
3920 1096 : gfc_add_expr_to_block (&block, body);
3921 1096 : gfc_add_expr_to_block (&block, build1_v (LABEL_EXPR, exit_label));
3922 :
3923 1096 : return gfc_finish_block (&block);
3924 : }
3925 :
3926 : tree
3927 2998 : gfc_trans_select_type (gfc_code * code)
3928 : {
3929 2998 : stmtblock_t block;
3930 2998 : tree body;
3931 2998 : tree exit_label;
3932 :
3933 2998 : gcc_assert (code && code->expr1);
3934 2998 : gfc_init_block (&block);
3935 :
3936 : /* Build the exit label and hang it in. */
3937 2998 : exit_label = gfc_build_label_decl (NULL_TREE);
3938 2998 : code->exit_label = exit_label;
3939 :
3940 : /* Empty SELECT constructs are legal. */
3941 2998 : if (code->block == NULL)
3942 0 : body = build_empty_stmt (input_location);
3943 : else
3944 2998 : body = gfc_trans_select_type_cases (code);
3945 :
3946 : /* Build everything together. */
3947 2998 : gfc_add_expr_to_block (&block, body);
3948 :
3949 2998 : if (TREE_USED (exit_label))
3950 2777 : gfc_add_expr_to_block (&block, build1_v (LABEL_EXPR, exit_label));
3951 :
3952 2998 : return gfc_finish_block (&block);
3953 : }
3954 :
3955 :
3956 : static tree
3957 1018 : gfc_trans_select_rank_cases (gfc_code * code)
3958 : {
3959 1018 : gfc_code *c;
3960 1018 : gfc_case *cp;
3961 1018 : tree tmp;
3962 1018 : tree cond;
3963 1018 : tree low;
3964 1018 : tree rank;
3965 1018 : gfc_se se;
3966 1018 : gfc_se cse;
3967 1018 : stmtblock_t block;
3968 1018 : stmtblock_t body;
3969 1018 : bool def = false;
3970 :
3971 1018 : gfc_start_block (&block);
3972 :
3973 : /* Calculate the switch expression. */
3974 1018 : gfc_init_se (&se, NULL);
3975 1018 : gfc_conv_expr_descriptor (&se, code->expr1);
3976 1018 : rank = fold_convert_loc (input_location, signed_char_type_node,
3977 : gfc_conv_descriptor_rank_get (se.expr));
3978 1018 : rank = gfc_evaluate_now (rank, &block);
3979 1018 : symbol_attribute attr = gfc_expr_attr (code->expr1);
3980 1018 : if (!attr.pointer && !attr.allocatable)
3981 : {
3982 : /* Special case for assumed-rank ('rank(*)', internally -1):
3983 : rank = (rank == 0 || ubound[rank-1] != -1) ? rank : -1. */
3984 784 : cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
3985 784 : rank, build_int_cst (TREE_TYPE (rank), 0));
3986 784 : tmp = fold_build2_loc (input_location, MINUS_EXPR, signed_char_type_node,
3987 : rank, build_one_cst (signed_char_type_node));
3988 784 : tmp = gfc_conv_descriptor_ubound_get (se.expr, tmp);
3989 784 : tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
3990 784 : tmp, build_int_cst (TREE_TYPE (tmp), -1));
3991 784 : cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
3992 : logical_type_node, cond, tmp);
3993 784 : tmp = fold_build3_loc (input_location, COND_EXPR, signed_char_type_node,
3994 : cond, rank,
3995 : build_minus_one_cst (signed_char_type_node));
3996 784 : rank = gfc_evaluate_now (tmp, &block);
3997 : }
3998 1018 : TREE_USED (code->exit_label) = 0;
3999 :
4000 2036 : repeat:
4001 6674 : for (c = code->block; c; c = c->block)
4002 : {
4003 4638 : cp = c->ext.block.case_list;
4004 :
4005 : /* Assume it's the default case. */
4006 4638 : low = NULL_TREE;
4007 4638 : tmp = NULL_TREE;
4008 :
4009 : /* Put the default case at the end. */
4010 4638 : if ((!def && !cp->low) || (def && cp->low))
4011 2319 : continue;
4012 :
4013 2319 : if (cp->low)
4014 : {
4015 1392 : gfc_init_se (&cse, NULL);
4016 1392 : gfc_conv_expr_val (&cse, cp->low);
4017 1392 : gfc_add_block_to_block (&block, &cse.pre);
4018 1392 : low = cse.expr;
4019 : }
4020 :
4021 2319 : gfc_init_block (&body);
4022 :
4023 : /* Add the statements for this case. */
4024 2319 : tmp = gfc_trans_code (c->next);
4025 2319 : gfc_add_expr_to_block (&body, tmp);
4026 :
4027 : /* Break to the end of the SELECT RANK construct. The default
4028 : case just falls through. */
4029 2319 : if (!def)
4030 : {
4031 1392 : TREE_USED (code->exit_label) = 1;
4032 1392 : tmp = build1_v (GOTO_EXPR, code->exit_label);
4033 1392 : gfc_add_expr_to_block (&body, tmp);
4034 : }
4035 :
4036 2319 : tmp = gfc_finish_block (&body);
4037 :
4038 2319 : if (low != NULL_TREE)
4039 : {
4040 2784 : cond = fold_build2_loc (input_location, EQ_EXPR,
4041 1392 : TREE_TYPE (rank), rank,
4042 1392 : fold_convert (TREE_TYPE (rank), low));
4043 1392 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
4044 : cond, tmp,
4045 : build_empty_stmt (input_location));
4046 : }
4047 :
4048 2319 : gfc_add_expr_to_block (&block, tmp);
4049 : }
4050 :
4051 2036 : if (!def)
4052 : {
4053 1018 : def = true;
4054 1018 : goto repeat;
4055 : }
4056 :
4057 1018 : return gfc_finish_block (&block);
4058 : }
4059 :
4060 :
4061 : tree
4062 1019 : gfc_trans_select_rank (gfc_code * code)
4063 : {
4064 1019 : stmtblock_t block;
4065 1019 : tree body;
4066 1019 : tree exit_label;
4067 :
4068 1019 : gcc_assert (code && code->expr1);
4069 1019 : gfc_init_block (&block);
4070 :
4071 : /* Build the exit label and hang it in. */
4072 1019 : exit_label = gfc_build_label_decl (NULL_TREE);
4073 1019 : code->exit_label = exit_label;
4074 :
4075 : /* Empty SELECT constructs are legal. */
4076 1019 : if (code->block == NULL)
4077 1 : body = build_empty_stmt (input_location);
4078 : else
4079 1018 : body = gfc_trans_select_rank_cases (code);
4080 :
4081 : /* Build everything together. */
4082 1019 : gfc_add_expr_to_block (&block, body);
4083 :
4084 1019 : if (TREE_USED (exit_label))
4085 1019 : gfc_add_expr_to_block (&block, build1_v (LABEL_EXPR, exit_label));
4086 :
4087 1019 : return gfc_finish_block (&block);
4088 : }
4089 :
4090 :
4091 : /* Traversal function to substitute a replacement symtree if the symbol
4092 : in the expression is the same as that passed. f == 2 signals that
4093 : that variable itself is not to be checked - only the references.
4094 : This group of functions is used when the variable expression in a
4095 : FORALL assignment has internal references. For example:
4096 : FORALL (i = 1:4) p(p(i)) = i
4097 : The only recourse here is to store a copy of 'p' for the index
4098 : expression. */
4099 :
4100 : static gfc_symtree *new_symtree;
4101 : static gfc_symtree *old_symtree;
4102 :
4103 : static bool
4104 710 : forall_replace (gfc_expr *expr, gfc_symbol *sym, int *f)
4105 : {
4106 710 : if (expr->expr_type != EXPR_VARIABLE)
4107 : return false;
4108 :
4109 406 : if (*f == 2)
4110 62 : *f = 1;
4111 344 : else if (expr->symtree->n.sym == sym)
4112 72 : expr->symtree = new_symtree;
4113 :
4114 : return false;
4115 : }
4116 :
4117 : static void
4118 124 : forall_replace_symtree (gfc_expr *e, gfc_symbol *sym, int f)
4119 : {
4120 0 : gfc_traverse_expr (e, sym, forall_replace, f);
4121 0 : }
4122 :
4123 : static bool
4124 710 : forall_restore (gfc_expr *expr,
4125 : gfc_symbol *sym ATTRIBUTE_UNUSED,
4126 : int *f ATTRIBUTE_UNUSED)
4127 : {
4128 710 : if (expr->expr_type != EXPR_VARIABLE)
4129 : return false;
4130 :
4131 406 : if (expr->symtree == new_symtree)
4132 72 : expr->symtree = old_symtree;
4133 :
4134 : return false;
4135 : }
4136 :
4137 : static void
4138 124 : forall_restore_symtree (gfc_expr *e)
4139 : {
4140 0 : gfc_traverse_expr (e, NULL, forall_restore, 0);
4141 0 : }
4142 :
4143 : static void
4144 62 : forall_make_variable_temp (gfc_code *c, stmtblock_t *pre, stmtblock_t *post)
4145 : {
4146 62 : gfc_se tse;
4147 62 : gfc_se rse;
4148 62 : gfc_expr *e;
4149 62 : gfc_symbol *new_sym;
4150 62 : gfc_symbol *old_sym;
4151 62 : gfc_symtree *root;
4152 62 : tree tmp;
4153 :
4154 : /* Build a copy of the lvalue. */
4155 62 : old_symtree = c->expr1->symtree;
4156 62 : old_sym = old_symtree->n.sym;
4157 62 : e = gfc_lval_expr_from_sym (old_sym);
4158 62 : if (old_sym->attr.dimension)
4159 : {
4160 30 : gfc_init_se (&tse, NULL);
4161 30 : gfc_conv_subref_array_arg (&tse, e, 0, INTENT_IN, false);
4162 30 : gfc_add_block_to_block (pre, &tse.pre);
4163 30 : gfc_add_block_to_block (post, &tse.post);
4164 30 : tse.expr = build_fold_indirect_ref_loc (input_location, tse.expr);
4165 :
4166 30 : if (c->expr1->ref->u.ar.type != AR_SECTION)
4167 : {
4168 : /* Use the variable offset for the temporary. */
4169 24 : tmp = gfc_conv_array_offset (old_sym->backend_decl);
4170 24 : gfc_conv_descriptor_offset_set (pre, tse.expr, tmp);
4171 : }
4172 : }
4173 : else
4174 : {
4175 32 : gfc_init_se (&tse, NULL);
4176 32 : gfc_init_se (&rse, NULL);
4177 32 : gfc_conv_expr (&rse, e);
4178 32 : if (e->ts.type == BT_CHARACTER)
4179 : {
4180 32 : tse.string_length = rse.string_length;
4181 32 : tmp = gfc_get_character_type_len (gfc_default_character_kind,
4182 : tse.string_length);
4183 32 : tse.expr = gfc_conv_string_tmp (&tse, build_pointer_type (tmp),
4184 : rse.string_length);
4185 32 : gfc_add_block_to_block (pre, &tse.pre);
4186 32 : gfc_add_block_to_block (post, &tse.post);
4187 : }
4188 : else
4189 : {
4190 0 : tmp = gfc_typenode_for_spec (&e->ts);
4191 0 : tse.expr = gfc_create_var (tmp, "temp");
4192 : }
4193 :
4194 64 : tmp = gfc_trans_scalar_assign (&tse, &rse, e->ts,
4195 32 : e->expr_type == EXPR_VARIABLE, false);
4196 32 : gfc_add_expr_to_block (pre, tmp);
4197 : }
4198 62 : gfc_free_expr (e);
4199 :
4200 : /* Create a new symbol to represent the lvalue. */
4201 62 : new_sym = gfc_new_symbol (old_sym->name, NULL);
4202 62 : new_sym->ts = old_sym->ts;
4203 62 : new_sym->attr.referenced = 1;
4204 62 : new_sym->attr.temporary = 1;
4205 62 : new_sym->attr.dimension = old_sym->attr.dimension;
4206 62 : new_sym->attr.flavor = old_sym->attr.flavor;
4207 :
4208 : /* Use the temporary as the backend_decl. */
4209 62 : new_sym->backend_decl = tse.expr;
4210 :
4211 : /* Create a fake symtree for it. */
4212 62 : root = NULL;
4213 62 : new_symtree = gfc_new_symtree (&root, old_sym->name);
4214 62 : new_symtree->n.sym = new_sym;
4215 62 : gcc_assert (new_symtree == root);
4216 :
4217 : /* Go through the expression reference replacing the old_symtree
4218 : with the new. */
4219 62 : forall_replace_symtree (c->expr1, old_sym, 2);
4220 :
4221 : /* Now we have made this temporary, we might as well use it for
4222 : the right hand side. */
4223 62 : forall_replace_symtree (c->expr2, old_sym, 1);
4224 62 : }
4225 :
4226 :
4227 : /* Handles dependencies in forall assignments. */
4228 : static int
4229 1826 : check_forall_dependencies (gfc_code *c, stmtblock_t *pre, stmtblock_t *post)
4230 : {
4231 1826 : gfc_ref *lref;
4232 1826 : gfc_ref *rref;
4233 1826 : int need_temp;
4234 1826 : gfc_symbol *lsym;
4235 :
4236 1826 : lsym = c->expr1->symtree->n.sym;
4237 1826 : need_temp = gfc_check_dependency (c->expr1, c->expr2, 0);
4238 :
4239 : /* Now check for dependencies within the 'variable'
4240 : expression itself. These are treated by making a complete
4241 : copy of variable and changing all the references to it
4242 : point to the copy instead. Note that the shallow copy of
4243 : the variable will not suffice for derived types with
4244 : pointer components. We therefore leave these to their
4245 : own devices. Likewise for allocatable components. */
4246 1826 : if (lsym->ts.type == BT_DERIVED
4247 149 : && (lsym->ts.u.derived->attr.pointer_comp
4248 139 : || lsym->ts.u.derived->attr.alloc_comp))
4249 : return need_temp;
4250 :
4251 1731 : new_symtree = NULL;
4252 1731 : if (find_forall_index (c->expr1, lsym, 2))
4253 : {
4254 12 : forall_make_variable_temp (c, pre, post);
4255 12 : need_temp = 0;
4256 : }
4257 :
4258 : /* Substrings with dependencies are treated in the same
4259 : way. */
4260 1731 : if (c->expr1->ts.type == BT_CHARACTER
4261 685 : && c->expr1->ref
4262 685 : && c->expr2->expr_type == EXPR_VARIABLE
4263 492 : && lsym == c->expr2->symtree->n.sym)
4264 : {
4265 124 : for (lref = c->expr1->ref; lref; lref = lref->next)
4266 117 : if (lref->type == REF_SUBSTRING)
4267 : break;
4268 124 : for (rref = c->expr2->ref; rref; rref = rref->next)
4269 117 : if (rref->type == REF_SUBSTRING)
4270 : break;
4271 :
4272 81 : if (rref && lref
4273 81 : && gfc_dep_compare_expr (rref->u.ss.start, lref->u.ss.start) < 0)
4274 : {
4275 50 : forall_make_variable_temp (c, pre, post);
4276 50 : need_temp = 0;
4277 : }
4278 : }
4279 : return need_temp;
4280 : }
4281 :
4282 :
4283 : static void
4284 62 : cleanup_forall_symtrees (gfc_code *c)
4285 : {
4286 62 : forall_restore_symtree (c->expr1);
4287 62 : forall_restore_symtree (c->expr2);
4288 62 : free (new_symtree->n.sym);
4289 62 : free (new_symtree);
4290 62 : }
4291 :
4292 :
4293 : /* Generate the loops for a FORALL block, specified by FORALL_TMP. BODY
4294 : is the contents of the FORALL block/stmt to be iterated. MASK_FLAG
4295 : indicates whether we should generate code to test the FORALLs mask
4296 : array. OUTER is the loop header to be used for initializing mask
4297 : indices.
4298 :
4299 : The generated loop format is:
4300 : count = (end - start + step) / step
4301 : loopvar = start
4302 : while (1)
4303 : {
4304 : if (count <=0 )
4305 : goto end_of_loop
4306 : <body>
4307 : loopvar += step
4308 : count --
4309 : }
4310 : end_of_loop: */
4311 :
4312 : static tree
4313 3545 : gfc_trans_forall_loop (forall_info *forall_tmp, tree body,
4314 : int mask_flag, stmtblock_t *outer)
4315 : {
4316 3545 : int n, nvar;
4317 3545 : tree tmp;
4318 3545 : tree cond;
4319 3545 : stmtblock_t block;
4320 3545 : tree exit_label;
4321 3545 : tree count;
4322 3545 : tree var, start, end, step;
4323 3545 : iter_info *iter;
4324 :
4325 : /* Initialize the mask index outside the FORALL nest. */
4326 3545 : if (mask_flag && forall_tmp->mask)
4327 1071 : gfc_add_modify (outer, forall_tmp->maskindex, gfc_index_zero_node);
4328 :
4329 3545 : iter = forall_tmp->this_loop;
4330 3545 : nvar = forall_tmp->nvar;
4331 9769 : for (n = 0; n < nvar; n++)
4332 : {
4333 6224 : var = iter->var;
4334 6224 : start = iter->start;
4335 6224 : end = iter->end;
4336 6224 : step = iter->step;
4337 :
4338 6224 : exit_label = gfc_build_label_decl (NULL_TREE);
4339 6224 : TREE_USED (exit_label) = 1;
4340 :
4341 : /* The loop counter. */
4342 6224 : count = gfc_create_var (TREE_TYPE (var), "count");
4343 :
4344 : /* The body of the loop. */
4345 6224 : gfc_init_block (&block);
4346 :
4347 : /* The exit condition. */
4348 6224 : cond = fold_build2_loc (input_location, LE_EXPR, logical_type_node,
4349 6224 : count, build_int_cst (TREE_TYPE (count), 0));
4350 :
4351 : /* PR 83064 means that we cannot use annot_expr_parallel_kind until
4352 : the autoparallelizer can handle this. */
4353 6224 : if (forall_tmp->do_concurrent || iter->annot.ivdep)
4354 177 : cond = build3 (ANNOTATE_EXPR, TREE_TYPE (cond), cond,
4355 : build_int_cst (integer_type_node,
4356 : annot_expr_ivdep_kind),
4357 : integer_zero_node);
4358 :
4359 6224 : if (iter->annot.unroll && cond != error_mark_node)
4360 1 : cond = build3 (ANNOTATE_EXPR, TREE_TYPE (cond), cond,
4361 : build_int_cst (integer_type_node,
4362 : annot_expr_unroll_kind),
4363 1 : build_int_cst (integer_type_node, iter->annot.unroll));
4364 :
4365 6224 : if (iter->annot.vector && cond != error_mark_node)
4366 1 : cond = build3 (ANNOTATE_EXPR, TREE_TYPE (cond), cond,
4367 : build_int_cst (integer_type_node,
4368 : annot_expr_vector_kind),
4369 : integer_zero_node);
4370 :
4371 6224 : if (iter->annot.novector && cond != error_mark_node)
4372 2 : cond = build3 (ANNOTATE_EXPR, TREE_TYPE (cond), cond,
4373 : build_int_cst (integer_type_node,
4374 : annot_expr_no_vector_kind),
4375 : integer_zero_node);
4376 :
4377 6224 : tmp = build1_v (GOTO_EXPR, exit_label);
4378 6224 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
4379 : cond, tmp, build_empty_stmt (input_location));
4380 6224 : gfc_add_expr_to_block (&block, tmp);
4381 :
4382 : /* The main loop body. */
4383 6224 : gfc_add_expr_to_block (&block, body);
4384 :
4385 : /* Increment the loop variable. */
4386 6224 : tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (var), var,
4387 : step);
4388 6224 : gfc_add_modify (&block, var, tmp);
4389 :
4390 : /* Advance to the next mask element. Only do this for the
4391 : innermost loop. */
4392 6224 : if (n == 0 && mask_flag && forall_tmp->mask)
4393 : {
4394 1071 : tree maskindex = forall_tmp->maskindex;
4395 1071 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
4396 : maskindex, gfc_index_one_node);
4397 1071 : gfc_add_modify (&block, maskindex, tmp);
4398 : }
4399 :
4400 : /* Decrement the loop counter. */
4401 6224 : tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (var), count,
4402 6224 : build_int_cst (TREE_TYPE (var), 1));
4403 6224 : gfc_add_modify (&block, count, tmp);
4404 :
4405 6224 : body = gfc_finish_block (&block);
4406 :
4407 : /* Loop var initialization. */
4408 6224 : gfc_init_block (&block);
4409 6224 : gfc_add_modify (&block, var, start);
4410 :
4411 :
4412 : /* Initialize the loop counter. */
4413 6224 : tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (var), step,
4414 : start);
4415 6224 : tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (var), end,
4416 : tmp);
4417 6224 : tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR, TREE_TYPE (var),
4418 : tmp, step);
4419 6224 : gfc_add_modify (&block, count, tmp);
4420 :
4421 : /* The loop expression. */
4422 6224 : tmp = build1_v (LOOP_EXPR, body);
4423 6224 : gfc_add_expr_to_block (&block, tmp);
4424 :
4425 : /* The exit label. */
4426 6224 : tmp = build1_v (LABEL_EXPR, exit_label);
4427 6224 : gfc_add_expr_to_block (&block, tmp);
4428 :
4429 6224 : body = gfc_finish_block (&block);
4430 6224 : iter = iter->next;
4431 : }
4432 3545 : return body;
4433 : }
4434 :
4435 :
4436 : /* Generate the body and loops according to MASK_FLAG. If MASK_FLAG
4437 : is nonzero, the body is controlled by all masks in the forall nest.
4438 : Otherwise, the innermost loop is not controlled by it's mask. This
4439 : is used for initializing that mask. */
4440 :
4441 : static tree
4442 3345 : gfc_trans_nested_forall_loop (forall_info * nested_forall_info, tree body,
4443 : int mask_flag)
4444 : {
4445 3345 : tree tmp;
4446 3345 : stmtblock_t header;
4447 3345 : forall_info *forall_tmp;
4448 3345 : tree mask, maskindex;
4449 :
4450 3345 : gfc_start_block (&header);
4451 :
4452 3345 : forall_tmp = nested_forall_info;
4453 10235 : while (forall_tmp != NULL)
4454 : {
4455 : /* Generate body with masks' control. */
4456 3545 : if (mask_flag)
4457 : {
4458 2820 : mask = forall_tmp->mask;
4459 2820 : maskindex = forall_tmp->maskindex;
4460 :
4461 : /* If a mask was specified make the assignment conditional. */
4462 2820 : if (mask)
4463 : {
4464 1071 : tmp = gfc_build_array_ref (mask, maskindex, NULL);
4465 1071 : body = build3_v (COND_EXPR, tmp, body,
4466 : build_empty_stmt (input_location));
4467 : }
4468 : }
4469 3545 : body = gfc_trans_forall_loop (forall_tmp, body, mask_flag, &header);
4470 3545 : forall_tmp = forall_tmp->prev_nest;
4471 3545 : mask_flag = 1;
4472 : }
4473 :
4474 3345 : gfc_add_expr_to_block (&header, body);
4475 3345 : return gfc_finish_block (&header);
4476 : }
4477 :
4478 :
4479 : /* Allocate data for holding a temporary array. Returns either a local
4480 : temporary array or a pointer variable. */
4481 :
4482 : static tree
4483 1384 : gfc_do_allocate (tree bytesize, tree size, tree * pdata, stmtblock_t * pblock,
4484 : tree elem_type)
4485 : {
4486 1384 : tree tmpvar;
4487 1384 : tree type;
4488 1384 : tree tmp;
4489 :
4490 1384 : if (INTEGER_CST_P (size))
4491 1140 : tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
4492 : size, gfc_index_one_node);
4493 : else
4494 : tmp = NULL_TREE;
4495 :
4496 1384 : type = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp);
4497 1384 : type = build_array_type (elem_type, type);
4498 1384 : if (gfc_can_put_var_on_stack (bytesize) && INTEGER_CST_P (size))
4499 : {
4500 1140 : tmpvar = gfc_create_var (type, "temp");
4501 1140 : *pdata = NULL_TREE;
4502 : }
4503 : else
4504 : {
4505 244 : tmpvar = gfc_create_var (build_pointer_type (type), "temp");
4506 244 : *pdata = convert (pvoid_type_node, tmpvar);
4507 :
4508 244 : tmp = gfc_call_malloc (pblock, TREE_TYPE (tmpvar), bytesize);
4509 244 : gfc_add_modify (pblock, tmpvar, tmp);
4510 : }
4511 1384 : return tmpvar;
4512 : }
4513 :
4514 :
4515 : /* Generate codes to copy the temporary to the actual lhs. */
4516 :
4517 : static tree
4518 224 : generate_loop_for_temp_to_lhs (gfc_expr *expr, tree tmp1, tree count3,
4519 : tree count1,
4520 : gfc_ss *lss, gfc_ss *rss,
4521 : tree wheremask, bool invert)
4522 : {
4523 224 : stmtblock_t block, body1;
4524 224 : gfc_loopinfo loop;
4525 224 : gfc_se lse;
4526 224 : gfc_se rse;
4527 224 : tree tmp;
4528 224 : tree wheremaskexpr;
4529 :
4530 224 : (void) rss; /* TODO: unused. */
4531 :
4532 224 : gfc_start_block (&block);
4533 :
4534 224 : gfc_init_se (&rse, NULL);
4535 224 : gfc_init_se (&lse, NULL);
4536 :
4537 224 : if (lss == gfc_ss_terminator)
4538 : {
4539 149 : gfc_init_block (&body1);
4540 149 : gfc_conv_expr (&lse, expr);
4541 149 : rse.expr = gfc_build_array_ref (tmp1, count1, NULL);
4542 : }
4543 : else
4544 : {
4545 : /* Initialize the loop. */
4546 75 : gfc_init_loopinfo (&loop);
4547 :
4548 : /* We may need LSS to determine the shape of the expression. */
4549 75 : gfc_add_ss_to_loop (&loop, lss);
4550 :
4551 75 : gfc_conv_ss_startstride (&loop);
4552 75 : gfc_conv_loop_setup (&loop, &expr->where);
4553 :
4554 75 : gfc_mark_ss_chain_used (lss, 1);
4555 : /* Start the loop body. */
4556 75 : gfc_start_scalarized_body (&loop, &body1);
4557 :
4558 : /* Translate the expression. */
4559 75 : gfc_copy_loopinfo_to_se (&lse, &loop);
4560 75 : lse.ss = lss;
4561 75 : gfc_conv_expr (&lse, expr);
4562 :
4563 : /* Form the expression of the temporary. */
4564 75 : rse.expr = gfc_build_array_ref (tmp1, count1, NULL);
4565 : }
4566 :
4567 : /* Use the scalar assignment. */
4568 224 : rse.string_length = lse.string_length;
4569 448 : tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts,
4570 224 : expr->expr_type == EXPR_VARIABLE, false);
4571 :
4572 : /* Form the mask expression according to the mask tree list. */
4573 224 : if (wheremask)
4574 : {
4575 27 : wheremaskexpr = gfc_build_array_ref (wheremask, count3, NULL);
4576 27 : if (invert)
4577 0 : wheremaskexpr = fold_build1_loc (input_location, TRUTH_NOT_EXPR,
4578 0 : TREE_TYPE (wheremaskexpr),
4579 : wheremaskexpr);
4580 27 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
4581 : wheremaskexpr, tmp,
4582 : build_empty_stmt (input_location));
4583 : }
4584 :
4585 224 : gfc_add_expr_to_block (&body1, tmp);
4586 :
4587 224 : tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (count1),
4588 : count1, gfc_index_one_node);
4589 224 : gfc_add_modify (&body1, count1, tmp);
4590 :
4591 224 : if (lss == gfc_ss_terminator)
4592 149 : gfc_add_block_to_block (&block, &body1);
4593 : else
4594 : {
4595 : /* Increment count3. */
4596 75 : if (count3)
4597 : {
4598 27 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
4599 : gfc_array_index_type,
4600 : count3, gfc_index_one_node);
4601 27 : gfc_add_modify (&body1, count3, tmp);
4602 : }
4603 :
4604 : /* Generate the copying loops. */
4605 75 : gfc_trans_scalarizing_loops (&loop, &body1);
4606 :
4607 75 : gfc_add_block_to_block (&block, &loop.pre);
4608 75 : gfc_add_block_to_block (&block, &loop.post);
4609 :
4610 75 : gfc_cleanup_loop (&loop);
4611 : /* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful
4612 : as tree nodes in SS may not be valid in different scope. */
4613 : }
4614 :
4615 224 : tmp = gfc_finish_block (&block);
4616 224 : return tmp;
4617 : }
4618 :
4619 :
4620 : /* Generate codes to copy rhs to the temporary. TMP1 is the address of
4621 : temporary, LSS and RSS are formed in function compute_inner_temp_size(),
4622 : and should not be freed. WHEREMASK is the conditional execution mask
4623 : whose sense may be inverted by INVERT. */
4624 :
4625 : static tree
4626 224 : generate_loop_for_rhs_to_temp (gfc_expr *expr2, tree tmp1, tree count3,
4627 : tree count1, gfc_ss *lss, gfc_ss *rss,
4628 : tree wheremask, bool invert)
4629 : {
4630 224 : stmtblock_t block, body1;
4631 224 : gfc_loopinfo loop;
4632 224 : gfc_se lse;
4633 224 : gfc_se rse;
4634 224 : tree tmp;
4635 224 : tree wheremaskexpr;
4636 :
4637 224 : gfc_start_block (&block);
4638 :
4639 224 : gfc_init_se (&rse, NULL);
4640 224 : gfc_init_se (&lse, NULL);
4641 :
4642 224 : if (lss == gfc_ss_terminator)
4643 : {
4644 149 : gfc_init_block (&body1);
4645 149 : gfc_conv_expr (&rse, expr2);
4646 149 : lse.expr = gfc_build_array_ref (tmp1, count1, NULL);
4647 : }
4648 : else
4649 : {
4650 : /* Initialize the loop. */
4651 75 : gfc_init_loopinfo (&loop);
4652 :
4653 : /* We may need LSS to determine the shape of the expression. */
4654 75 : gfc_add_ss_to_loop (&loop, lss);
4655 75 : gfc_add_ss_to_loop (&loop, rss);
4656 :
4657 75 : gfc_conv_ss_startstride (&loop);
4658 75 : gfc_conv_loop_setup (&loop, &expr2->where);
4659 :
4660 75 : gfc_mark_ss_chain_used (rss, 1);
4661 : /* Start the loop body. */
4662 75 : gfc_start_scalarized_body (&loop, &body1);
4663 :
4664 : /* Translate the expression. */
4665 75 : gfc_copy_loopinfo_to_se (&rse, &loop);
4666 75 : rse.ss = rss;
4667 75 : gfc_conv_expr (&rse, expr2);
4668 :
4669 : /* Form the expression of the temporary. */
4670 75 : lse.expr = gfc_build_array_ref (tmp1, count1, NULL);
4671 : }
4672 :
4673 : /* Use the scalar assignment. */
4674 224 : lse.string_length = rse.string_length;
4675 448 : tmp = gfc_trans_scalar_assign (&lse, &rse, expr2->ts,
4676 224 : expr2->expr_type == EXPR_VARIABLE, false);
4677 :
4678 : /* Form the mask expression according to the mask tree list. */
4679 224 : if (wheremask)
4680 : {
4681 27 : wheremaskexpr = gfc_build_array_ref (wheremask, count3, NULL);
4682 27 : if (invert)
4683 0 : wheremaskexpr = fold_build1_loc (input_location, TRUTH_NOT_EXPR,
4684 0 : TREE_TYPE (wheremaskexpr),
4685 : wheremaskexpr);
4686 27 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
4687 : wheremaskexpr, tmp,
4688 : build_empty_stmt (input_location));
4689 : }
4690 :
4691 224 : gfc_add_expr_to_block (&body1, tmp);
4692 :
4693 224 : if (lss == gfc_ss_terminator)
4694 : {
4695 149 : gfc_add_block_to_block (&block, &body1);
4696 :
4697 : /* Increment count1. */
4698 149 : tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (count1),
4699 : count1, gfc_index_one_node);
4700 149 : gfc_add_modify (&block, count1, tmp);
4701 : }
4702 : else
4703 : {
4704 : /* Increment count1. */
4705 75 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
4706 : count1, gfc_index_one_node);
4707 75 : gfc_add_modify (&body1, count1, tmp);
4708 :
4709 : /* Increment count3. */
4710 75 : if (count3)
4711 : {
4712 27 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
4713 : gfc_array_index_type,
4714 : count3, gfc_index_one_node);
4715 27 : gfc_add_modify (&body1, count3, tmp);
4716 : }
4717 :
4718 : /* Generate the copying loops. */
4719 75 : gfc_trans_scalarizing_loops (&loop, &body1);
4720 :
4721 75 : gfc_add_block_to_block (&block, &loop.pre);
4722 75 : gfc_add_block_to_block (&block, &loop.post);
4723 :
4724 75 : gfc_cleanup_loop (&loop);
4725 : /* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful
4726 : as tree nodes in SS may not be valid in different scope. */
4727 : }
4728 :
4729 224 : tmp = gfc_finish_block (&block);
4730 224 : return tmp;
4731 : }
4732 :
4733 :
4734 : /* Calculate the size of temporary needed in the assignment inside forall.
4735 : LSS and RSS are filled in this function. */
4736 :
4737 : static tree
4738 780 : compute_inner_temp_size (gfc_expr *expr1, gfc_expr *expr2,
4739 : stmtblock_t * pblock,
4740 : gfc_ss **lss, gfc_ss **rss)
4741 : {
4742 780 : gfc_loopinfo loop;
4743 780 : tree size;
4744 780 : int i;
4745 780 : int save_flag;
4746 780 : tree tmp;
4747 :
4748 780 : *lss = gfc_walk_expr (expr1);
4749 780 : *rss = NULL;
4750 :
4751 780 : size = gfc_index_one_node;
4752 780 : if (*lss != gfc_ss_terminator)
4753 : {
4754 482 : gfc_init_loopinfo (&loop);
4755 :
4756 : /* Walk the RHS of the expression. */
4757 482 : *rss = gfc_walk_expr (expr2);
4758 482 : if (*rss == gfc_ss_terminator)
4759 : /* The rhs is scalar. Add a ss for the expression. */
4760 0 : *rss = gfc_get_scalar_ss (gfc_ss_terminator, expr2);
4761 :
4762 : /* Associate the SS with the loop. */
4763 482 : gfc_add_ss_to_loop (&loop, *lss);
4764 : /* We don't actually need to add the rhs at this point, but it might
4765 : make guessing the loop bounds a bit easier. */
4766 482 : gfc_add_ss_to_loop (&loop, *rss);
4767 :
4768 : /* We only want the shape of the expression, not rest of the junk
4769 : generated by the scalarizer. */
4770 482 : loop.array_parameter = 1;
4771 :
4772 : /* Calculate the bounds of the scalarization. */
4773 482 : save_flag = gfc_option.rtcheck;
4774 482 : gfc_option.rtcheck &= ~GFC_RTCHECK_BOUNDS;
4775 482 : gfc_conv_ss_startstride (&loop);
4776 482 : gfc_option.rtcheck = save_flag;
4777 482 : gfc_conv_loop_setup (&loop, &expr2->where);
4778 :
4779 : /* Figure out how many elements we need. */
4780 1477 : for (i = 0; i < loop.dimen; i++)
4781 : {
4782 513 : tmp = fold_build2_loc (input_location, MINUS_EXPR,
4783 : gfc_array_index_type,
4784 : gfc_index_one_node, loop.from[i]);
4785 513 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
4786 : gfc_array_index_type, tmp, loop.to[i]);
4787 513 : size = fold_build2_loc (input_location, MULT_EXPR,
4788 : gfc_array_index_type, size, tmp);
4789 : }
4790 482 : gfc_add_block_to_block (pblock, &loop.pre);
4791 482 : size = gfc_evaluate_now (size, pblock);
4792 482 : gfc_add_block_to_block (pblock, &loop.post);
4793 :
4794 : /* TODO: write a function that cleans up a loopinfo without freeing
4795 : the SS chains. Currently a NOP. */
4796 : }
4797 :
4798 780 : return size;
4799 : }
4800 :
4801 :
4802 : /* Calculate the overall iterator number of the nested forall construct.
4803 : This routine actually calculates the number of times the body of the
4804 : nested forall specified by NESTED_FORALL_INFO is executed and multiplies
4805 : that by the expression INNER_SIZE. The BLOCK argument specifies the
4806 : block in which to calculate the result, and the optional INNER_SIZE_BODY
4807 : argument contains any statements that need to executed (inside the loop)
4808 : to initialize or calculate INNER_SIZE. */
4809 :
4810 : static tree
4811 1301 : compute_overall_iter_number (forall_info *nested_forall_info, tree inner_size,
4812 : stmtblock_t *inner_size_body, stmtblock_t *block)
4813 : {
4814 1301 : forall_info *forall_tmp = nested_forall_info;
4815 1301 : tree tmp, number;
4816 1301 : stmtblock_t body;
4817 :
4818 : /* We can eliminate the innermost unconditional loops with constant
4819 : array bounds. */
4820 1301 : if (INTEGER_CST_P (inner_size))
4821 : {
4822 : while (forall_tmp
4823 268 : && !forall_tmp->mask
4824 1508 : && INTEGER_CST_P (forall_tmp->size))
4825 : {
4826 117 : inner_size = fold_build2_loc (input_location, MULT_EXPR,
4827 : gfc_array_index_type,
4828 : inner_size, forall_tmp->size);
4829 117 : forall_tmp = forall_tmp->prev_nest;
4830 : }
4831 :
4832 : /* If there are no loops left, we have our constant result. */
4833 1209 : if (!forall_tmp)
4834 : return inner_size;
4835 : }
4836 :
4837 : /* Otherwise, create a temporary variable to compute the result. */
4838 243 : number = gfc_create_var (gfc_array_index_type, "num");
4839 243 : gfc_add_modify (block, number, gfc_index_zero_node);
4840 :
4841 243 : gfc_start_block (&body);
4842 243 : if (inner_size_body)
4843 189 : gfc_add_block_to_block (&body, inner_size_body);
4844 243 : if (forall_tmp)
4845 226 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
4846 : gfc_array_index_type, number, inner_size);
4847 : else
4848 : tmp = inner_size;
4849 243 : gfc_add_modify (&body, number, tmp);
4850 243 : tmp = gfc_finish_block (&body);
4851 :
4852 : /* Generate loops. */
4853 243 : if (forall_tmp != NULL)
4854 226 : tmp = gfc_trans_nested_forall_loop (forall_tmp, tmp, 1);
4855 :
4856 243 : gfc_add_expr_to_block (block, tmp);
4857 :
4858 243 : return number;
4859 : }
4860 :
4861 :
4862 : /* Allocate temporary for forall construct. SIZE is the size of temporary
4863 : needed. PTEMP1 is returned for space free. */
4864 :
4865 : static tree
4866 1384 : allocate_temp_for_forall_nest_1 (tree type, tree size, stmtblock_t * block,
4867 : tree * ptemp1)
4868 : {
4869 1384 : tree bytesize;
4870 1384 : tree unit;
4871 1384 : tree tmp;
4872 :
4873 1384 : unit = fold_convert (gfc_array_index_type, TYPE_SIZE_UNIT (type));
4874 1384 : if (!integer_onep (unit))
4875 166 : bytesize = fold_build2_loc (input_location, MULT_EXPR,
4876 : gfc_array_index_type, size, unit);
4877 : else
4878 : bytesize = size;
4879 :
4880 1384 : *ptemp1 = NULL;
4881 1384 : tmp = gfc_do_allocate (bytesize, size, ptemp1, block, type);
4882 :
4883 1384 : if (*ptemp1)
4884 244 : tmp = build_fold_indirect_ref_loc (input_location, tmp);
4885 1384 : return tmp;
4886 : }
4887 :
4888 :
4889 : /* Allocate temporary for forall construct according to the information in
4890 : nested_forall_info. INNER_SIZE is the size of temporary needed in the
4891 : assignment inside forall. PTEMP1 is returned for space free. */
4892 :
4893 : static tree
4894 969 : allocate_temp_for_forall_nest (forall_info * nested_forall_info, tree type,
4895 : tree inner_size, stmtblock_t * inner_size_body,
4896 : stmtblock_t * block, tree * ptemp1)
4897 : {
4898 969 : tree size;
4899 :
4900 : /* Calculate the total size of temporary needed in forall construct. */
4901 969 : size = compute_overall_iter_number (nested_forall_info, inner_size,
4902 : inner_size_body, block);
4903 :
4904 969 : return allocate_temp_for_forall_nest_1 (type, size, block, ptemp1);
4905 : }
4906 :
4907 :
4908 : /* Handle assignments inside forall which need temporary.
4909 :
4910 : forall (i=start:end:stride; maskexpr)
4911 : e<i> = f<i>
4912 : end forall
4913 : (where e,f<i> are arbitrary expressions possibly involving i
4914 : and there is a dependency between e<i> and f<i>)
4915 : Translates to:
4916 : masktmp(:) = maskexpr(:)
4917 :
4918 : maskindex = 0;
4919 : count1 = 0;
4920 : num = 0;
4921 : for (i = start; i <= end; i += stride)
4922 : num += SIZE (f<i>)
4923 : count1 = 0;
4924 : ALLOCATE (tmp(num))
4925 : for (i = start; i <= end; i += stride)
4926 : {
4927 : if (masktmp[maskindex++])
4928 : tmp[count1++] = f<i>
4929 : }
4930 : maskindex = 0;
4931 : count1 = 0;
4932 : for (i = start; i <= end; i += stride)
4933 : {
4934 : if (masktmp[maskindex++])
4935 : e<i> = tmp[count1++]
4936 : }
4937 : DEALLOCATE (tmp)
4938 : */
4939 : static void
4940 224 : gfc_trans_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2,
4941 : tree wheremask, bool invert,
4942 : forall_info * nested_forall_info,
4943 : stmtblock_t * block)
4944 : {
4945 224 : tree type;
4946 224 : tree inner_size;
4947 224 : gfc_ss *lss, *rss;
4948 224 : tree count, count1;
4949 224 : tree tmp, tmp1;
4950 224 : tree ptemp1;
4951 224 : stmtblock_t inner_size_body;
4952 :
4953 : /* Create vars. count1 is the current iterator number of the nested
4954 : forall. */
4955 224 : count1 = gfc_create_var (gfc_array_index_type, "count1");
4956 :
4957 : /* Count is the wheremask index. */
4958 224 : if (wheremask)
4959 : {
4960 27 : count = gfc_create_var (gfc_array_index_type, "count");
4961 27 : gfc_add_modify (block, count, gfc_index_zero_node);
4962 : }
4963 : else
4964 : count = NULL;
4965 :
4966 : /* Initialize count1. */
4967 224 : gfc_add_modify (block, count1, gfc_index_zero_node);
4968 :
4969 : /* Calculate the size of temporary needed in the assignment. Return loop, lss
4970 : and rss which are used in function generate_loop_for_rhs_to_temp(). */
4971 : /* The type of LHS. Used in function allocate_temp_for_forall_nest */
4972 224 : if (expr1->ts.type == BT_CHARACTER)
4973 : {
4974 103 : type = NULL;
4975 103 : if (expr1->ref && expr1->ref->type == REF_SUBSTRING)
4976 : {
4977 72 : gfc_se ssse;
4978 72 : gfc_init_se (&ssse, NULL);
4979 72 : gfc_conv_expr (&ssse, expr1);
4980 72 : type = gfc_get_character_type_len (gfc_default_character_kind,
4981 : ssse.string_length);
4982 72 : }
4983 : else
4984 : {
4985 31 : if (!expr1->ts.u.cl->backend_decl)
4986 : {
4987 6 : gfc_se tse;
4988 6 : gcc_assert (expr1->ts.u.cl->length);
4989 6 : gfc_init_se (&tse, NULL);
4990 6 : gfc_conv_expr (&tse, expr1->ts.u.cl->length);
4991 6 : expr1->ts.u.cl->backend_decl = tse.expr;
4992 : }
4993 31 : type = gfc_get_character_type_len (gfc_default_character_kind,
4994 31 : expr1->ts.u.cl->backend_decl);
4995 : }
4996 : }
4997 : else
4998 121 : type = gfc_typenode_for_spec (&expr1->ts);
4999 :
5000 224 : gfc_init_block (&inner_size_body);
5001 224 : inner_size = compute_inner_temp_size (expr1, expr2, &inner_size_body,
5002 : &lss, &rss);
5003 :
5004 : /* Allocate temporary for nested forall construct according to the
5005 : information in nested_forall_info and inner_size. */
5006 224 : tmp1 = allocate_temp_for_forall_nest (nested_forall_info, type, inner_size,
5007 : &inner_size_body, block, &ptemp1);
5008 :
5009 : /* Generate codes to copy rhs to the temporary . */
5010 224 : tmp = generate_loop_for_rhs_to_temp (expr2, tmp1, count, count1, lss, rss,
5011 : wheremask, invert);
5012 :
5013 : /* Generate body and loops according to the information in
5014 : nested_forall_info. */
5015 224 : tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
5016 224 : gfc_add_expr_to_block (block, tmp);
5017 :
5018 : /* Reset count1. */
5019 224 : gfc_add_modify (block, count1, gfc_index_zero_node);
5020 :
5021 : /* Reset count. */
5022 224 : if (wheremask)
5023 27 : gfc_add_modify (block, count, gfc_index_zero_node);
5024 :
5025 : /* TODO: Second call to compute_inner_temp_size to initialize lss and
5026 : rss; there must be a better way. */
5027 224 : inner_size = compute_inner_temp_size (expr1, expr2, &inner_size_body,
5028 : &lss, &rss);
5029 :
5030 : /* Generate codes to copy the temporary to lhs. */
5031 224 : tmp = generate_loop_for_temp_to_lhs (expr1, tmp1, count, count1,
5032 : lss, rss,
5033 : wheremask, invert);
5034 :
5035 : /* Generate body and loops according to the information in
5036 : nested_forall_info. */
5037 224 : tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
5038 224 : gfc_add_expr_to_block (block, tmp);
5039 :
5040 224 : if (ptemp1)
5041 : {
5042 : /* Free the temporary. */
5043 145 : tmp = gfc_call_free (ptemp1);
5044 145 : gfc_add_expr_to_block (block, tmp);
5045 : }
5046 224 : }
5047 :
5048 :
5049 : /* Translate pointer assignment inside FORALL which need temporary. */
5050 :
5051 : static void
5052 20 : gfc_trans_pointer_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2,
5053 : forall_info * nested_forall_info,
5054 : stmtblock_t * block)
5055 : {
5056 20 : tree type;
5057 20 : tree inner_size;
5058 20 : gfc_ss *lss, *rss;
5059 20 : gfc_se lse;
5060 20 : gfc_se rse;
5061 20 : gfc_array_info *info;
5062 20 : gfc_loopinfo loop;
5063 20 : tree desc;
5064 20 : tree parm;
5065 20 : tree parmtype;
5066 20 : stmtblock_t body;
5067 20 : tree count;
5068 20 : tree tmp, tmp1, ptemp1;
5069 :
5070 20 : count = gfc_create_var (gfc_array_index_type, "count");
5071 20 : gfc_add_modify (block, count, gfc_index_zero_node);
5072 :
5073 20 : inner_size = gfc_index_one_node;
5074 20 : lss = gfc_walk_expr (expr1);
5075 20 : rss = gfc_walk_expr (expr2);
5076 20 : if (lss == gfc_ss_terminator)
5077 : {
5078 11 : type = gfc_typenode_for_spec (&expr1->ts);
5079 11 : type = build_pointer_type (type);
5080 :
5081 : /* Allocate temporary for nested forall construct according to the
5082 : information in nested_forall_info and inner_size. */
5083 11 : tmp1 = allocate_temp_for_forall_nest (nested_forall_info, type,
5084 : inner_size, NULL, block, &ptemp1);
5085 11 : gfc_start_block (&body);
5086 11 : gfc_init_se (&lse, NULL);
5087 11 : lse.expr = gfc_build_array_ref (tmp1, count, NULL);
5088 11 : gfc_init_se (&rse, NULL);
5089 11 : rse.want_pointer = 1;
5090 11 : gfc_conv_expr (&rse, expr2);
5091 11 : gfc_add_block_to_block (&body, &rse.pre);
5092 11 : gfc_add_modify (&body, lse.expr,
5093 11 : fold_convert (TREE_TYPE (lse.expr), rse.expr));
5094 11 : gfc_add_block_to_block (&body, &rse.post);
5095 :
5096 : /* Increment count. */
5097 11 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
5098 : count, gfc_index_one_node);
5099 11 : gfc_add_modify (&body, count, tmp);
5100 :
5101 11 : tmp = gfc_finish_block (&body);
5102 :
5103 : /* Generate body and loops according to the information in
5104 : nested_forall_info. */
5105 11 : tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
5106 11 : gfc_add_expr_to_block (block, tmp);
5107 :
5108 : /* Reset count. */
5109 11 : gfc_add_modify (block, count, gfc_index_zero_node);
5110 :
5111 11 : gfc_start_block (&body);
5112 11 : gfc_init_se (&lse, NULL);
5113 11 : gfc_init_se (&rse, NULL);
5114 11 : rse.expr = gfc_build_array_ref (tmp1, count, NULL);
5115 11 : lse.want_pointer = 1;
5116 11 : gfc_conv_expr (&lse, expr1);
5117 11 : gfc_add_block_to_block (&body, &lse.pre);
5118 11 : gfc_add_modify (&body, lse.expr, rse.expr);
5119 11 : gfc_add_block_to_block (&body, &lse.post);
5120 : /* Increment count. */
5121 11 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
5122 : count, gfc_index_one_node);
5123 11 : gfc_add_modify (&body, count, tmp);
5124 11 : tmp = gfc_finish_block (&body);
5125 :
5126 : /* Generate body and loops according to the information in
5127 : nested_forall_info. */
5128 11 : tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
5129 11 : gfc_add_expr_to_block (block, tmp);
5130 : }
5131 : else
5132 : {
5133 9 : gfc_init_loopinfo (&loop);
5134 :
5135 : /* Associate the SS with the loop. */
5136 9 : gfc_add_ss_to_loop (&loop, rss);
5137 :
5138 : /* Setup the scalarizing loops and bounds. */
5139 9 : gfc_conv_ss_startstride (&loop);
5140 :
5141 9 : gfc_conv_loop_setup (&loop, &expr2->where);
5142 :
5143 9 : info = &rss->info->data.array;
5144 9 : desc = info->descriptor;
5145 :
5146 : /* Make a new descriptor. */
5147 9 : parmtype = gfc_get_element_type (TREE_TYPE (desc));
5148 9 : parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen, 0,
5149 : loop.from, loop.to, 1,
5150 : GFC_ARRAY_UNKNOWN, true);
5151 :
5152 : /* Allocate temporary for nested forall construct. */
5153 9 : tmp1 = allocate_temp_for_forall_nest (nested_forall_info, parmtype,
5154 : inner_size, NULL, block, &ptemp1);
5155 9 : gfc_start_block (&body);
5156 9 : gfc_init_se (&lse, NULL);
5157 9 : lse.expr = gfc_build_array_ref (tmp1, count, NULL);
5158 9 : lse.direct_byref = 1;
5159 9 : gfc_conv_expr_descriptor (&lse, expr2);
5160 :
5161 9 : gfc_add_block_to_block (&body, &lse.pre);
5162 9 : gfc_add_block_to_block (&body, &lse.post);
5163 :
5164 : /* Increment count. */
5165 9 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
5166 : count, gfc_index_one_node);
5167 9 : gfc_add_modify (&body, count, tmp);
5168 :
5169 9 : tmp = gfc_finish_block (&body);
5170 :
5171 : /* Generate body and loops according to the information in
5172 : nested_forall_info. */
5173 9 : tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
5174 9 : gfc_add_expr_to_block (block, tmp);
5175 :
5176 : /* Reset count. */
5177 9 : gfc_add_modify (block, count, gfc_index_zero_node);
5178 :
5179 9 : parm = gfc_build_array_ref (tmp1, count, NULL);
5180 9 : gfc_init_se (&lse, NULL);
5181 9 : gfc_conv_expr_descriptor (&lse, expr1);
5182 9 : gfc_add_modify (&lse.pre, lse.expr, parm);
5183 9 : gfc_start_block (&body);
5184 9 : gfc_add_block_to_block (&body, &lse.pre);
5185 9 : gfc_add_block_to_block (&body, &lse.post);
5186 :
5187 : /* Increment count. */
5188 9 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
5189 : count, gfc_index_one_node);
5190 9 : gfc_add_modify (&body, count, tmp);
5191 :
5192 9 : tmp = gfc_finish_block (&body);
5193 :
5194 9 : tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
5195 9 : gfc_add_expr_to_block (block, tmp);
5196 : }
5197 : /* Free the temporary. */
5198 20 : if (ptemp1)
5199 : {
5200 1 : tmp = gfc_call_free (ptemp1);
5201 1 : gfc_add_expr_to_block (block, tmp);
5202 : }
5203 20 : }
5204 :
5205 : /* For saving the outer-variable data when doing
5206 : LOCAL and LOCAL_INIT substitution. */
5207 : struct symbol_and_tree_t
5208 : {
5209 : gfc_symbol *sym;
5210 : gfc_expr *value;
5211 : tree decl;
5212 : symbol_attribute attr;
5213 : };
5214 :
5215 : /* Handle the LOCAL and LOCAL_INIT locality specifiers. This has to be
5216 : called twice, once with after_body=false - and then after the loop
5217 : body has been processed with after_body=true.
5218 :
5219 : Creates a copy of the variables that appear in the LOCAL and LOCAL_INIT
5220 : locality specifiers of 'do concurrent' - and use it in the original
5221 : gfc_symbol. The declaration is then reset by after_body=true.
5222 :
5223 : Variables in LOCAL_INIT are set in every loop iteration. */
5224 :
5225 : void
5226 320 : gfc_trans_concurrent_locality_spec (bool after_body, stmtblock_t *body,
5227 : std::vector<symbol_and_tree_t> *saved_decls,
5228 : gfc_expr_list **locality_list)
5229 : {
5230 320 : if (!locality_list[LOCALITY_LOCAL] && !locality_list[LOCALITY_LOCAL_INIT])
5231 : return;
5232 :
5233 96 : if (after_body)
5234 : {
5235 205 : for (unsigned i = 0; i < saved_decls->size (); i++)
5236 : {
5237 157 : (*saved_decls)[i].sym->backend_decl = (*saved_decls)[i].decl;
5238 157 : (*saved_decls)[i].sym->attr = (*saved_decls)[i].attr;
5239 157 : (*saved_decls)[i].sym->value = (*saved_decls)[i].value;
5240 : }
5241 : return;
5242 : }
5243 :
5244 : gfc_expr_list *el;
5245 : int cnt = 0;
5246 144 : for (int i = 0; i <= 1; i++)
5247 96 : for (el = locality_list[i == 0 ? LOCALITY_LOCAL : LOCALITY_LOCAL_INIT];
5248 253 : el; el = el->next)
5249 : {
5250 157 : gfc_symbol *outer_sym = el->expr->symtree->n.sym;
5251 157 : if (!outer_sym->backend_decl)
5252 0 : outer_sym->backend_decl = gfc_get_symbol_decl (outer_sym);
5253 157 : cnt++;
5254 : }
5255 48 : saved_decls->resize (cnt);
5256 :
5257 : /* The variables have to be created in the scope of the loop body. */
5258 48 : if (!body->has_scope)
5259 : {
5260 48 : gcc_checking_assert (body->head == NULL_TREE);
5261 48 : gfc_start_block (body);
5262 : }
5263 48 : gfc_start_saved_local_decls ();
5264 :
5265 48 : cnt = 0;
5266 48 : static_assert (LOCALITY_LOCAL_INIT - LOCALITY_LOCAL == 1, "locality_type");
5267 144 : for (int type = LOCALITY_LOCAL;
5268 144 : type <= LOCALITY_LOCAL_INIT; type++)
5269 253 : for (el = locality_list[type]; el; el = el->next)
5270 : {
5271 157 : gfc_symbol *sym = el->expr->symtree->n.sym;
5272 157 : (*saved_decls)[cnt].sym = sym;
5273 157 : (*saved_decls)[cnt].attr = sym->attr;
5274 157 : (*saved_decls)[cnt].value = sym->value;
5275 157 : (*saved_decls)[cnt].decl = sym->backend_decl;
5276 :
5277 157 : if (sym->attr.dimension && sym->as->type == AS_ASSUMED_SHAPE)
5278 : {
5279 3 : gfc_error ("Sorry, %s specifier at %L for assumed-size array %qs "
5280 : "is not yet supported",
5281 : type == LOCALITY_LOCAL ? "LOCAL" : "LOCAL_INIT",
5282 : &el->expr->where, sym->name);
5283 2 : continue;
5284 : }
5285 :
5286 155 : gfc_symbol outer_sym = *sym;
5287 :
5288 : /* Create the inner local variable. */
5289 155 : sym->backend_decl = NULL;
5290 155 : sym->value = NULL;
5291 155 : sym->attr.save = SAVE_NONE;
5292 155 : sym->attr.value = 0;
5293 155 : sym->attr.dummy = 0;
5294 155 : sym->attr.optional = 0;
5295 :
5296 155 : {
5297 : /* Slightly ugly hack for adding the decl via add_decl_as_local. */
5298 155 : gfc_symbol dummy_block_sym;
5299 155 : dummy_block_sym.attr.flavor = FL_LABEL;
5300 155 : gfc_symbol *saved_proc_name = sym->ns->proc_name;
5301 155 : sym->ns->proc_name = &dummy_block_sym;
5302 :
5303 155 : gfc_get_symbol_decl (sym);
5304 310 : DECL_SOURCE_LOCATION (sym->backend_decl)
5305 155 : = gfc_get_location (&el->expr->where);
5306 :
5307 155 : sym->ns->proc_name = saved_proc_name;
5308 : }
5309 :
5310 155 : symbol_attribute attr = gfc_expr_attr (el->expr);
5311 155 : if (type == LOCALITY_LOCAL
5312 89 : && !attr.pointer
5313 41 : && sym->ts.type == BT_DERIVED
5314 183 : && gfc_has_default_initializer (sym->ts.u.derived))
5315 : /* Cf. PR fortran/ */
5316 4 : gfc_error ("Sorry, LOCAL specifier at %L for %qs of derived type with"
5317 : " default initializer is not yet supported",
5318 4 : &el->expr->where, sym->name);
5319 155 : if (type == LOCALITY_LOCAL_INIT)
5320 : {
5321 : /* LOCAL_INIT: local_var = outer_var. */
5322 66 : gfc_symtree st = *el->expr->symtree;
5323 66 : st.n.sym = &outer_sym;
5324 66 : gfc_expr expr = *el->expr;
5325 66 : expr.symtree = &st;
5326 66 : tree t = (attr.pointer
5327 66 : ? gfc_trans_pointer_assignment (el->expr, &expr)
5328 42 : : gfc_trans_assignment (el->expr, &expr, false, false,
5329 : false, false));
5330 66 : gfc_add_expr_to_block (body, t);
5331 : }
5332 155 : cnt++;
5333 : }
5334 48 : gfc_stop_saved_local_decls ();
5335 : }
5336 :
5337 :
5338 : /* FORALL and WHERE statements are really nasty, especially when you nest
5339 : them. All the rhs of a forall assignment must be evaluated before the
5340 : actual assignments are performed. Presumably this also applies to all the
5341 : assignments in an inner where statement. */
5342 :
5343 : /* Generate code for a FORALL statement. Any temporaries are allocated as a
5344 : linear array, relying on the fact that we process in the same order in all
5345 : loops.
5346 :
5347 : forall (i=start:end:stride; maskexpr)
5348 : e<i> = f<i>
5349 : g<i> = h<i>
5350 : end forall
5351 : (where e,f,g,h<i> are arbitrary expressions possibly involving i)
5352 : Translates to:
5353 : count = ((end + 1 - start) / stride)
5354 : masktmp(:) = maskexpr(:)
5355 :
5356 : maskindex = 0;
5357 : for (i = start; i <= end; i += stride)
5358 : {
5359 : if (masktmp[maskindex++])
5360 : e<i> = f<i>
5361 : }
5362 : maskindex = 0;
5363 : for (i = start; i <= end; i += stride)
5364 : {
5365 : if (masktmp[maskindex++])
5366 : g<i> = h<i>
5367 : }
5368 :
5369 : Note that this code only works when there are no dependencies.
5370 : Forall loop with array assignments and data dependencies are a real pain,
5371 : because the size of the temporary cannot always be determined before the
5372 : loop is executed. This problem is compounded by the presence of nested
5373 : FORALL constructs.
5374 : */
5375 :
5376 : static tree
5377 2126 : gfc_trans_forall_1 (gfc_code * code, forall_info * nested_forall_info)
5378 : {
5379 2126 : stmtblock_t pre;
5380 2126 : stmtblock_t post;
5381 2126 : stmtblock_t block;
5382 2126 : stmtblock_t body;
5383 2126 : tree *var;
5384 2126 : tree *start;
5385 2126 : tree *end;
5386 2126 : tree *step;
5387 2126 : gfc_expr **varexpr;
5388 2126 : tree tmp;
5389 2126 : tree assign;
5390 2126 : tree size;
5391 2126 : tree maskindex;
5392 2126 : tree mask;
5393 2126 : tree pmask;
5394 2126 : tree cycle_label = NULL_TREE;
5395 2126 : int n;
5396 2126 : int nvar;
5397 2126 : int need_temp;
5398 2126 : gfc_forall_iterator *fa;
5399 2126 : gfc_se se;
5400 2126 : gfc_code *c;
5401 2126 : gfc_saved_var *saved_vars;
5402 2126 : iter_info *this_forall;
5403 2126 : forall_info *info;
5404 2126 : bool need_mask;
5405 :
5406 : /* Do nothing if the mask is false. */
5407 2126 : if (code->expr1
5408 727 : && code->expr1->expr_type == EXPR_CONSTANT
5409 2 : && !code->expr1->value.logical)
5410 1 : return build_empty_stmt (input_location);
5411 :
5412 2125 : n = 0;
5413 : /* Count the FORALL index number. */
5414 6161 : for (fa = code->ext.concur.forall_iterator; fa; fa = fa->next)
5415 4036 : n++;
5416 2125 : nvar = n;
5417 :
5418 : /* Allocate the space for var, start, end, step, varexpr. */
5419 2125 : var = XCNEWVEC (tree, nvar);
5420 2125 : start = XCNEWVEC (tree, nvar);
5421 2125 : end = XCNEWVEC (tree, nvar);
5422 2125 : step = XCNEWVEC (tree, nvar);
5423 2125 : varexpr = XCNEWVEC (gfc_expr *, nvar);
5424 2125 : saved_vars = XCNEWVEC (gfc_saved_var, nvar);
5425 :
5426 : /* Allocate the space for info. */
5427 2125 : info = XCNEW (forall_info);
5428 :
5429 2125 : gfc_start_block (&pre);
5430 2125 : gfc_init_block (&post);
5431 2125 : gfc_init_block (&block);
5432 :
5433 2125 : n = 0;
5434 6161 : for (fa = code->ext.concur.forall_iterator; fa; fa = fa->next)
5435 : {
5436 4036 : gfc_symbol *sym = fa->var->symtree->n.sym;
5437 :
5438 : /* Allocate space for this_forall. */
5439 4036 : this_forall = XCNEW (iter_info);
5440 :
5441 : /* Create a temporary variable for the FORALL index. */
5442 4036 : tmp = gfc_typenode_for_spec (&sym->ts);
5443 4036 : var[n] = gfc_create_var (tmp, sym->name);
5444 4036 : gfc_shadow_sym (sym, var[n], &saved_vars[n]);
5445 :
5446 : /* Record it in this_forall. */
5447 4036 : this_forall->var = var[n];
5448 :
5449 : /* Replace the index symbol's backend_decl with the temporary decl. */
5450 4036 : sym->backend_decl = var[n];
5451 :
5452 : /* Work out the start, end and stride for the loop. */
5453 4036 : gfc_init_se (&se, NULL);
5454 4036 : gfc_conv_expr_val (&se, fa->start);
5455 : /* Record it in this_forall. */
5456 4036 : this_forall->start = se.expr;
5457 4036 : gfc_add_block_to_block (&block, &se.pre);
5458 4036 : start[n] = se.expr;
5459 :
5460 4036 : gfc_init_se (&se, NULL);
5461 4036 : gfc_conv_expr_val (&se, fa->end);
5462 : /* Record it in this_forall. */
5463 4036 : this_forall->end = se.expr;
5464 4036 : gfc_make_safe_expr (&se);
5465 4036 : gfc_add_block_to_block (&block, &se.pre);
5466 4036 : end[n] = se.expr;
5467 :
5468 4036 : gfc_init_se (&se, NULL);
5469 4036 : gfc_conv_expr_val (&se, fa->stride);
5470 : /* Record it in this_forall. */
5471 4036 : this_forall->step = se.expr;
5472 4036 : gfc_make_safe_expr (&se);
5473 4036 : gfc_add_block_to_block (&block, &se.pre);
5474 4036 : step[n] = se.expr;
5475 :
5476 : /* Copy loop annotations. */
5477 4036 : this_forall->annot = fa->annot;
5478 :
5479 : /* Set the NEXT field of this_forall to NULL. */
5480 4036 : this_forall->next = NULL;
5481 : /* Link this_forall to the info construct. */
5482 4036 : if (info->this_loop)
5483 : {
5484 : iter_info *iter_tmp = info->this_loop;
5485 2837 : while (iter_tmp->next != NULL)
5486 : iter_tmp = iter_tmp->next;
5487 1911 : iter_tmp->next = this_forall;
5488 : }
5489 : else
5490 2125 : info->this_loop = this_forall;
5491 :
5492 4036 : n++;
5493 : }
5494 2125 : nvar = n;
5495 :
5496 : /* Calculate the size needed for the current forall level. */
5497 2125 : size = gfc_index_one_node;
5498 6161 : for (n = 0; n < nvar; n++)
5499 : {
5500 : /* size = (end + step - start) / step. */
5501 4036 : tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (start[n]),
5502 4036 : step[n], start[n]);
5503 4036 : tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (end[n]),
5504 4036 : end[n], tmp);
5505 4036 : tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR, TREE_TYPE (tmp),
5506 : tmp, step[n]);
5507 4036 : tmp = convert (gfc_array_index_type, tmp);
5508 :
5509 4036 : size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
5510 : size, tmp);
5511 : }
5512 :
5513 : /* Record the nvar and size of current forall level. */
5514 2125 : info->nvar = nvar;
5515 2125 : info->size = size;
5516 :
5517 2125 : if (code->expr1)
5518 : {
5519 : /* If the mask is .true., consider the FORALL unconditional. */
5520 726 : if (code->expr1->expr_type == EXPR_CONSTANT
5521 1 : && code->expr1->value.logical)
5522 : need_mask = false;
5523 : else
5524 725 : need_mask = true;
5525 : }
5526 : else
5527 : need_mask = false;
5528 :
5529 : /* First we need to allocate the mask. */
5530 725 : if (need_mask)
5531 : {
5532 : /* As the mask array can be very big, prefer compact boolean types. */
5533 725 : tree mask_type = gfc_get_logical_type (gfc_logical_kinds[0].kind);
5534 725 : mask = allocate_temp_for_forall_nest (nested_forall_info, mask_type,
5535 : size, NULL, &block, &pmask);
5536 725 : maskindex = gfc_create_var_np (gfc_array_index_type, "mi");
5537 :
5538 : /* Record them in the info structure. */
5539 725 : info->maskindex = maskindex;
5540 725 : info->mask = mask;
5541 : }
5542 : else
5543 : {
5544 : /* No mask was specified. */
5545 1400 : maskindex = NULL_TREE;
5546 1400 : mask = pmask = NULL_TREE;
5547 : }
5548 :
5549 : /* Link the current forall level to nested_forall_info. */
5550 2125 : info->prev_nest = nested_forall_info;
5551 2125 : nested_forall_info = info;
5552 :
5553 : /* Copy the mask into a temporary variable if required.
5554 : For now we assume a mask temporary is needed. */
5555 2125 : if (need_mask)
5556 : {
5557 : /* As the mask array can be very big, prefer compact boolean types. */
5558 725 : tree mask_type = gfc_get_logical_type (gfc_logical_kinds[0].kind);
5559 :
5560 725 : gfc_add_modify (&block, maskindex, gfc_index_zero_node);
5561 :
5562 : /* Start of mask assignment loop body. */
5563 725 : gfc_start_block (&body);
5564 :
5565 : /* Evaluate the mask expression. */
5566 725 : gfc_init_se (&se, NULL);
5567 725 : gfc_conv_expr_val (&se, code->expr1);
5568 725 : gfc_add_block_to_block (&body, &se.pre);
5569 :
5570 : /* Store the mask. */
5571 725 : se.expr = convert (mask_type, se.expr);
5572 :
5573 725 : tmp = gfc_build_array_ref (mask, maskindex, NULL);
5574 725 : gfc_add_modify (&body, tmp, se.expr);
5575 :
5576 : /* Advance to the next mask element. */
5577 725 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
5578 : maskindex, gfc_index_one_node);
5579 725 : gfc_add_modify (&body, maskindex, tmp);
5580 :
5581 : /* Generate the loops. */
5582 725 : tmp = gfc_finish_block (&body);
5583 725 : tmp = gfc_trans_nested_forall_loop (info, tmp, 0);
5584 725 : gfc_add_expr_to_block (&block, tmp);
5585 : }
5586 :
5587 2125 : if (code->op == EXEC_DO_CONCURRENT)
5588 : {
5589 160 : gfc_init_block (&body);
5590 160 : cycle_label = gfc_build_label_decl (NULL_TREE);
5591 160 : code->cycle_label = cycle_label;
5592 :
5593 : /* Handle LOCAL and LOCAL_INIT. */
5594 160 : std::vector<symbol_and_tree_t> saved_decls;
5595 160 : gfc_trans_concurrent_locality_spec (false, &body, &saved_decls,
5596 160 : code->ext.concur.locality);
5597 :
5598 : /* Translate the body. */
5599 160 : tmp = gfc_trans_code (code->block->next);
5600 160 : gfc_add_expr_to_block (&body, tmp);
5601 :
5602 : /* Reset locality variables. */
5603 160 : gfc_trans_concurrent_locality_spec (true, &body, &saved_decls,
5604 : code->ext.concur.locality);
5605 160 : if (TREE_USED (cycle_label))
5606 : {
5607 160 : tmp = build1_v (LABEL_EXPR, cycle_label);
5608 160 : gfc_add_expr_to_block (&body, tmp);
5609 : }
5610 :
5611 160 : tmp = gfc_finish_block (&body);
5612 160 : nested_forall_info->do_concurrent = true;
5613 160 : tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
5614 160 : gfc_add_expr_to_block (&block, tmp);
5615 160 : goto done;
5616 160 : }
5617 :
5618 1965 : c = code->block->next;
5619 :
5620 : /* TODO: loop merging in FORALL statements. */
5621 : /* Now that we've got a copy of the mask, generate the assignment loops. */
5622 3947 : while (c)
5623 : {
5624 1982 : switch (c->op)
5625 : {
5626 1826 : case EXEC_ASSIGN:
5627 : /* A scalar or array assignment. DO the simple check for
5628 : lhs to rhs dependencies. These make a temporary for the
5629 : rhs and form a second forall block to copy to variable. */
5630 1826 : need_temp = check_forall_dependencies(c, &pre, &post);
5631 :
5632 : /* Temporaries due to array assignment data dependencies introduce
5633 : no end of problems. */
5634 1826 : if (need_temp || flag_test_forall_temp)
5635 197 : gfc_trans_assign_need_temp (c->expr1, c->expr2, NULL, false,
5636 : nested_forall_info, &block);
5637 : else
5638 : {
5639 : /* Use the normal assignment copying routines. */
5640 1629 : assign = gfc_trans_assignment (c->expr1, c->expr2, false, true);
5641 :
5642 : /* Generate body and loops. */
5643 1629 : tmp = gfc_trans_nested_forall_loop (nested_forall_info,
5644 : assign, 1);
5645 1629 : gfc_add_expr_to_block (&block, tmp);
5646 : }
5647 :
5648 : /* Cleanup any temporary symtrees that have been made to deal
5649 : with dependencies. */
5650 1826 : if (new_symtree)
5651 62 : cleanup_forall_symtrees (c);
5652 :
5653 : break;
5654 :
5655 47 : case EXEC_WHERE:
5656 : /* Translate WHERE or WHERE construct nested in FORALL. */
5657 47 : gfc_trans_where_2 (c, NULL, false, nested_forall_info, &block);
5658 47 : break;
5659 :
5660 : /* Pointer assignment inside FORALL. */
5661 27 : case EXEC_POINTER_ASSIGN:
5662 27 : need_temp = gfc_check_dependency (c->expr1, c->expr2, 0);
5663 : /* Avoid cases where a temporary would never be needed and where
5664 : the temp code is guaranteed to fail. */
5665 27 : if (need_temp
5666 7 : || (flag_test_forall_temp
5667 0 : && c->expr2->expr_type != EXPR_CONSTANT
5668 0 : && c->expr2->expr_type != EXPR_NULL))
5669 20 : gfc_trans_pointer_assign_need_temp (c->expr1, c->expr2,
5670 : nested_forall_info, &block);
5671 : else
5672 : {
5673 : /* Use the normal assignment copying routines. */
5674 7 : assign = gfc_trans_pointer_assignment (c->expr1, c->expr2);
5675 :
5676 : /* Generate body and loops. */
5677 7 : tmp = gfc_trans_nested_forall_loop (nested_forall_info,
5678 : assign, 1);
5679 7 : gfc_add_expr_to_block (&block, tmp);
5680 : }
5681 : break;
5682 :
5683 76 : case EXEC_FORALL:
5684 76 : tmp = gfc_trans_forall_1 (c, nested_forall_info);
5685 76 : gfc_add_expr_to_block (&block, tmp);
5686 76 : break;
5687 :
5688 : /* Explicit subroutine calls are prevented by the frontend but interface
5689 : assignments can legitimately produce them. */
5690 6 : case EXEC_ASSIGN_CALL:
5691 6 : assign = gfc_trans_call (c, true, NULL_TREE, NULL_TREE, false);
5692 6 : tmp = gfc_trans_nested_forall_loop (nested_forall_info, assign, 1);
5693 6 : gfc_add_expr_to_block (&block, tmp);
5694 6 : break;
5695 :
5696 0 : default:
5697 0 : gcc_unreachable ();
5698 : }
5699 :
5700 1982 : c = c->next;
5701 : }
5702 :
5703 1965 : done:
5704 : /* Restore the original index variables. */
5705 6161 : for (fa = code->ext.concur.forall_iterator, n = 0; fa; fa = fa->next, n++)
5706 4036 : gfc_restore_sym (fa->var->symtree->n.sym, &saved_vars[n]);
5707 :
5708 : /* Free the space for var, start, end, step, varexpr. */
5709 2125 : free (var);
5710 2125 : free (start);
5711 2125 : free (end);
5712 2125 : free (step);
5713 2125 : free (varexpr);
5714 2125 : free (saved_vars);
5715 :
5716 6161 : for (this_forall = info->this_loop; this_forall;)
5717 : {
5718 4036 : iter_info *next = this_forall->next;
5719 4036 : free (this_forall);
5720 4036 : this_forall = next;
5721 : }
5722 :
5723 : /* Free the space for this forall_info. */
5724 2125 : free (info);
5725 :
5726 2125 : if (pmask)
5727 : {
5728 : /* Free the temporary for the mask. */
5729 53 : tmp = gfc_call_free (pmask);
5730 53 : gfc_add_expr_to_block (&block, tmp);
5731 : }
5732 2125 : if (maskindex)
5733 725 : pushdecl (maskindex);
5734 :
5735 2125 : gfc_add_block_to_block (&pre, &block);
5736 2125 : gfc_add_block_to_block (&pre, &post);
5737 :
5738 2125 : return gfc_finish_block (&pre);
5739 : }
5740 :
5741 :
5742 : /* Translate the FORALL statement or construct. */
5743 :
5744 1890 : tree gfc_trans_forall (gfc_code * code)
5745 : {
5746 1890 : return gfc_trans_forall_1 (code, NULL);
5747 : }
5748 :
5749 :
5750 : /* Translate the DO CONCURRENT construct. */
5751 :
5752 160 : tree gfc_trans_do_concurrent (gfc_code * code)
5753 : {
5754 160 : return gfc_trans_forall_1 (code, NULL);
5755 : }
5756 :
5757 :
5758 : /* Evaluate the WHERE mask expression, copy its value to a temporary.
5759 : If the WHERE construct is nested in FORALL, compute the overall temporary
5760 : needed by the WHERE mask expression multiplied by the iterator number of
5761 : the nested forall.
5762 : ME is the WHERE mask expression.
5763 : MASK is the current execution mask upon input, whose sense may or may
5764 : not be inverted as specified by the INVERT argument.
5765 : CMASK is the updated execution mask on output, or NULL if not required.
5766 : PMASK is the pending execution mask on output, or NULL if not required.
5767 : BLOCK is the block in which to place the condition evaluation loops. */
5768 :
5769 : static void
5770 528 : gfc_evaluate_where_mask (gfc_expr * me, forall_info * nested_forall_info,
5771 : tree mask, bool invert, tree cmask, tree pmask,
5772 : tree mask_type, stmtblock_t * block)
5773 : {
5774 528 : tree tmp, tmp1;
5775 528 : gfc_ss *lss, *rss;
5776 528 : gfc_loopinfo loop;
5777 528 : stmtblock_t body, body1;
5778 528 : tree count, cond, mtmp;
5779 528 : gfc_se lse, rse;
5780 :
5781 528 : gfc_init_loopinfo (&loop);
5782 :
5783 528 : lss = gfc_walk_expr (me);
5784 528 : rss = gfc_walk_expr (me);
5785 :
5786 : /* Variable to index the temporary. */
5787 528 : count = gfc_create_var (gfc_array_index_type, "count");
5788 : /* Initialize count. */
5789 528 : gfc_add_modify (block, count, gfc_index_zero_node);
5790 :
5791 528 : gfc_start_block (&body);
5792 :
5793 528 : gfc_init_se (&rse, NULL);
5794 528 : gfc_init_se (&lse, NULL);
5795 :
5796 528 : if (lss == gfc_ss_terminator)
5797 : {
5798 0 : gfc_init_block (&body1);
5799 : }
5800 : else
5801 : {
5802 : /* Initialize the loop. */
5803 528 : gfc_init_loopinfo (&loop);
5804 :
5805 : /* We may need LSS to determine the shape of the expression. */
5806 528 : gfc_add_ss_to_loop (&loop, lss);
5807 528 : gfc_add_ss_to_loop (&loop, rss);
5808 :
5809 528 : gfc_conv_ss_startstride (&loop);
5810 528 : gfc_conv_loop_setup (&loop, &me->where);
5811 :
5812 528 : gfc_mark_ss_chain_used (rss, 1);
5813 : /* Start the loop body. */
5814 528 : gfc_start_scalarized_body (&loop, &body1);
5815 :
5816 : /* Translate the expression. */
5817 528 : gfc_copy_loopinfo_to_se (&rse, &loop);
5818 528 : rse.ss = rss;
5819 528 : gfc_conv_expr (&rse, me);
5820 : }
5821 :
5822 : /* Variable to evaluate mask condition. */
5823 528 : cond = gfc_create_var (mask_type, "cond");
5824 528 : if (mask && (cmask || pmask))
5825 234 : mtmp = gfc_create_var (mask_type, "mask");
5826 : else mtmp = NULL_TREE;
5827 :
5828 528 : gfc_add_block_to_block (&body1, &lse.pre);
5829 528 : gfc_add_block_to_block (&body1, &rse.pre);
5830 :
5831 528 : gfc_add_modify (&body1, cond, fold_convert (mask_type, rse.expr));
5832 :
5833 528 : if (mask && (cmask || pmask))
5834 : {
5835 234 : tmp = gfc_build_array_ref (mask, count, NULL);
5836 234 : if (invert)
5837 99 : tmp = fold_build1_loc (input_location, TRUTH_NOT_EXPR, mask_type, tmp);
5838 234 : gfc_add_modify (&body1, mtmp, tmp);
5839 : }
5840 :
5841 528 : if (cmask)
5842 : {
5843 510 : tmp1 = gfc_build_array_ref (cmask, count, NULL);
5844 510 : tmp = cond;
5845 510 : if (mask)
5846 234 : tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, mask_type,
5847 : mtmp, tmp);
5848 510 : gfc_add_modify (&body1, tmp1, tmp);
5849 : }
5850 :
5851 528 : if (pmask)
5852 : {
5853 146 : tmp1 = gfc_build_array_ref (pmask, count, NULL);
5854 146 : tmp = fold_build1_loc (input_location, TRUTH_NOT_EXPR, mask_type, cond);
5855 146 : if (mask)
5856 146 : tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, mask_type, mtmp,
5857 : tmp);
5858 146 : gfc_add_modify (&body1, tmp1, tmp);
5859 : }
5860 :
5861 528 : gfc_add_block_to_block (&body1, &lse.post);
5862 528 : gfc_add_block_to_block (&body1, &rse.post);
5863 :
5864 528 : if (lss == gfc_ss_terminator)
5865 : {
5866 0 : gfc_add_block_to_block (&body, &body1);
5867 : }
5868 : else
5869 : {
5870 : /* Increment count. */
5871 528 : tmp1 = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
5872 : count, gfc_index_one_node);
5873 528 : gfc_add_modify (&body1, count, tmp1);
5874 :
5875 : /* Generate the copying loops. */
5876 528 : gfc_trans_scalarizing_loops (&loop, &body1);
5877 :
5878 528 : gfc_add_block_to_block (&body, &loop.pre);
5879 528 : gfc_add_block_to_block (&body, &loop.post);
5880 :
5881 528 : gfc_cleanup_loop (&loop);
5882 : /* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful
5883 : as tree nodes in SS may not be valid in different scope. */
5884 : }
5885 :
5886 528 : tmp1 = gfc_finish_block (&body);
5887 : /* If the WHERE construct is inside FORALL, fill the full temporary. */
5888 528 : if (nested_forall_info != NULL)
5889 65 : tmp1 = gfc_trans_nested_forall_loop (nested_forall_info, tmp1, 1);
5890 :
5891 528 : gfc_add_expr_to_block (block, tmp1);
5892 528 : }
5893 :
5894 :
5895 : /* Translate an assignment statement in a WHERE statement or construct
5896 : statement. The MASK expression is used to control which elements
5897 : of EXPR1 shall be assigned. The sense of MASK is specified by
5898 : INVERT. */
5899 :
5900 : static tree
5901 545 : gfc_trans_where_assign (gfc_expr *expr1, gfc_expr *expr2,
5902 : tree mask, bool invert,
5903 : tree count1, tree count2,
5904 : gfc_code *cnext)
5905 : {
5906 545 : gfc_se lse;
5907 545 : gfc_se rse;
5908 545 : gfc_ss *lss;
5909 545 : gfc_ss *lss_section;
5910 545 : gfc_ss *rss;
5911 :
5912 545 : gfc_loopinfo loop;
5913 545 : tree tmp;
5914 545 : stmtblock_t block;
5915 545 : stmtblock_t body;
5916 545 : tree index, maskexpr;
5917 :
5918 : /* A defined assignment. */
5919 545 : if (cnext && cnext->resolved_sym)
5920 44 : return gfc_trans_call (cnext, true, mask, count1, invert);
5921 :
5922 : #if 0
5923 : /* TODO: handle this special case.
5924 : Special case a single function returning an array. */
5925 : if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
5926 : {
5927 : tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
5928 : if (tmp)
5929 : return tmp;
5930 : }
5931 : #endif
5932 :
5933 : /* Assignment of the form lhs = rhs. */
5934 501 : gfc_start_block (&block);
5935 :
5936 501 : gfc_init_se (&lse, NULL);
5937 501 : gfc_init_se (&rse, NULL);
5938 :
5939 : /* Walk the lhs. */
5940 501 : lss = gfc_walk_expr (expr1);
5941 501 : rss = NULL;
5942 :
5943 : /* In each where-assign-stmt, the mask-expr and the variable being
5944 : defined shall be arrays of the same shape. */
5945 501 : gcc_assert (lss != gfc_ss_terminator);
5946 :
5947 : /* The assignment needs scalarization. */
5948 : lss_section = lss;
5949 :
5950 : /* Find a non-scalar SS from the lhs. */
5951 : while (lss_section != gfc_ss_terminator
5952 501 : && lss_section->info->type != GFC_SS_SECTION)
5953 0 : lss_section = lss_section->next;
5954 :
5955 501 : gcc_assert (lss_section != gfc_ss_terminator);
5956 :
5957 : /* Initialize the scalarizer. */
5958 501 : gfc_init_loopinfo (&loop);
5959 :
5960 : /* Walk the rhs. */
5961 501 : rss = gfc_walk_expr (expr2);
5962 501 : if (rss == gfc_ss_terminator)
5963 : {
5964 : /* The rhs is scalar. Add a ss for the expression. */
5965 343 : rss = gfc_get_scalar_ss (gfc_ss_terminator, expr2);
5966 343 : rss->info->where = 1;
5967 : }
5968 :
5969 : /* Associate the SS with the loop. */
5970 501 : gfc_add_ss_to_loop (&loop, lss);
5971 501 : gfc_add_ss_to_loop (&loop, rss);
5972 :
5973 : /* Calculate the bounds of the scalarization. */
5974 501 : gfc_conv_ss_startstride (&loop);
5975 :
5976 : /* Resolve any data dependencies in the statement. */
5977 501 : gfc_conv_resolve_dependencies (&loop, lss_section, rss);
5978 :
5979 : /* Setup the scalarizing loops. */
5980 501 : gfc_conv_loop_setup (&loop, &expr2->where);
5981 :
5982 : /* Setup the gfc_se structures. */
5983 501 : gfc_copy_loopinfo_to_se (&lse, &loop);
5984 501 : gfc_copy_loopinfo_to_se (&rse, &loop);
5985 :
5986 501 : rse.ss = rss;
5987 501 : gfc_mark_ss_chain_used (rss, 1);
5988 501 : if (loop.temp_ss == NULL)
5989 : {
5990 422 : lse.ss = lss;
5991 422 : gfc_mark_ss_chain_used (lss, 1);
5992 : }
5993 : else
5994 : {
5995 79 : lse.ss = loop.temp_ss;
5996 79 : gfc_mark_ss_chain_used (lss, 3);
5997 79 : gfc_mark_ss_chain_used (loop.temp_ss, 3);
5998 : }
5999 :
6000 : /* Start the scalarized loop body. */
6001 501 : gfc_start_scalarized_body (&loop, &body);
6002 :
6003 : /* Translate the expression. */
6004 501 : gfc_conv_expr (&rse, expr2);
6005 501 : if (lss != gfc_ss_terminator && loop.temp_ss != NULL)
6006 79 : gfc_conv_tmp_array_ref (&lse);
6007 : else
6008 422 : gfc_conv_expr (&lse, expr1);
6009 :
6010 : /* Form the mask expression according to the mask. */
6011 501 : index = count1;
6012 501 : maskexpr = gfc_build_array_ref (mask, index, NULL);
6013 501 : if (invert)
6014 24 : maskexpr = fold_build1_loc (input_location, TRUTH_NOT_EXPR,
6015 24 : TREE_TYPE (maskexpr), maskexpr);
6016 :
6017 : /* Use the scalar assignment as is. */
6018 1002 : tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
6019 501 : false, loop.temp_ss == NULL);
6020 :
6021 501 : tmp = build3_v (COND_EXPR, maskexpr, tmp, build_empty_stmt (input_location));
6022 :
6023 501 : gfc_add_expr_to_block (&body, tmp);
6024 :
6025 501 : if (lss == gfc_ss_terminator)
6026 : {
6027 : /* Increment count1. */
6028 : tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
6029 : count1, gfc_index_one_node);
6030 : gfc_add_modify (&body, count1, tmp);
6031 :
6032 : /* Use the scalar assignment as is. */
6033 : gfc_add_block_to_block (&block, &body);
6034 : }
6035 : else
6036 : {
6037 501 : gcc_assert (lse.ss == gfc_ss_terminator
6038 : && rse.ss == gfc_ss_terminator);
6039 :
6040 501 : if (loop.temp_ss != NULL)
6041 : {
6042 : /* Increment count1 before finish the main body of a scalarized
6043 : expression. */
6044 79 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
6045 : gfc_array_index_type, count1, gfc_index_one_node);
6046 79 : gfc_add_modify (&body, count1, tmp);
6047 79 : gfc_trans_scalarized_loop_boundary (&loop, &body);
6048 :
6049 : /* We need to copy the temporary to the actual lhs. */
6050 79 : gfc_init_se (&lse, NULL);
6051 79 : gfc_init_se (&rse, NULL);
6052 79 : gfc_copy_loopinfo_to_se (&lse, &loop);
6053 79 : gfc_copy_loopinfo_to_se (&rse, &loop);
6054 :
6055 79 : rse.ss = loop.temp_ss;
6056 79 : lse.ss = lss;
6057 :
6058 79 : gfc_conv_tmp_array_ref (&rse);
6059 79 : gfc_conv_expr (&lse, expr1);
6060 :
6061 79 : gcc_assert (lse.ss == gfc_ss_terminator
6062 : && rse.ss == gfc_ss_terminator);
6063 :
6064 : /* Form the mask expression according to the mask tree list. */
6065 79 : index = count2;
6066 79 : maskexpr = gfc_build_array_ref (mask, index, NULL);
6067 79 : if (invert)
6068 0 : maskexpr = fold_build1_loc (input_location, TRUTH_NOT_EXPR,
6069 0 : TREE_TYPE (maskexpr), maskexpr);
6070 :
6071 : /* Use the scalar assignment as is. */
6072 79 : tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts, false, true);
6073 79 : tmp = build3_v (COND_EXPR, maskexpr, tmp,
6074 : build_empty_stmt (input_location));
6075 79 : gfc_add_expr_to_block (&body, tmp);
6076 :
6077 : /* Increment count2. */
6078 79 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
6079 : gfc_array_index_type, count2,
6080 : gfc_index_one_node);
6081 79 : gfc_add_modify (&body, count2, tmp);
6082 : }
6083 : else
6084 : {
6085 : /* Increment count1. */
6086 422 : tmp = fold_build2_loc (input_location, PLUS_EXPR,
6087 : gfc_array_index_type, count1,
6088 : gfc_index_one_node);
6089 422 : gfc_add_modify (&body, count1, tmp);
6090 : }
6091 :
6092 : /* Generate the copying loops. */
6093 501 : gfc_trans_scalarizing_loops (&loop, &body);
6094 :
6095 : /* Wrap the whole thing up. */
6096 501 : gfc_add_block_to_block (&block, &loop.pre);
6097 501 : gfc_add_block_to_block (&block, &loop.post);
6098 501 : gfc_cleanup_loop (&loop);
6099 : }
6100 :
6101 501 : return gfc_finish_block (&block);
6102 : }
6103 :
6104 :
6105 : /* Translate the WHERE construct or statement.
6106 : This function can be called iteratively to translate the nested WHERE
6107 : construct or statement.
6108 : MASK is the control mask. */
6109 :
6110 : static void
6111 350 : gfc_trans_where_2 (gfc_code * code, tree mask, bool invert,
6112 : forall_info * nested_forall_info, stmtblock_t * block)
6113 : {
6114 350 : stmtblock_t inner_size_body;
6115 350 : tree inner_size, size;
6116 350 : gfc_ss *lss, *rss;
6117 350 : tree mask_type;
6118 350 : gfc_expr *expr1;
6119 350 : gfc_expr *expr2;
6120 350 : gfc_code *cblock;
6121 350 : gfc_code *cnext;
6122 350 : tree tmp;
6123 350 : tree cond;
6124 350 : tree count1, count2;
6125 350 : bool need_cmask;
6126 350 : bool need_pmask;
6127 350 : int need_temp;
6128 350 : tree pcmask = NULL_TREE;
6129 350 : tree ppmask = NULL_TREE;
6130 350 : tree cmask = NULL_TREE;
6131 350 : tree pmask = NULL_TREE;
6132 350 : gfc_actual_arglist *arg;
6133 :
6134 : /* the WHERE statement or the WHERE construct statement. */
6135 350 : cblock = code->block;
6136 :
6137 : /* As the mask array can be very big, prefer compact boolean types. */
6138 350 : mask_type = gfc_get_logical_type (gfc_logical_kinds[0].kind);
6139 :
6140 : /* Determine which temporary masks are needed. */
6141 350 : if (!cblock->block)
6142 : {
6143 : /* One clause: No ELSEWHEREs. */
6144 169 : need_cmask = (cblock->next != 0);
6145 169 : need_pmask = false;
6146 : }
6147 181 : else if (cblock->block->block)
6148 : {
6149 : /* Three or more clauses: Conditional ELSEWHEREs. */
6150 : need_cmask = true;
6151 : need_pmask = true;
6152 : }
6153 102 : else if (cblock->next)
6154 : {
6155 : /* Two clauses, the first non-empty. */
6156 84 : need_cmask = true;
6157 84 : need_pmask = (mask != NULL_TREE
6158 84 : && cblock->block->next != 0);
6159 : }
6160 18 : else if (!cblock->block->next)
6161 : {
6162 : /* Two clauses, both empty. */
6163 : need_cmask = false;
6164 : need_pmask = false;
6165 : }
6166 : /* Two clauses, the first empty, the second non-empty. */
6167 9 : else if (mask)
6168 : {
6169 0 : need_cmask = (cblock->block->expr1 != 0);
6170 0 : need_pmask = true;
6171 : }
6172 : else
6173 : {
6174 : need_cmask = true;
6175 : need_pmask = false;
6176 : }
6177 :
6178 169 : if (need_cmask || need_pmask)
6179 : {
6180 : /* Calculate the size of temporary needed by the mask-expr. */
6181 332 : gfc_init_block (&inner_size_body);
6182 332 : inner_size = compute_inner_temp_size (cblock->expr1, cblock->expr1,
6183 : &inner_size_body, &lss, &rss);
6184 :
6185 332 : gfc_free_ss_chain (lss);
6186 332 : gfc_free_ss_chain (rss);
6187 :
6188 : /* Calculate the total size of temporary needed. */
6189 332 : size = compute_overall_iter_number (nested_forall_info, inner_size,
6190 : &inner_size_body, block);
6191 :
6192 : /* Check whether the size is negative. */
6193 332 : cond = fold_build2_loc (input_location, LE_EXPR, logical_type_node, size,
6194 : gfc_index_zero_node);
6195 332 : size = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type,
6196 : cond, gfc_index_zero_node, size);
6197 332 : size = gfc_evaluate_now (size, block);
6198 :
6199 : /* Allocate temporary for WHERE mask if needed. */
6200 332 : if (need_cmask)
6201 332 : cmask = allocate_temp_for_forall_nest_1 (mask_type, size, block,
6202 : &pcmask);
6203 :
6204 : /* Allocate temporary for !mask if needed. */
6205 332 : if (need_pmask)
6206 83 : pmask = allocate_temp_for_forall_nest_1 (mask_type, size, block,
6207 : &ppmask);
6208 : }
6209 :
6210 996 : while (cblock)
6211 : {
6212 : /* Each time around this loop, the where clause is conditional
6213 : on the value of mask and invert, which are updated at the
6214 : bottom of the loop. */
6215 :
6216 : /* Has mask-expr. */
6217 646 : if (cblock->expr1)
6218 : {
6219 : /* Ensure that the WHERE mask will be evaluated exactly once.
6220 : If there are no statements in this WHERE/ELSEWHERE clause,
6221 : then we don't need to update the control mask (cmask).
6222 : If this is the last clause of the WHERE construct, then
6223 : we don't need to update the pending control mask (pmask). */
6224 528 : if (mask)
6225 234 : gfc_evaluate_where_mask (cblock->expr1, nested_forall_info,
6226 : mask, invert,
6227 234 : cblock->next ? cmask : NULL_TREE,
6228 234 : cblock->block ? pmask : NULL_TREE,
6229 : mask_type, block);
6230 : else
6231 294 : gfc_evaluate_where_mask (cblock->expr1, nested_forall_info,
6232 : NULL_TREE, false,
6233 294 : (cblock->next || cblock->block)
6234 : ? cmask : NULL_TREE,
6235 : NULL_TREE, mask_type, block);
6236 :
6237 : invert = false;
6238 : }
6239 : /* It's a final elsewhere-stmt. No mask-expr is present. */
6240 : else
6241 : cmask = mask;
6242 :
6243 : /* The body of this where clause are controlled by cmask with
6244 : sense specified by invert. */
6245 :
6246 : /* Get the assignment statement of a WHERE statement, or the first
6247 : statement in where-body-construct of a WHERE construct. */
6248 646 : cnext = cblock->next;
6249 1274 : while (cnext)
6250 : {
6251 628 : switch (cnext->op)
6252 : {
6253 : /* WHERE assignment statement. */
6254 44 : case EXEC_ASSIGN_CALL:
6255 :
6256 44 : arg = cnext->ext.actual;
6257 44 : expr1 = expr2 = NULL;
6258 132 : for (; arg; arg = arg->next)
6259 : {
6260 88 : if (!arg->expr)
6261 0 : continue;
6262 88 : if (expr1 == NULL)
6263 : expr1 = arg->expr;
6264 : else
6265 44 : expr2 = arg->expr;
6266 : }
6267 44 : goto evaluate;
6268 :
6269 528 : case EXEC_ASSIGN:
6270 528 : expr1 = cnext->expr1;
6271 528 : expr2 = cnext->expr2;
6272 572 : evaluate:
6273 572 : if (nested_forall_info != NULL)
6274 : {
6275 66 : need_temp = gfc_check_dependency (expr1, expr2, 0);
6276 66 : if ((need_temp || flag_test_forall_temp)
6277 28 : && cnext->op != EXEC_ASSIGN_CALL)
6278 27 : gfc_trans_assign_need_temp (expr1, expr2,
6279 : cmask, invert,
6280 : nested_forall_info, block);
6281 : else
6282 : {
6283 : /* Variables to control maskexpr. */
6284 39 : count1 = gfc_create_var (gfc_array_index_type, "count1");
6285 39 : count2 = gfc_create_var (gfc_array_index_type, "count2");
6286 39 : gfc_add_modify (block, count1, gfc_index_zero_node);
6287 39 : gfc_add_modify (block, count2, gfc_index_zero_node);
6288 :
6289 39 : tmp = gfc_trans_where_assign (expr1, expr2,
6290 : cmask, invert,
6291 : count1, count2,
6292 : cnext);
6293 :
6294 39 : tmp = gfc_trans_nested_forall_loop (nested_forall_info,
6295 : tmp, 1);
6296 39 : gfc_add_expr_to_block (block, tmp);
6297 : }
6298 : }
6299 : else
6300 : {
6301 : /* Variables to control maskexpr. */
6302 506 : count1 = gfc_create_var (gfc_array_index_type, "count1");
6303 506 : count2 = gfc_create_var (gfc_array_index_type, "count2");
6304 506 : gfc_add_modify (block, count1, gfc_index_zero_node);
6305 506 : gfc_add_modify (block, count2, gfc_index_zero_node);
6306 :
6307 506 : tmp = gfc_trans_where_assign (expr1, expr2,
6308 : cmask, invert,
6309 : count1, count2,
6310 : cnext);
6311 506 : gfc_add_expr_to_block (block, tmp);
6312 :
6313 : }
6314 : break;
6315 :
6316 : /* WHERE or WHERE construct is part of a where-body-construct. */
6317 56 : case EXEC_WHERE:
6318 56 : gfc_trans_where_2 (cnext, cmask, invert,
6319 : nested_forall_info, block);
6320 56 : break;
6321 :
6322 0 : default:
6323 0 : gcc_unreachable ();
6324 : }
6325 :
6326 : /* The next statement within the same where-body-construct. */
6327 628 : cnext = cnext->next;
6328 : }
6329 : /* The next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt. */
6330 646 : cblock = cblock->block;
6331 646 : if (mask == NULL_TREE)
6332 : {
6333 : /* If we're the initial WHERE, we can simply invert the sense
6334 : of the current mask to obtain the "mask" for the remaining
6335 : ELSEWHEREs. */
6336 : invert = true;
6337 : mask = cmask;
6338 : }
6339 : else
6340 : {
6341 : /* Otherwise, for nested WHERE's we need to use the pending mask. */
6342 343 : invert = false;
6343 343 : mask = pmask;
6344 : }
6345 : }
6346 :
6347 : /* If we allocated a pending mask array, deallocate it now. */
6348 350 : if (ppmask)
6349 : {
6350 1 : tmp = gfc_call_free (ppmask);
6351 1 : gfc_add_expr_to_block (block, tmp);
6352 : }
6353 :
6354 : /* If we allocated a current mask array, deallocate it now. */
6355 350 : if (pcmask)
6356 : {
6357 44 : tmp = gfc_call_free (pcmask);
6358 44 : gfc_add_expr_to_block (block, tmp);
6359 : }
6360 350 : }
6361 :
6362 : /* Translate a simple WHERE construct or statement without dependencies.
6363 : CBLOCK is the "then" clause of the WHERE statement, where CBLOCK->EXPR
6364 : is the mask condition, and EBLOCK if non-NULL is the "else" clause.
6365 : Currently both CBLOCK and EBLOCK are restricted to single assignments. */
6366 :
6367 : static tree
6368 96 : gfc_trans_where_3 (gfc_code * cblock, gfc_code * eblock)
6369 : {
6370 96 : stmtblock_t block, body;
6371 96 : gfc_expr *cond, *tdst, *tsrc, *edst, *esrc;
6372 96 : tree tmp, cexpr, tstmt, estmt;
6373 96 : gfc_ss *css, *tdss, *tsss;
6374 96 : gfc_se cse, tdse, tsse, edse, esse;
6375 96 : gfc_loopinfo loop;
6376 96 : gfc_ss *edss = 0;
6377 96 : gfc_ss *esss = 0;
6378 96 : bool maybe_workshare = false;
6379 :
6380 : /* Allow the scalarizer to workshare simple where loops. */
6381 96 : if ((ompws_flags & (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_BODY))
6382 : == OMPWS_WORKSHARE_FLAG)
6383 : {
6384 13 : maybe_workshare = true;
6385 13 : ompws_flags |= OMPWS_SCALARIZER_WS | OMPWS_SCALARIZER_BODY;
6386 : }
6387 :
6388 96 : cond = cblock->expr1;
6389 96 : tdst = cblock->next->expr1;
6390 96 : tsrc = cblock->next->expr2;
6391 96 : edst = eblock ? eblock->next->expr1 : NULL;
6392 13 : esrc = eblock ? eblock->next->expr2 : NULL;
6393 :
6394 96 : gfc_start_block (&block);
6395 96 : gfc_init_loopinfo (&loop);
6396 :
6397 : /* Handle the condition. */
6398 96 : gfc_init_se (&cse, NULL);
6399 96 : css = gfc_walk_expr (cond);
6400 96 : gfc_add_ss_to_loop (&loop, css);
6401 :
6402 : /* Handle the then-clause. */
6403 96 : gfc_init_se (&tdse, NULL);
6404 96 : gfc_init_se (&tsse, NULL);
6405 96 : tdss = gfc_walk_expr (tdst);
6406 96 : tsss = gfc_walk_expr (tsrc);
6407 96 : if (tsss == gfc_ss_terminator)
6408 : {
6409 58 : tsss = gfc_get_scalar_ss (gfc_ss_terminator, tsrc);
6410 58 : tsss->info->where = 1;
6411 : }
6412 96 : gfc_add_ss_to_loop (&loop, tdss);
6413 96 : gfc_add_ss_to_loop (&loop, tsss);
6414 :
6415 96 : if (eblock)
6416 : {
6417 : /* Handle the else clause. */
6418 13 : gfc_init_se (&edse, NULL);
6419 13 : gfc_init_se (&esse, NULL);
6420 13 : edss = gfc_walk_expr (edst);
6421 13 : esss = gfc_walk_expr (esrc);
6422 13 : if (esss == gfc_ss_terminator)
6423 : {
6424 13 : esss = gfc_get_scalar_ss (gfc_ss_terminator, esrc);
6425 13 : esss->info->where = 1;
6426 : }
6427 13 : gfc_add_ss_to_loop (&loop, edss);
6428 13 : gfc_add_ss_to_loop (&loop, esss);
6429 : }
6430 :
6431 96 : gfc_conv_ss_startstride (&loop);
6432 96 : gfc_conv_loop_setup (&loop, &tdst->where);
6433 :
6434 96 : gfc_mark_ss_chain_used (css, 1);
6435 96 : gfc_mark_ss_chain_used (tdss, 1);
6436 96 : gfc_mark_ss_chain_used (tsss, 1);
6437 96 : if (eblock)
6438 : {
6439 13 : gfc_mark_ss_chain_used (edss, 1);
6440 13 : gfc_mark_ss_chain_used (esss, 1);
6441 : }
6442 :
6443 96 : gfc_start_scalarized_body (&loop, &body);
6444 :
6445 96 : gfc_copy_loopinfo_to_se (&cse, &loop);
6446 96 : gfc_copy_loopinfo_to_se (&tdse, &loop);
6447 96 : gfc_copy_loopinfo_to_se (&tsse, &loop);
6448 96 : cse.ss = css;
6449 96 : tdse.ss = tdss;
6450 96 : tsse.ss = tsss;
6451 96 : if (eblock)
6452 : {
6453 13 : gfc_copy_loopinfo_to_se (&edse, &loop);
6454 13 : gfc_copy_loopinfo_to_se (&esse, &loop);
6455 13 : edse.ss = edss;
6456 13 : esse.ss = esss;
6457 : }
6458 :
6459 96 : gfc_conv_expr (&cse, cond);
6460 96 : gfc_add_block_to_block (&body, &cse.pre);
6461 96 : cexpr = cse.expr;
6462 :
6463 96 : gfc_conv_expr (&tsse, tsrc);
6464 96 : if (tdss != gfc_ss_terminator && loop.temp_ss != NULL)
6465 0 : gfc_conv_tmp_array_ref (&tdse);
6466 : else
6467 96 : gfc_conv_expr (&tdse, tdst);
6468 :
6469 96 : if (eblock)
6470 : {
6471 13 : gfc_conv_expr (&esse, esrc);
6472 13 : if (edss != gfc_ss_terminator && loop.temp_ss != NULL)
6473 0 : gfc_conv_tmp_array_ref (&edse);
6474 : else
6475 13 : gfc_conv_expr (&edse, edst);
6476 : }
6477 :
6478 96 : tstmt = gfc_trans_scalar_assign (&tdse, &tsse, tdst->ts, false, true);
6479 96 : estmt = eblock ? gfc_trans_scalar_assign (&edse, &esse, edst->ts,
6480 : false, true)
6481 83 : : build_empty_stmt (input_location);
6482 96 : tmp = build3_v (COND_EXPR, cexpr, tstmt, estmt);
6483 96 : gfc_add_expr_to_block (&body, tmp);
6484 96 : gfc_add_block_to_block (&body, &cse.post);
6485 :
6486 96 : if (maybe_workshare)
6487 13 : ompws_flags &= ~OMPWS_SCALARIZER_BODY;
6488 96 : gfc_trans_scalarizing_loops (&loop, &body);
6489 96 : gfc_add_block_to_block (&block, &loop.pre);
6490 96 : gfc_add_block_to_block (&block, &loop.post);
6491 96 : gfc_cleanup_loop (&loop);
6492 :
6493 96 : return gfc_finish_block (&block);
6494 : }
6495 :
6496 : /* As the WHERE or WHERE construct statement can be nested, we call
6497 : gfc_trans_where_2 to do the translation, and pass the initial
6498 : NULL values for both the control mask and the pending control mask. */
6499 :
6500 : tree
6501 343 : gfc_trans_where (gfc_code * code)
6502 : {
6503 343 : stmtblock_t block;
6504 343 : gfc_code *cblock;
6505 343 : gfc_code *eblock;
6506 :
6507 343 : cblock = code->block;
6508 343 : if (cblock->next
6509 316 : && cblock->next->op == EXEC_ASSIGN
6510 271 : && !cblock->next->next)
6511 : {
6512 269 : eblock = cblock->block;
6513 269 : if (!eblock)
6514 : {
6515 : /* A simple "WHERE (cond) x = y" statement or block is
6516 : dependence free if cond is not dependent upon writing x,
6517 : and the source y is unaffected by the destination x. */
6518 164 : if (!gfc_check_dependency (cblock->next->expr1,
6519 : cblock->expr1, 0)
6520 272 : && !gfc_check_dependency (cblock->next->expr1,
6521 108 : cblock->next->expr2, 0))
6522 83 : return gfc_trans_where_3 (cblock, NULL);
6523 : }
6524 105 : else if (!eblock->expr1
6525 35 : && !eblock->block
6526 35 : && eblock->next
6527 26 : && eblock->next->op == EXEC_ASSIGN
6528 25 : && !eblock->next->next)
6529 : {
6530 : /* A simple "WHERE (cond) x1 = y1 ELSEWHERE x2 = y2 ENDWHERE"
6531 : block is dependence free if cond is not dependent on writes
6532 : to x1 and x2, y1 is not dependent on writes to x2, and y2
6533 : is not dependent on writes to x1, and both y's are not
6534 : dependent upon their own x's. In addition to this, the
6535 : final two dependency checks below exclude all but the same
6536 : array reference if the where and elswhere destinations
6537 : are the same. In short, this is VERY conservative and this
6538 : is needed because the two loops, required by the standard
6539 : are coalesced in gfc_trans_where_3. */
6540 25 : if (!gfc_check_dependency (cblock->next->expr1,
6541 : cblock->expr1, 0)
6542 25 : && !gfc_check_dependency (eblock->next->expr1,
6543 : cblock->expr1, 0)
6544 25 : && !gfc_check_dependency (cblock->next->expr1,
6545 25 : eblock->next->expr2, 1)
6546 19 : && !gfc_check_dependency (eblock->next->expr1,
6547 19 : cblock->next->expr2, 1)
6548 19 : && !gfc_check_dependency (cblock->next->expr1,
6549 19 : cblock->next->expr2, 1)
6550 19 : && !gfc_check_dependency (eblock->next->expr1,
6551 19 : eblock->next->expr2, 1)
6552 19 : && !gfc_check_dependency (cblock->next->expr1,
6553 19 : eblock->next->expr1, 0)
6554 44 : && !gfc_check_dependency (eblock->next->expr1,
6555 19 : cblock->next->expr1, 0))
6556 13 : return gfc_trans_where_3 (cblock, eblock);
6557 : }
6558 : }
6559 :
6560 247 : gfc_start_block (&block);
6561 :
6562 247 : gfc_trans_where_2 (code, NULL, false, NULL, &block);
6563 :
6564 247 : return gfc_finish_block (&block);
6565 : }
6566 :
6567 :
6568 : /* CYCLE a DO loop. The label decl has already been created by
6569 : gfc_trans_do(), it's in TREE_PURPOSE (backend_decl) of the gfc_code
6570 : node at the head of the loop. We must mark the label as used. */
6571 :
6572 : tree
6573 123 : gfc_trans_cycle (gfc_code * code)
6574 : {
6575 123 : tree cycle_label;
6576 :
6577 123 : cycle_label = code->ext.which_construct->cycle_label;
6578 123 : gcc_assert (cycle_label);
6579 :
6580 123 : TREE_USED (cycle_label) = 1;
6581 123 : return build1_v (GOTO_EXPR, cycle_label);
6582 : }
6583 :
6584 :
6585 : /* EXIT a DO loop. Similar to CYCLE, but now the label is in
6586 : TREE_VALUE (backend_decl) of the gfc_code node at the head of the
6587 : loop. */
6588 :
6589 : tree
6590 698 : gfc_trans_exit (gfc_code * code)
6591 : {
6592 698 : tree exit_label;
6593 :
6594 698 : exit_label = code->ext.which_construct->exit_label;
6595 698 : gcc_assert (exit_label);
6596 :
6597 698 : TREE_USED (exit_label) = 1;
6598 698 : return build1_v (GOTO_EXPR, exit_label);
6599 : }
6600 :
6601 :
6602 : /* Get the initializer expression for the code and expr of an allocate.
6603 : When no initializer is needed return NULL. */
6604 :
6605 : static gfc_expr *
6606 13549 : allocate_get_initializer (gfc_code * code, gfc_expr * expr)
6607 : {
6608 13549 : if (!gfc_bt_struct (expr->ts.type) && expr->ts.type != BT_CLASS)
6609 : return NULL;
6610 :
6611 : /* An explicit type was given in allocate ( T:: object). */
6612 3946 : if (code->ext.alloc.ts.type == BT_DERIVED
6613 3946 : && (code->ext.alloc.ts.u.derived->attr.alloc_comp
6614 512 : || gfc_has_default_initializer (code->ext.alloc.ts.u.derived)))
6615 362 : return gfc_default_initializer (&code->ext.alloc.ts);
6616 :
6617 593 : if (gfc_bt_struct (expr->ts.type)
6618 3584 : && (expr->ts.u.derived->attr.alloc_comp
6619 1914 : || gfc_has_default_initializer (expr->ts.u.derived)))
6620 1533 : return gfc_default_initializer (&expr->ts);
6621 :
6622 2051 : if (expr->ts.type == BT_CLASS
6623 2051 : && (CLASS_DATA (expr)->ts.u.derived->attr.alloc_comp
6624 497 : || gfc_has_default_initializer (CLASS_DATA (expr)->ts.u.derived)))
6625 181 : return gfc_default_initializer (&CLASS_DATA (expr)->ts);
6626 :
6627 : return NULL;
6628 : }
6629 :
6630 : /* Translate the ALLOCATE statement. */
6631 :
6632 : tree
6633 14433 : gfc_trans_allocate (gfc_code * code, gfc_omp_namelist *omp_allocate)
6634 : {
6635 14433 : gfc_alloc *al;
6636 14433 : gfc_expr *expr, *e3rhs = NULL, *init_expr;
6637 14433 : gfc_se se, se_sz;
6638 14433 : tree tmp;
6639 14433 : tree parm;
6640 14433 : tree stat;
6641 14433 : tree errmsg;
6642 14433 : tree errlen;
6643 14433 : tree label_errmsg;
6644 14433 : tree label_finish;
6645 14433 : tree memsz;
6646 14433 : tree al_vptr, al_len;
6647 : /* If an expr3 is present, then store the tree for accessing its
6648 : _vptr, and _len components in the variables, respectively. The
6649 : element size, i.e. _vptr%size, is stored in expr3_esize. Any of
6650 : the trees may be the NULL_TREE indicating that this is not
6651 : available for expr3's type. */
6652 14433 : tree expr3, expr3_vptr, expr3_len, expr3_esize;
6653 : /* Classify what expr3 stores. */
6654 14433 : enum { E3_UNSET = 0, E3_SOURCE, E3_MOLD, E3_DESC } e3_is;
6655 14433 : stmtblock_t block;
6656 14433 : stmtblock_t post;
6657 14433 : stmtblock_t final_block;
6658 14433 : bool upoly_expr, tmp_expr3_len_flag = false, al_len_needs_set, is_coarray;
6659 14433 : bool needs_caf_sync, caf_refs_comp;
6660 14433 : bool e3_has_nodescriptor = false;
6661 14433 : gfc_symtree *newsym = NULL;
6662 14433 : symbol_attribute caf_attr;
6663 14433 : gfc_actual_arglist *param_list;
6664 14433 : tree ts_string_length = NULL_TREE;
6665 :
6666 14433 : if (!code->ext.alloc.list)
6667 : return NULL_TREE;
6668 :
6669 14433 : stat = tmp = memsz = al_vptr = al_len = NULL_TREE;
6670 14433 : expr3 = expr3_vptr = expr3_len = expr3_esize = NULL_TREE;
6671 14433 : label_errmsg = label_finish = errmsg = errlen = NULL_TREE;
6672 14433 : e3_is = E3_UNSET;
6673 14433 : is_coarray = needs_caf_sync = false;
6674 :
6675 14433 : gfc_init_block (&block);
6676 14433 : gfc_init_block (&post);
6677 14433 : gfc_init_block (&final_block);
6678 :
6679 : /* STAT= (and maybe ERRMSG=) is present. */
6680 14433 : if (code->expr1)
6681 : {
6682 : /* STAT=. */
6683 290 : tree gfc_int4_type_node = gfc_get_int_type (4);
6684 290 : stat = gfc_create_var (gfc_int4_type_node, "stat");
6685 :
6686 : /* ERRMSG= only makes sense with STAT=. */
6687 290 : if (code->expr2)
6688 : {
6689 72 : gfc_init_se (&se, NULL);
6690 72 : se.want_pointer = 1;
6691 72 : gfc_conv_expr_lhs (&se, code->expr2);
6692 72 : errmsg = se.expr;
6693 72 : errlen = se.string_length;
6694 : }
6695 : else
6696 : {
6697 218 : errmsg = null_pointer_node;
6698 218 : errlen = build_int_cst (gfc_charlen_type_node, 0);
6699 : }
6700 :
6701 : /* GOTO destinations. */
6702 290 : label_errmsg = gfc_build_label_decl (NULL_TREE);
6703 290 : label_finish = gfc_build_label_decl (NULL_TREE);
6704 290 : TREE_USED (label_finish) = 0;
6705 : }
6706 :
6707 : /* When an expr3 is present evaluate it only once. The standards prevent a
6708 : dependency of expr3 on the objects in the allocate list. An expr3 can
6709 : be pre-evaluated in all cases. One just has to make sure, to use the
6710 : correct way, i.e., to get the descriptor or to get a reference
6711 : expression. */
6712 14433 : if (code->expr3)
6713 : {
6714 3869 : bool vtab_needed = false, temp_var_needed = false,
6715 3869 : temp_obj_created = false;
6716 :
6717 3869 : is_coarray = gfc_is_coarray (code->expr3);
6718 :
6719 293 : if (code->expr3->expr_type == EXPR_FUNCTION && !code->expr3->mold
6720 4126 : && (gfc_is_class_array_function (code->expr3)
6721 227 : || gfc_is_alloc_class_scalar_function (code->expr3)))
6722 78 : code->expr3->must_finalize = 1;
6723 :
6724 : /* Figure whether we need the vtab from expr3. */
6725 7752 : for (al = code->ext.alloc.list; !vtab_needed && al != NULL;
6726 3883 : al = al->next)
6727 3883 : vtab_needed = (al->expr->ts.type == BT_CLASS);
6728 :
6729 3869 : gfc_init_se (&se, NULL);
6730 : /* When expr3 is a variable, i.e., a very simple expression, then
6731 : convert it once here. If one has a source expression that has
6732 : substring references, part-refs, or %re/%im inquiries, wrap the
6733 : entity in parentheses to force evaluation of the expression. */
6734 3869 : if (code->expr3->expr_type == EXPR_VARIABLE
6735 3869 : && is_subref_array (code->expr3))
6736 60 : code->expr3 = gfc_get_parentheses (code->expr3);
6737 :
6738 3869 : if (code->expr3->expr_type == EXPR_VARIABLE
6739 2558 : || code->expr3->expr_type == EXPR_ARRAY
6740 1518 : || code->expr3->expr_type == EXPR_CONSTANT)
6741 : {
6742 2795 : if (!code->expr3->mold
6743 247 : || code->expr3->ts.type == BT_CHARACTER
6744 119 : || vtab_needed
6745 71 : || code->ext.alloc.arr_spec_from_expr3)
6746 : {
6747 : /* Convert expr3 to a tree. For all "simple" expression just
6748 : get the descriptor or the reference, respectively, depending
6749 : on the rank of the expr. */
6750 2795 : if (code->ext.alloc.arr_spec_from_expr3 || code->expr3->rank != 0)
6751 1605 : gfc_conv_expr_descriptor (&se, code->expr3);
6752 : else
6753 : {
6754 1190 : gfc_conv_expr_reference (&se, code->expr3);
6755 :
6756 : /* gfc_conv_expr_reference wraps POINTER_PLUS_EXPR in a
6757 : NOP_EXPR, which prevents gfortran from getting the vptr
6758 : from the source=-expression. Remove the NOP_EXPR and go
6759 : with the POINTER_PLUS_EXPR in this case. */
6760 1190 : if (code->expr3->ts.type == BT_CLASS
6761 256 : && TREE_CODE (se.expr) == NOP_EXPR
6762 1346 : && (TREE_CODE (TREE_OPERAND (se.expr, 0))
6763 : == POINTER_PLUS_EXPR
6764 138 : || is_coarray))
6765 30 : se.expr = TREE_OPERAND (se.expr, 0);
6766 : }
6767 : /* Create a temp variable only for component refs to prevent
6768 : having to go through the full deref-chain each time and to
6769 : simplify computation of array properties. */
6770 2795 : temp_var_needed = TREE_CODE (se.expr) == COMPONENT_REF;
6771 : }
6772 : }
6773 : else
6774 : {
6775 : /* In all other cases evaluate the expr3. */
6776 1074 : symbol_attribute attr;
6777 : /* Get the descriptor for all arrays, that are not allocatable or
6778 : pointer, because the latter are descriptors already.
6779 : The exception are function calls returning a class object:
6780 : The descriptor is stored in their results _data component, which
6781 : is easier to access, when first a temporary variable for the
6782 : result is created and the descriptor retrieved from there. */
6783 1074 : attr = gfc_expr_attr (code->expr3);
6784 1074 : if (code->expr3->rank != 0
6785 248 : && ((!attr.allocatable && !attr.pointer)
6786 71 : || (code->expr3->expr_type == EXPR_FUNCTION
6787 71 : && (code->expr3->ts.type != BT_CLASS
6788 53 : || (code->expr3->value.function.isym
6789 12 : && code->expr3->value.function.isym
6790 12 : ->transformational)))))
6791 207 : gfc_conv_expr_descriptor (&se, code->expr3);
6792 : else
6793 867 : gfc_conv_expr_reference (&se, code->expr3);
6794 1074 : if (code->expr3->ts.type == BT_CLASS)
6795 132 : gfc_conv_class_to_class (&se, code->expr3,
6796 : code->expr3->ts,
6797 : false, true,
6798 : false, false);
6799 1074 : temp_obj_created = temp_var_needed = !VAR_P (se.expr);
6800 : }
6801 3869 : gfc_add_block_to_block (&block, &se.pre);
6802 3869 : if (code->expr3->must_finalize)
6803 : {
6804 78 : gfc_add_block_to_block (&final_block, &se.finalblock);
6805 78 : gfc_add_block_to_block (&final_block, &se.post);
6806 : }
6807 : else
6808 3791 : gfc_add_block_to_block (&post, &se.post);
6809 :
6810 : /* Special case when string in expr3 is scalar and has length zero. */
6811 3869 : if (code->expr3->ts.type == BT_CHARACTER
6812 845 : && code->expr3->rank == 0
6813 4365 : && integer_zerop (se.string_length))
6814 : {
6815 6 : gfc_init_se (&se, NULL);
6816 6 : temp_var_needed = false;
6817 6 : expr3_len = build_zero_cst (gfc_charlen_type_node);
6818 6 : e3_is = E3_MOLD;
6819 : }
6820 : /* Prevent aliasing, i.e., se.expr may be already a
6821 : variable declaration. */
6822 3863 : else if (se.expr != NULL_TREE && temp_var_needed)
6823 : {
6824 928 : tree var, desc;
6825 928 : tmp = (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr))
6826 866 : || is_coarray
6827 854 : || (code->expr3->ts.type == BT_CHARACTER
6828 950 : && code->expr3->rank == 0)) ?
6829 : se.expr
6830 832 : : build_fold_indirect_ref_loc (input_location, se.expr);
6831 :
6832 : /* Get the array descriptor and prepare it to be assigned to the
6833 : temporary variable var. For classes the array descriptor is
6834 : in the _data component and the object goes into the
6835 : GFC_DECL_SAVED_DESCRIPTOR. */
6836 928 : if (code->expr3->ts.type == BT_CLASS
6837 187 : && code->expr3->rank != 0)
6838 : {
6839 : /* When an array_ref was in expr3, then the descriptor is the
6840 : first operand. */
6841 96 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)) || is_coarray)
6842 : {
6843 49 : desc = TREE_OPERAND (tmp, 0);
6844 : }
6845 : else
6846 : {
6847 47 : desc = tmp;
6848 47 : tmp = gfc_class_data_get (tmp);
6849 : }
6850 96 : if (code->ext.alloc.arr_spec_from_expr3)
6851 39 : e3_is = E3_DESC;
6852 : }
6853 : else
6854 844 : desc = !is_coarray ? se.expr
6855 12 : : TREE_OPERAND (TREE_OPERAND (se.expr, 0), 0);
6856 : /* We need a regular (non-UID) symbol here, therefore give a
6857 : prefix. */
6858 928 : var = gfc_create_var (TREE_TYPE (tmp), "source");
6859 928 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)) || is_coarray)
6860 : {
6861 121 : gfc_allocate_lang_decl (var);
6862 121 : GFC_DECL_SAVED_DESCRIPTOR (var) = desc;
6863 : }
6864 928 : gfc_add_modify_loc (input_location, &block, var, tmp);
6865 :
6866 928 : expr3 = var;
6867 928 : if (se.string_length)
6868 : /* Evaluate it assuming that it also is complicated like expr3. */
6869 29 : expr3_len = gfc_evaluate_now (se.string_length, &block);
6870 : }
6871 : else
6872 : {
6873 2935 : expr3 = se.expr;
6874 2935 : expr3_len = se.string_length;
6875 : }
6876 :
6877 : /* Deallocate any allocatable components in expressions that use a
6878 : temporary object, i.e. are not a simple alias of to an EXPR_VARIABLE.
6879 : E.g. temporaries of a function call need freeing of their components
6880 : here. Explicit derived type allocation of class entities uses expr3
6881 : to carry the default initializer. This must not be deallocated or
6882 : finalized. */
6883 3869 : if ((code->expr3->ts.type == BT_DERIVED
6884 2560 : || code->expr3->ts.type == BT_CLASS)
6885 1836 : && (code->expr3->expr_type != EXPR_VARIABLE || temp_obj_created)
6886 1235 : && (code->expr3->ts.u.derived->attr.alloc_comp
6887 903 : || code->expr3->ts.u.derived->attr.pdt_type)
6888 338 : && !code->expr3->must_finalize
6889 3967 : && !gfc_expr_attr (code->expr3).pointer
6890 4189 : && !code->ext.alloc.expr3_not_explicit)
6891 : {
6892 444 : tmp = gfc_deallocate_alloc_comp (code->expr3->ts.u.derived,
6893 222 : expr3, code->expr3->rank);
6894 222 : gfc_prepend_expr_to_block (&post, tmp);
6895 : }
6896 :
6897 : /* Store what the expr3 is to be used for. */
6898 3869 : if (e3_is == E3_UNSET)
6899 6288 : e3_is = expr3 != NULL_TREE ?
6900 3824 : (code->ext.alloc.arr_spec_from_expr3 ?
6901 : E3_DESC
6902 2650 : : (code->expr3->mold ? E3_MOLD : E3_SOURCE))
6903 : : E3_UNSET;
6904 :
6905 : /* Figure how to get the _vtab entry. This also obtains the tree
6906 : expression for accessing the _len component, because only
6907 : unlimited polymorphic objects, which are a subcategory of class
6908 : types, have a _len component. */
6909 3869 : if (code->expr3->ts.type == BT_CLASS)
6910 : {
6911 527 : gfc_expr *rhs;
6912 783 : tmp = expr3 != NULL_TREE && POINTER_TYPE_P (TREE_TYPE (expr3)) ?
6913 256 : build_fold_indirect_ref (expr3): expr3;
6914 : /* Polymorphic SOURCE: VPTR must be determined at run time.
6915 : expr3 may be a temporary array declaration, therefore check for
6916 : GFC_CLASS_TYPE_P before trying to get the _vptr component. */
6917 527 : if (tmp != NULL_TREE
6918 527 : && (e3_is == E3_DESC
6919 440 : || (GFC_CLASS_TYPE_P (TREE_TYPE (tmp))
6920 280 : && (VAR_P (tmp) || !code->expr3->ref))
6921 186 : || (VAR_P (tmp) && DECL_LANG_SPECIFIC (tmp))))
6922 446 : tmp = gfc_class_vptr_get (expr3);
6923 : else
6924 : {
6925 81 : rhs = gfc_find_and_cut_at_last_class_ref (code->expr3);
6926 81 : gfc_add_vptr_component (rhs);
6927 81 : gfc_init_se (&se, NULL);
6928 81 : se.want_pointer = 1;
6929 81 : gfc_conv_expr (&se, rhs);
6930 81 : tmp = se.expr;
6931 81 : gfc_free_expr (rhs);
6932 : }
6933 : /* Set the element size. */
6934 527 : expr3_esize = gfc_vptr_size_get (tmp);
6935 527 : if (vtab_needed)
6936 521 : expr3_vptr = tmp;
6937 : /* Initialize the ref to the _len component. */
6938 527 : if (expr3_len == NULL_TREE && UNLIMITED_POLY (code->expr3))
6939 : {
6940 : /* Same like for retrieving the _vptr. */
6941 164 : if (expr3 != NULL_TREE && !code->expr3->ref)
6942 92 : expr3_len = gfc_class_len_get (expr3);
6943 : else
6944 : {
6945 72 : rhs = gfc_find_and_cut_at_last_class_ref (code->expr3);
6946 72 : gfc_add_len_component (rhs);
6947 72 : gfc_init_se (&se, NULL);
6948 72 : gfc_conv_expr (&se, rhs);
6949 72 : expr3_len = se.expr;
6950 72 : gfc_free_expr (rhs);
6951 : }
6952 : }
6953 : }
6954 : else
6955 : {
6956 : /* When the object to allocate is polymorphic type, then it
6957 : needs its vtab set correctly, so deduce the required _vtab
6958 : and _len from the source expression. */
6959 3342 : if (vtab_needed)
6960 : {
6961 : /* VPTR is fixed at compile time. */
6962 1225 : gfc_symbol *vtab;
6963 :
6964 1225 : vtab = gfc_find_vtab (&code->expr3->ts);
6965 1225 : gcc_assert (vtab);
6966 1225 : expr3_vptr = gfc_get_symbol_decl (vtab);
6967 1225 : expr3_vptr = gfc_build_addr_expr (NULL_TREE,
6968 : expr3_vptr);
6969 : }
6970 : /* _len component needs to be set, when ts is a character
6971 : array. */
6972 3342 : if (expr3_len == NULL_TREE
6973 2497 : && code->expr3->ts.type == BT_CHARACTER)
6974 : {
6975 0 : if (code->expr3->ts.u.cl
6976 0 : && code->expr3->ts.u.cl->length)
6977 : {
6978 0 : gfc_init_se (&se, NULL);
6979 0 : gfc_conv_expr (&se, code->expr3->ts.u.cl->length);
6980 0 : gfc_add_block_to_block (&block, &se.pre);
6981 0 : expr3_len = gfc_evaluate_now (se.expr, &block);
6982 : }
6983 0 : gcc_assert (expr3_len);
6984 : }
6985 : /* For character arrays only the kind's size is needed, because
6986 : the array mem_size is _len * (elem_size = kind_size).
6987 : For all other get the element size in the normal way. */
6988 3342 : if (code->expr3->ts.type == BT_CHARACTER)
6989 845 : expr3_esize = TYPE_SIZE_UNIT (
6990 : gfc_get_char_type (code->expr3->ts.kind));
6991 : else
6992 2497 : expr3_esize = TYPE_SIZE_UNIT (
6993 : gfc_typenode_for_spec (&code->expr3->ts));
6994 : }
6995 3869 : gcc_assert (expr3_esize);
6996 3869 : expr3_esize = fold_convert (sizetype, expr3_esize);
6997 3869 : if (e3_is == E3_MOLD)
6998 : /* The expr3 is no longer valid after this point. */
6999 192 : expr3 = NULL_TREE;
7000 : }
7001 10564 : else if (code->ext.alloc.ts.type != BT_UNKNOWN)
7002 : {
7003 : /* Compute the explicit typespec given only once for all objects
7004 : to allocate. */
7005 1270 : if (code->ext.alloc.ts.type != BT_CHARACTER)
7006 815 : expr3_esize = TYPE_SIZE_UNIT (
7007 : gfc_typenode_for_spec (&code->ext.alloc.ts));
7008 455 : else if (code->ext.alloc.ts.u.cl->length != NULL)
7009 : {
7010 449 : gfc_expr *sz;
7011 449 : sz = gfc_copy_expr (code->ext.alloc.ts.u.cl->length);
7012 449 : gfc_init_se (&se_sz, NULL);
7013 449 : gfc_conv_expr (&se_sz, sz);
7014 449 : gfc_free_expr (sz);
7015 449 : ts_string_length = fold_convert (gfc_charlen_type_node, se_sz.expr);
7016 449 : tmp = gfc_get_char_type (code->ext.alloc.ts.kind);
7017 449 : tmp = TYPE_SIZE_UNIT (tmp);
7018 449 : tmp = fold_convert (TREE_TYPE (se_sz.expr), tmp);
7019 449 : gfc_add_block_to_block (&block, &se_sz.pre);
7020 449 : expr3_esize = fold_build2_loc (input_location, MULT_EXPR,
7021 449 : TREE_TYPE (se_sz.expr),
7022 : tmp, se_sz.expr);
7023 449 : expr3_esize = gfc_evaluate_now (expr3_esize, &block);
7024 : }
7025 : else
7026 : expr3_esize = NULL_TREE;
7027 : }
7028 :
7029 : /* The routine gfc_trans_assignment () already implements all
7030 : techniques needed. Unfortunately we may have a temporary
7031 : variable for the source= expression here. When that is the
7032 : case convert this variable into a temporary gfc_expr of type
7033 : EXPR_VARIABLE and used it as rhs for the assignment. The
7034 : advantage is, that we get scalarizer support for free,
7035 : don't have to take care about scalar to array treatment and
7036 : will benefit of every enhancements gfc_trans_assignment ()
7037 : gets.
7038 : No need to check whether e3_is is E3_UNSET, because that is
7039 : done by expr3 != NULL_TREE.
7040 : Exclude variables since the following block does not handle
7041 : array sections. In any case, there is no harm in sending
7042 : variables to gfc_trans_assignment because there is no
7043 : evaluation of variables. */
7044 14433 : if (code->expr3)
7045 : {
7046 3869 : if (code->expr3->expr_type != EXPR_VARIABLE
7047 2558 : && e3_is != E3_MOLD && expr3 != NULL_TREE
7048 6353 : && DECL_P (expr3) && DECL_ARTIFICIAL (expr3))
7049 : {
7050 : /* Build a temporary symtree and symbol. Do not add it to the current
7051 : namespace to prevent accidentally modifying a colliding
7052 : symbol's as. */
7053 : /* The name of the symtree should be unique, because gfc_create_var ()
7054 : took care about generating the identifier. */
7055 2080 : if (DECL_NAME (expr3) && IDENTIFIER_POINTER (DECL_NAME (expr3)))
7056 : {
7057 2068 : const char *name = IDENTIFIER_POINTER (DECL_NAME (expr3));
7058 2068 : newsym = XCNEW (gfc_symtree);
7059 2068 : newsym->name = gfc_get_string ("%s", name);
7060 : }
7061 : else
7062 12 : newsym = gfc_get_unique_symtree (NULL);
7063 2080 : newsym->n.sym = gfc_new_symbol (newsym->name, NULL);
7064 : /* The backend_decl is known. It is expr3, which is inserted
7065 : here. */
7066 2080 : newsym->n.sym->backend_decl = expr3;
7067 2080 : e3rhs = gfc_get_expr ();
7068 2080 : e3rhs->rank = code->expr3->rank;
7069 2080 : e3rhs->corank = code->expr3->corank;
7070 2080 : e3rhs->symtree = newsym;
7071 : /* Mark the symbol referenced or gfc_trans_assignment will bug. */
7072 2080 : newsym->n.sym->attr.referenced = 1;
7073 2080 : e3rhs->expr_type = EXPR_VARIABLE;
7074 2080 : e3rhs->where = code->expr3->where;
7075 : /* Set the symbols type, upto it was BT_UNKNOWN. */
7076 2080 : if (IS_CLASS_ARRAY (code->expr3)
7077 54 : && code->expr3->expr_type == EXPR_FUNCTION
7078 42 : && code->expr3->value.function.isym
7079 12 : && code->expr3->value.function.isym->transformational)
7080 : {
7081 12 : e3rhs->ts = CLASS_DATA (code->expr3)->ts;
7082 : }
7083 2068 : else if (code->expr3->ts.type == BT_CLASS
7084 2068 : && !GFC_CLASS_TYPE_P (TREE_TYPE (expr3)))
7085 46 : e3rhs->ts = CLASS_DATA (code->expr3)->ts;
7086 : else
7087 2022 : e3rhs->ts = code->expr3->ts;
7088 2080 : newsym->n.sym->ts = e3rhs->ts;
7089 : /* Check whether the expr3 is array valued. */
7090 2080 : if (e3rhs->rank)
7091 : {
7092 1281 : gfc_array_spec *arr;
7093 1281 : arr = gfc_get_array_spec ();
7094 1281 : arr->rank = e3rhs->rank;
7095 1281 : arr->corank = e3rhs->corank;
7096 1281 : arr->type = AS_DEFERRED;
7097 : /* Set the dimension and pointer attribute for arrays
7098 : to be on the safe side. */
7099 1281 : newsym->n.sym->attr.dimension = 1;
7100 1281 : newsym->n.sym->attr.pointer = 1;
7101 1281 : newsym->n.sym->as = arr;
7102 1281 : if (IS_CLASS_ARRAY (code->expr3)
7103 54 : && code->expr3->expr_type == EXPR_FUNCTION
7104 42 : && code->expr3->value.function.isym
7105 12 : && code->expr3->value.function.isym->transformational)
7106 : {
7107 12 : gfc_array_spec *tarr;
7108 12 : tarr = gfc_get_array_spec ();
7109 12 : *tarr = *arr;
7110 12 : e3rhs->ts.u.derived->as = tarr;
7111 : }
7112 1281 : gfc_add_full_array_ref (e3rhs, arr);
7113 : }
7114 799 : else if (POINTER_TYPE_P (TREE_TYPE (expr3)))
7115 57 : newsym->n.sym->attr.pointer = 1;
7116 : /* The string length is known, too. Set it for char arrays. */
7117 2080 : if (e3rhs->ts.type == BT_CHARACTER)
7118 331 : newsym->n.sym->ts.u.cl->backend_decl = expr3_len;
7119 2080 : gfc_commit_symbol (newsym->n.sym);
7120 : }
7121 : else
7122 1789 : e3rhs = gfc_copy_expr (code->expr3);
7123 :
7124 : // We need to propagate the bounds of the expr3 for source=/mold=.
7125 : // However, for non-named arrays, the lbound has to be 1 and neither the
7126 : // bound used inside the called function even when returning an
7127 : // allocatable/pointer nor the zero used internally.
7128 3869 : if (e3_is == E3_DESC
7129 1213 : && code->expr3->expr_type != EXPR_VARIABLE)
7130 14433 : e3_has_nodescriptor = true;
7131 : }
7132 :
7133 : /* Loop over all objects to allocate. */
7134 31847 : for (al = code->ext.alloc.list; al != NULL; al = al->next)
7135 : {
7136 17414 : expr = gfc_copy_expr (al->expr);
7137 : /* UNLIMITED_POLY () needs the _data component to be set, when
7138 : expr is a unlimited polymorphic object. But the _data component
7139 : has not been set yet, so check the derived type's attr for the
7140 : unlimited polymorphic flag to be safe. */
7141 17414 : upoly_expr = UNLIMITED_POLY (expr)
7142 34228 : || (expr->ts.type == BT_DERIVED
7143 2699 : && expr->ts.u.derived->attr.unlimited_polymorphic);
7144 17414 : gfc_init_se (&se, NULL);
7145 :
7146 : /* For class types prepare the expressions to ref the _vptr
7147 : and the _len component. The latter for unlimited polymorphic
7148 : types only. */
7149 17414 : if (expr->ts.type == BT_CLASS)
7150 : {
7151 3540 : gfc_expr *expr_ref_vptr, *expr_ref_len;
7152 3540 : gfc_add_data_component (expr);
7153 : /* Prep the vptr handle. */
7154 3540 : expr_ref_vptr = gfc_copy_expr (al->expr);
7155 3540 : gfc_add_vptr_component (expr_ref_vptr);
7156 3540 : se.want_pointer = 1;
7157 3540 : gfc_conv_expr (&se, expr_ref_vptr);
7158 3540 : al_vptr = se.expr;
7159 3540 : se.want_pointer = 0;
7160 3540 : gfc_free_expr (expr_ref_vptr);
7161 : /* Allocated unlimited polymorphic objects always have a _len
7162 : component. */
7163 3540 : if (upoly_expr)
7164 : {
7165 600 : expr_ref_len = gfc_copy_expr (al->expr);
7166 600 : gfc_add_len_component (expr_ref_len);
7167 600 : gfc_conv_expr (&se, expr_ref_len);
7168 600 : al_len = se.expr;
7169 600 : gfc_free_expr (expr_ref_len);
7170 : }
7171 : else
7172 : /* In a loop ensure that all loop variable dependent variables
7173 : are initialized at the same spot in all execution paths. */
7174 : al_len = NULL_TREE;
7175 : }
7176 : else
7177 : al_vptr = al_len = NULL_TREE;
7178 :
7179 17414 : se.want_pointer = 1;
7180 17414 : se.descriptor_only = 1;
7181 :
7182 17414 : gfc_conv_expr (&se, expr);
7183 17414 : if (expr->ts.type == BT_CHARACTER && expr->ts.deferred)
7184 : /* se.string_length now stores the .string_length variable of expr
7185 : needed to allocate character(len=:) arrays. */
7186 1086 : al_len = se.string_length;
7187 :
7188 17414 : al_len_needs_set = al_len != NULL_TREE;
7189 : /* When allocating an array one cannot use much of the
7190 : pre-evaluated expr3 expressions, because for most of them the
7191 : scalarizer is needed which is not available in the pre-evaluation
7192 : step. Therefore gfc_array_allocate () is responsible (and able)
7193 : to handle the complete array allocation. Only the element size
7194 : needs to be provided, which is done most of the time by the
7195 : pre-evaluation step. */
7196 17414 : if (expr3_len && (code->expr3->ts.type == BT_CHARACTER
7197 1015 : || code->expr3->ts.type == BT_CLASS))
7198 : {
7199 : /* When al is an array, then the element size for each element
7200 : in the array is needed, which is the product of the len and
7201 : esize for char arrays. For unlimited polymorphics len can be
7202 : zero, therefore take the maximum of len and one. */
7203 1015 : tree lhs_len;
7204 :
7205 : /* If an allocatable character variable has fixed length, use it.
7206 : Otherwise use source length. As different lengths are not
7207 : allowed by the standard, generate a runtime check. */
7208 1015 : if (expr->ts.type == BT_CHARACTER && !expr->ts.deferred)
7209 : {
7210 135 : gfc_trans_same_strlen_check ("ALLOCATE with SOURCE= or MOLD=",
7211 : &code->expr3->where,
7212 : se.string_length, expr3_len,
7213 : &block);
7214 135 : lhs_len = fold_convert (TREE_TYPE (expr3_len), se.string_length);
7215 : }
7216 : else
7217 : lhs_len = expr3_len;
7218 :
7219 2030 : tmp = fold_build2_loc (input_location, MAX_EXPR,
7220 1015 : TREE_TYPE (expr3_len),
7221 1015 : lhs_len, fold_convert (TREE_TYPE (expr3_len),
7222 : integer_one_node));
7223 2030 : tmp = fold_build2_loc (input_location, MULT_EXPR,
7224 1015 : TREE_TYPE (expr3_esize), expr3_esize,
7225 1015 : fold_convert (TREE_TYPE (expr3_esize), tmp));
7226 1015 : }
7227 : else
7228 : tmp = expr3_esize;
7229 :
7230 : /* Create runtime check for ALLOCATE of character with type-spec. */
7231 17414 : if (expr->ts.type == BT_CHARACTER && !expr->ts.deferred
7232 770 : && ts_string_length
7233 19 : && se.string_length)
7234 19 : gfc_trans_same_strlen_check ("ALLOCATE with type-spec",
7235 19 : &al->expr->where,
7236 : ts_string_length, se.string_length,
7237 : &block);
7238 :
7239 17414 : gfc_omp_namelist *omp_alloc_item = NULL;
7240 17414 : if (omp_allocate)
7241 : {
7242 : gfc_omp_namelist *n = NULL;
7243 : gfc_omp_namelist *n_null = NULL;
7244 130 : for (n = omp_allocate; n; n = n->next)
7245 : {
7246 88 : if (n->sym == NULL)
7247 : {
7248 41 : n_null = n;
7249 41 : continue;
7250 : }
7251 47 : if (expr->expr_type == EXPR_VARIABLE
7252 47 : && expr->symtree->n.sym == n->sym)
7253 : {
7254 25 : gfc_ref *ref;
7255 38 : for (ref = expr->ref; ref; ref = ref->next)
7256 16 : if (ref->type == REF_COMPONENT)
7257 : break;
7258 : if (ref == NULL)
7259 : break;
7260 : }
7261 : }
7262 64 : omp_alloc_item = n ? n : n_null;
7263 :
7264 : }
7265 :
7266 17414 : if (!gfc_array_allocate (&se, expr, stat, errmsg, errlen, label_finish,
7267 : tmp, e3rhs ? e3rhs : code->expr3,
7268 : e3_is == E3_DESC ? expr3 : NULL_TREE,
7269 : e3_has_nodescriptor, omp_alloc_item,
7270 17414 : code->ext.alloc.ts.type != BT_UNKNOWN))
7271 : {
7272 : /* A scalar or derived type. First compute the size to
7273 : allocate.
7274 :
7275 : expr3_len is set when expr3 is an unlimited polymorphic
7276 : object or a deferred length string.
7277 :
7278 : If an allocatable character variable has fixed length, use it.
7279 : Otherwise use source length. As different lengths are not
7280 : allowed by the standard, a runtime check was inserted
7281 : above. */
7282 5188 : if (expr3_len != NULL_TREE)
7283 : {
7284 539 : tree lhs_len;
7285 539 : if (expr->ts.type == BT_CHARACTER && !expr->ts.deferred)
7286 56 : lhs_len = fold_convert (TREE_TYPE (expr3_len),
7287 : se.string_length);
7288 : else
7289 : lhs_len = expr3_len;
7290 :
7291 539 : tmp = fold_convert (TREE_TYPE (expr3_esize), lhs_len);
7292 539 : tmp = fold_build2_loc (input_location, MULT_EXPR,
7293 539 : TREE_TYPE (expr3_esize),
7294 : expr3_esize, tmp);
7295 539 : if (code->expr3->ts.type != BT_CLASS)
7296 : /* expr3 is a deferred length string, i.e., we are
7297 : done. */
7298 : memsz = tmp;
7299 : else
7300 : {
7301 : /* For unlimited polymorphic enties build
7302 : (len > 0) ? element_size * len : element_size
7303 : to compute the number of bytes to allocate.
7304 : This allows the allocation of unlimited polymorphic
7305 : objects from an expr3 that is also unlimited
7306 : polymorphic and stores a _len dependent object,
7307 : e.g., a string. */
7308 98 : memsz = fold_build2_loc (input_location, GT_EXPR,
7309 : logical_type_node, expr3_len,
7310 : build_zero_cst
7311 98 : (TREE_TYPE (expr3_len)));
7312 98 : memsz = fold_build3_loc (input_location, COND_EXPR,
7313 98 : TREE_TYPE (expr3_esize),
7314 : memsz, tmp, expr3_esize);
7315 : }
7316 : }
7317 4649 : else if (expr3_esize != NULL_TREE)
7318 : /* Any other object in expr3 just needs element size in
7319 : bytes. */
7320 : memsz = expr3_esize;
7321 2839 : else if ((expr->ts.type == BT_CHARACTER && expr->ts.deferred)
7322 2839 : || (upoly_expr
7323 0 : && code->ext.alloc.ts.type == BT_CHARACTER))
7324 : {
7325 : /* Allocating deferred length char arrays need the length
7326 : to allocate in the alloc_type_spec. But also unlimited
7327 : polymorphic objects may be allocated as char arrays.
7328 : Both are handled here. */
7329 0 : gfc_init_se (&se_sz, NULL);
7330 0 : gfc_conv_expr (&se_sz, code->ext.alloc.ts.u.cl->length);
7331 0 : gfc_add_block_to_block (&se.pre, &se_sz.pre);
7332 0 : se_sz.expr = gfc_evaluate_now (se_sz.expr, &se.pre);
7333 0 : gfc_add_block_to_block (&se.pre, &se_sz.post);
7334 0 : expr3_len = se_sz.expr;
7335 0 : tmp_expr3_len_flag = true;
7336 0 : tmp = TYPE_SIZE_UNIT (
7337 : gfc_get_char_type (code->ext.alloc.ts.kind));
7338 0 : memsz = fold_build2_loc (input_location, MULT_EXPR,
7339 0 : TREE_TYPE (tmp),
7340 0 : fold_convert (TREE_TYPE (tmp),
7341 : expr3_len),
7342 : tmp);
7343 : }
7344 2839 : else if (expr->ts.type == BT_CHARACTER)
7345 : {
7346 : /* Compute the number of bytes needed to allocate a fixed
7347 : length char array. */
7348 170 : gcc_assert (se.string_length != NULL_TREE);
7349 170 : tmp = TYPE_SIZE_UNIT (gfc_get_char_type (expr->ts.kind));
7350 340 : memsz = fold_build2_loc (input_location, MULT_EXPR,
7351 170 : TREE_TYPE (tmp), tmp,
7352 170 : fold_convert (TREE_TYPE (tmp),
7353 : se.string_length));
7354 : }
7355 2669 : else if (code->ext.alloc.ts.type != BT_UNKNOWN)
7356 : /* Handle all types, where the alloc_type_spec is set. */
7357 0 : memsz = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->ext.alloc.ts));
7358 : else
7359 : /* Handle size computation of the type declared to alloc. */
7360 2669 : memsz = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (se.expr)));
7361 :
7362 5188 : bool use_coarray_alloc
7363 5188 : = (flag_coarray == GFC_FCOARRAY_LIB
7364 5188 : && (caf_attr = gfc_caf_attr (expr, true, &caf_refs_comp))
7365 77 : .codimension);
7366 5188 : tree omp_cond = NULL_TREE;
7367 5188 : tree omp_alt_alloc = NULL_TREE;
7368 5188 : tree succ_add_expr = NULL_TREE;
7369 5188 : if (!use_coarray_alloc && omp_alloc_item)
7370 : {
7371 28 : tree align, alloc, sz;
7372 28 : gfc_se se2;
7373 :
7374 28 : omp_cond = boolean_true_node;
7375 28 : if (omp_alloc_item->u2.allocator)
7376 : {
7377 2 : gfc_init_se (&se2, NULL);
7378 2 : gfc_conv_expr (&se2, omp_alloc_item->u2.allocator);
7379 2 : gfc_add_block_to_block (&se.pre, &se2.pre);
7380 2 : alloc = gfc_evaluate_now (se2.expr, &se.pre);
7381 2 : gfc_add_block_to_block (&se.pre, &se2.post);
7382 : }
7383 : else
7384 26 : alloc = build_zero_cst (ptr_type_node);
7385 28 : tmp = TREE_TYPE (TREE_TYPE (se.expr));
7386 28 : if (tmp == void_type_node)
7387 3 : tmp = gfc_typenode_for_spec (&expr->ts, 0);
7388 28 : if (omp_alloc_item->u.align)
7389 : {
7390 14 : gfc_init_se (&se2, NULL);
7391 14 : gfc_conv_expr (&se2, omp_alloc_item->u.align);
7392 14 : gcc_assert (CONSTANT_CLASS_P (se2.expr)
7393 : && se2.pre.head == NULL
7394 : && se2.post.head == NULL);
7395 14 : align = build_int_cst (size_type_node,
7396 14 : MAX (tree_to_uhwi (se2.expr),
7397 : TYPE_ALIGN_UNIT (tmp)));
7398 : }
7399 : else
7400 14 : align = build_int_cst (size_type_node, TYPE_ALIGN_UNIT (tmp));
7401 28 : sz = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
7402 : fold_convert (size_type_node, memsz),
7403 : build_int_cst (size_type_node, 1));
7404 28 : omp_alt_alloc = builtin_decl_explicit (BUILT_IN_GOMP_ALLOC);
7405 28 : DECL_ATTRIBUTES (omp_alt_alloc)
7406 28 : = tree_cons (get_identifier ("omp allocator"),
7407 : build_tree_list (NULL_TREE, alloc),
7408 28 : DECL_ATTRIBUTES (omp_alt_alloc));
7409 28 : omp_alt_alloc = build_call_expr (omp_alt_alloc, 3, align, sz, alloc);
7410 28 : succ_add_expr = gfc_omp_call_add_alloc (se.expr);
7411 : }
7412 :
7413 : /* Store the caf-attributes for latter use. */
7414 5188 : if (use_coarray_alloc)
7415 : {
7416 : /* Scalar allocatable components in coarray'ed derived types make
7417 : it here and are treated now. */
7418 68 : tree caf_decl, token;
7419 68 : gfc_se caf_se;
7420 :
7421 68 : is_coarray = true;
7422 : /* Set flag, to add synchronize after the allocate. */
7423 136 : needs_caf_sync = needs_caf_sync
7424 68 : || caf_attr.coarray_comp || !caf_refs_comp;
7425 :
7426 68 : gfc_init_se (&caf_se, NULL);
7427 :
7428 68 : caf_decl = gfc_get_tree_for_caf_expr (expr);
7429 68 : gfc_get_caf_token_offset (&caf_se, &token, NULL, caf_decl,
7430 : NULL_TREE, NULL);
7431 68 : gfc_add_block_to_block (&se.pre, &caf_se.pre);
7432 68 : gfc_allocate_allocatable (&se.pre, se.expr, memsz,
7433 : gfc_build_addr_expr (NULL_TREE, token),
7434 : NULL_TREE, NULL_TREE, NULL_TREE,
7435 : label_finish, expr, 1);
7436 : }
7437 : /* Allocate - for non-pointers with re-alloc checking. */
7438 5120 : else if (gfc_expr_attr (expr).allocatable)
7439 3531 : gfc_allocate_allocatable (&se.pre, se.expr, memsz,
7440 : NULL_TREE, stat, errmsg, errlen,
7441 : label_finish, expr, 0,
7442 : omp_cond, omp_alt_alloc, succ_add_expr);
7443 : else
7444 1589 : gfc_allocate_using_malloc (&se.pre, se.expr, memsz, stat,
7445 : omp_cond, omp_alt_alloc, succ_add_expr);
7446 : }
7447 : else
7448 : {
7449 : /* Allocating coarrays needs a sync after the allocate executed.
7450 : Set the flag to add the sync after all objects are allocated. */
7451 12226 : if (flag_coarray == GFC_FCOARRAY_LIB
7452 12226 : && (caf_attr = gfc_caf_attr (expr, true, &caf_refs_comp))
7453 487 : .codimension)
7454 : {
7455 425 : is_coarray = true;
7456 425 : needs_caf_sync = needs_caf_sync
7457 425 : || caf_attr.coarray_comp || !caf_refs_comp;
7458 : }
7459 :
7460 12226 : if (expr->ts.type == BT_CHARACTER && al_len != NULL_TREE
7461 1079 : && expr3_len != NULL_TREE)
7462 : {
7463 : /* Arrays need to have a _len set before the array
7464 : descriptor is filled. */
7465 310 : gfc_add_modify (&block, al_len,
7466 310 : fold_convert (TREE_TYPE (al_len), expr3_len));
7467 : /* Prevent setting the length twice. */
7468 310 : al_len_needs_set = false;
7469 : }
7470 11916 : else if (expr->ts.type == BT_CHARACTER && al_len != NULL_TREE
7471 235 : && code->ext.alloc.ts.u.cl->length)
7472 : {
7473 : /* Cover the cases where a string length is explicitly
7474 : specified by a type spec for deferred length character
7475 : arrays or unlimited polymorphic objects without a
7476 : source= or mold= expression. */
7477 235 : gfc_init_se (&se_sz, NULL);
7478 235 : gfc_conv_expr (&se_sz, code->ext.alloc.ts.u.cl->length);
7479 235 : gfc_add_block_to_block (&block, &se_sz.pre);
7480 235 : gfc_add_modify (&block, al_len,
7481 235 : fold_convert (TREE_TYPE (al_len),
7482 : se_sz.expr));
7483 235 : al_len_needs_set = false;
7484 : }
7485 : }
7486 :
7487 17414 : gfc_add_block_to_block (&block, &se.pre);
7488 :
7489 : /* Error checking -- Note: ERRMSG only makes sense with STAT. */
7490 17414 : if (code->expr1)
7491 : {
7492 305 : tmp = build1_v (GOTO_EXPR, label_errmsg);
7493 305 : parm = fold_build2_loc (input_location, NE_EXPR,
7494 : logical_type_node, stat,
7495 305 : build_int_cst (TREE_TYPE (stat), 0));
7496 305 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
7497 : gfc_unlikely (parm, PRED_FORTRAN_FAIL_ALLOC),
7498 : tmp, build_empty_stmt (input_location));
7499 305 : gfc_add_expr_to_block (&block, tmp);
7500 : }
7501 :
7502 : /* Set the vptr only when no source= is set. When source= is set, then
7503 : the trans_assignment below will set the vptr. */
7504 17414 : if (al_vptr != NULL_TREE && (!code->expr3 || code->expr3->mold))
7505 : {
7506 1754 : if (expr3_vptr != NULL_TREE)
7507 : /* The vtab is already known, so just assign it. */
7508 86 : gfc_add_modify (&block, al_vptr,
7509 86 : fold_convert (TREE_TYPE (al_vptr), expr3_vptr));
7510 : else
7511 : {
7512 : /* VPTR is fixed at compile time. */
7513 1668 : gfc_symbol *vtab;
7514 1668 : gfc_typespec *ts;
7515 :
7516 1668 : if (code->expr3)
7517 : /* Although expr3 is pre-evaluated above, it may happen,
7518 : that for arrays or in mold= cases the pre-evaluation
7519 : was not successful. In these rare cases take the vtab
7520 : from the typespec of expr3 here. */
7521 0 : ts = &code->expr3->ts;
7522 1668 : else if (code->ext.alloc.ts.type == BT_DERIVED || upoly_expr)
7523 : /* The alloc_type_spec gives the type to allocate or the
7524 : al is unlimited polymorphic, which enforces the use of
7525 : an alloc_type_spec that is not necessarily a BT_DERIVED. */
7526 751 : ts = &code->ext.alloc.ts;
7527 : else
7528 : /* Prepare for setting the vtab as declared. */
7529 917 : ts = &expr->ts;
7530 :
7531 1668 : vtab = gfc_find_vtab (ts);
7532 1668 : gcc_assert (vtab);
7533 1668 : tmp = gfc_build_addr_expr (NULL_TREE,
7534 : gfc_get_symbol_decl (vtab));
7535 1668 : gfc_add_modify (&block, al_vptr,
7536 1668 : fold_convert (TREE_TYPE (al_vptr), tmp));
7537 : }
7538 : }
7539 :
7540 : /* Add assignment for string length. */
7541 17414 : if (al_len != NULL_TREE && al_len_needs_set)
7542 : {
7543 1141 : if (expr3_len != NULL_TREE)
7544 : {
7545 570 : gfc_add_modify (&block, al_len,
7546 570 : fold_convert (TREE_TYPE (al_len),
7547 : expr3_len));
7548 : /* When tmp_expr3_len_flag is set, then expr3_len is
7549 : abused to carry the length information from the
7550 : alloc_type. Clear it to prevent setting incorrect len
7551 : information in future loop iterations. */
7552 570 : if (tmp_expr3_len_flag)
7553 : /* No need to reset tmp_expr3_len_flag, because the
7554 : presence of an expr3 cannot change within in the
7555 : loop. */
7556 571 : expr3_len = NULL_TREE;
7557 : }
7558 571 : else if (code->ext.alloc.ts.type == BT_CHARACTER
7559 229 : && code->ext.alloc.ts.u.cl->length)
7560 : {
7561 : /* Cover the cases where a string length is explicitly
7562 : specified by a type spec for deferred length character
7563 : arrays or unlimited polymorphic objects without a
7564 : source= or mold= expression. */
7565 229 : if (expr3_esize == NULL_TREE || code->ext.alloc.ts.kind != 1)
7566 : {
7567 75 : gfc_init_se (&se_sz, NULL);
7568 75 : gfc_conv_expr (&se_sz, code->ext.alloc.ts.u.cl->length);
7569 75 : gfc_add_block_to_block (&block, &se_sz.pre);
7570 75 : gfc_add_modify (&block, al_len,
7571 75 : fold_convert (TREE_TYPE (al_len),
7572 : se_sz.expr));
7573 : }
7574 : else
7575 154 : gfc_add_modify (&block, al_len,
7576 154 : fold_convert (TREE_TYPE (al_len),
7577 : expr3_esize));
7578 : }
7579 : else
7580 : /* No length information needed, because type to allocate
7581 : has no length. Set _len to 0. */
7582 342 : gfc_add_modify (&block, al_len,
7583 342 : fold_convert (TREE_TYPE (al_len),
7584 : integer_zero_node));
7585 : }
7586 :
7587 17414 : init_expr = NULL;
7588 17414 : if (code->expr3 && !code->expr3->mold && e3_is != E3_MOLD)
7589 : {
7590 : /* Initialization via SOURCE block (or static default initializer).
7591 : Switch off automatic reallocation since we have just done the
7592 : ALLOCATE. */
7593 3694 : int realloc_lhs = flag_realloc_lhs;
7594 3694 : gfc_expr *init_expr = gfc_expr_to_initialize (expr);
7595 3694 : gfc_expr *rhs = e3rhs ? e3rhs : gfc_copy_expr (code->expr3);
7596 3694 : flag_realloc_lhs = 0;
7597 :
7598 : /* The handling of code->expr3 above produces a derived type of
7599 : type "STAR", whose size defaults to size(void*). In order to
7600 : have the right type information for the assignment, we must
7601 : reconstruct an unlimited polymorphic rhs. */
7602 3694 : if (UNLIMITED_POLY (code->expr3)
7603 151 : && e3rhs && e3rhs->ts.type == BT_DERIVED
7604 6 : && !strcmp (e3rhs->ts.u.derived->name, "STAR"))
7605 : {
7606 6 : gfc_ref *ref;
7607 6 : gcc_assert (TREE_CODE (expr3_vptr) == COMPONENT_REF);
7608 6 : tmp = gfc_create_var (gfc_typenode_for_spec (&code->expr3->ts),
7609 : "e3");
7610 6 : gfc_add_modify (&block, tmp,
7611 : gfc_get_class_from_expr (expr3_vptr));
7612 6 : rhs->symtree->n.sym->backend_decl = tmp;
7613 6 : rhs->ts = code->expr3->ts;
7614 6 : rhs->symtree->n.sym->ts = rhs->ts;
7615 6 : for (ref = init_expr->ref; ref; ref = ref->next)
7616 : {
7617 : /* Copy over the lhs _data component ref followed by the
7618 : full array reference for source expressions with rank.
7619 : Otherwise, just copy the _data component ref. */
7620 6 : if (code->expr3->rank
7621 6 : && ref && ref->next && !ref->next->next)
7622 : {
7623 6 : rhs->ref = gfc_copy_ref (ref);
7624 6 : break;
7625 : }
7626 0 : else if ((init_expr->rank && !code->expr3->rank
7627 0 : && ref && ref->next && !ref->next->next)
7628 0 : || (ref && !ref->next))
7629 : {
7630 0 : rhs->ref = gfc_copy_ref (ref);
7631 0 : gfc_free_ref_list (rhs->ref->next);
7632 0 : rhs->ref->next = NULL;
7633 0 : break;
7634 : }
7635 : }
7636 : }
7637 :
7638 : /* Set the symbol to be artificial so that the result is not finalized. */
7639 3694 : init_expr->symtree->n.sym->attr.artificial = 1;
7640 3694 : tmp = gfc_trans_assignment (init_expr, rhs, true, false, true,
7641 : false);
7642 3694 : init_expr->symtree->n.sym->attr.artificial = 0;
7643 :
7644 3694 : flag_realloc_lhs = realloc_lhs;
7645 : /* Free the expression allocated for init_expr. */
7646 3694 : gfc_free_expr (init_expr);
7647 3694 : if (rhs != e3rhs)
7648 0 : gfc_free_expr (rhs);
7649 3694 : gfc_add_expr_to_block (&block, tmp);
7650 3694 : }
7651 : /* Set KIND and LEN PDT components and allocate those that are
7652 : parameterized and make sure that allocatable components are
7653 : nullified. */
7654 13720 : else if (IS_PDT (expr) || IS_CLASS_PDT (expr))
7655 : {
7656 : gfc_symbol *declared;
7657 : gfc_symbol *type_spec_dt;
7658 : tree type;
7659 : tree ptr;
7660 :
7661 110 : declared = IS_PDT (expr) ? expr->ts.u.derived
7662 0 : : CLASS_DATA (expr)->ts.u.derived;
7663 :
7664 110 : if (code->ext.alloc.ts.type == BT_DERIVED)
7665 76 : type_spec_dt = code->ext.alloc.ts.u.derived;
7666 : else
7667 : type_spec_dt = NULL;
7668 :
7669 110 : if (code->expr3 && code->expr3->param_list)
7670 : param_list = code->expr3->param_list;
7671 110 : else if (expr->param_list)
7672 : param_list = expr->param_list;
7673 : else
7674 34 : param_list = expr->symtree->n.sym->param_list;
7675 : /* For array allocations the allocate-shape-spec expression has
7676 : rank 0 even though the symbol is an array. Use the rank from
7677 : the array descriptor when se.expr is a GFC descriptor so that
7678 : gfc_allocate_pdt_comp loops over all elements. */
7679 110 : int pdt_rank = (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr))
7680 110 : ? GFC_TYPE_ARRAY_RANK (TREE_TYPE (se.expr))
7681 110 : : expr->rank);
7682 110 : tmp = gfc_allocate_pdt_comp (declared, se.expr,
7683 : pdt_rank, param_list);
7684 110 : gfc_add_expr_to_block (&block, tmp);
7685 :
7686 : /* If this is a CLASS allocation and the declared type does not have
7687 : allocatable components but the explicit type_spec does, nullify
7688 : the allocatable components of the type_spec derived type. */
7689 110 : if (pdt_rank == 0 && type_spec_dt
7690 70 : && !declared->attr.alloc_comp && type_spec_dt->attr.alloc_comp)
7691 : {
7692 12 : type = build_pointer_type (gfc_get_derived_type (type_spec_dt));
7693 12 : ptr = fold_convert (type, se.expr);
7694 12 : tmp = gfc_nullify_alloc_comp (type_spec_dt, ptr, 0);
7695 12 : gfc_add_expr_to_block (&block, tmp);
7696 : }
7697 : }
7698 13610 : else if (code->expr3 && code->expr3->mold
7699 309 : && code->expr3->ts.type == BT_CLASS)
7700 : {
7701 : /* Use class_init_assign to initialize expr. */
7702 61 : gfc_code *ini;
7703 61 : ini = gfc_get_code (EXEC_ALLOCATE);
7704 61 : ini->expr1 = gfc_find_and_cut_at_last_class_ref (expr, true);
7705 61 : tmp = gfc_trans_class_init_assign (ini);
7706 61 : gfc_free_statements (ini);
7707 61 : if (tmp != NULL_TREE)
7708 61 : gfc_add_expr_to_block (&block, tmp);
7709 : }
7710 13549 : else if ((init_expr = allocate_get_initializer (code, expr)))
7711 : {
7712 : /* Use class_init_assign to initialize expr. */
7713 2076 : gfc_code *ini;
7714 2076 : int realloc_lhs = flag_realloc_lhs;
7715 2076 : ini = gfc_get_code (EXEC_INIT_ASSIGN);
7716 2076 : ini->expr1 = gfc_expr_to_initialize (expr);
7717 2076 : ini->expr2 = init_expr;
7718 2076 : flag_realloc_lhs = 0;
7719 2076 : tmp= gfc_trans_init_assign (ini);
7720 2076 : flag_realloc_lhs = realloc_lhs;
7721 2076 : gfc_free_statements (ini);
7722 : /* Init_expr is freed by above free_statements, just need to null
7723 : it here. */
7724 2076 : init_expr = NULL;
7725 2076 : gfc_add_expr_to_block (&block, tmp);
7726 : }
7727 :
7728 : /* Nullify all pointers in derived type coarrays. This registers a
7729 : token for them which allows their allocation. */
7730 17414 : if (is_coarray)
7731 : {
7732 541 : gfc_symbol *type = NULL;
7733 541 : symbol_attribute caf_attr;
7734 541 : int rank = 0;
7735 541 : if (code->ext.alloc.ts.type == BT_DERIVED
7736 10 : && code->ext.alloc.ts.u.derived->attr.pointer_comp)
7737 : {
7738 0 : type = code->ext.alloc.ts.u.derived;
7739 0 : rank = type->attr.dimension ? type->as->rank : 0;
7740 0 : gfc_clear_attr (&caf_attr);
7741 : }
7742 541 : else if (expr->ts.type == BT_DERIVED
7743 116 : && expr->ts.u.derived->attr.pointer_comp)
7744 : {
7745 16 : type = expr->ts.u.derived;
7746 16 : rank = expr->rank;
7747 16 : caf_attr = gfc_caf_attr (expr, true);
7748 : }
7749 :
7750 : /* Initialize the tokens of pointer components in derived type
7751 : coarrays. */
7752 16 : if (type)
7753 : {
7754 20 : tmp = (caf_attr.codimension && !caf_attr.dimension)
7755 20 : ? gfc_conv_descriptor_data_get (se.expr) : se.expr;
7756 16 : tmp = gfc_nullify_alloc_comp (type, tmp, rank,
7757 : GFC_STRUCTURE_CAF_MODE_IN_COARRAY);
7758 16 : gfc_add_expr_to_block (&block, tmp);
7759 : }
7760 : }
7761 :
7762 17414 : gfc_free_expr (expr);
7763 : } // for-loop
7764 :
7765 14433 : if (e3rhs)
7766 : {
7767 3869 : if (newsym)
7768 : {
7769 2080 : gfc_free_symbol (newsym->n.sym);
7770 2080 : XDELETE (newsym);
7771 : }
7772 3869 : gfc_free_expr (e3rhs);
7773 : }
7774 : /* STAT. */
7775 14433 : if (code->expr1)
7776 : {
7777 290 : tmp = build1_v (LABEL_EXPR, label_errmsg);
7778 290 : gfc_add_expr_to_block (&block, tmp);
7779 : }
7780 :
7781 : /* ERRMSG - only useful if STAT is present. */
7782 14433 : if (code->expr1 && code->expr2)
7783 : {
7784 72 : const char *msg = "Attempt to allocate an allocated object";
7785 72 : const char *oommsg = "Insufficient virtual memory";
7786 72 : tree slen, dlen, errmsg_str, oom_str, oom_loc;
7787 72 : stmtblock_t errmsg_block;
7788 :
7789 72 : gfc_init_block (&errmsg_block);
7790 :
7791 72 : errmsg_str = gfc_create_var (pchar_type_node, "ERRMSG");
7792 72 : gfc_add_modify (&errmsg_block, errmsg_str,
7793 : gfc_build_addr_expr (pchar_type_node,
7794 : gfc_build_localized_cstring_const (msg)));
7795 :
7796 72 : slen = build_int_cst (gfc_charlen_type_node, strlen (msg));
7797 72 : dlen = gfc_get_expr_charlen (code->expr2);
7798 72 : slen = fold_build2_loc (input_location, MIN_EXPR,
7799 72 : TREE_TYPE (slen), dlen, slen);
7800 :
7801 72 : gfc_trans_string_copy (&errmsg_block, dlen, errmsg,
7802 72 : code->expr2->ts.kind,
7803 : slen, errmsg_str,
7804 : gfc_default_character_kind);
7805 72 : dlen = gfc_finish_block (&errmsg_block);
7806 :
7807 72 : tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
7808 72 : stat, build_int_cst (TREE_TYPE (stat),
7809 : LIBERROR_ALLOCATION));
7810 :
7811 72 : tmp = build3_v (COND_EXPR, tmp,
7812 : dlen, build_empty_stmt (input_location));
7813 :
7814 72 : gfc_add_expr_to_block (&block, tmp);
7815 :
7816 72 : oom_str = gfc_create_var (pchar_type_node, "OOMMSG");
7817 72 : oom_loc = gfc_build_localized_cstring_const (oommsg);
7818 72 : gfc_add_modify (&errmsg_block, oom_str,
7819 : gfc_build_addr_expr (pchar_type_node, oom_loc));
7820 :
7821 72 : slen = build_int_cst (gfc_charlen_type_node, strlen (oommsg));
7822 72 : dlen = gfc_get_expr_charlen (code->expr2);
7823 72 : slen = fold_build2_loc (input_location, MIN_EXPR,
7824 72 : TREE_TYPE (slen), dlen, slen);
7825 :
7826 72 : gfc_trans_string_copy (&errmsg_block, dlen, errmsg,
7827 72 : code->expr2->ts.kind,
7828 : slen, oom_str,
7829 : gfc_default_character_kind);
7830 72 : dlen = gfc_finish_block (&errmsg_block);
7831 :
7832 72 : tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
7833 72 : stat, build_int_cst (TREE_TYPE (stat),
7834 : LIBERROR_NO_MEMORY));
7835 :
7836 72 : tmp = build3_v (COND_EXPR, tmp,
7837 : dlen, build_empty_stmt (input_location));
7838 :
7839 72 : gfc_add_expr_to_block (&block, tmp);
7840 : }
7841 :
7842 : /* STAT block. */
7843 14433 : if (code->expr1)
7844 : {
7845 290 : if (TREE_USED (label_finish))
7846 : {
7847 16 : tmp = build1_v (LABEL_EXPR, label_finish);
7848 16 : gfc_add_expr_to_block (&block, tmp);
7849 : }
7850 :
7851 290 : gfc_init_se (&se, NULL);
7852 290 : gfc_conv_expr_lhs (&se, code->expr1);
7853 290 : tmp = convert (TREE_TYPE (se.expr), stat);
7854 290 : gfc_add_modify (&block, se.expr, tmp);
7855 : }
7856 :
7857 14433 : if (needs_caf_sync)
7858 : {
7859 : /* Add a sync all after the allocation has been executed. */
7860 252 : tree zero_size = build_zero_cst (size_type_node);
7861 252 : tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_all,
7862 : 3, null_pointer_node, null_pointer_node,
7863 : zero_size);
7864 252 : gfc_add_expr_to_block (&post, tmp);
7865 : }
7866 :
7867 14433 : gfc_add_block_to_block (&block, &se.post);
7868 14433 : gfc_add_block_to_block (&block, &post);
7869 14433 : if (code->expr3 && code->expr3->must_finalize)
7870 78 : gfc_add_block_to_block (&block, &final_block);
7871 :
7872 14433 : return gfc_finish_block (&block);
7873 : }
7874 :
7875 :
7876 : /* Translate a DEALLOCATE statement. */
7877 :
7878 : tree
7879 8975 : gfc_trans_deallocate (gfc_code *code)
7880 : {
7881 8975 : gfc_se se;
7882 8975 : gfc_alloc *al;
7883 8975 : tree apstat, pstat, stat, errmsg, errlen, tmp;
7884 8975 : tree label_finish, label_errmsg;
7885 8975 : stmtblock_t block;
7886 :
7887 8975 : pstat = apstat = stat = errmsg = errlen = tmp = NULL_TREE;
7888 8975 : label_finish = label_errmsg = NULL_TREE;
7889 :
7890 8975 : gfc_start_block (&block);
7891 :
7892 : /* Count the number of failed deallocations. If deallocate() was
7893 : called with STAT= , then set STAT to the count. If deallocate
7894 : was called with ERRMSG, then set ERRMG to a string. */
7895 8975 : if (code->expr1)
7896 : {
7897 2756 : tree gfc_int4_type_node = gfc_get_int_type (4);
7898 :
7899 2756 : stat = gfc_create_var (gfc_int4_type_node, "stat");
7900 2756 : pstat = gfc_build_addr_expr (NULL_TREE, stat);
7901 :
7902 : /* GOTO destinations. */
7903 2756 : label_errmsg = gfc_build_label_decl (NULL_TREE);
7904 2756 : label_finish = gfc_build_label_decl (NULL_TREE);
7905 2756 : TREE_USED (label_finish) = 0;
7906 : }
7907 :
7908 : /* Set ERRMSG - only needed if STAT is available. */
7909 8975 : if (code->expr1 && code->expr2)
7910 : {
7911 51 : gfc_init_se (&se, NULL);
7912 51 : se.want_pointer = 1;
7913 51 : gfc_conv_expr_lhs (&se, code->expr2);
7914 51 : errmsg = se.expr;
7915 51 : errlen = se.string_length;
7916 : }
7917 :
7918 20216 : for (al = code->ext.alloc.list; al != NULL; al = al->next)
7919 : {
7920 11241 : gfc_expr *expr = gfc_copy_expr (al->expr);
7921 11241 : bool is_coarray = false, is_coarray_array = false;
7922 11241 : int caf_mode = 0;
7923 11241 : gfc_ref * ref;
7924 11241 : gfc_actual_arglist * param_list;
7925 :
7926 11241 : gcc_assert (expr->expr_type == EXPR_VARIABLE);
7927 :
7928 11241 : if (expr->ts.type == BT_CLASS)
7929 2053 : gfc_add_data_component (expr);
7930 :
7931 11241 : gfc_init_se (&se, NULL);
7932 11241 : gfc_start_block (&se.pre);
7933 :
7934 11241 : se.want_pointer = 1;
7935 11241 : se.descriptor_only = 1;
7936 11241 : gfc_conv_expr (&se, expr);
7937 :
7938 : /* Deallocate PDT components that are parameterized. */
7939 11241 : tmp = NULL;
7940 11241 : param_list = expr->param_list;
7941 11241 : if (!param_list && expr->symtree->n.sym->param_list)
7942 : param_list = expr->symtree->n.sym->param_list;
7943 26856 : for (ref = expr->ref; ref; ref = ref->next)
7944 15615 : if (ref->type == REF_COMPONENT
7945 7124 : && IS_PDT (ref->u.c.component)
7946 119 : && ref->u.c.component->param_list)
7947 15615 : param_list = ref->u.c.component->param_list;
7948 11241 : if (expr->ts.type == BT_DERIVED
7949 2925 : && ((expr->ts.u.derived->attr.pdt_type && param_list)
7950 2777 : || expr->ts.u.derived->attr.pdt_comp))
7951 : {
7952 148 : int pdt_rank = (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr))
7953 148 : ? GFC_TYPE_ARRAY_RANK (TREE_TYPE (se.expr))
7954 148 : : expr->rank);
7955 148 : tmp = gfc_deallocate_pdt_comp (expr->ts.u.derived, se.expr, pdt_rank);
7956 148 : }
7957 11093 : else if (IS_CLASS_PDT (expr) && expr->symtree->n.sym->param_list)
7958 : {
7959 0 : int pdt_rank = (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr))
7960 0 : ? GFC_TYPE_ARRAY_RANK (TREE_TYPE (se.expr))
7961 0 : : expr->rank);
7962 0 : tmp = gfc_deallocate_pdt_comp (CLASS_DATA (expr)->ts.u.derived,
7963 : se.expr, pdt_rank);
7964 : }
7965 :
7966 148 : if (tmp)
7967 48 : gfc_add_expr_to_block (&se.pre, tmp);
7968 :
7969 11241 : if (flag_coarray == GFC_FCOARRAY_LIB
7970 11241 : || flag_coarray == GFC_FCOARRAY_SINGLE)
7971 : {
7972 474 : bool comp_ref;
7973 474 : symbol_attribute caf_attr = gfc_caf_attr (expr, false, &comp_ref);
7974 474 : if (caf_attr.codimension)
7975 : {
7976 357 : is_coarray = true;
7977 175 : is_coarray_array = caf_attr.dimension || !comp_ref
7978 431 : || caf_attr.coarray_comp;
7979 :
7980 357 : if (flag_coarray == GFC_FCOARRAY_LIB)
7981 : /* When the expression to deallocate is referencing a
7982 : component, then only deallocate it, but do not
7983 : deregister. */
7984 138 : caf_mode = GFC_STRUCTURE_CAF_MODE_IN_COARRAY
7985 250 : | (comp_ref && !caf_attr.coarray_comp
7986 : ? GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY : 0);
7987 : }
7988 : }
7989 :
7990 11241 : if (expr->rank || is_coarray_array)
7991 : {
7992 7817 : gfc_ref *ref;
7993 :
7994 6455 : if (gfc_bt_struct (expr->ts.type)
7995 1362 : && expr->ts.u.derived->attr.alloc_comp
7996 8537 : && !gfc_is_finalizable (expr->ts.u.derived, NULL))
7997 : {
7998 716 : gfc_ref *last = NULL;
7999 :
8000 1950 : for (ref = expr->ref; ref; ref = ref->next)
8001 1234 : if (ref->type == REF_COMPONENT)
8002 448 : last = ref;
8003 :
8004 : /* Do not deallocate the components of a derived type
8005 : ultimate pointer component. */
8006 716 : if (!(last && last->u.c.component->attr.pointer)
8007 317 : && !(!last && expr->symtree->n.sym->attr.pointer))
8008 : {
8009 30 : if (is_coarray && expr->rank == 0
8010 21 : && (!last || !last->u.c.component->attr.dimension)
8011 713 : && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr)))
8012 : {
8013 : /* Add the ref to the data member only, when this is not
8014 : a regular array or deallocate_alloc_comp will try to
8015 : add another one. */
8016 21 : tmp = gfc_conv_descriptor_data_get (se.expr);
8017 : }
8018 : else
8019 671 : tmp = se.expr;
8020 692 : tmp = gfc_deallocate_alloc_comp (expr->ts.u.derived, tmp,
8021 : expr->rank, caf_mode);
8022 692 : gfc_add_expr_to_block (&se.pre, tmp);
8023 : }
8024 : }
8025 :
8026 7817 : if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr)))
8027 : {
8028 7758 : gfc_coarray_deregtype caf_dtype;
8029 :
8030 7758 : if (is_coarray)
8031 556 : caf_dtype = gfc_caf_is_dealloc_only (caf_mode)
8032 314 : ? GFC_CAF_COARRAY_DEALLOCATE_ONLY
8033 : : GFC_CAF_COARRAY_DEREGISTER;
8034 : else
8035 : caf_dtype = GFC_CAF_COARRAY_NOCOARRAY;
8036 7758 : tmp = gfc_deallocate_with_status (se.expr, pstat, errmsg, errlen,
8037 : label_finish, false, expr,
8038 : caf_dtype);
8039 7758 : gfc_add_expr_to_block (&se.pre, tmp);
8040 : }
8041 59 : else if (TREE_CODE (se.expr) == COMPONENT_REF
8042 59 : && TREE_CODE (TREE_TYPE (se.expr)) == ARRAY_TYPE
8043 118 : && TREE_CODE (TREE_TYPE (TREE_TYPE (se.expr)))
8044 : == RECORD_TYPE)
8045 : {
8046 : /* class.cc(finalize_component) generates these, when a
8047 : finalizable entity has a non-allocatable derived type array
8048 : component, which has allocatable components. Obtain the
8049 : derived type of the array and deallocate the allocatable
8050 : components. */
8051 65 : for (ref = expr->ref; ref; ref = ref->next)
8052 : {
8053 65 : if (ref->u.c.component->attr.dimension
8054 59 : && ref->u.c.component->ts.type == BT_DERIVED)
8055 : break;
8056 : }
8057 :
8058 59 : if (ref && ref->u.c.component->ts.u.derived->attr.alloc_comp
8059 118 : && !gfc_is_finalizable (ref->u.c.component->ts.u.derived,
8060 : NULL))
8061 : {
8062 59 : tmp = gfc_deallocate_alloc_comp
8063 59 : (ref->u.c.component->ts.u.derived,
8064 : se.expr, expr->rank);
8065 59 : gfc_add_expr_to_block (&se.pre, tmp);
8066 : }
8067 : }
8068 :
8069 7817 : if (al->expr->ts.type == BT_CLASS)
8070 : {
8071 1164 : gfc_reset_vptr (&se.pre, al->expr);
8072 1164 : if (UNLIMITED_POLY (al->expr)
8073 760 : || (al->expr->ts.type == BT_DERIVED
8074 0 : && al->expr->ts.u.derived->attr.unlimited_polymorphic))
8075 : /* Clear _len, too. */
8076 404 : gfc_reset_len (&se.pre, al->expr);
8077 : }
8078 : }
8079 : else
8080 : {
8081 6848 : tmp = gfc_deallocate_scalar_with_status (se.expr, pstat, label_finish,
8082 : false, al->expr,
8083 3424 : al->expr->ts, NULL_TREE,
8084 : is_coarray);
8085 3424 : gfc_add_expr_to_block (&se.pre, tmp);
8086 :
8087 : /* Set to zero after deallocation. */
8088 3424 : tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
8089 : se.expr,
8090 3424 : build_int_cst (TREE_TYPE (se.expr), 0));
8091 3424 : gfc_add_expr_to_block (&se.pre, tmp);
8092 :
8093 3424 : if (al->expr->ts.type == BT_CLASS)
8094 : {
8095 889 : gfc_reset_vptr (&se.pre, al->expr);
8096 889 : if (UNLIMITED_POLY (al->expr)
8097 656 : || (al->expr->ts.type == BT_DERIVED
8098 0 : && al->expr->ts.u.derived->attr.unlimited_polymorphic))
8099 : /* Clear _len, too. */
8100 233 : gfc_reset_len (&se.pre, al->expr);
8101 : }
8102 : }
8103 :
8104 11241 : if (code->expr1)
8105 : {
8106 2795 : tree cond;
8107 :
8108 2795 : cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, stat,
8109 2795 : build_int_cst (TREE_TYPE (stat), 0));
8110 2795 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
8111 : gfc_unlikely (cond, PRED_FORTRAN_FAIL_ALLOC),
8112 : build1_v (GOTO_EXPR, label_errmsg),
8113 : build_empty_stmt (input_location));
8114 2795 : gfc_add_expr_to_block (&se.pre, tmp);
8115 : }
8116 :
8117 11241 : tmp = gfc_finish_block (&se.pre);
8118 11241 : gfc_add_expr_to_block (&block, tmp);
8119 11241 : gfc_free_expr (expr);
8120 : }
8121 :
8122 8975 : if (code->expr1)
8123 : {
8124 2756 : tmp = build1_v (LABEL_EXPR, label_errmsg);
8125 2756 : gfc_add_expr_to_block (&block, tmp);
8126 : }
8127 :
8128 : /* Set ERRMSG - only needed if STAT is available. */
8129 8975 : if (code->expr1 && code->expr2)
8130 : {
8131 51 : const char *msg = "Attempt to deallocate an unallocated object";
8132 51 : stmtblock_t errmsg_block;
8133 51 : tree errmsg_str, slen, dlen, cond;
8134 :
8135 51 : gfc_init_block (&errmsg_block);
8136 :
8137 51 : errmsg_str = gfc_create_var (pchar_type_node, "ERRMSG");
8138 51 : gfc_add_modify (&errmsg_block, errmsg_str,
8139 : gfc_build_addr_expr (pchar_type_node,
8140 : gfc_build_localized_cstring_const (msg)));
8141 51 : slen = build_int_cst (gfc_charlen_type_node, strlen (msg));
8142 51 : dlen = gfc_get_expr_charlen (code->expr2);
8143 :
8144 51 : gfc_trans_string_copy (&errmsg_block, dlen, errmsg, code->expr2->ts.kind,
8145 : slen, errmsg_str, gfc_default_character_kind);
8146 51 : tmp = gfc_finish_block (&errmsg_block);
8147 :
8148 51 : cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, stat,
8149 51 : build_int_cst (TREE_TYPE (stat), 0));
8150 51 : tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
8151 : gfc_unlikely (cond, PRED_FORTRAN_FAIL_ALLOC), tmp,
8152 : build_empty_stmt (input_location));
8153 :
8154 51 : gfc_add_expr_to_block (&block, tmp);
8155 : }
8156 :
8157 8975 : if (code->expr1 && TREE_USED (label_finish))
8158 : {
8159 17 : tmp = build1_v (LABEL_EXPR, label_finish);
8160 17 : gfc_add_expr_to_block (&block, tmp);
8161 : }
8162 :
8163 : /* Set STAT. */
8164 8975 : if (code->expr1)
8165 : {
8166 2756 : gfc_init_se (&se, NULL);
8167 2756 : gfc_conv_expr_lhs (&se, code->expr1);
8168 2756 : tmp = convert (TREE_TYPE (se.expr), stat);
8169 2756 : gfc_add_modify (&block, se.expr, tmp);
8170 : }
8171 :
8172 8975 : return gfc_finish_block (&block);
8173 : }
8174 :
8175 : #include "gt-fortran-trans-stmt.h"
|
