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 images2 = fold_convert (integer_type_node, images);
1217 tree cond;
1218 if (flag_coarray != GFC_FCOARRAY_LIB)
1219 cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
1220 images, build_int_cst (TREE_TYPE (images), 1));
1221 else
1222 {
1223 tree cond2;
1224 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images,
1225 2, integer_zero_node,
1226 build_int_cst (integer_type_node, -1));
1227 cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
1228 images2, tmp);
1229 cond2 = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
1230 images,
1231 build_int_cst (TREE_TYPE (images), 1));
1232 cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
1233 logical_type_node, cond, cond2);
1234 }
1235 gfc_trans_runtime_check (true, false, cond, &se.pre,
1236 &code->expr1->where, "Invalid image number "
1237 "%d in SYNC IMAGES", images2);
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. Likewise for allocatable components. */
3539 if (lsym->ts.type == BT_DERIVED
3540 && (lsym->ts.u.derived->attr.pointer_comp
3541 || lsym->ts.u.derived->attr.alloc_comp))
3542 return need_temp;
3543
3544 new_symtree = NULL;
3545 if (find_forall_index (c->expr1, lsym, 2))
3546 {
3547 forall_make_variable_temp (c, pre, post);
3548 need_temp = 0;
3549 }
3550
3551 /* Substrings with dependencies are treated in the same
3552 way. */
3553 if (c->expr1->ts.type == BT_CHARACTER
3554 && c->expr1->ref
3555 && c->expr2->expr_type == EXPR_VARIABLE
3556 && lsym == c->expr2->symtree->n.sym)
3557 {
3558 for (lref = c->expr1->ref; lref; lref = lref->next)
3559 if (lref->type == REF_SUBSTRING)
3560 break;
3561 for (rref = c->expr2->ref; rref; rref = rref->next)
3562 if (rref->type == REF_SUBSTRING)
3563 break;
3564
3565 if (rref && lref
3566 && gfc_dep_compare_expr (rref->u.ss.start, lref->u.ss.start) < 0)
3567 {
3568 forall_make_variable_temp (c, pre, post);
3569 need_temp = 0;
3570 }
3571 }
3572 return need_temp;
3573 }
3574
3575
3576 static void
cleanup_forall_symtrees(gfc_code * c)3577 cleanup_forall_symtrees (gfc_code *c)
3578 {
3579 forall_restore_symtree (c->expr1);
3580 forall_restore_symtree (c->expr2);
3581 free (new_symtree->n.sym);
3582 free (new_symtree);
3583 }
3584
3585
3586 /* Generate the loops for a FORALL block, specified by FORALL_TMP. BODY
3587 is the contents of the FORALL block/stmt to be iterated. MASK_FLAG
3588 indicates whether we should generate code to test the FORALLs mask
3589 array. OUTER is the loop header to be used for initializing mask
3590 indices.
3591
3592 The generated loop format is:
3593 count = (end - start + step) / step
3594 loopvar = start
3595 while (1)
3596 {
3597 if (count <=0 )
3598 goto end_of_loop
3599 <body>
3600 loopvar += step
3601 count --
3602 }
3603 end_of_loop: */
3604
3605 static tree
gfc_trans_forall_loop(forall_info * forall_tmp,tree body,int mask_flag,stmtblock_t * outer)3606 gfc_trans_forall_loop (forall_info *forall_tmp, tree body,
3607 int mask_flag, stmtblock_t *outer)
3608 {
3609 int n, nvar;
3610 tree tmp;
3611 tree cond;
3612 stmtblock_t block;
3613 tree exit_label;
3614 tree count;
3615 tree var, start, end, step;
3616 iter_info *iter;
3617
3618 /* Initialize the mask index outside the FORALL nest. */
3619 if (mask_flag && forall_tmp->mask)
3620 gfc_add_modify (outer, forall_tmp->maskindex, gfc_index_zero_node);
3621
3622 iter = forall_tmp->this_loop;
3623 nvar = forall_tmp->nvar;
3624 for (n = 0; n < nvar; n++)
3625 {
3626 var = iter->var;
3627 start = iter->start;
3628 end = iter->end;
3629 step = iter->step;
3630
3631 exit_label = gfc_build_label_decl (NULL_TREE);
3632 TREE_USED (exit_label) = 1;
3633
3634 /* The loop counter. */
3635 count = gfc_create_var (TREE_TYPE (var), "count");
3636
3637 /* The body of the loop. */
3638 gfc_init_block (&block);
3639
3640 /* The exit condition. */
3641 cond = fold_build2_loc (input_location, LE_EXPR, logical_type_node,
3642 count, build_int_cst (TREE_TYPE (count), 0));
3643
3644 /* PR 83064 means that we cannot use annot_expr_parallel_kind until
3645 the autoparallelizer can hande this. */
3646 if (forall_tmp->do_concurrent)
3647 cond = build3 (ANNOTATE_EXPR, TREE_TYPE (cond), cond,
3648 build_int_cst (integer_type_node,
3649 annot_expr_ivdep_kind),
3650 integer_zero_node);
3651
3652 tmp = build1_v (GOTO_EXPR, exit_label);
3653 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
3654 cond, tmp, build_empty_stmt (input_location));
3655 gfc_add_expr_to_block (&block, tmp);
3656
3657 /* The main loop body. */
3658 gfc_add_expr_to_block (&block, body);
3659
3660 /* Increment the loop variable. */
3661 tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (var), var,
3662 step);
3663 gfc_add_modify (&block, var, tmp);
3664
3665 /* Advance to the next mask element. Only do this for the
3666 innermost loop. */
3667 if (n == 0 && mask_flag && forall_tmp->mask)
3668 {
3669 tree maskindex = forall_tmp->maskindex;
3670 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
3671 maskindex, gfc_index_one_node);
3672 gfc_add_modify (&block, maskindex, tmp);
3673 }
3674
3675 /* Decrement the loop counter. */
3676 tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (var), count,
3677 build_int_cst (TREE_TYPE (var), 1));
3678 gfc_add_modify (&block, count, tmp);
3679
3680 body = gfc_finish_block (&block);
3681
3682 /* Loop var initialization. */
3683 gfc_init_block (&block);
3684 gfc_add_modify (&block, var, start);
3685
3686
3687 /* Initialize the loop counter. */
3688 tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (var), step,
3689 start);
3690 tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (var), end,
3691 tmp);
3692 tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR, TREE_TYPE (var),
3693 tmp, step);
3694 gfc_add_modify (&block, count, tmp);
3695
3696 /* The loop expression. */
3697 tmp = build1_v (LOOP_EXPR, body);
3698 gfc_add_expr_to_block (&block, tmp);
3699
3700 /* The exit label. */
3701 tmp = build1_v (LABEL_EXPR, exit_label);
3702 gfc_add_expr_to_block (&block, tmp);
3703
3704 body = gfc_finish_block (&block);
3705 iter = iter->next;
3706 }
3707 return body;
3708 }
3709
3710
3711 /* Generate the body and loops according to MASK_FLAG. If MASK_FLAG
3712 is nonzero, the body is controlled by all masks in the forall nest.
3713 Otherwise, the innermost loop is not controlled by it's mask. This
3714 is used for initializing that mask. */
3715
3716 static tree
gfc_trans_nested_forall_loop(forall_info * nested_forall_info,tree body,int mask_flag)3717 gfc_trans_nested_forall_loop (forall_info * nested_forall_info, tree body,
3718 int mask_flag)
3719 {
3720 tree tmp;
3721 stmtblock_t header;
3722 forall_info *forall_tmp;
3723 tree mask, maskindex;
3724
3725 gfc_start_block (&header);
3726
3727 forall_tmp = nested_forall_info;
3728 while (forall_tmp != NULL)
3729 {
3730 /* Generate body with masks' control. */
3731 if (mask_flag)
3732 {
3733 mask = forall_tmp->mask;
3734 maskindex = forall_tmp->maskindex;
3735
3736 /* If a mask was specified make the assignment conditional. */
3737 if (mask)
3738 {
3739 tmp = gfc_build_array_ref (mask, maskindex, NULL);
3740 body = build3_v (COND_EXPR, tmp, body,
3741 build_empty_stmt (input_location));
3742 }
3743 }
3744 body = gfc_trans_forall_loop (forall_tmp, body, mask_flag, &header);
3745 forall_tmp = forall_tmp->prev_nest;
3746 mask_flag = 1;
3747 }
3748
3749 gfc_add_expr_to_block (&header, body);
3750 return gfc_finish_block (&header);
3751 }
3752
3753
3754 /* Allocate data for holding a temporary array. Returns either a local
3755 temporary array or a pointer variable. */
3756
3757 static tree
gfc_do_allocate(tree bytesize,tree size,tree * pdata,stmtblock_t * pblock,tree elem_type)3758 gfc_do_allocate (tree bytesize, tree size, tree * pdata, stmtblock_t * pblock,
3759 tree elem_type)
3760 {
3761 tree tmpvar;
3762 tree type;
3763 tree tmp;
3764
3765 if (INTEGER_CST_P (size))
3766 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
3767 size, gfc_index_one_node);
3768 else
3769 tmp = NULL_TREE;
3770
3771 type = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp);
3772 type = build_array_type (elem_type, type);
3773 if (gfc_can_put_var_on_stack (bytesize) && INTEGER_CST_P (size))
3774 {
3775 tmpvar = gfc_create_var (type, "temp");
3776 *pdata = NULL_TREE;
3777 }
3778 else
3779 {
3780 tmpvar = gfc_create_var (build_pointer_type (type), "temp");
3781 *pdata = convert (pvoid_type_node, tmpvar);
3782
3783 tmp = gfc_call_malloc (pblock, TREE_TYPE (tmpvar), bytesize);
3784 gfc_add_modify (pblock, tmpvar, tmp);
3785 }
3786 return tmpvar;
3787 }
3788
3789
3790 /* Generate codes to copy the temporary to the actual lhs. */
3791
3792 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)3793 generate_loop_for_temp_to_lhs (gfc_expr *expr, tree tmp1, tree count3,
3794 tree count1,
3795 gfc_ss *lss, gfc_ss *rss,
3796 tree wheremask, bool invert)
3797 {
3798 stmtblock_t block, body1;
3799 gfc_loopinfo loop;
3800 gfc_se lse;
3801 gfc_se rse;
3802 tree tmp;
3803 tree wheremaskexpr;
3804
3805 (void) rss; /* TODO: unused. */
3806
3807 gfc_start_block (&block);
3808
3809 gfc_init_se (&rse, NULL);
3810 gfc_init_se (&lse, NULL);
3811
3812 if (lss == gfc_ss_terminator)
3813 {
3814 gfc_init_block (&body1);
3815 gfc_conv_expr (&lse, expr);
3816 rse.expr = gfc_build_array_ref (tmp1, count1, NULL);
3817 }
3818 else
3819 {
3820 /* Initialize the loop. */
3821 gfc_init_loopinfo (&loop);
3822
3823 /* We may need LSS to determine the shape of the expression. */
3824 gfc_add_ss_to_loop (&loop, lss);
3825
3826 gfc_conv_ss_startstride (&loop);
3827 gfc_conv_loop_setup (&loop, &expr->where);
3828
3829 gfc_mark_ss_chain_used (lss, 1);
3830 /* Start the loop body. */
3831 gfc_start_scalarized_body (&loop, &body1);
3832
3833 /* Translate the expression. */
3834 gfc_copy_loopinfo_to_se (&lse, &loop);
3835 lse.ss = lss;
3836 gfc_conv_expr (&lse, expr);
3837
3838 /* Form the expression of the temporary. */
3839 rse.expr = gfc_build_array_ref (tmp1, count1, NULL);
3840 }
3841
3842 /* Use the scalar assignment. */
3843 rse.string_length = lse.string_length;
3844 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts,
3845 expr->expr_type == EXPR_VARIABLE, false);
3846
3847 /* Form the mask expression according to the mask tree list. */
3848 if (wheremask)
3849 {
3850 wheremaskexpr = gfc_build_array_ref (wheremask, count3, NULL);
3851 if (invert)
3852 wheremaskexpr = fold_build1_loc (input_location, TRUTH_NOT_EXPR,
3853 TREE_TYPE (wheremaskexpr),
3854 wheremaskexpr);
3855 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
3856 wheremaskexpr, tmp,
3857 build_empty_stmt (input_location));
3858 }
3859
3860 gfc_add_expr_to_block (&body1, tmp);
3861
3862 tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (count1),
3863 count1, gfc_index_one_node);
3864 gfc_add_modify (&body1, count1, tmp);
3865
3866 if (lss == gfc_ss_terminator)
3867 gfc_add_block_to_block (&block, &body1);
3868 else
3869 {
3870 /* Increment count3. */
3871 if (count3)
3872 {
3873 tmp = fold_build2_loc (input_location, PLUS_EXPR,
3874 gfc_array_index_type,
3875 count3, gfc_index_one_node);
3876 gfc_add_modify (&body1, count3, tmp);
3877 }
3878
3879 /* Generate the copying loops. */
3880 gfc_trans_scalarizing_loops (&loop, &body1);
3881
3882 gfc_add_block_to_block (&block, &loop.pre);
3883 gfc_add_block_to_block (&block, &loop.post);
3884
3885 gfc_cleanup_loop (&loop);
3886 /* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful
3887 as tree nodes in SS may not be valid in different scope. */
3888 }
3889
3890 tmp = gfc_finish_block (&block);
3891 return tmp;
3892 }
3893
3894
3895 /* Generate codes to copy rhs to the temporary. TMP1 is the address of
3896 temporary, LSS and RSS are formed in function compute_inner_temp_size(),
3897 and should not be freed. WHEREMASK is the conditional execution mask
3898 whose sense may be inverted by INVERT. */
3899
3900 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)3901 generate_loop_for_rhs_to_temp (gfc_expr *expr2, tree tmp1, tree count3,
3902 tree count1, gfc_ss *lss, gfc_ss *rss,
3903 tree wheremask, bool invert)
3904 {
3905 stmtblock_t block, body1;
3906 gfc_loopinfo loop;
3907 gfc_se lse;
3908 gfc_se rse;
3909 tree tmp;
3910 tree wheremaskexpr;
3911
3912 gfc_start_block (&block);
3913
3914 gfc_init_se (&rse, NULL);
3915 gfc_init_se (&lse, NULL);
3916
3917 if (lss == gfc_ss_terminator)
3918 {
3919 gfc_init_block (&body1);
3920 gfc_conv_expr (&rse, expr2);
3921 lse.expr = gfc_build_array_ref (tmp1, count1, NULL);
3922 }
3923 else
3924 {
3925 /* Initialize the loop. */
3926 gfc_init_loopinfo (&loop);
3927
3928 /* We may need LSS to determine the shape of the expression. */
3929 gfc_add_ss_to_loop (&loop, lss);
3930 gfc_add_ss_to_loop (&loop, rss);
3931
3932 gfc_conv_ss_startstride (&loop);
3933 gfc_conv_loop_setup (&loop, &expr2->where);
3934
3935 gfc_mark_ss_chain_used (rss, 1);
3936 /* Start the loop body. */
3937 gfc_start_scalarized_body (&loop, &body1);
3938
3939 /* Translate the expression. */
3940 gfc_copy_loopinfo_to_se (&rse, &loop);
3941 rse.ss = rss;
3942 gfc_conv_expr (&rse, expr2);
3943
3944 /* Form the expression of the temporary. */
3945 lse.expr = gfc_build_array_ref (tmp1, count1, NULL);
3946 }
3947
3948 /* Use the scalar assignment. */
3949 lse.string_length = rse.string_length;
3950 tmp = gfc_trans_scalar_assign (&lse, &rse, expr2->ts,
3951 expr2->expr_type == EXPR_VARIABLE, false);
3952
3953 /* Form the mask expression according to the mask tree list. */
3954 if (wheremask)
3955 {
3956 wheremaskexpr = gfc_build_array_ref (wheremask, count3, NULL);
3957 if (invert)
3958 wheremaskexpr = fold_build1_loc (input_location, TRUTH_NOT_EXPR,
3959 TREE_TYPE (wheremaskexpr),
3960 wheremaskexpr);
3961 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
3962 wheremaskexpr, tmp,
3963 build_empty_stmt (input_location));
3964 }
3965
3966 gfc_add_expr_to_block (&body1, tmp);
3967
3968 if (lss == gfc_ss_terminator)
3969 {
3970 gfc_add_block_to_block (&block, &body1);
3971
3972 /* Increment count1. */
3973 tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (count1),
3974 count1, gfc_index_one_node);
3975 gfc_add_modify (&block, count1, tmp);
3976 }
3977 else
3978 {
3979 /* Increment count1. */
3980 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
3981 count1, gfc_index_one_node);
3982 gfc_add_modify (&body1, count1, tmp);
3983
3984 /* Increment count3. */
3985 if (count3)
3986 {
3987 tmp = fold_build2_loc (input_location, PLUS_EXPR,
3988 gfc_array_index_type,
3989 count3, gfc_index_one_node);
3990 gfc_add_modify (&body1, count3, tmp);
3991 }
3992
3993 /* Generate the copying loops. */
3994 gfc_trans_scalarizing_loops (&loop, &body1);
3995
3996 gfc_add_block_to_block (&block, &loop.pre);
3997 gfc_add_block_to_block (&block, &loop.post);
3998
3999 gfc_cleanup_loop (&loop);
4000 /* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful
4001 as tree nodes in SS may not be valid in different scope. */
4002 }
4003
4004 tmp = gfc_finish_block (&block);
4005 return tmp;
4006 }
4007
4008
4009 /* Calculate the size of temporary needed in the assignment inside forall.
4010 LSS and RSS are filled in this function. */
4011
4012 static tree
compute_inner_temp_size(gfc_expr * expr1,gfc_expr * expr2,stmtblock_t * pblock,gfc_ss ** lss,gfc_ss ** rss)4013 compute_inner_temp_size (gfc_expr *expr1, gfc_expr *expr2,
4014 stmtblock_t * pblock,
4015 gfc_ss **lss, gfc_ss **rss)
4016 {
4017 gfc_loopinfo loop;
4018 tree size;
4019 int i;
4020 int save_flag;
4021 tree tmp;
4022
4023 *lss = gfc_walk_expr (expr1);
4024 *rss = NULL;
4025
4026 size = gfc_index_one_node;
4027 if (*lss != gfc_ss_terminator)
4028 {
4029 gfc_init_loopinfo (&loop);
4030
4031 /* Walk the RHS of the expression. */
4032 *rss = gfc_walk_expr (expr2);
4033 if (*rss == gfc_ss_terminator)
4034 /* The rhs is scalar. Add a ss for the expression. */
4035 *rss = gfc_get_scalar_ss (gfc_ss_terminator, expr2);
4036
4037 /* Associate the SS with the loop. */
4038 gfc_add_ss_to_loop (&loop, *lss);
4039 /* We don't actually need to add the rhs at this point, but it might
4040 make guessing the loop bounds a bit easier. */
4041 gfc_add_ss_to_loop (&loop, *rss);
4042
4043 /* We only want the shape of the expression, not rest of the junk
4044 generated by the scalarizer. */
4045 loop.array_parameter = 1;
4046
4047 /* Calculate the bounds of the scalarization. */
4048 save_flag = gfc_option.rtcheck;
4049 gfc_option.rtcheck &= ~GFC_RTCHECK_BOUNDS;
4050 gfc_conv_ss_startstride (&loop);
4051 gfc_option.rtcheck = save_flag;
4052 gfc_conv_loop_setup (&loop, &expr2->where);
4053
4054 /* Figure out how many elements we need. */
4055 for (i = 0; i < loop.dimen; i++)
4056 {
4057 tmp = fold_build2_loc (input_location, MINUS_EXPR,
4058 gfc_array_index_type,
4059 gfc_index_one_node, loop.from[i]);
4060 tmp = fold_build2_loc (input_location, PLUS_EXPR,
4061 gfc_array_index_type, tmp, loop.to[i]);
4062 size = fold_build2_loc (input_location, MULT_EXPR,
4063 gfc_array_index_type, size, tmp);
4064 }
4065 gfc_add_block_to_block (pblock, &loop.pre);
4066 size = gfc_evaluate_now (size, pblock);
4067 gfc_add_block_to_block (pblock, &loop.post);
4068
4069 /* TODO: write a function that cleans up a loopinfo without freeing
4070 the SS chains. Currently a NOP. */
4071 }
4072
4073 return size;
4074 }
4075
4076
4077 /* Calculate the overall iterator number of the nested forall construct.
4078 This routine actually calculates the number of times the body of the
4079 nested forall specified by NESTED_FORALL_INFO is executed and multiplies
4080 that by the expression INNER_SIZE. The BLOCK argument specifies the
4081 block in which to calculate the result, and the optional INNER_SIZE_BODY
4082 argument contains any statements that need to executed (inside the loop)
4083 to initialize or calculate INNER_SIZE. */
4084
4085 static tree
compute_overall_iter_number(forall_info * nested_forall_info,tree inner_size,stmtblock_t * inner_size_body,stmtblock_t * block)4086 compute_overall_iter_number (forall_info *nested_forall_info, tree inner_size,
4087 stmtblock_t *inner_size_body, stmtblock_t *block)
4088 {
4089 forall_info *forall_tmp = nested_forall_info;
4090 tree tmp, number;
4091 stmtblock_t body;
4092
4093 /* We can eliminate the innermost unconditional loops with constant
4094 array bounds. */
4095 if (INTEGER_CST_P (inner_size))
4096 {
4097 while (forall_tmp
4098 && !forall_tmp->mask
4099 && INTEGER_CST_P (forall_tmp->size))
4100 {
4101 inner_size = fold_build2_loc (input_location, MULT_EXPR,
4102 gfc_array_index_type,
4103 inner_size, forall_tmp->size);
4104 forall_tmp = forall_tmp->prev_nest;
4105 }
4106
4107 /* If there are no loops left, we have our constant result. */
4108 if (!forall_tmp)
4109 return inner_size;
4110 }
4111
4112 /* Otherwise, create a temporary variable to compute the result. */
4113 number = gfc_create_var (gfc_array_index_type, "num");
4114 gfc_add_modify (block, number, gfc_index_zero_node);
4115
4116 gfc_start_block (&body);
4117 if (inner_size_body)
4118 gfc_add_block_to_block (&body, inner_size_body);
4119 if (forall_tmp)
4120 tmp = fold_build2_loc (input_location, PLUS_EXPR,
4121 gfc_array_index_type, number, inner_size);
4122 else
4123 tmp = inner_size;
4124 gfc_add_modify (&body, number, tmp);
4125 tmp = gfc_finish_block (&body);
4126
4127 /* Generate loops. */
4128 if (forall_tmp != NULL)
4129 tmp = gfc_trans_nested_forall_loop (forall_tmp, tmp, 1);
4130
4131 gfc_add_expr_to_block (block, tmp);
4132
4133 return number;
4134 }
4135
4136
4137 /* Allocate temporary for forall construct. SIZE is the size of temporary
4138 needed. PTEMP1 is returned for space free. */
4139
4140 static tree
allocate_temp_for_forall_nest_1(tree type,tree size,stmtblock_t * block,tree * ptemp1)4141 allocate_temp_for_forall_nest_1 (tree type, tree size, stmtblock_t * block,
4142 tree * ptemp1)
4143 {
4144 tree bytesize;
4145 tree unit;
4146 tree tmp;
4147
4148 unit = fold_convert (gfc_array_index_type, TYPE_SIZE_UNIT (type));
4149 if (!integer_onep (unit))
4150 bytesize = fold_build2_loc (input_location, MULT_EXPR,
4151 gfc_array_index_type, size, unit);
4152 else
4153 bytesize = size;
4154
4155 *ptemp1 = NULL;
4156 tmp = gfc_do_allocate (bytesize, size, ptemp1, block, type);
4157
4158 if (*ptemp1)
4159 tmp = build_fold_indirect_ref_loc (input_location, tmp);
4160 return tmp;
4161 }
4162
4163
4164 /* Allocate temporary for forall construct according to the information in
4165 nested_forall_info. INNER_SIZE is the size of temporary needed in the
4166 assignment inside forall. PTEMP1 is returned for space free. */
4167
4168 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)4169 allocate_temp_for_forall_nest (forall_info * nested_forall_info, tree type,
4170 tree inner_size, stmtblock_t * inner_size_body,
4171 stmtblock_t * block, tree * ptemp1)
4172 {
4173 tree size;
4174
4175 /* Calculate the total size of temporary needed in forall construct. */
4176 size = compute_overall_iter_number (nested_forall_info, inner_size,
4177 inner_size_body, block);
4178
4179 return allocate_temp_for_forall_nest_1 (type, size, block, ptemp1);
4180 }
4181
4182
4183 /* Handle assignments inside forall which need temporary.
4184
4185 forall (i=start:end:stride; maskexpr)
4186 e<i> = f<i>
4187 end forall
4188 (where e,f<i> are arbitrary expressions possibly involving i
4189 and there is a dependency between e<i> and f<i>)
4190 Translates to:
4191 masktmp(:) = maskexpr(:)
4192
4193 maskindex = 0;
4194 count1 = 0;
4195 num = 0;
4196 for (i = start; i <= end; i += stride)
4197 num += SIZE (f<i>)
4198 count1 = 0;
4199 ALLOCATE (tmp(num))
4200 for (i = start; i <= end; i += stride)
4201 {
4202 if (masktmp[maskindex++])
4203 tmp[count1++] = f<i>
4204 }
4205 maskindex = 0;
4206 count1 = 0;
4207 for (i = start; i <= end; i += stride)
4208 {
4209 if (masktmp[maskindex++])
4210 e<i> = tmp[count1++]
4211 }
4212 DEALLOCATE (tmp)
4213 */
4214 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)4215 gfc_trans_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2,
4216 tree wheremask, bool invert,
4217 forall_info * nested_forall_info,
4218 stmtblock_t * block)
4219 {
4220 tree type;
4221 tree inner_size;
4222 gfc_ss *lss, *rss;
4223 tree count, count1;
4224 tree tmp, tmp1;
4225 tree ptemp1;
4226 stmtblock_t inner_size_body;
4227
4228 /* Create vars. count1 is the current iterator number of the nested
4229 forall. */
4230 count1 = gfc_create_var (gfc_array_index_type, "count1");
4231
4232 /* Count is the wheremask index. */
4233 if (wheremask)
4234 {
4235 count = gfc_create_var (gfc_array_index_type, "count");
4236 gfc_add_modify (block, count, gfc_index_zero_node);
4237 }
4238 else
4239 count = NULL;
4240
4241 /* Initialize count1. */
4242 gfc_add_modify (block, count1, gfc_index_zero_node);
4243
4244 /* Calculate the size of temporary needed in the assignment. Return loop, lss
4245 and rss which are used in function generate_loop_for_rhs_to_temp(). */
4246 /* The type of LHS. Used in function allocate_temp_for_forall_nest */
4247 if (expr1->ts.type == BT_CHARACTER)
4248 {
4249 type = NULL;
4250 if (expr1->ref && expr1->ref->type == REF_SUBSTRING)
4251 {
4252 gfc_se ssse;
4253 gfc_init_se (&ssse, NULL);
4254 gfc_conv_expr (&ssse, expr1);
4255 type = gfc_get_character_type_len (gfc_default_character_kind,
4256 ssse.string_length);
4257 }
4258 else
4259 {
4260 if (!expr1->ts.u.cl->backend_decl)
4261 {
4262 gfc_se tse;
4263 gcc_assert (expr1->ts.u.cl->length);
4264 gfc_init_se (&tse, NULL);
4265 gfc_conv_expr (&tse, expr1->ts.u.cl->length);
4266 expr1->ts.u.cl->backend_decl = tse.expr;
4267 }
4268 type = gfc_get_character_type_len (gfc_default_character_kind,
4269 expr1->ts.u.cl->backend_decl);
4270 }
4271 }
4272 else
4273 type = gfc_typenode_for_spec (&expr1->ts);
4274
4275 gfc_init_block (&inner_size_body);
4276 inner_size = compute_inner_temp_size (expr1, expr2, &inner_size_body,
4277 &lss, &rss);
4278
4279 /* Allocate temporary for nested forall construct according to the
4280 information in nested_forall_info and inner_size. */
4281 tmp1 = allocate_temp_for_forall_nest (nested_forall_info, type, inner_size,
4282 &inner_size_body, block, &ptemp1);
4283
4284 /* Generate codes to copy rhs to the temporary . */
4285 tmp = generate_loop_for_rhs_to_temp (expr2, tmp1, count, count1, lss, rss,
4286 wheremask, invert);
4287
4288 /* Generate body and loops according to the information in
4289 nested_forall_info. */
4290 tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
4291 gfc_add_expr_to_block (block, tmp);
4292
4293 /* Reset count1. */
4294 gfc_add_modify (block, count1, gfc_index_zero_node);
4295
4296 /* Reset count. */
4297 if (wheremask)
4298 gfc_add_modify (block, count, gfc_index_zero_node);
4299
4300 /* TODO: Second call to compute_inner_temp_size to initialize lss and
4301 rss; there must be a better way. */
4302 inner_size = compute_inner_temp_size (expr1, expr2, &inner_size_body,
4303 &lss, &rss);
4304
4305 /* Generate codes to copy the temporary to lhs. */
4306 tmp = generate_loop_for_temp_to_lhs (expr1, tmp1, count, count1,
4307 lss, rss,
4308 wheremask, invert);
4309
4310 /* Generate body and loops according to the information in
4311 nested_forall_info. */
4312 tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
4313 gfc_add_expr_to_block (block, tmp);
4314
4315 if (ptemp1)
4316 {
4317 /* Free the temporary. */
4318 tmp = gfc_call_free (ptemp1);
4319 gfc_add_expr_to_block (block, tmp);
4320 }
4321 }
4322
4323
4324 /* Translate pointer assignment inside FORALL which need temporary. */
4325
4326 static void
gfc_trans_pointer_assign_need_temp(gfc_expr * expr1,gfc_expr * expr2,forall_info * nested_forall_info,stmtblock_t * block)4327 gfc_trans_pointer_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2,
4328 forall_info * nested_forall_info,
4329 stmtblock_t * block)
4330 {
4331 tree type;
4332 tree inner_size;
4333 gfc_ss *lss, *rss;
4334 gfc_se lse;
4335 gfc_se rse;
4336 gfc_array_info *info;
4337 gfc_loopinfo loop;
4338 tree desc;
4339 tree parm;
4340 tree parmtype;
4341 stmtblock_t body;
4342 tree count;
4343 tree tmp, tmp1, ptemp1;
4344
4345 count = gfc_create_var (gfc_array_index_type, "count");
4346 gfc_add_modify (block, count, gfc_index_zero_node);
4347
4348 inner_size = gfc_index_one_node;
4349 lss = gfc_walk_expr (expr1);
4350 rss = gfc_walk_expr (expr2);
4351 if (lss == gfc_ss_terminator)
4352 {
4353 type = gfc_typenode_for_spec (&expr1->ts);
4354 type = build_pointer_type (type);
4355
4356 /* Allocate temporary for nested forall construct according to the
4357 information in nested_forall_info and inner_size. */
4358 tmp1 = allocate_temp_for_forall_nest (nested_forall_info, type,
4359 inner_size, NULL, block, &ptemp1);
4360 gfc_start_block (&body);
4361 gfc_init_se (&lse, NULL);
4362 lse.expr = gfc_build_array_ref (tmp1, count, NULL);
4363 gfc_init_se (&rse, NULL);
4364 rse.want_pointer = 1;
4365 gfc_conv_expr (&rse, expr2);
4366 gfc_add_block_to_block (&body, &rse.pre);
4367 gfc_add_modify (&body, lse.expr,
4368 fold_convert (TREE_TYPE (lse.expr), rse.expr));
4369 gfc_add_block_to_block (&body, &rse.post);
4370
4371 /* Increment count. */
4372 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
4373 count, gfc_index_one_node);
4374 gfc_add_modify (&body, count, tmp);
4375
4376 tmp = gfc_finish_block (&body);
4377
4378 /* Generate body and loops according to the information in
4379 nested_forall_info. */
4380 tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
4381 gfc_add_expr_to_block (block, tmp);
4382
4383 /* Reset count. */
4384 gfc_add_modify (block, count, gfc_index_zero_node);
4385
4386 gfc_start_block (&body);
4387 gfc_init_se (&lse, NULL);
4388 gfc_init_se (&rse, NULL);
4389 rse.expr = gfc_build_array_ref (tmp1, count, NULL);
4390 lse.want_pointer = 1;
4391 gfc_conv_expr (&lse, expr1);
4392 gfc_add_block_to_block (&body, &lse.pre);
4393 gfc_add_modify (&body, lse.expr, rse.expr);
4394 gfc_add_block_to_block (&body, &lse.post);
4395 /* Increment count. */
4396 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
4397 count, gfc_index_one_node);
4398 gfc_add_modify (&body, count, tmp);
4399 tmp = gfc_finish_block (&body);
4400
4401 /* Generate body and loops according to the information in
4402 nested_forall_info. */
4403 tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
4404 gfc_add_expr_to_block (block, tmp);
4405 }
4406 else
4407 {
4408 gfc_init_loopinfo (&loop);
4409
4410 /* Associate the SS with the loop. */
4411 gfc_add_ss_to_loop (&loop, rss);
4412
4413 /* Setup the scalarizing loops and bounds. */
4414 gfc_conv_ss_startstride (&loop);
4415
4416 gfc_conv_loop_setup (&loop, &expr2->where);
4417
4418 info = &rss->info->data.array;
4419 desc = info->descriptor;
4420
4421 /* Make a new descriptor. */
4422 parmtype = gfc_get_element_type (TREE_TYPE (desc));
4423 parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen, 0,
4424 loop.from, loop.to, 1,
4425 GFC_ARRAY_UNKNOWN, true);
4426
4427 /* Allocate temporary for nested forall construct. */
4428 tmp1 = allocate_temp_for_forall_nest (nested_forall_info, parmtype,
4429 inner_size, NULL, block, &ptemp1);
4430 gfc_start_block (&body);
4431 gfc_init_se (&lse, NULL);
4432 lse.expr = gfc_build_array_ref (tmp1, count, NULL);
4433 lse.direct_byref = 1;
4434 gfc_conv_expr_descriptor (&lse, expr2);
4435
4436 gfc_add_block_to_block (&body, &lse.pre);
4437 gfc_add_block_to_block (&body, &lse.post);
4438
4439 /* Increment count. */
4440 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
4441 count, gfc_index_one_node);
4442 gfc_add_modify (&body, count, tmp);
4443
4444 tmp = gfc_finish_block (&body);
4445
4446 /* Generate body and loops according to the information in
4447 nested_forall_info. */
4448 tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
4449 gfc_add_expr_to_block (block, tmp);
4450
4451 /* Reset count. */
4452 gfc_add_modify (block, count, gfc_index_zero_node);
4453
4454 parm = gfc_build_array_ref (tmp1, count, NULL);
4455 gfc_init_se (&lse, NULL);
4456 gfc_conv_expr_descriptor (&lse, expr1);
4457 gfc_add_modify (&lse.pre, lse.expr, parm);
4458 gfc_start_block (&body);
4459 gfc_add_block_to_block (&body, &lse.pre);
4460 gfc_add_block_to_block (&body, &lse.post);
4461
4462 /* Increment count. */
4463 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
4464 count, gfc_index_one_node);
4465 gfc_add_modify (&body, count, tmp);
4466
4467 tmp = gfc_finish_block (&body);
4468
4469 tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
4470 gfc_add_expr_to_block (block, tmp);
4471 }
4472 /* Free the temporary. */
4473 if (ptemp1)
4474 {
4475 tmp = gfc_call_free (ptemp1);
4476 gfc_add_expr_to_block (block, tmp);
4477 }
4478 }
4479
4480
4481 /* FORALL and WHERE statements are really nasty, especially when you nest
4482 them. All the rhs of a forall assignment must be evaluated before the
4483 actual assignments are performed. Presumably this also applies to all the
4484 assignments in an inner where statement. */
4485
4486 /* Generate code for a FORALL statement. Any temporaries are allocated as a
4487 linear array, relying on the fact that we process in the same order in all
4488 loops.
4489
4490 forall (i=start:end:stride; maskexpr)
4491 e<i> = f<i>
4492 g<i> = h<i>
4493 end forall
4494 (where e,f,g,h<i> are arbitrary expressions possibly involving i)
4495 Translates to:
4496 count = ((end + 1 - start) / stride)
4497 masktmp(:) = maskexpr(:)
4498
4499 maskindex = 0;
4500 for (i = start; i <= end; i += stride)
4501 {
4502 if (masktmp[maskindex++])
4503 e<i> = f<i>
4504 }
4505 maskindex = 0;
4506 for (i = start; i <= end; i += stride)
4507 {
4508 if (masktmp[maskindex++])
4509 g<i> = h<i>
4510 }
4511
4512 Note that this code only works when there are no dependencies.
4513 Forall loop with array assignments and data dependencies are a real pain,
4514 because the size of the temporary cannot always be determined before the
4515 loop is executed. This problem is compounded by the presence of nested
4516 FORALL constructs.
4517 */
4518
4519 static tree
gfc_trans_forall_1(gfc_code * code,forall_info * nested_forall_info)4520 gfc_trans_forall_1 (gfc_code * code, forall_info * nested_forall_info)
4521 {
4522 stmtblock_t pre;
4523 stmtblock_t post;
4524 stmtblock_t block;
4525 stmtblock_t body;
4526 tree *var;
4527 tree *start;
4528 tree *end;
4529 tree *step;
4530 gfc_expr **varexpr;
4531 tree tmp;
4532 tree assign;
4533 tree size;
4534 tree maskindex;
4535 tree mask;
4536 tree pmask;
4537 tree cycle_label = NULL_TREE;
4538 int n;
4539 int nvar;
4540 int need_temp;
4541 gfc_forall_iterator *fa;
4542 gfc_se se;
4543 gfc_code *c;
4544 gfc_saved_var *saved_vars;
4545 iter_info *this_forall;
4546 forall_info *info;
4547 bool need_mask;
4548
4549 /* Do nothing if the mask is false. */
4550 if (code->expr1
4551 && code->expr1->expr_type == EXPR_CONSTANT
4552 && !code->expr1->value.logical)
4553 return build_empty_stmt (input_location);
4554
4555 n = 0;
4556 /* Count the FORALL index number. */
4557 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
4558 n++;
4559 nvar = n;
4560
4561 /* Allocate the space for var, start, end, step, varexpr. */
4562 var = XCNEWVEC (tree, nvar);
4563 start = XCNEWVEC (tree, nvar);
4564 end = XCNEWVEC (tree, nvar);
4565 step = XCNEWVEC (tree, nvar);
4566 varexpr = XCNEWVEC (gfc_expr *, nvar);
4567 saved_vars = XCNEWVEC (gfc_saved_var, nvar);
4568
4569 /* Allocate the space for info. */
4570 info = XCNEW (forall_info);
4571
4572 gfc_start_block (&pre);
4573 gfc_init_block (&post);
4574 gfc_init_block (&block);
4575
4576 n = 0;
4577 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
4578 {
4579 gfc_symbol *sym = fa->var->symtree->n.sym;
4580
4581 /* Allocate space for this_forall. */
4582 this_forall = XCNEW (iter_info);
4583
4584 /* Create a temporary variable for the FORALL index. */
4585 tmp = gfc_typenode_for_spec (&sym->ts);
4586 var[n] = gfc_create_var (tmp, sym->name);
4587 gfc_shadow_sym (sym, var[n], &saved_vars[n]);
4588
4589 /* Record it in this_forall. */
4590 this_forall->var = var[n];
4591
4592 /* Replace the index symbol's backend_decl with the temporary decl. */
4593 sym->backend_decl = var[n];
4594
4595 /* Work out the start, end and stride for the loop. */
4596 gfc_init_se (&se, NULL);
4597 gfc_conv_expr_val (&se, fa->start);
4598 /* Record it in this_forall. */
4599 this_forall->start = se.expr;
4600 gfc_add_block_to_block (&block, &se.pre);
4601 start[n] = se.expr;
4602
4603 gfc_init_se (&se, NULL);
4604 gfc_conv_expr_val (&se, fa->end);
4605 /* Record it in this_forall. */
4606 this_forall->end = se.expr;
4607 gfc_make_safe_expr (&se);
4608 gfc_add_block_to_block (&block, &se.pre);
4609 end[n] = se.expr;
4610
4611 gfc_init_se (&se, NULL);
4612 gfc_conv_expr_val (&se, fa->stride);
4613 /* Record it in this_forall. */
4614 this_forall->step = se.expr;
4615 gfc_make_safe_expr (&se);
4616 gfc_add_block_to_block (&block, &se.pre);
4617 step[n] = se.expr;
4618
4619 /* Set the NEXT field of this_forall to NULL. */
4620 this_forall->next = NULL;
4621 /* Link this_forall to the info construct. */
4622 if (info->this_loop)
4623 {
4624 iter_info *iter_tmp = info->this_loop;
4625 while (iter_tmp->next != NULL)
4626 iter_tmp = iter_tmp->next;
4627 iter_tmp->next = this_forall;
4628 }
4629 else
4630 info->this_loop = this_forall;
4631
4632 n++;
4633 }
4634 nvar = n;
4635
4636 /* Calculate the size needed for the current forall level. */
4637 size = gfc_index_one_node;
4638 for (n = 0; n < nvar; n++)
4639 {
4640 /* size = (end + step - start) / step. */
4641 tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (start[n]),
4642 step[n], start[n]);
4643 tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (end[n]),
4644 end[n], tmp);
4645 tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR, TREE_TYPE (tmp),
4646 tmp, step[n]);
4647 tmp = convert (gfc_array_index_type, tmp);
4648
4649 size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
4650 size, tmp);
4651 }
4652
4653 /* Record the nvar and size of current forall level. */
4654 info->nvar = nvar;
4655 info->size = size;
4656
4657 if (code->expr1)
4658 {
4659 /* If the mask is .true., consider the FORALL unconditional. */
4660 if (code->expr1->expr_type == EXPR_CONSTANT
4661 && code->expr1->value.logical)
4662 need_mask = false;
4663 else
4664 need_mask = true;
4665 }
4666 else
4667 need_mask = false;
4668
4669 /* First we need to allocate the mask. */
4670 if (need_mask)
4671 {
4672 /* As the mask array can be very big, prefer compact boolean types. */
4673 tree mask_type = gfc_get_logical_type (gfc_logical_kinds[0].kind);
4674 mask = allocate_temp_for_forall_nest (nested_forall_info, mask_type,
4675 size, NULL, &block, &pmask);
4676 maskindex = gfc_create_var_np (gfc_array_index_type, "mi");
4677
4678 /* Record them in the info structure. */
4679 info->maskindex = maskindex;
4680 info->mask = mask;
4681 }
4682 else
4683 {
4684 /* No mask was specified. */
4685 maskindex = NULL_TREE;
4686 mask = pmask = NULL_TREE;
4687 }
4688
4689 /* Link the current forall level to nested_forall_info. */
4690 info->prev_nest = nested_forall_info;
4691 nested_forall_info = info;
4692
4693 /* Copy the mask into a temporary variable if required.
4694 For now we assume a mask temporary is needed. */
4695 if (need_mask)
4696 {
4697 /* As the mask array can be very big, prefer compact boolean types. */
4698 tree mask_type = gfc_get_logical_type (gfc_logical_kinds[0].kind);
4699
4700 gfc_add_modify (&block, maskindex, gfc_index_zero_node);
4701
4702 /* Start of mask assignment loop body. */
4703 gfc_start_block (&body);
4704
4705 /* Evaluate the mask expression. */
4706 gfc_init_se (&se, NULL);
4707 gfc_conv_expr_val (&se, code->expr1);
4708 gfc_add_block_to_block (&body, &se.pre);
4709
4710 /* Store the mask. */
4711 se.expr = convert (mask_type, se.expr);
4712
4713 tmp = gfc_build_array_ref (mask, maskindex, NULL);
4714 gfc_add_modify (&body, tmp, se.expr);
4715
4716 /* Advance to the next mask element. */
4717 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
4718 maskindex, gfc_index_one_node);
4719 gfc_add_modify (&body, maskindex, tmp);
4720
4721 /* Generate the loops. */
4722 tmp = gfc_finish_block (&body);
4723 tmp = gfc_trans_nested_forall_loop (info, tmp, 0);
4724 gfc_add_expr_to_block (&block, tmp);
4725 }
4726
4727 if (code->op == EXEC_DO_CONCURRENT)
4728 {
4729 gfc_init_block (&body);
4730 cycle_label = gfc_build_label_decl (NULL_TREE);
4731 code->cycle_label = cycle_label;
4732 tmp = gfc_trans_code (code->block->next);
4733 gfc_add_expr_to_block (&body, tmp);
4734
4735 if (TREE_USED (cycle_label))
4736 {
4737 tmp = build1_v (LABEL_EXPR, cycle_label);
4738 gfc_add_expr_to_block (&body, tmp);
4739 }
4740
4741 tmp = gfc_finish_block (&body);
4742 nested_forall_info->do_concurrent = true;
4743 tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
4744 gfc_add_expr_to_block (&block, tmp);
4745 goto done;
4746 }
4747
4748 c = code->block->next;
4749
4750 /* TODO: loop merging in FORALL statements. */
4751 /* Now that we've got a copy of the mask, generate the assignment loops. */
4752 while (c)
4753 {
4754 switch (c->op)
4755 {
4756 case EXEC_ASSIGN:
4757 /* A scalar or array assignment. DO the simple check for
4758 lhs to rhs dependencies. These make a temporary for the
4759 rhs and form a second forall block to copy to variable. */
4760 need_temp = check_forall_dependencies(c, &pre, &post);
4761
4762 /* Temporaries due to array assignment data dependencies introduce
4763 no end of problems. */
4764 if (need_temp || flag_test_forall_temp)
4765 gfc_trans_assign_need_temp (c->expr1, c->expr2, NULL, false,
4766 nested_forall_info, &block);
4767 else
4768 {
4769 /* Use the normal assignment copying routines. */
4770 assign = gfc_trans_assignment (c->expr1, c->expr2, false, true);
4771
4772 /* Generate body and loops. */
4773 tmp = gfc_trans_nested_forall_loop (nested_forall_info,
4774 assign, 1);
4775 gfc_add_expr_to_block (&block, tmp);
4776 }
4777
4778 /* Cleanup any temporary symtrees that have been made to deal
4779 with dependencies. */
4780 if (new_symtree)
4781 cleanup_forall_symtrees (c);
4782
4783 break;
4784
4785 case EXEC_WHERE:
4786 /* Translate WHERE or WHERE construct nested in FORALL. */
4787 gfc_trans_where_2 (c, NULL, false, nested_forall_info, &block);
4788 break;
4789
4790 /* Pointer assignment inside FORALL. */
4791 case EXEC_POINTER_ASSIGN:
4792 need_temp = gfc_check_dependency (c->expr1, c->expr2, 0);
4793 /* Avoid cases where a temporary would never be needed and where
4794 the temp code is guaranteed to fail. */
4795 if (need_temp
4796 || (flag_test_forall_temp
4797 && c->expr2->expr_type != EXPR_CONSTANT
4798 && c->expr2->expr_type != EXPR_NULL))
4799 gfc_trans_pointer_assign_need_temp (c->expr1, c->expr2,
4800 nested_forall_info, &block);
4801 else
4802 {
4803 /* Use the normal assignment copying routines. */
4804 assign = gfc_trans_pointer_assignment (c->expr1, c->expr2);
4805
4806 /* Generate body and loops. */
4807 tmp = gfc_trans_nested_forall_loop (nested_forall_info,
4808 assign, 1);
4809 gfc_add_expr_to_block (&block, tmp);
4810 }
4811 break;
4812
4813 case EXEC_FORALL:
4814 tmp = gfc_trans_forall_1 (c, nested_forall_info);
4815 gfc_add_expr_to_block (&block, tmp);
4816 break;
4817
4818 /* Explicit subroutine calls are prevented by the frontend but interface
4819 assignments can legitimately produce them. */
4820 case EXEC_ASSIGN_CALL:
4821 assign = gfc_trans_call (c, true, NULL_TREE, NULL_TREE, false);
4822 tmp = gfc_trans_nested_forall_loop (nested_forall_info, assign, 1);
4823 gfc_add_expr_to_block (&block, tmp);
4824 break;
4825
4826 default:
4827 gcc_unreachable ();
4828 }
4829
4830 c = c->next;
4831 }
4832
4833 done:
4834 /* Restore the original index variables. */
4835 for (fa = code->ext.forall_iterator, n = 0; fa; fa = fa->next, n++)
4836 gfc_restore_sym (fa->var->symtree->n.sym, &saved_vars[n]);
4837
4838 /* Free the space for var, start, end, step, varexpr. */
4839 free (var);
4840 free (start);
4841 free (end);
4842 free (step);
4843 free (varexpr);
4844 free (saved_vars);
4845
4846 for (this_forall = info->this_loop; this_forall;)
4847 {
4848 iter_info *next = this_forall->next;
4849 free (this_forall);
4850 this_forall = next;
4851 }
4852
4853 /* Free the space for this forall_info. */
4854 free (info);
4855
4856 if (pmask)
4857 {
4858 /* Free the temporary for the mask. */
4859 tmp = gfc_call_free (pmask);
4860 gfc_add_expr_to_block (&block, tmp);
4861 }
4862 if (maskindex)
4863 pushdecl (maskindex);
4864
4865 gfc_add_block_to_block (&pre, &block);
4866 gfc_add_block_to_block (&pre, &post);
4867
4868 return gfc_finish_block (&pre);
4869 }
4870
4871
4872 /* Translate the FORALL statement or construct. */
4873
gfc_trans_forall(gfc_code * code)4874 tree gfc_trans_forall (gfc_code * code)
4875 {
4876 return gfc_trans_forall_1 (code, NULL);
4877 }
4878
4879
4880 /* Translate the DO CONCURRENT construct. */
4881
gfc_trans_do_concurrent(gfc_code * code)4882 tree gfc_trans_do_concurrent (gfc_code * code)
4883 {
4884 return gfc_trans_forall_1 (code, NULL);
4885 }
4886
4887
4888 /* Evaluate the WHERE mask expression, copy its value to a temporary.
4889 If the WHERE construct is nested in FORALL, compute the overall temporary
4890 needed by the WHERE mask expression multiplied by the iterator number of
4891 the nested forall.
4892 ME is the WHERE mask expression.
4893 MASK is the current execution mask upon input, whose sense may or may
4894 not be inverted as specified by the INVERT argument.
4895 CMASK is the updated execution mask on output, or NULL if not required.
4896 PMASK is the pending execution mask on output, or NULL if not required.
4897 BLOCK is the block in which to place the condition evaluation loops. */
4898
4899 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)4900 gfc_evaluate_where_mask (gfc_expr * me, forall_info * nested_forall_info,
4901 tree mask, bool invert, tree cmask, tree pmask,
4902 tree mask_type, stmtblock_t * block)
4903 {
4904 tree tmp, tmp1;
4905 gfc_ss *lss, *rss;
4906 gfc_loopinfo loop;
4907 stmtblock_t body, body1;
4908 tree count, cond, mtmp;
4909 gfc_se lse, rse;
4910
4911 gfc_init_loopinfo (&loop);
4912
4913 lss = gfc_walk_expr (me);
4914 rss = gfc_walk_expr (me);
4915
4916 /* Variable to index the temporary. */
4917 count = gfc_create_var (gfc_array_index_type, "count");
4918 /* Initialize count. */
4919 gfc_add_modify (block, count, gfc_index_zero_node);
4920
4921 gfc_start_block (&body);
4922
4923 gfc_init_se (&rse, NULL);
4924 gfc_init_se (&lse, NULL);
4925
4926 if (lss == gfc_ss_terminator)
4927 {
4928 gfc_init_block (&body1);
4929 }
4930 else
4931 {
4932 /* Initialize the loop. */
4933 gfc_init_loopinfo (&loop);
4934
4935 /* We may need LSS to determine the shape of the expression. */
4936 gfc_add_ss_to_loop (&loop, lss);
4937 gfc_add_ss_to_loop (&loop, rss);
4938
4939 gfc_conv_ss_startstride (&loop);
4940 gfc_conv_loop_setup (&loop, &me->where);
4941
4942 gfc_mark_ss_chain_used (rss, 1);
4943 /* Start the loop body. */
4944 gfc_start_scalarized_body (&loop, &body1);
4945
4946 /* Translate the expression. */
4947 gfc_copy_loopinfo_to_se (&rse, &loop);
4948 rse.ss = rss;
4949 gfc_conv_expr (&rse, me);
4950 }
4951
4952 /* Variable to evaluate mask condition. */
4953 cond = gfc_create_var (mask_type, "cond");
4954 if (mask && (cmask || pmask))
4955 mtmp = gfc_create_var (mask_type, "mask");
4956 else mtmp = NULL_TREE;
4957
4958 gfc_add_block_to_block (&body1, &lse.pre);
4959 gfc_add_block_to_block (&body1, &rse.pre);
4960
4961 gfc_add_modify (&body1, cond, fold_convert (mask_type, rse.expr));
4962
4963 if (mask && (cmask || pmask))
4964 {
4965 tmp = gfc_build_array_ref (mask, count, NULL);
4966 if (invert)
4967 tmp = fold_build1_loc (input_location, TRUTH_NOT_EXPR, mask_type, tmp);
4968 gfc_add_modify (&body1, mtmp, tmp);
4969 }
4970
4971 if (cmask)
4972 {
4973 tmp1 = gfc_build_array_ref (cmask, count, NULL);
4974 tmp = cond;
4975 if (mask)
4976 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, mask_type,
4977 mtmp, tmp);
4978 gfc_add_modify (&body1, tmp1, tmp);
4979 }
4980
4981 if (pmask)
4982 {
4983 tmp1 = gfc_build_array_ref (pmask, count, NULL);
4984 tmp = fold_build1_loc (input_location, TRUTH_NOT_EXPR, mask_type, cond);
4985 if (mask)
4986 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, mask_type, mtmp,
4987 tmp);
4988 gfc_add_modify (&body1, tmp1, tmp);
4989 }
4990
4991 gfc_add_block_to_block (&body1, &lse.post);
4992 gfc_add_block_to_block (&body1, &rse.post);
4993
4994 if (lss == gfc_ss_terminator)
4995 {
4996 gfc_add_block_to_block (&body, &body1);
4997 }
4998 else
4999 {
5000 /* Increment count. */
5001 tmp1 = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
5002 count, gfc_index_one_node);
5003 gfc_add_modify (&body1, count, tmp1);
5004
5005 /* Generate the copying loops. */
5006 gfc_trans_scalarizing_loops (&loop, &body1);
5007
5008 gfc_add_block_to_block (&body, &loop.pre);
5009 gfc_add_block_to_block (&body, &loop.post);
5010
5011 gfc_cleanup_loop (&loop);
5012 /* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful
5013 as tree nodes in SS may not be valid in different scope. */
5014 }
5015
5016 tmp1 = gfc_finish_block (&body);
5017 /* If the WHERE construct is inside FORALL, fill the full temporary. */
5018 if (nested_forall_info != NULL)
5019 tmp1 = gfc_trans_nested_forall_loop (nested_forall_info, tmp1, 1);
5020
5021 gfc_add_expr_to_block (block, tmp1);
5022 }
5023
5024
5025 /* Translate an assignment statement in a WHERE statement or construct
5026 statement. The MASK expression is used to control which elements
5027 of EXPR1 shall be assigned. The sense of MASK is specified by
5028 INVERT. */
5029
5030 static tree
gfc_trans_where_assign(gfc_expr * expr1,gfc_expr * expr2,tree mask,bool invert,tree count1,tree count2,gfc_code * cnext)5031 gfc_trans_where_assign (gfc_expr *expr1, gfc_expr *expr2,
5032 tree mask, bool invert,
5033 tree count1, tree count2,
5034 gfc_code *cnext)
5035 {
5036 gfc_se lse;
5037 gfc_se rse;
5038 gfc_ss *lss;
5039 gfc_ss *lss_section;
5040 gfc_ss *rss;
5041
5042 gfc_loopinfo loop;
5043 tree tmp;
5044 stmtblock_t block;
5045 stmtblock_t body;
5046 tree index, maskexpr;
5047
5048 /* A defined assignment. */
5049 if (cnext && cnext->resolved_sym)
5050 return gfc_trans_call (cnext, true, mask, count1, invert);
5051
5052 #if 0
5053 /* TODO: handle this special case.
5054 Special case a single function returning an array. */
5055 if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
5056 {
5057 tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
5058 if (tmp)
5059 return tmp;
5060 }
5061 #endif
5062
5063 /* Assignment of the form lhs = rhs. */
5064 gfc_start_block (&block);
5065
5066 gfc_init_se (&lse, NULL);
5067 gfc_init_se (&rse, NULL);
5068
5069 /* Walk the lhs. */
5070 lss = gfc_walk_expr (expr1);
5071 rss = NULL;
5072
5073 /* In each where-assign-stmt, the mask-expr and the variable being
5074 defined shall be arrays of the same shape. */
5075 gcc_assert (lss != gfc_ss_terminator);
5076
5077 /* The assignment needs scalarization. */
5078 lss_section = lss;
5079
5080 /* Find a non-scalar SS from the lhs. */
5081 while (lss_section != gfc_ss_terminator
5082 && lss_section->info->type != GFC_SS_SECTION)
5083 lss_section = lss_section->next;
5084
5085 gcc_assert (lss_section != gfc_ss_terminator);
5086
5087 /* Initialize the scalarizer. */
5088 gfc_init_loopinfo (&loop);
5089
5090 /* Walk the rhs. */
5091 rss = gfc_walk_expr (expr2);
5092 if (rss == gfc_ss_terminator)
5093 {
5094 /* The rhs is scalar. Add a ss for the expression. */
5095 rss = gfc_get_scalar_ss (gfc_ss_terminator, expr2);
5096 rss->info->where = 1;
5097 }
5098
5099 /* Associate the SS with the loop. */
5100 gfc_add_ss_to_loop (&loop, lss);
5101 gfc_add_ss_to_loop (&loop, rss);
5102
5103 /* Calculate the bounds of the scalarization. */
5104 gfc_conv_ss_startstride (&loop);
5105
5106 /* Resolve any data dependencies in the statement. */
5107 gfc_conv_resolve_dependencies (&loop, lss_section, rss);
5108
5109 /* Setup the scalarizing loops. */
5110 gfc_conv_loop_setup (&loop, &expr2->where);
5111
5112 /* Setup the gfc_se structures. */
5113 gfc_copy_loopinfo_to_se (&lse, &loop);
5114 gfc_copy_loopinfo_to_se (&rse, &loop);
5115
5116 rse.ss = rss;
5117 gfc_mark_ss_chain_used (rss, 1);
5118 if (loop.temp_ss == NULL)
5119 {
5120 lse.ss = lss;
5121 gfc_mark_ss_chain_used (lss, 1);
5122 }
5123 else
5124 {
5125 lse.ss = loop.temp_ss;
5126 gfc_mark_ss_chain_used (lss, 3);
5127 gfc_mark_ss_chain_used (loop.temp_ss, 3);
5128 }
5129
5130 /* Start the scalarized loop body. */
5131 gfc_start_scalarized_body (&loop, &body);
5132
5133 /* Translate the expression. */
5134 gfc_conv_expr (&rse, expr2);
5135 if (lss != gfc_ss_terminator && loop.temp_ss != NULL)
5136 gfc_conv_tmp_array_ref (&lse);
5137 else
5138 gfc_conv_expr (&lse, expr1);
5139
5140 /* Form the mask expression according to the mask. */
5141 index = count1;
5142 maskexpr = gfc_build_array_ref (mask, index, NULL);
5143 if (invert)
5144 maskexpr = fold_build1_loc (input_location, TRUTH_NOT_EXPR,
5145 TREE_TYPE (maskexpr), maskexpr);
5146
5147 /* Use the scalar assignment as is. */
5148 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
5149 false, loop.temp_ss == NULL);
5150
5151 tmp = build3_v (COND_EXPR, maskexpr, tmp, build_empty_stmt (input_location));
5152
5153 gfc_add_expr_to_block (&body, tmp);
5154
5155 if (lss == gfc_ss_terminator)
5156 {
5157 /* Increment count1. */
5158 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
5159 count1, gfc_index_one_node);
5160 gfc_add_modify (&body, count1, tmp);
5161
5162 /* Use the scalar assignment as is. */
5163 gfc_add_block_to_block (&block, &body);
5164 }
5165 else
5166 {
5167 gcc_assert (lse.ss == gfc_ss_terminator
5168 && rse.ss == gfc_ss_terminator);
5169
5170 if (loop.temp_ss != NULL)
5171 {
5172 /* Increment count1 before finish the main body of a scalarized
5173 expression. */
5174 tmp = fold_build2_loc (input_location, PLUS_EXPR,
5175 gfc_array_index_type, count1, gfc_index_one_node);
5176 gfc_add_modify (&body, count1, tmp);
5177 gfc_trans_scalarized_loop_boundary (&loop, &body);
5178
5179 /* We need to copy the temporary to the actual lhs. */
5180 gfc_init_se (&lse, NULL);
5181 gfc_init_se (&rse, NULL);
5182 gfc_copy_loopinfo_to_se (&lse, &loop);
5183 gfc_copy_loopinfo_to_se (&rse, &loop);
5184
5185 rse.ss = loop.temp_ss;
5186 lse.ss = lss;
5187
5188 gfc_conv_tmp_array_ref (&rse);
5189 gfc_conv_expr (&lse, expr1);
5190
5191 gcc_assert (lse.ss == gfc_ss_terminator
5192 && rse.ss == gfc_ss_terminator);
5193
5194 /* Form the mask expression according to the mask tree list. */
5195 index = count2;
5196 maskexpr = gfc_build_array_ref (mask, index, NULL);
5197 if (invert)
5198 maskexpr = fold_build1_loc (input_location, TRUTH_NOT_EXPR,
5199 TREE_TYPE (maskexpr), maskexpr);
5200
5201 /* Use the scalar assignment as is. */
5202 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts, false, true);
5203 tmp = build3_v (COND_EXPR, maskexpr, tmp,
5204 build_empty_stmt (input_location));
5205 gfc_add_expr_to_block (&body, tmp);
5206
5207 /* Increment count2. */
5208 tmp = fold_build2_loc (input_location, PLUS_EXPR,
5209 gfc_array_index_type, count2,
5210 gfc_index_one_node);
5211 gfc_add_modify (&body, count2, tmp);
5212 }
5213 else
5214 {
5215 /* Increment count1. */
5216 tmp = fold_build2_loc (input_location, PLUS_EXPR,
5217 gfc_array_index_type, count1,
5218 gfc_index_one_node);
5219 gfc_add_modify (&body, count1, tmp);
5220 }
5221
5222 /* Generate the copying loops. */
5223 gfc_trans_scalarizing_loops (&loop, &body);
5224
5225 /* Wrap the whole thing up. */
5226 gfc_add_block_to_block (&block, &loop.pre);
5227 gfc_add_block_to_block (&block, &loop.post);
5228 gfc_cleanup_loop (&loop);
5229 }
5230
5231 return gfc_finish_block (&block);
5232 }
5233
5234
5235 /* Translate the WHERE construct or statement.
5236 This function can be called iteratively to translate the nested WHERE
5237 construct or statement.
5238 MASK is the control mask. */
5239
5240 static void
gfc_trans_where_2(gfc_code * code,tree mask,bool invert,forall_info * nested_forall_info,stmtblock_t * block)5241 gfc_trans_where_2 (gfc_code * code, tree mask, bool invert,
5242 forall_info * nested_forall_info, stmtblock_t * block)
5243 {
5244 stmtblock_t inner_size_body;
5245 tree inner_size, size;
5246 gfc_ss *lss, *rss;
5247 tree mask_type;
5248 gfc_expr *expr1;
5249 gfc_expr *expr2;
5250 gfc_code *cblock;
5251 gfc_code *cnext;
5252 tree tmp;
5253 tree cond;
5254 tree count1, count2;
5255 bool need_cmask;
5256 bool need_pmask;
5257 int need_temp;
5258 tree pcmask = NULL_TREE;
5259 tree ppmask = NULL_TREE;
5260 tree cmask = NULL_TREE;
5261 tree pmask = NULL_TREE;
5262 gfc_actual_arglist *arg;
5263
5264 /* the WHERE statement or the WHERE construct statement. */
5265 cblock = code->block;
5266
5267 /* As the mask array can be very big, prefer compact boolean types. */
5268 mask_type = gfc_get_logical_type (gfc_logical_kinds[0].kind);
5269
5270 /* Determine which temporary masks are needed. */
5271 if (!cblock->block)
5272 {
5273 /* One clause: No ELSEWHEREs. */
5274 need_cmask = (cblock->next != 0);
5275 need_pmask = false;
5276 }
5277 else if (cblock->block->block)
5278 {
5279 /* Three or more clauses: Conditional ELSEWHEREs. */
5280 need_cmask = true;
5281 need_pmask = true;
5282 }
5283 else if (cblock->next)
5284 {
5285 /* Two clauses, the first non-empty. */
5286 need_cmask = true;
5287 need_pmask = (mask != NULL_TREE
5288 && cblock->block->next != 0);
5289 }
5290 else if (!cblock->block->next)
5291 {
5292 /* Two clauses, both empty. */
5293 need_cmask = false;
5294 need_pmask = false;
5295 }
5296 /* Two clauses, the first empty, the second non-empty. */
5297 else if (mask)
5298 {
5299 need_cmask = (cblock->block->expr1 != 0);
5300 need_pmask = true;
5301 }
5302 else
5303 {
5304 need_cmask = true;
5305 need_pmask = false;
5306 }
5307
5308 if (need_cmask || need_pmask)
5309 {
5310 /* Calculate the size of temporary needed by the mask-expr. */
5311 gfc_init_block (&inner_size_body);
5312 inner_size = compute_inner_temp_size (cblock->expr1, cblock->expr1,
5313 &inner_size_body, &lss, &rss);
5314
5315 gfc_free_ss_chain (lss);
5316 gfc_free_ss_chain (rss);
5317
5318 /* Calculate the total size of temporary needed. */
5319 size = compute_overall_iter_number (nested_forall_info, inner_size,
5320 &inner_size_body, block);
5321
5322 /* Check whether the size is negative. */
5323 cond = fold_build2_loc (input_location, LE_EXPR, logical_type_node, size,
5324 gfc_index_zero_node);
5325 size = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type,
5326 cond, gfc_index_zero_node, size);
5327 size = gfc_evaluate_now (size, block);
5328
5329 /* Allocate temporary for WHERE mask if needed. */
5330 if (need_cmask)
5331 cmask = allocate_temp_for_forall_nest_1 (mask_type, size, block,
5332 &pcmask);
5333
5334 /* Allocate temporary for !mask if needed. */
5335 if (need_pmask)
5336 pmask = allocate_temp_for_forall_nest_1 (mask_type, size, block,
5337 &ppmask);
5338 }
5339
5340 while (cblock)
5341 {
5342 /* Each time around this loop, the where clause is conditional
5343 on the value of mask and invert, which are updated at the
5344 bottom of the loop. */
5345
5346 /* Has mask-expr. */
5347 if (cblock->expr1)
5348 {
5349 /* Ensure that the WHERE mask will be evaluated exactly once.
5350 If there are no statements in this WHERE/ELSEWHERE clause,
5351 then we don't need to update the control mask (cmask).
5352 If this is the last clause of the WHERE construct, then
5353 we don't need to update the pending control mask (pmask). */
5354 if (mask)
5355 gfc_evaluate_where_mask (cblock->expr1, nested_forall_info,
5356 mask, invert,
5357 cblock->next ? cmask : NULL_TREE,
5358 cblock->block ? pmask : NULL_TREE,
5359 mask_type, block);
5360 else
5361 gfc_evaluate_where_mask (cblock->expr1, nested_forall_info,
5362 NULL_TREE, false,
5363 (cblock->next || cblock->block)
5364 ? cmask : NULL_TREE,
5365 NULL_TREE, mask_type, block);
5366
5367 invert = false;
5368 }
5369 /* It's a final elsewhere-stmt. No mask-expr is present. */
5370 else
5371 cmask = mask;
5372
5373 /* The body of this where clause are controlled by cmask with
5374 sense specified by invert. */
5375
5376 /* Get the assignment statement of a WHERE statement, or the first
5377 statement in where-body-construct of a WHERE construct. */
5378 cnext = cblock->next;
5379 while (cnext)
5380 {
5381 switch (cnext->op)
5382 {
5383 /* WHERE assignment statement. */
5384 case EXEC_ASSIGN_CALL:
5385
5386 arg = cnext->ext.actual;
5387 expr1 = expr2 = NULL;
5388 for (; arg; arg = arg->next)
5389 {
5390 if (!arg->expr)
5391 continue;
5392 if (expr1 == NULL)
5393 expr1 = arg->expr;
5394 else
5395 expr2 = arg->expr;
5396 }
5397 goto evaluate;
5398
5399 case EXEC_ASSIGN:
5400 expr1 = cnext->expr1;
5401 expr2 = cnext->expr2;
5402 evaluate:
5403 if (nested_forall_info != NULL)
5404 {
5405 need_temp = gfc_check_dependency (expr1, expr2, 0);
5406 if ((need_temp || flag_test_forall_temp)
5407 && cnext->op != EXEC_ASSIGN_CALL)
5408 gfc_trans_assign_need_temp (expr1, expr2,
5409 cmask, invert,
5410 nested_forall_info, block);
5411 else
5412 {
5413 /* Variables to control maskexpr. */
5414 count1 = gfc_create_var (gfc_array_index_type, "count1");
5415 count2 = gfc_create_var (gfc_array_index_type, "count2");
5416 gfc_add_modify (block, count1, gfc_index_zero_node);
5417 gfc_add_modify (block, count2, gfc_index_zero_node);
5418
5419 tmp = gfc_trans_where_assign (expr1, expr2,
5420 cmask, invert,
5421 count1, count2,
5422 cnext);
5423
5424 tmp = gfc_trans_nested_forall_loop (nested_forall_info,
5425 tmp, 1);
5426 gfc_add_expr_to_block (block, tmp);
5427 }
5428 }
5429 else
5430 {
5431 /* Variables to control maskexpr. */
5432 count1 = gfc_create_var (gfc_array_index_type, "count1");
5433 count2 = gfc_create_var (gfc_array_index_type, "count2");
5434 gfc_add_modify (block, count1, gfc_index_zero_node);
5435 gfc_add_modify (block, count2, gfc_index_zero_node);
5436
5437 tmp = gfc_trans_where_assign (expr1, expr2,
5438 cmask, invert,
5439 count1, count2,
5440 cnext);
5441 gfc_add_expr_to_block (block, tmp);
5442
5443 }
5444 break;
5445
5446 /* WHERE or WHERE construct is part of a where-body-construct. */
5447 case EXEC_WHERE:
5448 gfc_trans_where_2 (cnext, cmask, invert,
5449 nested_forall_info, block);
5450 break;
5451
5452 default:
5453 gcc_unreachable ();
5454 }
5455
5456 /* The next statement within the same where-body-construct. */
5457 cnext = cnext->next;
5458 }
5459 /* The next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt. */
5460 cblock = cblock->block;
5461 if (mask == NULL_TREE)
5462 {
5463 /* If we're the initial WHERE, we can simply invert the sense
5464 of the current mask to obtain the "mask" for the remaining
5465 ELSEWHEREs. */
5466 invert = true;
5467 mask = cmask;
5468 }
5469 else
5470 {
5471 /* Otherwise, for nested WHERE's we need to use the pending mask. */
5472 invert = false;
5473 mask = pmask;
5474 }
5475 }
5476
5477 /* If we allocated a pending mask array, deallocate it now. */
5478 if (ppmask)
5479 {
5480 tmp = gfc_call_free (ppmask);
5481 gfc_add_expr_to_block (block, tmp);
5482 }
5483
5484 /* If we allocated a current mask array, deallocate it now. */
5485 if (pcmask)
5486 {
5487 tmp = gfc_call_free (pcmask);
5488 gfc_add_expr_to_block (block, tmp);
5489 }
5490 }
5491
5492 /* Translate a simple WHERE construct or statement without dependencies.
5493 CBLOCK is the "then" clause of the WHERE statement, where CBLOCK->EXPR
5494 is the mask condition, and EBLOCK if non-NULL is the "else" clause.
5495 Currently both CBLOCK and EBLOCK are restricted to single assignments. */
5496
5497 static tree
gfc_trans_where_3(gfc_code * cblock,gfc_code * eblock)5498 gfc_trans_where_3 (gfc_code * cblock, gfc_code * eblock)
5499 {
5500 stmtblock_t block, body;
5501 gfc_expr *cond, *tdst, *tsrc, *edst, *esrc;
5502 tree tmp, cexpr, tstmt, estmt;
5503 gfc_ss *css, *tdss, *tsss;
5504 gfc_se cse, tdse, tsse, edse, esse;
5505 gfc_loopinfo loop;
5506 gfc_ss *edss = 0;
5507 gfc_ss *esss = 0;
5508 bool maybe_workshare = false;
5509
5510 /* Allow the scalarizer to workshare simple where loops. */
5511 if ((ompws_flags & (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_BODY))
5512 == OMPWS_WORKSHARE_FLAG)
5513 {
5514 maybe_workshare = true;
5515 ompws_flags |= OMPWS_SCALARIZER_WS | OMPWS_SCALARIZER_BODY;
5516 }
5517
5518 cond = cblock->expr1;
5519 tdst = cblock->next->expr1;
5520 tsrc = cblock->next->expr2;
5521 edst = eblock ? eblock->next->expr1 : NULL;
5522 esrc = eblock ? eblock->next->expr2 : NULL;
5523
5524 gfc_start_block (&block);
5525 gfc_init_loopinfo (&loop);
5526
5527 /* Handle the condition. */
5528 gfc_init_se (&cse, NULL);
5529 css = gfc_walk_expr (cond);
5530 gfc_add_ss_to_loop (&loop, css);
5531
5532 /* Handle the then-clause. */
5533 gfc_init_se (&tdse, NULL);
5534 gfc_init_se (&tsse, NULL);
5535 tdss = gfc_walk_expr (tdst);
5536 tsss = gfc_walk_expr (tsrc);
5537 if (tsss == gfc_ss_terminator)
5538 {
5539 tsss = gfc_get_scalar_ss (gfc_ss_terminator, tsrc);
5540 tsss->info->where = 1;
5541 }
5542 gfc_add_ss_to_loop (&loop, tdss);
5543 gfc_add_ss_to_loop (&loop, tsss);
5544
5545 if (eblock)
5546 {
5547 /* Handle the else clause. */
5548 gfc_init_se (&edse, NULL);
5549 gfc_init_se (&esse, NULL);
5550 edss = gfc_walk_expr (edst);
5551 esss = gfc_walk_expr (esrc);
5552 if (esss == gfc_ss_terminator)
5553 {
5554 esss = gfc_get_scalar_ss (gfc_ss_terminator, esrc);
5555 esss->info->where = 1;
5556 }
5557 gfc_add_ss_to_loop (&loop, edss);
5558 gfc_add_ss_to_loop (&loop, esss);
5559 }
5560
5561 gfc_conv_ss_startstride (&loop);
5562 gfc_conv_loop_setup (&loop, &tdst->where);
5563
5564 gfc_mark_ss_chain_used (css, 1);
5565 gfc_mark_ss_chain_used (tdss, 1);
5566 gfc_mark_ss_chain_used (tsss, 1);
5567 if (eblock)
5568 {
5569 gfc_mark_ss_chain_used (edss, 1);
5570 gfc_mark_ss_chain_used (esss, 1);
5571 }
5572
5573 gfc_start_scalarized_body (&loop, &body);
5574
5575 gfc_copy_loopinfo_to_se (&cse, &loop);
5576 gfc_copy_loopinfo_to_se (&tdse, &loop);
5577 gfc_copy_loopinfo_to_se (&tsse, &loop);
5578 cse.ss = css;
5579 tdse.ss = tdss;
5580 tsse.ss = tsss;
5581 if (eblock)
5582 {
5583 gfc_copy_loopinfo_to_se (&edse, &loop);
5584 gfc_copy_loopinfo_to_se (&esse, &loop);
5585 edse.ss = edss;
5586 esse.ss = esss;
5587 }
5588
5589 gfc_conv_expr (&cse, cond);
5590 gfc_add_block_to_block (&body, &cse.pre);
5591 cexpr = cse.expr;
5592
5593 gfc_conv_expr (&tsse, tsrc);
5594 if (tdss != gfc_ss_terminator && loop.temp_ss != NULL)
5595 gfc_conv_tmp_array_ref (&tdse);
5596 else
5597 gfc_conv_expr (&tdse, tdst);
5598
5599 if (eblock)
5600 {
5601 gfc_conv_expr (&esse, esrc);
5602 if (edss != gfc_ss_terminator && loop.temp_ss != NULL)
5603 gfc_conv_tmp_array_ref (&edse);
5604 else
5605 gfc_conv_expr (&edse, edst);
5606 }
5607
5608 tstmt = gfc_trans_scalar_assign (&tdse, &tsse, tdst->ts, false, true);
5609 estmt = eblock ? gfc_trans_scalar_assign (&edse, &esse, edst->ts,
5610 false, true)
5611 : build_empty_stmt (input_location);
5612 tmp = build3_v (COND_EXPR, cexpr, tstmt, estmt);
5613 gfc_add_expr_to_block (&body, tmp);
5614 gfc_add_block_to_block (&body, &cse.post);
5615
5616 if (maybe_workshare)
5617 ompws_flags &= ~OMPWS_SCALARIZER_BODY;
5618 gfc_trans_scalarizing_loops (&loop, &body);
5619 gfc_add_block_to_block (&block, &loop.pre);
5620 gfc_add_block_to_block (&block, &loop.post);
5621 gfc_cleanup_loop (&loop);
5622
5623 return gfc_finish_block (&block);
5624 }
5625
5626 /* As the WHERE or WHERE construct statement can be nested, we call
5627 gfc_trans_where_2 to do the translation, and pass the initial
5628 NULL values for both the control mask and the pending control mask. */
5629
5630 tree
gfc_trans_where(gfc_code * code)5631 gfc_trans_where (gfc_code * code)
5632 {
5633 stmtblock_t block;
5634 gfc_code *cblock;
5635 gfc_code *eblock;
5636
5637 cblock = code->block;
5638 if (cblock->next
5639 && cblock->next->op == EXEC_ASSIGN
5640 && !cblock->next->next)
5641 {
5642 eblock = cblock->block;
5643 if (!eblock)
5644 {
5645 /* A simple "WHERE (cond) x = y" statement or block is
5646 dependence free if cond is not dependent upon writing x,
5647 and the source y is unaffected by the destination x. */
5648 if (!gfc_check_dependency (cblock->next->expr1,
5649 cblock->expr1, 0)
5650 && !gfc_check_dependency (cblock->next->expr1,
5651 cblock->next->expr2, 0))
5652 return gfc_trans_where_3 (cblock, NULL);
5653 }
5654 else if (!eblock->expr1
5655 && !eblock->block
5656 && eblock->next
5657 && eblock->next->op == EXEC_ASSIGN
5658 && !eblock->next->next)
5659 {
5660 /* A simple "WHERE (cond) x1 = y1 ELSEWHERE x2 = y2 ENDWHERE"
5661 block is dependence free if cond is not dependent on writes
5662 to x1 and x2, y1 is not dependent on writes to x2, and y2
5663 is not dependent on writes to x1, and both y's are not
5664 dependent upon their own x's. In addition to this, the
5665 final two dependency checks below exclude all but the same
5666 array reference if the where and elswhere destinations
5667 are the same. In short, this is VERY conservative and this
5668 is needed because the two loops, required by the standard
5669 are coalesced in gfc_trans_where_3. */
5670 if (!gfc_check_dependency (cblock->next->expr1,
5671 cblock->expr1, 0)
5672 && !gfc_check_dependency (eblock->next->expr1,
5673 cblock->expr1, 0)
5674 && !gfc_check_dependency (cblock->next->expr1,
5675 eblock->next->expr2, 1)
5676 && !gfc_check_dependency (eblock->next->expr1,
5677 cblock->next->expr2, 1)
5678 && !gfc_check_dependency (cblock->next->expr1,
5679 cblock->next->expr2, 1)
5680 && !gfc_check_dependency (eblock->next->expr1,
5681 eblock->next->expr2, 1)
5682 && !gfc_check_dependency (cblock->next->expr1,
5683 eblock->next->expr1, 0)
5684 && !gfc_check_dependency (eblock->next->expr1,
5685 cblock->next->expr1, 0))
5686 return gfc_trans_where_3 (cblock, eblock);
5687 }
5688 }
5689
5690 gfc_start_block (&block);
5691
5692 gfc_trans_where_2 (code, NULL, false, NULL, &block);
5693
5694 return gfc_finish_block (&block);
5695 }
5696
5697
5698 /* CYCLE a DO loop. The label decl has already been created by
5699 gfc_trans_do(), it's in TREE_PURPOSE (backend_decl) of the gfc_code
5700 node at the head of the loop. We must mark the label as used. */
5701
5702 tree
gfc_trans_cycle(gfc_code * code)5703 gfc_trans_cycle (gfc_code * code)
5704 {
5705 tree cycle_label;
5706
5707 cycle_label = code->ext.which_construct->cycle_label;
5708 gcc_assert (cycle_label);
5709
5710 TREE_USED (cycle_label) = 1;
5711 return build1_v (GOTO_EXPR, cycle_label);
5712 }
5713
5714
5715 /* EXIT a DO loop. Similar to CYCLE, but now the label is in
5716 TREE_VALUE (backend_decl) of the gfc_code node at the head of the
5717 loop. */
5718
5719 tree
gfc_trans_exit(gfc_code * code)5720 gfc_trans_exit (gfc_code * code)
5721 {
5722 tree exit_label;
5723
5724 exit_label = code->ext.which_construct->exit_label;
5725 gcc_assert (exit_label);
5726
5727 TREE_USED (exit_label) = 1;
5728 return build1_v (GOTO_EXPR, exit_label);
5729 }
5730
5731
5732 /* Get the initializer expression for the code and expr of an allocate.
5733 When no initializer is needed return NULL. */
5734
5735 static gfc_expr *
allocate_get_initializer(gfc_code * code,gfc_expr * expr)5736 allocate_get_initializer (gfc_code * code, gfc_expr * expr)
5737 {
5738 if (!gfc_bt_struct (expr->ts.type) && expr->ts.type != BT_CLASS)
5739 return NULL;
5740
5741 /* An explicit type was given in allocate ( T:: object). */
5742 if (code->ext.alloc.ts.type == BT_DERIVED
5743 && (code->ext.alloc.ts.u.derived->attr.alloc_comp
5744 || gfc_has_default_initializer (code->ext.alloc.ts.u.derived)))
5745 return gfc_default_initializer (&code->ext.alloc.ts);
5746
5747 if (gfc_bt_struct (expr->ts.type)
5748 && (expr->ts.u.derived->attr.alloc_comp
5749 || gfc_has_default_initializer (expr->ts.u.derived)))
5750 return gfc_default_initializer (&expr->ts);
5751
5752 if (expr->ts.type == BT_CLASS
5753 && (CLASS_DATA (expr)->ts.u.derived->attr.alloc_comp
5754 || gfc_has_default_initializer (CLASS_DATA (expr)->ts.u.derived)))
5755 return gfc_default_initializer (&CLASS_DATA (expr)->ts);
5756
5757 return NULL;
5758 }
5759
5760 /* Translate the ALLOCATE statement. */
5761
5762 tree
gfc_trans_allocate(gfc_code * code)5763 gfc_trans_allocate (gfc_code * code)
5764 {
5765 gfc_alloc *al;
5766 gfc_expr *expr, *e3rhs = NULL, *init_expr;
5767 gfc_se se, se_sz;
5768 tree tmp;
5769 tree parm;
5770 tree stat;
5771 tree errmsg;
5772 tree errlen;
5773 tree label_errmsg;
5774 tree label_finish;
5775 tree memsz;
5776 tree al_vptr, al_len;
5777 /* If an expr3 is present, then store the tree for accessing its
5778 _vptr, and _len components in the variables, respectively. The
5779 element size, i.e. _vptr%size, is stored in expr3_esize. Any of
5780 the trees may be the NULL_TREE indicating that this is not
5781 available for expr3's type. */
5782 tree expr3, expr3_vptr, expr3_len, expr3_esize;
5783 /* Classify what expr3 stores. */
5784 enum { E3_UNSET = 0, E3_SOURCE, E3_MOLD, E3_DESC } e3_is;
5785 stmtblock_t block;
5786 stmtblock_t post;
5787 tree nelems;
5788 bool upoly_expr, tmp_expr3_len_flag = false, al_len_needs_set, is_coarray;
5789 bool needs_caf_sync, caf_refs_comp;
5790 gfc_symtree *newsym = NULL;
5791 symbol_attribute caf_attr;
5792 gfc_actual_arglist *param_list;
5793
5794 if (!code->ext.alloc.list)
5795 return NULL_TREE;
5796
5797 stat = tmp = memsz = al_vptr = al_len = NULL_TREE;
5798 expr3 = expr3_vptr = expr3_len = expr3_esize = NULL_TREE;
5799 label_errmsg = label_finish = errmsg = errlen = NULL_TREE;
5800 e3_is = E3_UNSET;
5801 is_coarray = needs_caf_sync = false;
5802
5803 gfc_init_block (&block);
5804 gfc_init_block (&post);
5805
5806 /* STAT= (and maybe ERRMSG=) is present. */
5807 if (code->expr1)
5808 {
5809 /* STAT=. */
5810 tree gfc_int4_type_node = gfc_get_int_type (4);
5811 stat = gfc_create_var (gfc_int4_type_node, "stat");
5812
5813 /* ERRMSG= only makes sense with STAT=. */
5814 if (code->expr2)
5815 {
5816 gfc_init_se (&se, NULL);
5817 se.want_pointer = 1;
5818 gfc_conv_expr_lhs (&se, code->expr2);
5819 errmsg = se.expr;
5820 errlen = se.string_length;
5821 }
5822 else
5823 {
5824 errmsg = null_pointer_node;
5825 errlen = build_int_cst (gfc_charlen_type_node, 0);
5826 }
5827
5828 /* GOTO destinations. */
5829 label_errmsg = gfc_build_label_decl (NULL_TREE);
5830 label_finish = gfc_build_label_decl (NULL_TREE);
5831 TREE_USED (label_finish) = 0;
5832 }
5833
5834 /* When an expr3 is present evaluate it only once. The standards prevent a
5835 dependency of expr3 on the objects in the allocate list. An expr3 can
5836 be pre-evaluated in all cases. One just has to make sure, to use the
5837 correct way, i.e., to get the descriptor or to get a reference
5838 expression. */
5839 if (code->expr3)
5840 {
5841 bool vtab_needed = false, temp_var_needed = false,
5842 temp_obj_created = false;
5843
5844 is_coarray = gfc_is_coarray (code->expr3);
5845
5846 /* Figure whether we need the vtab from expr3. */
5847 for (al = code->ext.alloc.list; !vtab_needed && al != NULL;
5848 al = al->next)
5849 vtab_needed = (al->expr->ts.type == BT_CLASS);
5850
5851 gfc_init_se (&se, NULL);
5852 /* When expr3 is a variable, i.e., a very simple expression,
5853 then convert it once here. */
5854 if (code->expr3->expr_type == EXPR_VARIABLE
5855 || code->expr3->expr_type == EXPR_ARRAY
5856 || code->expr3->expr_type == EXPR_CONSTANT)
5857 {
5858 if (!code->expr3->mold
5859 || code->expr3->ts.type == BT_CHARACTER
5860 || vtab_needed
5861 || code->ext.alloc.arr_spec_from_expr3)
5862 {
5863 /* Convert expr3 to a tree. For all "simple" expression just
5864 get the descriptor or the reference, respectively, depending
5865 on the rank of the expr. */
5866 if (code->ext.alloc.arr_spec_from_expr3 || code->expr3->rank != 0)
5867 gfc_conv_expr_descriptor (&se, code->expr3);
5868 else
5869 {
5870 gfc_conv_expr_reference (&se, code->expr3);
5871
5872 /* gfc_conv_expr_reference wraps POINTER_PLUS_EXPR in a
5873 NOP_EXPR, which prevents gfortran from getting the vptr
5874 from the source=-expression. Remove the NOP_EXPR and go
5875 with the POINTER_PLUS_EXPR in this case. */
5876 if (code->expr3->ts.type == BT_CLASS
5877 && TREE_CODE (se.expr) == NOP_EXPR
5878 && (TREE_CODE (TREE_OPERAND (se.expr, 0))
5879 == POINTER_PLUS_EXPR
5880 || is_coarray))
5881 se.expr = TREE_OPERAND (se.expr, 0);
5882 }
5883 /* Create a temp variable only for component refs to prevent
5884 having to go through the full deref-chain each time and to
5885 simplfy computation of array properties. */
5886 temp_var_needed = TREE_CODE (se.expr) == COMPONENT_REF;
5887 }
5888 }
5889 else
5890 {
5891 /* In all other cases evaluate the expr3. */
5892 symbol_attribute attr;
5893 /* Get the descriptor for all arrays, that are not allocatable or
5894 pointer, because the latter are descriptors already.
5895 The exception are function calls returning a class object:
5896 The descriptor is stored in their results _data component, which
5897 is easier to access, when first a temporary variable for the
5898 result is created and the descriptor retrieved from there. */
5899 attr = gfc_expr_attr (code->expr3);
5900 if (code->expr3->rank != 0
5901 && ((!attr.allocatable && !attr.pointer)
5902 || (code->expr3->expr_type == EXPR_FUNCTION
5903 && (code->expr3->ts.type != BT_CLASS
5904 || (code->expr3->value.function.isym
5905 && code->expr3->value.function.isym
5906 ->transformational)))))
5907 gfc_conv_expr_descriptor (&se, code->expr3);
5908 else
5909 gfc_conv_expr_reference (&se, code->expr3);
5910 if (code->expr3->ts.type == BT_CLASS)
5911 gfc_conv_class_to_class (&se, code->expr3,
5912 code->expr3->ts,
5913 false, true,
5914 false, false);
5915 temp_obj_created = temp_var_needed = !VAR_P (se.expr);
5916 }
5917 gfc_add_block_to_block (&block, &se.pre);
5918 gfc_add_block_to_block (&post, &se.post);
5919
5920 /* Special case when string in expr3 is zero. */
5921 if (code->expr3->ts.type == BT_CHARACTER
5922 && integer_zerop (se.string_length))
5923 {
5924 gfc_init_se (&se, NULL);
5925 temp_var_needed = false;
5926 expr3_len = build_zero_cst (gfc_charlen_type_node);
5927 e3_is = E3_MOLD;
5928 }
5929 /* Prevent aliasing, i.e., se.expr may be already a
5930 variable declaration. */
5931 else if (se.expr != NULL_TREE && temp_var_needed)
5932 {
5933 tree var, desc;
5934 tmp = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr)) || is_coarray ?
5935 se.expr
5936 : build_fold_indirect_ref_loc (input_location, se.expr);
5937
5938 /* Get the array descriptor and prepare it to be assigned to the
5939 temporary variable var. For classes the array descriptor is
5940 in the _data component and the object goes into the
5941 GFC_DECL_SAVED_DESCRIPTOR. */
5942 if (code->expr3->ts.type == BT_CLASS
5943 && code->expr3->rank != 0)
5944 {
5945 /* When an array_ref was in expr3, then the descriptor is the
5946 first operand. */
5947 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)) || is_coarray)
5948 {
5949 desc = TREE_OPERAND (tmp, 0);
5950 }
5951 else
5952 {
5953 desc = tmp;
5954 tmp = gfc_class_data_get (tmp);
5955 }
5956 if (code->ext.alloc.arr_spec_from_expr3)
5957 e3_is = E3_DESC;
5958 }
5959 else
5960 desc = !is_coarray ? se.expr
5961 : TREE_OPERAND (TREE_OPERAND (se.expr, 0), 0);
5962 /* We need a regular (non-UID) symbol here, therefore give a
5963 prefix. */
5964 var = gfc_create_var (TREE_TYPE (tmp), "source");
5965 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)) || is_coarray)
5966 {
5967 gfc_allocate_lang_decl (var);
5968 GFC_DECL_SAVED_DESCRIPTOR (var) = desc;
5969 }
5970 gfc_add_modify_loc (input_location, &block, var, tmp);
5971
5972 expr3 = var;
5973 if (se.string_length)
5974 /* Evaluate it assuming that it also is complicated like expr3. */
5975 expr3_len = gfc_evaluate_now (se.string_length, &block);
5976 }
5977 else
5978 {
5979 expr3 = se.expr;
5980 expr3_len = se.string_length;
5981 }
5982
5983 /* Deallocate any allocatable components in expressions that use a
5984 temporary object, i.e. are not a simple alias of to an EXPR_VARIABLE.
5985 E.g. temporaries of a function call need freeing of their components
5986 here. */
5987 if ((code->expr3->ts.type == BT_DERIVED
5988 || code->expr3->ts.type == BT_CLASS)
5989 && (code->expr3->expr_type != EXPR_VARIABLE || temp_obj_created)
5990 && code->expr3->ts.u.derived->attr.alloc_comp)
5991 {
5992 tmp = gfc_deallocate_alloc_comp (code->expr3->ts.u.derived,
5993 expr3, code->expr3->rank);
5994 gfc_prepend_expr_to_block (&post, tmp);
5995 }
5996
5997 /* Store what the expr3 is to be used for. */
5998 if (e3_is == E3_UNSET)
5999 e3_is = expr3 != NULL_TREE ?
6000 (code->ext.alloc.arr_spec_from_expr3 ?
6001 E3_DESC
6002 : (code->expr3->mold ? E3_MOLD : E3_SOURCE))
6003 : E3_UNSET;
6004
6005 /* Figure how to get the _vtab entry. This also obtains the tree
6006 expression for accessing the _len component, because only
6007 unlimited polymorphic objects, which are a subcategory of class
6008 types, have a _len component. */
6009 if (code->expr3->ts.type == BT_CLASS)
6010 {
6011 gfc_expr *rhs;
6012 tmp = expr3 != NULL_TREE && POINTER_TYPE_P (TREE_TYPE (expr3)) ?
6013 build_fold_indirect_ref (expr3): expr3;
6014 /* Polymorphic SOURCE: VPTR must be determined at run time.
6015 expr3 may be a temporary array declaration, therefore check for
6016 GFC_CLASS_TYPE_P before trying to get the _vptr component. */
6017 if (tmp != NULL_TREE
6018 && (e3_is == E3_DESC
6019 || (GFC_CLASS_TYPE_P (TREE_TYPE (tmp))
6020 && (VAR_P (tmp) || !code->expr3->ref))
6021 || (VAR_P (tmp) && DECL_LANG_SPECIFIC (tmp))))
6022 tmp = gfc_class_vptr_get (expr3);
6023 else
6024 {
6025 rhs = gfc_find_and_cut_at_last_class_ref (code->expr3);
6026 gfc_add_vptr_component (rhs);
6027 gfc_init_se (&se, NULL);
6028 se.want_pointer = 1;
6029 gfc_conv_expr (&se, rhs);
6030 tmp = se.expr;
6031 gfc_free_expr (rhs);
6032 }
6033 /* Set the element size. */
6034 expr3_esize = gfc_vptr_size_get (tmp);
6035 if (vtab_needed)
6036 expr3_vptr = tmp;
6037 /* Initialize the ref to the _len component. */
6038 if (expr3_len == NULL_TREE && UNLIMITED_POLY (code->expr3))
6039 {
6040 /* Same like for retrieving the _vptr. */
6041 if (expr3 != NULL_TREE && !code->expr3->ref)
6042 expr3_len = gfc_class_len_get (expr3);
6043 else
6044 {
6045 rhs = gfc_find_and_cut_at_last_class_ref (code->expr3);
6046 gfc_add_len_component (rhs);
6047 gfc_init_se (&se, NULL);
6048 gfc_conv_expr (&se, rhs);
6049 expr3_len = se.expr;
6050 gfc_free_expr (rhs);
6051 }
6052 }
6053 }
6054 else
6055 {
6056 /* When the object to allocate is polymorphic type, then it
6057 needs its vtab set correctly, so deduce the required _vtab
6058 and _len from the source expression. */
6059 if (vtab_needed)
6060 {
6061 /* VPTR is fixed at compile time. */
6062 gfc_symbol *vtab;
6063
6064 vtab = gfc_find_vtab (&code->expr3->ts);
6065 gcc_assert (vtab);
6066 expr3_vptr = gfc_get_symbol_decl (vtab);
6067 expr3_vptr = gfc_build_addr_expr (NULL_TREE,
6068 expr3_vptr);
6069 }
6070 /* _len component needs to be set, when ts is a character
6071 array. */
6072 if (expr3_len == NULL_TREE
6073 && code->expr3->ts.type == BT_CHARACTER)
6074 {
6075 if (code->expr3->ts.u.cl
6076 && code->expr3->ts.u.cl->length)
6077 {
6078 gfc_init_se (&se, NULL);
6079 gfc_conv_expr (&se, code->expr3->ts.u.cl->length);
6080 gfc_add_block_to_block (&block, &se.pre);
6081 expr3_len = gfc_evaluate_now (se.expr, &block);
6082 }
6083 gcc_assert (expr3_len);
6084 }
6085 /* For character arrays only the kind's size is needed, because
6086 the array mem_size is _len * (elem_size = kind_size).
6087 For all other get the element size in the normal way. */
6088 if (code->expr3->ts.type == BT_CHARACTER)
6089 expr3_esize = TYPE_SIZE_UNIT (
6090 gfc_get_char_type (code->expr3->ts.kind));
6091 else
6092 expr3_esize = TYPE_SIZE_UNIT (
6093 gfc_typenode_for_spec (&code->expr3->ts));
6094 }
6095 gcc_assert (expr3_esize);
6096 expr3_esize = fold_convert (sizetype, expr3_esize);
6097 if (e3_is == E3_MOLD)
6098 /* The expr3 is no longer valid after this point. */
6099 expr3 = NULL_TREE;
6100 }
6101 else if (code->ext.alloc.ts.type != BT_UNKNOWN)
6102 {
6103 /* Compute the explicit typespec given only once for all objects
6104 to allocate. */
6105 if (code->ext.alloc.ts.type != BT_CHARACTER)
6106 expr3_esize = TYPE_SIZE_UNIT (
6107 gfc_typenode_for_spec (&code->ext.alloc.ts));
6108 else if (code->ext.alloc.ts.u.cl->length != NULL)
6109 {
6110 gfc_expr *sz;
6111 sz = gfc_copy_expr (code->ext.alloc.ts.u.cl->length);
6112 gfc_init_se (&se_sz, NULL);
6113 gfc_conv_expr (&se_sz, sz);
6114 gfc_free_expr (sz);
6115 tmp = gfc_get_char_type (code->ext.alloc.ts.kind);
6116 tmp = TYPE_SIZE_UNIT (tmp);
6117 tmp = fold_convert (TREE_TYPE (se_sz.expr), tmp);
6118 gfc_add_block_to_block (&block, &se_sz.pre);
6119 expr3_esize = fold_build2_loc (input_location, MULT_EXPR,
6120 TREE_TYPE (se_sz.expr),
6121 tmp, se_sz.expr);
6122 expr3_esize = gfc_evaluate_now (expr3_esize, &block);
6123 }
6124 else
6125 expr3_esize = NULL_TREE;
6126 }
6127
6128 /* The routine gfc_trans_assignment () already implements all
6129 techniques needed. Unfortunately we may have a temporary
6130 variable for the source= expression here. When that is the
6131 case convert this variable into a temporary gfc_expr of type
6132 EXPR_VARIABLE and used it as rhs for the assignment. The
6133 advantage is, that we get scalarizer support for free,
6134 don't have to take care about scalar to array treatment and
6135 will benefit of every enhancements gfc_trans_assignment ()
6136 gets.
6137 No need to check whether e3_is is E3_UNSET, because that is
6138 done by expr3 != NULL_TREE.
6139 Exclude variables since the following block does not handle
6140 array sections. In any case, there is no harm in sending
6141 variables to gfc_trans_assignment because there is no
6142 evaluation of variables. */
6143 if (code->expr3)
6144 {
6145 if (code->expr3->expr_type != EXPR_VARIABLE
6146 && e3_is != E3_MOLD && expr3 != NULL_TREE
6147 && DECL_P (expr3) && DECL_ARTIFICIAL (expr3))
6148 {
6149 /* Build a temporary symtree and symbol. Do not add it to the current
6150 namespace to prevent accidently modifying a colliding
6151 symbol's as. */
6152 newsym = XCNEW (gfc_symtree);
6153 /* The name of the symtree should be unique, because gfc_create_var ()
6154 took care about generating the identifier. */
6155 newsym->name
6156 = gfc_get_string ("%s", IDENTIFIER_POINTER (DECL_NAME (expr3)));
6157 newsym->n.sym = gfc_new_symbol (newsym->name, NULL);
6158 /* The backend_decl is known. It is expr3, which is inserted
6159 here. */
6160 newsym->n.sym->backend_decl = expr3;
6161 e3rhs = gfc_get_expr ();
6162 e3rhs->rank = code->expr3->rank;
6163 e3rhs->symtree = newsym;
6164 /* Mark the symbol referenced or gfc_trans_assignment will bug. */
6165 newsym->n.sym->attr.referenced = 1;
6166 e3rhs->expr_type = EXPR_VARIABLE;
6167 e3rhs->where = code->expr3->where;
6168 /* Set the symbols type, upto it was BT_UNKNOWN. */
6169 if (IS_CLASS_ARRAY (code->expr3)
6170 && code->expr3->expr_type == EXPR_FUNCTION
6171 && code->expr3->value.function.isym
6172 && code->expr3->value.function.isym->transformational)
6173 {
6174 e3rhs->ts = CLASS_DATA (code->expr3)->ts;
6175 }
6176 else if (code->expr3->ts.type == BT_CLASS
6177 && !GFC_CLASS_TYPE_P (TREE_TYPE (expr3)))
6178 e3rhs->ts = CLASS_DATA (code->expr3)->ts;
6179 else
6180 e3rhs->ts = code->expr3->ts;
6181 newsym->n.sym->ts = e3rhs->ts;
6182 /* Check whether the expr3 is array valued. */
6183 if (e3rhs->rank)
6184 {
6185 gfc_array_spec *arr;
6186 arr = gfc_get_array_spec ();
6187 arr->rank = e3rhs->rank;
6188 arr->type = AS_DEFERRED;
6189 /* Set the dimension and pointer attribute for arrays
6190 to be on the safe side. */
6191 newsym->n.sym->attr.dimension = 1;
6192 newsym->n.sym->attr.pointer = 1;
6193 newsym->n.sym->as = arr;
6194 if (IS_CLASS_ARRAY (code->expr3)
6195 && code->expr3->expr_type == EXPR_FUNCTION
6196 && code->expr3->value.function.isym
6197 && code->expr3->value.function.isym->transformational)
6198 {
6199 gfc_array_spec *tarr;
6200 tarr = gfc_get_array_spec ();
6201 *tarr = *arr;
6202 e3rhs->ts.u.derived->as = tarr;
6203 }
6204 gfc_add_full_array_ref (e3rhs, arr);
6205 }
6206 else if (POINTER_TYPE_P (TREE_TYPE (expr3)))
6207 newsym->n.sym->attr.pointer = 1;
6208 /* The string length is known, too. Set it for char arrays. */
6209 if (e3rhs->ts.type == BT_CHARACTER)
6210 newsym->n.sym->ts.u.cl->backend_decl = expr3_len;
6211 gfc_commit_symbol (newsym->n.sym);
6212 }
6213 else
6214 e3rhs = gfc_copy_expr (code->expr3);
6215 }
6216
6217 /* Loop over all objects to allocate. */
6218 for (al = code->ext.alloc.list; al != NULL; al = al->next)
6219 {
6220 expr = gfc_copy_expr (al->expr);
6221 /* UNLIMITED_POLY () needs the _data component to be set, when
6222 expr is a unlimited polymorphic object. But the _data component
6223 has not been set yet, so check the derived type's attr for the
6224 unlimited polymorphic flag to be safe. */
6225 upoly_expr = UNLIMITED_POLY (expr)
6226 || (expr->ts.type == BT_DERIVED
6227 && expr->ts.u.derived->attr.unlimited_polymorphic);
6228 gfc_init_se (&se, NULL);
6229
6230 /* For class types prepare the expressions to ref the _vptr
6231 and the _len component. The latter for unlimited polymorphic
6232 types only. */
6233 if (expr->ts.type == BT_CLASS)
6234 {
6235 gfc_expr *expr_ref_vptr, *expr_ref_len;
6236 gfc_add_data_component (expr);
6237 /* Prep the vptr handle. */
6238 expr_ref_vptr = gfc_copy_expr (al->expr);
6239 gfc_add_vptr_component (expr_ref_vptr);
6240 se.want_pointer = 1;
6241 gfc_conv_expr (&se, expr_ref_vptr);
6242 al_vptr = se.expr;
6243 se.want_pointer = 0;
6244 gfc_free_expr (expr_ref_vptr);
6245 /* Allocated unlimited polymorphic objects always have a _len
6246 component. */
6247 if (upoly_expr)
6248 {
6249 expr_ref_len = gfc_copy_expr (al->expr);
6250 gfc_add_len_component (expr_ref_len);
6251 gfc_conv_expr (&se, expr_ref_len);
6252 al_len = se.expr;
6253 gfc_free_expr (expr_ref_len);
6254 }
6255 else
6256 /* In a loop ensure that all loop variable dependent variables
6257 are initialized at the same spot in all execution paths. */
6258 al_len = NULL_TREE;
6259 }
6260 else
6261 al_vptr = al_len = NULL_TREE;
6262
6263 se.want_pointer = 1;
6264 se.descriptor_only = 1;
6265
6266 gfc_conv_expr (&se, expr);
6267 if (expr->ts.type == BT_CHARACTER && expr->ts.deferred)
6268 /* se.string_length now stores the .string_length variable of expr
6269 needed to allocate character(len=:) arrays. */
6270 al_len = se.string_length;
6271
6272 al_len_needs_set = al_len != NULL_TREE;
6273 /* When allocating an array one can not use much of the
6274 pre-evaluated expr3 expressions, because for most of them the
6275 scalarizer is needed which is not available in the pre-evaluation
6276 step. Therefore gfc_array_allocate () is responsible (and able)
6277 to handle the complete array allocation. Only the element size
6278 needs to be provided, which is done most of the time by the
6279 pre-evaluation step. */
6280 nelems = NULL_TREE;
6281 if (expr3_len && (code->expr3->ts.type == BT_CHARACTER
6282 || code->expr3->ts.type == BT_CLASS))
6283 {
6284 /* When al is an array, then the element size for each element
6285 in the array is needed, which is the product of the len and
6286 esize for char arrays. For unlimited polymorphics len can be
6287 zero, therefore take the maximum of len and one. */
6288 tmp = fold_build2_loc (input_location, MAX_EXPR,
6289 TREE_TYPE (expr3_len),
6290 expr3_len, fold_convert (TREE_TYPE (expr3_len),
6291 integer_one_node));
6292 tmp = fold_build2_loc (input_location, MULT_EXPR,
6293 TREE_TYPE (expr3_esize), expr3_esize,
6294 fold_convert (TREE_TYPE (expr3_esize), tmp));
6295 }
6296 else
6297 tmp = expr3_esize;
6298 if (!gfc_array_allocate (&se, expr, stat, errmsg, errlen,
6299 label_finish, tmp, &nelems,
6300 e3rhs ? e3rhs : code->expr3,
6301 e3_is == E3_DESC ? expr3 : NULL_TREE,
6302 code->expr3 != NULL && e3_is == E3_DESC
6303 && code->expr3->expr_type == EXPR_ARRAY))
6304 {
6305 /* A scalar or derived type. First compute the size to
6306 allocate.
6307
6308 expr3_len is set when expr3 is an unlimited polymorphic
6309 object or a deferred length string. */
6310 if (expr3_len != NULL_TREE)
6311 {
6312 tmp = fold_convert (TREE_TYPE (expr3_esize), expr3_len);
6313 tmp = fold_build2_loc (input_location, MULT_EXPR,
6314 TREE_TYPE (expr3_esize),
6315 expr3_esize, tmp);
6316 if (code->expr3->ts.type != BT_CLASS)
6317 /* expr3 is a deferred length string, i.e., we are
6318 done. */
6319 memsz = tmp;
6320 else
6321 {
6322 /* For unlimited polymorphic enties build
6323 (len > 0) ? element_size * len : element_size
6324 to compute the number of bytes to allocate.
6325 This allows the allocation of unlimited polymorphic
6326 objects from an expr3 that is also unlimited
6327 polymorphic and stores a _len dependent object,
6328 e.g., a string. */
6329 memsz = fold_build2_loc (input_location, GT_EXPR,
6330 logical_type_node, expr3_len,
6331 build_zero_cst
6332 (TREE_TYPE (expr3_len)));
6333 memsz = fold_build3_loc (input_location, COND_EXPR,
6334 TREE_TYPE (expr3_esize),
6335 memsz, tmp, expr3_esize);
6336 }
6337 }
6338 else if (expr3_esize != NULL_TREE)
6339 /* Any other object in expr3 just needs element size in
6340 bytes. */
6341 memsz = expr3_esize;
6342 else if ((expr->ts.type == BT_CHARACTER && expr->ts.deferred)
6343 || (upoly_expr
6344 && code->ext.alloc.ts.type == BT_CHARACTER))
6345 {
6346 /* Allocating deferred length char arrays need the length
6347 to allocate in the alloc_type_spec. But also unlimited
6348 polymorphic objects may be allocated as char arrays.
6349 Both are handled here. */
6350 gfc_init_se (&se_sz, NULL);
6351 gfc_conv_expr (&se_sz, code->ext.alloc.ts.u.cl->length);
6352 gfc_add_block_to_block (&se.pre, &se_sz.pre);
6353 se_sz.expr = gfc_evaluate_now (se_sz.expr, &se.pre);
6354 gfc_add_block_to_block (&se.pre, &se_sz.post);
6355 expr3_len = se_sz.expr;
6356 tmp_expr3_len_flag = true;
6357 tmp = TYPE_SIZE_UNIT (
6358 gfc_get_char_type (code->ext.alloc.ts.kind));
6359 memsz = fold_build2_loc (input_location, MULT_EXPR,
6360 TREE_TYPE (tmp),
6361 fold_convert (TREE_TYPE (tmp),
6362 expr3_len),
6363 tmp);
6364 }
6365 else if (expr->ts.type == BT_CHARACTER)
6366 {
6367 /* Compute the number of bytes needed to allocate a fixed
6368 length char array. */
6369 gcc_assert (se.string_length != NULL_TREE);
6370 tmp = TYPE_SIZE_UNIT (gfc_get_char_type (expr->ts.kind));
6371 memsz = fold_build2_loc (input_location, MULT_EXPR,
6372 TREE_TYPE (tmp), tmp,
6373 fold_convert (TREE_TYPE (tmp),
6374 se.string_length));
6375 }
6376 else if (code->ext.alloc.ts.type != BT_UNKNOWN)
6377 /* Handle all types, where the alloc_type_spec is set. */
6378 memsz = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->ext.alloc.ts));
6379 else
6380 /* Handle size computation of the type declared to alloc. */
6381 memsz = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (se.expr)));
6382
6383 /* Store the caf-attributes for latter use. */
6384 if (flag_coarray == GFC_FCOARRAY_LIB
6385 && (caf_attr = gfc_caf_attr (expr, true, &caf_refs_comp))
6386 .codimension)
6387 {
6388 /* Scalar allocatable components in coarray'ed derived types make
6389 it here and are treated now. */
6390 tree caf_decl, token;
6391 gfc_se caf_se;
6392
6393 is_coarray = true;
6394 /* Set flag, to add synchronize after the allocate. */
6395 needs_caf_sync = needs_caf_sync
6396 || caf_attr.coarray_comp || !caf_refs_comp;
6397
6398 gfc_init_se (&caf_se, NULL);
6399
6400 caf_decl = gfc_get_tree_for_caf_expr (expr);
6401 gfc_get_caf_token_offset (&caf_se, &token, NULL, caf_decl,
6402 NULL_TREE, NULL);
6403 gfc_add_block_to_block (&se.pre, &caf_se.pre);
6404 gfc_allocate_allocatable (&se.pre, se.expr, memsz,
6405 gfc_build_addr_expr (NULL_TREE, token),
6406 NULL_TREE, NULL_TREE, NULL_TREE,
6407 label_finish, expr, 1);
6408 }
6409 /* Allocate - for non-pointers with re-alloc checking. */
6410 else if (gfc_expr_attr (expr).allocatable)
6411 gfc_allocate_allocatable (&se.pre, se.expr, memsz,
6412 NULL_TREE, stat, errmsg, errlen,
6413 label_finish, expr, 0);
6414 else
6415 gfc_allocate_using_malloc (&se.pre, se.expr, memsz, stat);
6416 }
6417 else
6418 {
6419 /* Allocating coarrays needs a sync after the allocate executed.
6420 Set the flag to add the sync after all objects are allocated. */
6421 if (flag_coarray == GFC_FCOARRAY_LIB
6422 && (caf_attr = gfc_caf_attr (expr, true, &caf_refs_comp))
6423 .codimension)
6424 {
6425 is_coarray = true;
6426 needs_caf_sync = needs_caf_sync
6427 || caf_attr.coarray_comp || !caf_refs_comp;
6428 }
6429
6430 if (expr->ts.type == BT_CHARACTER && al_len != NULL_TREE
6431 && expr3_len != NULL_TREE)
6432 {
6433 /* Arrays need to have a _len set before the array
6434 descriptor is filled. */
6435 gfc_add_modify (&block, al_len,
6436 fold_convert (TREE_TYPE (al_len), expr3_len));
6437 /* Prevent setting the length twice. */
6438 al_len_needs_set = false;
6439 }
6440 else if (expr->ts.type == BT_CHARACTER && al_len != NULL_TREE
6441 && code->ext.alloc.ts.u.cl->length)
6442 {
6443 /* Cover the cases where a string length is explicitly
6444 specified by a type spec for deferred length character
6445 arrays or unlimited polymorphic objects without a
6446 source= or mold= expression. */
6447 gfc_init_se (&se_sz, NULL);
6448 gfc_conv_expr (&se_sz, code->ext.alloc.ts.u.cl->length);
6449 gfc_add_block_to_block (&block, &se_sz.pre);
6450 gfc_add_modify (&block, al_len,
6451 fold_convert (TREE_TYPE (al_len),
6452 se_sz.expr));
6453 al_len_needs_set = false;
6454 }
6455 }
6456
6457 gfc_add_block_to_block (&block, &se.pre);
6458
6459 /* Error checking -- Note: ERRMSG only makes sense with STAT. */
6460 if (code->expr1)
6461 {
6462 tmp = build1_v (GOTO_EXPR, label_errmsg);
6463 parm = fold_build2_loc (input_location, NE_EXPR,
6464 logical_type_node, stat,
6465 build_int_cst (TREE_TYPE (stat), 0));
6466 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
6467 gfc_unlikely (parm, PRED_FORTRAN_FAIL_ALLOC),
6468 tmp, build_empty_stmt (input_location));
6469 gfc_add_expr_to_block (&block, tmp);
6470 }
6471
6472 /* Set the vptr only when no source= is set. When source= is set, then
6473 the trans_assignment below will set the vptr. */
6474 if (al_vptr != NULL_TREE && (!code->expr3 || code->expr3->mold))
6475 {
6476 if (expr3_vptr != NULL_TREE)
6477 /* The vtab is already known, so just assign it. */
6478 gfc_add_modify (&block, al_vptr,
6479 fold_convert (TREE_TYPE (al_vptr), expr3_vptr));
6480 else
6481 {
6482 /* VPTR is fixed at compile time. */
6483 gfc_symbol *vtab;
6484 gfc_typespec *ts;
6485
6486 if (code->expr3)
6487 /* Although expr3 is pre-evaluated above, it may happen,
6488 that for arrays or in mold= cases the pre-evaluation
6489 was not successful. In these rare cases take the vtab
6490 from the typespec of expr3 here. */
6491 ts = &code->expr3->ts;
6492 else if (code->ext.alloc.ts.type == BT_DERIVED || upoly_expr)
6493 /* The alloc_type_spec gives the type to allocate or the
6494 al is unlimited polymorphic, which enforces the use of
6495 an alloc_type_spec that is not necessarily a BT_DERIVED. */
6496 ts = &code->ext.alloc.ts;
6497 else
6498 /* Prepare for setting the vtab as declared. */
6499 ts = &expr->ts;
6500
6501 vtab = gfc_find_vtab (ts);
6502 gcc_assert (vtab);
6503 tmp = gfc_build_addr_expr (NULL_TREE,
6504 gfc_get_symbol_decl (vtab));
6505 gfc_add_modify (&block, al_vptr,
6506 fold_convert (TREE_TYPE (al_vptr), tmp));
6507 }
6508 }
6509
6510 /* Add assignment for string length. */
6511 if (al_len != NULL_TREE && al_len_needs_set)
6512 {
6513 if (expr3_len != NULL_TREE)
6514 {
6515 gfc_add_modify (&block, al_len,
6516 fold_convert (TREE_TYPE (al_len),
6517 expr3_len));
6518 /* When tmp_expr3_len_flag is set, then expr3_len is
6519 abused to carry the length information from the
6520 alloc_type. Clear it to prevent setting incorrect len
6521 information in future loop iterations. */
6522 if (tmp_expr3_len_flag)
6523 /* No need to reset tmp_expr3_len_flag, because the
6524 presence of an expr3 can not change within in the
6525 loop. */
6526 expr3_len = NULL_TREE;
6527 }
6528 else if (code->ext.alloc.ts.type == BT_CHARACTER
6529 && code->ext.alloc.ts.u.cl->length)
6530 {
6531 /* Cover the cases where a string length is explicitly
6532 specified by a type spec for deferred length character
6533 arrays or unlimited polymorphic objects without a
6534 source= or mold= expression. */
6535 if (expr3_esize == NULL_TREE || code->ext.alloc.ts.kind != 1)
6536 {
6537 gfc_init_se (&se_sz, NULL);
6538 gfc_conv_expr (&se_sz, code->ext.alloc.ts.u.cl->length);
6539 gfc_add_block_to_block (&block, &se_sz.pre);
6540 gfc_add_modify (&block, al_len,
6541 fold_convert (TREE_TYPE (al_len),
6542 se_sz.expr));
6543 }
6544 else
6545 gfc_add_modify (&block, al_len,
6546 fold_convert (TREE_TYPE (al_len),
6547 expr3_esize));
6548 }
6549 else
6550 /* No length information needed, because type to allocate
6551 has no length. Set _len to 0. */
6552 gfc_add_modify (&block, al_len,
6553 fold_convert (TREE_TYPE (al_len),
6554 integer_zero_node));
6555 }
6556
6557 init_expr = NULL;
6558 if (code->expr3 && !code->expr3->mold && e3_is != E3_MOLD)
6559 {
6560 /* Initialization via SOURCE block (or static default initializer).
6561 Switch off automatic reallocation since we have just done the
6562 ALLOCATE. */
6563 int realloc_lhs = flag_realloc_lhs;
6564 gfc_expr *init_expr = gfc_expr_to_initialize (expr);
6565 gfc_expr *rhs = e3rhs ? e3rhs : gfc_copy_expr (code->expr3);
6566 flag_realloc_lhs = 0;
6567 tmp = gfc_trans_assignment (init_expr, rhs, false, false, true,
6568 false);
6569 flag_realloc_lhs = realloc_lhs;
6570 /* Free the expression allocated for init_expr. */
6571 gfc_free_expr (init_expr);
6572 if (rhs != e3rhs)
6573 gfc_free_expr (rhs);
6574 gfc_add_expr_to_block (&block, tmp);
6575 }
6576 /* Set KIND and LEN PDT components and allocate those that are
6577 parameterized. */
6578 else if (expr->ts.type == BT_DERIVED
6579 && expr->ts.u.derived->attr.pdt_type)
6580 {
6581 if (code->expr3 && code->expr3->param_list)
6582 param_list = code->expr3->param_list;
6583 else if (expr->param_list)
6584 param_list = expr->param_list;
6585 else
6586 param_list = expr->symtree->n.sym->param_list;
6587 tmp = gfc_allocate_pdt_comp (expr->ts.u.derived, se.expr,
6588 expr->rank, param_list);
6589 gfc_add_expr_to_block (&block, tmp);
6590 }
6591 /* Ditto for CLASS expressions. */
6592 else if (expr->ts.type == BT_CLASS
6593 && CLASS_DATA (expr)->ts.u.derived->attr.pdt_type)
6594 {
6595 if (code->expr3 && code->expr3->param_list)
6596 param_list = code->expr3->param_list;
6597 else if (expr->param_list)
6598 param_list = expr->param_list;
6599 else
6600 param_list = expr->symtree->n.sym->param_list;
6601 tmp = gfc_allocate_pdt_comp (CLASS_DATA (expr)->ts.u.derived,
6602 se.expr, expr->rank, param_list);
6603 gfc_add_expr_to_block (&block, tmp);
6604 }
6605 else if (code->expr3 && code->expr3->mold
6606 && code->expr3->ts.type == BT_CLASS)
6607 {
6608 /* Use class_init_assign to initialize expr. */
6609 gfc_code *ini;
6610 ini = gfc_get_code (EXEC_INIT_ASSIGN);
6611 ini->expr1 = gfc_find_and_cut_at_last_class_ref (expr, true);
6612 tmp = gfc_trans_class_init_assign (ini);
6613 gfc_free_statements (ini);
6614 gfc_add_expr_to_block (&block, tmp);
6615 }
6616 else if ((init_expr = allocate_get_initializer (code, expr)))
6617 {
6618 /* Use class_init_assign to initialize expr. */
6619 gfc_code *ini;
6620 int realloc_lhs = flag_realloc_lhs;
6621 ini = gfc_get_code (EXEC_INIT_ASSIGN);
6622 ini->expr1 = gfc_expr_to_initialize (expr);
6623 ini->expr2 = init_expr;
6624 flag_realloc_lhs = 0;
6625 tmp= gfc_trans_init_assign (ini);
6626 flag_realloc_lhs = realloc_lhs;
6627 gfc_free_statements (ini);
6628 /* Init_expr is freeed by above free_statements, just need to null
6629 it here. */
6630 init_expr = NULL;
6631 gfc_add_expr_to_block (&block, tmp);
6632 }
6633
6634 /* Nullify all pointers in derived type coarrays. This registers a
6635 token for them which allows their allocation. */
6636 if (is_coarray)
6637 {
6638 gfc_symbol *type = NULL;
6639 symbol_attribute caf_attr;
6640 int rank = 0;
6641 if (code->ext.alloc.ts.type == BT_DERIVED
6642 && code->ext.alloc.ts.u.derived->attr.pointer_comp)
6643 {
6644 type = code->ext.alloc.ts.u.derived;
6645 rank = type->attr.dimension ? type->as->rank : 0;
6646 gfc_clear_attr (&caf_attr);
6647 }
6648 else if (expr->ts.type == BT_DERIVED
6649 && expr->ts.u.derived->attr.pointer_comp)
6650 {
6651 type = expr->ts.u.derived;
6652 rank = expr->rank;
6653 caf_attr = gfc_caf_attr (expr, true);
6654 }
6655
6656 /* Initialize the tokens of pointer components in derived type
6657 coarrays. */
6658 if (type)
6659 {
6660 tmp = (caf_attr.codimension && !caf_attr.dimension)
6661 ? gfc_conv_descriptor_data_get (se.expr) : se.expr;
6662 tmp = gfc_nullify_alloc_comp (type, tmp, rank,
6663 GFC_STRUCTURE_CAF_MODE_IN_COARRAY);
6664 gfc_add_expr_to_block (&block, tmp);
6665 }
6666 }
6667
6668 gfc_free_expr (expr);
6669 } // for-loop
6670
6671 if (e3rhs)
6672 {
6673 if (newsym)
6674 {
6675 gfc_free_symbol (newsym->n.sym);
6676 XDELETE (newsym);
6677 }
6678 gfc_free_expr (e3rhs);
6679 }
6680 /* STAT. */
6681 if (code->expr1)
6682 {
6683 tmp = build1_v (LABEL_EXPR, label_errmsg);
6684 gfc_add_expr_to_block (&block, tmp);
6685 }
6686
6687 /* ERRMSG - only useful if STAT is present. */
6688 if (code->expr1 && code->expr2)
6689 {
6690 const char *msg = "Attempt to allocate an allocated object";
6691 tree slen, dlen, errmsg_str;
6692 stmtblock_t errmsg_block;
6693
6694 gfc_init_block (&errmsg_block);
6695
6696 errmsg_str = gfc_create_var (pchar_type_node, "ERRMSG");
6697 gfc_add_modify (&errmsg_block, errmsg_str,
6698 gfc_build_addr_expr (pchar_type_node,
6699 gfc_build_localized_cstring_const (msg)));
6700
6701 slen = build_int_cst (gfc_charlen_type_node, strlen (msg));
6702 dlen = gfc_get_expr_charlen (code->expr2);
6703 slen = fold_build2_loc (input_location, MIN_EXPR,
6704 TREE_TYPE (slen), dlen, slen);
6705
6706 gfc_trans_string_copy (&errmsg_block, dlen, errmsg,
6707 code->expr2->ts.kind,
6708 slen, errmsg_str,
6709 gfc_default_character_kind);
6710 dlen = gfc_finish_block (&errmsg_block);
6711
6712 tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
6713 stat, build_int_cst (TREE_TYPE (stat), 0));
6714
6715 tmp = build3_v (COND_EXPR, tmp,
6716 dlen, build_empty_stmt (input_location));
6717
6718 gfc_add_expr_to_block (&block, tmp);
6719 }
6720
6721 /* STAT block. */
6722 if (code->expr1)
6723 {
6724 if (TREE_USED (label_finish))
6725 {
6726 tmp = build1_v (LABEL_EXPR, label_finish);
6727 gfc_add_expr_to_block (&block, tmp);
6728 }
6729
6730 gfc_init_se (&se, NULL);
6731 gfc_conv_expr_lhs (&se, code->expr1);
6732 tmp = convert (TREE_TYPE (se.expr), stat);
6733 gfc_add_modify (&block, se.expr, tmp);
6734 }
6735
6736 if (needs_caf_sync)
6737 {
6738 /* Add a sync all after the allocation has been executed. */
6739 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_all,
6740 3, null_pointer_node, null_pointer_node,
6741 integer_zero_node);
6742 gfc_add_expr_to_block (&post, tmp);
6743 }
6744
6745 gfc_add_block_to_block (&block, &se.post);
6746 gfc_add_block_to_block (&block, &post);
6747
6748 return gfc_finish_block (&block);
6749 }
6750
6751
6752 /* Translate a DEALLOCATE statement. */
6753
6754 tree
gfc_trans_deallocate(gfc_code * code)6755 gfc_trans_deallocate (gfc_code *code)
6756 {
6757 gfc_se se;
6758 gfc_alloc *al;
6759 tree apstat, pstat, stat, errmsg, errlen, tmp;
6760 tree label_finish, label_errmsg;
6761 stmtblock_t block;
6762
6763 pstat = apstat = stat = errmsg = errlen = tmp = NULL_TREE;
6764 label_finish = label_errmsg = NULL_TREE;
6765
6766 gfc_start_block (&block);
6767
6768 /* Count the number of failed deallocations. If deallocate() was
6769 called with STAT= , then set STAT to the count. If deallocate
6770 was called with ERRMSG, then set ERRMG to a string. */
6771 if (code->expr1)
6772 {
6773 tree gfc_int4_type_node = gfc_get_int_type (4);
6774
6775 stat = gfc_create_var (gfc_int4_type_node, "stat");
6776 pstat = gfc_build_addr_expr (NULL_TREE, stat);
6777
6778 /* GOTO destinations. */
6779 label_errmsg = gfc_build_label_decl (NULL_TREE);
6780 label_finish = gfc_build_label_decl (NULL_TREE);
6781 TREE_USED (label_finish) = 0;
6782 }
6783
6784 /* Set ERRMSG - only needed if STAT is available. */
6785 if (code->expr1 && code->expr2)
6786 {
6787 gfc_init_se (&se, NULL);
6788 se.want_pointer = 1;
6789 gfc_conv_expr_lhs (&se, code->expr2);
6790 errmsg = se.expr;
6791 errlen = se.string_length;
6792 }
6793
6794 for (al = code->ext.alloc.list; al != NULL; al = al->next)
6795 {
6796 gfc_expr *expr = gfc_copy_expr (al->expr);
6797 bool is_coarray = false, is_coarray_array = false;
6798 int caf_mode = 0;
6799
6800 gcc_assert (expr->expr_type == EXPR_VARIABLE);
6801
6802 if (expr->ts.type == BT_CLASS)
6803 gfc_add_data_component (expr);
6804
6805 gfc_init_se (&se, NULL);
6806 gfc_start_block (&se.pre);
6807
6808 se.want_pointer = 1;
6809 se.descriptor_only = 1;
6810 gfc_conv_expr (&se, expr);
6811
6812 /* Deallocate PDT components that are parameterized. */
6813 tmp = NULL;
6814 if (expr->ts.type == BT_DERIVED
6815 && expr->ts.u.derived->attr.pdt_type
6816 && expr->symtree->n.sym->param_list)
6817 tmp = gfc_deallocate_pdt_comp (expr->ts.u.derived, se.expr, expr->rank);
6818 else if (expr->ts.type == BT_CLASS
6819 && CLASS_DATA (expr)->ts.u.derived->attr.pdt_type
6820 && expr->symtree->n.sym->param_list)
6821 tmp = gfc_deallocate_pdt_comp (CLASS_DATA (expr)->ts.u.derived,
6822 se.expr, expr->rank);
6823
6824 if (tmp)
6825 gfc_add_expr_to_block (&block, tmp);
6826
6827 if (flag_coarray == GFC_FCOARRAY_LIB
6828 || flag_coarray == GFC_FCOARRAY_SINGLE)
6829 {
6830 bool comp_ref;
6831 symbol_attribute caf_attr = gfc_caf_attr (expr, false, &comp_ref);
6832 if (caf_attr.codimension)
6833 {
6834 is_coarray = true;
6835 is_coarray_array = caf_attr.dimension || !comp_ref
6836 || caf_attr.coarray_comp;
6837
6838 if (flag_coarray == GFC_FCOARRAY_LIB)
6839 /* When the expression to deallocate is referencing a
6840 component, then only deallocate it, but do not
6841 deregister. */
6842 caf_mode = GFC_STRUCTURE_CAF_MODE_IN_COARRAY
6843 | (comp_ref && !caf_attr.coarray_comp
6844 ? GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY : 0);
6845 }
6846 }
6847
6848 if (expr->rank || is_coarray_array)
6849 {
6850 gfc_ref *ref;
6851
6852 if (gfc_bt_struct (expr->ts.type)
6853 && expr->ts.u.derived->attr.alloc_comp
6854 && !gfc_is_finalizable (expr->ts.u.derived, NULL))
6855 {
6856 gfc_ref *last = NULL;
6857
6858 for (ref = expr->ref; ref; ref = ref->next)
6859 if (ref->type == REF_COMPONENT)
6860 last = ref;
6861
6862 /* Do not deallocate the components of a derived type
6863 ultimate pointer component. */
6864 if (!(last && last->u.c.component->attr.pointer)
6865 && !(!last && expr->symtree->n.sym->attr.pointer))
6866 {
6867 if (is_coarray && expr->rank == 0
6868 && (!last || !last->u.c.component->attr.dimension)
6869 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr)))
6870 {
6871 /* Add the ref to the data member only, when this is not
6872 a regular array or deallocate_alloc_comp will try to
6873 add another one. */
6874 tmp = gfc_conv_descriptor_data_get (se.expr);
6875 }
6876 else
6877 tmp = se.expr;
6878 tmp = gfc_deallocate_alloc_comp (expr->ts.u.derived, tmp,
6879 expr->rank, caf_mode);
6880 gfc_add_expr_to_block (&se.pre, tmp);
6881 }
6882 }
6883
6884 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr)))
6885 {
6886 gfc_coarray_deregtype caf_dtype;
6887
6888 if (is_coarray)
6889 caf_dtype = gfc_caf_is_dealloc_only (caf_mode)
6890 ? GFC_CAF_COARRAY_DEALLOCATE_ONLY
6891 : GFC_CAF_COARRAY_DEREGISTER;
6892 else
6893 caf_dtype = GFC_CAF_COARRAY_NOCOARRAY;
6894 tmp = gfc_deallocate_with_status (se.expr, pstat, errmsg, errlen,
6895 label_finish, false, expr,
6896 caf_dtype);
6897 gfc_add_expr_to_block (&se.pre, tmp);
6898 }
6899 else if (TREE_CODE (se.expr) == COMPONENT_REF
6900 && TREE_CODE (TREE_TYPE (se.expr)) == ARRAY_TYPE
6901 && TREE_CODE (TREE_TYPE (TREE_TYPE (se.expr)))
6902 == RECORD_TYPE)
6903 {
6904 /* class.c(finalize_component) generates these, when a
6905 finalizable entity has a non-allocatable derived type array
6906 component, which has allocatable components. Obtain the
6907 derived type of the array and deallocate the allocatable
6908 components. */
6909 for (ref = expr->ref; ref; ref = ref->next)
6910 {
6911 if (ref->u.c.component->attr.dimension
6912 && ref->u.c.component->ts.type == BT_DERIVED)
6913 break;
6914 }
6915
6916 if (ref && ref->u.c.component->ts.u.derived->attr.alloc_comp
6917 && !gfc_is_finalizable (ref->u.c.component->ts.u.derived,
6918 NULL))
6919 {
6920 tmp = gfc_deallocate_alloc_comp
6921 (ref->u.c.component->ts.u.derived,
6922 se.expr, expr->rank);
6923 gfc_add_expr_to_block (&se.pre, tmp);
6924 }
6925 }
6926
6927 if (al->expr->ts.type == BT_CLASS)
6928 {
6929 gfc_reset_vptr (&se.pre, al->expr);
6930 if (UNLIMITED_POLY (al->expr)
6931 || (al->expr->ts.type == BT_DERIVED
6932 && al->expr->ts.u.derived->attr.unlimited_polymorphic))
6933 /* Clear _len, too. */
6934 gfc_reset_len (&se.pre, al->expr);
6935 }
6936 }
6937 else
6938 {
6939 tmp = gfc_deallocate_scalar_with_status (se.expr, pstat, label_finish,
6940 false, al->expr,
6941 al->expr->ts, is_coarray);
6942 gfc_add_expr_to_block (&se.pre, tmp);
6943
6944 /* Set to zero after deallocation. */
6945 tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
6946 se.expr,
6947 build_int_cst (TREE_TYPE (se.expr), 0));
6948 gfc_add_expr_to_block (&se.pre, tmp);
6949
6950 if (al->expr->ts.type == BT_CLASS)
6951 {
6952 gfc_reset_vptr (&se.pre, al->expr);
6953 if (UNLIMITED_POLY (al->expr)
6954 || (al->expr->ts.type == BT_DERIVED
6955 && al->expr->ts.u.derived->attr.unlimited_polymorphic))
6956 /* Clear _len, too. */
6957 gfc_reset_len (&se.pre, al->expr);
6958 }
6959 }
6960
6961 if (code->expr1)
6962 {
6963 tree cond;
6964
6965 cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, stat,
6966 build_int_cst (TREE_TYPE (stat), 0));
6967 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
6968 gfc_unlikely (cond, PRED_FORTRAN_FAIL_ALLOC),
6969 build1_v (GOTO_EXPR, label_errmsg),
6970 build_empty_stmt (input_location));
6971 gfc_add_expr_to_block (&se.pre, tmp);
6972 }
6973
6974 tmp = gfc_finish_block (&se.pre);
6975 gfc_add_expr_to_block (&block, tmp);
6976 gfc_free_expr (expr);
6977 }
6978
6979 if (code->expr1)
6980 {
6981 tmp = build1_v (LABEL_EXPR, label_errmsg);
6982 gfc_add_expr_to_block (&block, tmp);
6983 }
6984
6985 /* Set ERRMSG - only needed if STAT is available. */
6986 if (code->expr1 && code->expr2)
6987 {
6988 const char *msg = "Attempt to deallocate an unallocated object";
6989 stmtblock_t errmsg_block;
6990 tree errmsg_str, slen, dlen, cond;
6991
6992 gfc_init_block (&errmsg_block);
6993
6994 errmsg_str = gfc_create_var (pchar_type_node, "ERRMSG");
6995 gfc_add_modify (&errmsg_block, errmsg_str,
6996 gfc_build_addr_expr (pchar_type_node,
6997 gfc_build_localized_cstring_const (msg)));
6998 slen = build_int_cst (gfc_charlen_type_node, strlen (msg));
6999 dlen = gfc_get_expr_charlen (code->expr2);
7000
7001 gfc_trans_string_copy (&errmsg_block, dlen, errmsg, code->expr2->ts.kind,
7002 slen, errmsg_str, gfc_default_character_kind);
7003 tmp = gfc_finish_block (&errmsg_block);
7004
7005 cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, stat,
7006 build_int_cst (TREE_TYPE (stat), 0));
7007 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
7008 gfc_unlikely (cond, PRED_FORTRAN_FAIL_ALLOC), tmp,
7009 build_empty_stmt (input_location));
7010
7011 gfc_add_expr_to_block (&block, tmp);
7012 }
7013
7014 if (code->expr1 && TREE_USED (label_finish))
7015 {
7016 tmp = build1_v (LABEL_EXPR, label_finish);
7017 gfc_add_expr_to_block (&block, tmp);
7018 }
7019
7020 /* Set STAT. */
7021 if (code->expr1)
7022 {
7023 gfc_init_se (&se, NULL);
7024 gfc_conv_expr_lhs (&se, code->expr1);
7025 tmp = convert (TREE_TYPE (se.expr), stat);
7026 gfc_add_modify (&block, se.expr, tmp);
7027 }
7028
7029 return gfc_finish_block (&block);
7030 }
7031
7032 #include "gt-fortran-trans-stmt.h"
7033