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