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