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