1 /* Statement translation -- generate GCC trees from gfc_code.
2 Copyright (C) 2002-2014 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 "tree.h"
27 #include "stringpool.h"
28 #include "gfortran.h"
29 #include "flags.h"
30 #include "trans.h"
31 #include "trans-stmt.h"
32 #include "trans-types.h"
33 #include "trans-array.h"
34 #include "trans-const.h"
35 #include "arith.h"
36 #include "dependency.h"
37 #include "ggc.h"
38
39 typedef struct iter_info
40 {
41 tree var;
42 tree start;
43 tree end;
44 tree step;
45 struct iter_info *next;
46 }
47 iter_info;
48
49 typedef struct forall_info
50 {
51 iter_info *this_loop;
52 tree mask;
53 tree maskindex;
54 int nvar;
55 tree size;
56 struct forall_info *prev_nest;
57 bool do_concurrent;
58 }
59 forall_info;
60
61 static void gfc_trans_where_2 (gfc_code *, tree, bool,
62 forall_info *, stmtblock_t *);
63
64 /* Translate a F95 label number to a LABEL_EXPR. */
65
66 tree
gfc_trans_label_here(gfc_code * code)67 gfc_trans_label_here (gfc_code * code)
68 {
69 return build1_v (LABEL_EXPR, gfc_get_label_decl (code->here));
70 }
71
72
73 /* Given a variable expression which has been ASSIGNed to, find the decl
74 containing the auxiliary variables. For variables in common blocks this
75 is a field_decl. */
76
77 void
gfc_conv_label_variable(gfc_se * se,gfc_expr * expr)78 gfc_conv_label_variable (gfc_se * se, gfc_expr * expr)
79 {
80 gcc_assert (expr->symtree->n.sym->attr.assign == 1);
81 gfc_conv_expr (se, expr);
82 /* Deals with variable in common block. Get the field declaration. */
83 if (TREE_CODE (se->expr) == COMPONENT_REF)
84 se->expr = TREE_OPERAND (se->expr, 1);
85 /* Deals with dummy argument. Get the parameter declaration. */
86 else if (TREE_CODE (se->expr) == INDIRECT_REF)
87 se->expr = TREE_OPERAND (se->expr, 0);
88 }
89
90 /* Translate a label assignment statement. */
91
92 tree
gfc_trans_label_assign(gfc_code * code)93 gfc_trans_label_assign (gfc_code * code)
94 {
95 tree label_tree;
96 gfc_se se;
97 tree len;
98 tree addr;
99 tree len_tree;
100 int label_len;
101
102 /* Start a new block. */
103 gfc_init_se (&se, NULL);
104 gfc_start_block (&se.pre);
105 gfc_conv_label_variable (&se, code->expr1);
106
107 len = GFC_DECL_STRING_LEN (se.expr);
108 addr = GFC_DECL_ASSIGN_ADDR (se.expr);
109
110 label_tree = gfc_get_label_decl (code->label1);
111
112 if (code->label1->defined == ST_LABEL_TARGET
113 || code->label1->defined == ST_LABEL_DO_TARGET)
114 {
115 label_tree = gfc_build_addr_expr (pvoid_type_node, label_tree);
116 len_tree = integer_minus_one_node;
117 }
118 else
119 {
120 gfc_expr *format = code->label1->format;
121
122 label_len = format->value.character.length;
123 len_tree = build_int_cst (gfc_charlen_type_node, label_len);
124 label_tree = gfc_build_wide_string_const (format->ts.kind, label_len + 1,
125 format->value.character.string);
126 label_tree = gfc_build_addr_expr (pvoid_type_node, label_tree);
127 }
128
129 gfc_add_modify (&se.pre, len, len_tree);
130 gfc_add_modify (&se.pre, addr, label_tree);
131
132 return gfc_finish_block (&se.pre);
133 }
134
135 /* Translate a GOTO statement. */
136
137 tree
gfc_trans_goto(gfc_code * code)138 gfc_trans_goto (gfc_code * code)
139 {
140 locus loc = code->loc;
141 tree assigned_goto;
142 tree target;
143 tree tmp;
144 gfc_se se;
145
146 if (code->label1 != NULL)
147 return build1_v (GOTO_EXPR, gfc_get_label_decl (code->label1));
148
149 /* ASSIGNED GOTO. */
150 gfc_init_se (&se, NULL);
151 gfc_start_block (&se.pre);
152 gfc_conv_label_variable (&se, code->expr1);
153 tmp = GFC_DECL_STRING_LEN (se.expr);
154 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, tmp,
155 build_int_cst (TREE_TYPE (tmp), -1));
156 gfc_trans_runtime_check (true, false, tmp, &se.pre, &loc,
157 "Assigned label is not a target label");
158
159 assigned_goto = GFC_DECL_ASSIGN_ADDR (se.expr);
160
161 /* We're going to ignore a label list. It does not really change the
162 statement's semantics (because it is just a further restriction on
163 what's legal code); before, we were comparing label addresses here, but
164 that's a very fragile business and may break with optimization. So
165 just ignore it. */
166
167 target = fold_build1_loc (input_location, GOTO_EXPR, void_type_node,
168 assigned_goto);
169 gfc_add_expr_to_block (&se.pre, target);
170 return gfc_finish_block (&se.pre);
171 }
172
173
174 /* Translate an ENTRY statement. Just adds a label for this entry point. */
175 tree
gfc_trans_entry(gfc_code * code)176 gfc_trans_entry (gfc_code * code)
177 {
178 return build1_v (LABEL_EXPR, code->ext.entry->label);
179 }
180
181
182 /* Replace a gfc_ss structure by another both in the gfc_se struct
183 and the gfc_loopinfo struct. This is used in gfc_conv_elemental_dependencies
184 to replace a variable ss by the corresponding temporary. */
185
186 static void
replace_ss(gfc_se * se,gfc_ss * old_ss,gfc_ss * new_ss)187 replace_ss (gfc_se *se, gfc_ss *old_ss, gfc_ss *new_ss)
188 {
189 gfc_ss **sess, **loopss;
190
191 /* The old_ss is a ss for a single variable. */
192 gcc_assert (old_ss->info->type == GFC_SS_SECTION);
193
194 for (sess = &(se->ss); *sess != gfc_ss_terminator; sess = &((*sess)->next))
195 if (*sess == old_ss)
196 break;
197 gcc_assert (*sess != gfc_ss_terminator);
198
199 *sess = new_ss;
200 new_ss->next = old_ss->next;
201
202
203 for (loopss = &(se->loop->ss); *loopss != gfc_ss_terminator;
204 loopss = &((*loopss)->loop_chain))
205 if (*loopss == old_ss)
206 break;
207 gcc_assert (*loopss != gfc_ss_terminator);
208
209 *loopss = new_ss;
210 new_ss->loop_chain = old_ss->loop_chain;
211 new_ss->loop = old_ss->loop;
212
213 gfc_free_ss (old_ss);
214 }
215
216
217 /* Check for dependencies between INTENT(IN) and INTENT(OUT) arguments of
218 elemental subroutines. Make temporaries for output arguments if any such
219 dependencies are found. Output arguments are chosen because internal_unpack
220 can be used, as is, to copy the result back to the variable. */
221 static void
gfc_conv_elemental_dependencies(gfc_se * se,gfc_se * loopse,gfc_symbol * sym,gfc_actual_arglist * arg,gfc_dep_check check_variable)222 gfc_conv_elemental_dependencies (gfc_se * se, gfc_se * loopse,
223 gfc_symbol * sym, gfc_actual_arglist * arg,
224 gfc_dep_check check_variable)
225 {
226 gfc_actual_arglist *arg0;
227 gfc_expr *e;
228 gfc_formal_arglist *formal;
229 gfc_se parmse;
230 gfc_ss *ss;
231 gfc_symbol *fsym;
232 tree data;
233 tree size;
234 tree tmp;
235
236 if (loopse->ss == NULL)
237 return;
238
239 ss = loopse->ss;
240 arg0 = arg;
241 formal = gfc_sym_get_dummy_args (sym);
242
243 /* Loop over all the arguments testing for dependencies. */
244 for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
245 {
246 e = arg->expr;
247 if (e == NULL)
248 continue;
249
250 /* Obtain the info structure for the current argument. */
251 for (ss = loopse->ss; ss && ss != gfc_ss_terminator; ss = ss->next)
252 if (ss->info->expr == e)
253 break;
254
255 /* If there is a dependency, create a temporary and use it
256 instead of the variable. */
257 fsym = formal ? formal->sym : NULL;
258 if (e->expr_type == EXPR_VARIABLE
259 && e->rank && fsym
260 && fsym->attr.intent != INTENT_IN
261 && gfc_check_fncall_dependency (e, fsym->attr.intent,
262 sym, arg0, check_variable))
263 {
264 tree initial, temptype;
265 stmtblock_t temp_post;
266 gfc_ss *tmp_ss;
267
268 tmp_ss = gfc_get_array_ss (gfc_ss_terminator, NULL, ss->dimen,
269 GFC_SS_SECTION);
270 gfc_mark_ss_chain_used (tmp_ss, 1);
271 tmp_ss->info->expr = ss->info->expr;
272 replace_ss (loopse, ss, tmp_ss);
273
274 /* Obtain the argument descriptor for unpacking. */
275 gfc_init_se (&parmse, NULL);
276 parmse.want_pointer = 1;
277 gfc_conv_expr_descriptor (&parmse, e);
278 gfc_add_block_to_block (&se->pre, &parmse.pre);
279
280 /* If we've got INTENT(INOUT) or a derived type with INTENT(OUT),
281 initialize the array temporary with a copy of the values. */
282 if (fsym->attr.intent == INTENT_INOUT
283 || (fsym->ts.type ==BT_DERIVED
284 && fsym->attr.intent == INTENT_OUT))
285 initial = parmse.expr;
286 /* For class expressions, we always initialize with the copy of
287 the values. */
288 else if (e->ts.type == BT_CLASS)
289 initial = parmse.expr;
290 else
291 initial = NULL_TREE;
292
293 if (e->ts.type != BT_CLASS)
294 {
295 /* Find the type of the temporary to create; we don't use the type
296 of e itself as this breaks for subcomponent-references in e
297 (where the type of e is that of the final reference, but
298 parmse.expr's type corresponds to the full derived-type). */
299 /* TODO: Fix this somehow so we don't need a temporary of the whole
300 array but instead only the components referenced. */
301 temptype = TREE_TYPE (parmse.expr); /* Pointer to descriptor. */
302 gcc_assert (TREE_CODE (temptype) == POINTER_TYPE);
303 temptype = TREE_TYPE (temptype);
304 temptype = gfc_get_element_type (temptype);
305 }
306
307 else
308 /* For class arrays signal that the size of the dynamic type has to
309 be obtained from the vtable, using the 'initial' expression. */
310 temptype = NULL_TREE;
311
312 /* Generate the temporary. Cleaning up the temporary should be the
313 very last thing done, so we add the code to a new block and add it
314 to se->post as last instructions. */
315 size = gfc_create_var (gfc_array_index_type, NULL);
316 data = gfc_create_var (pvoid_type_node, NULL);
317 gfc_init_block (&temp_post);
318 tmp = gfc_trans_create_temp_array (&se->pre, &temp_post, tmp_ss,
319 temptype, initial, false, true,
320 false, &arg->expr->where);
321 gfc_add_modify (&se->pre, size, tmp);
322 tmp = fold_convert (pvoid_type_node, tmp_ss->info->data.array.data);
323 gfc_add_modify (&se->pre, data, tmp);
324
325 /* Update other ss' delta. */
326 gfc_set_delta (loopse->loop);
327
328 /* Copy the result back using unpack..... */
329 if (e->ts.type != BT_CLASS)
330 tmp = build_call_expr_loc (input_location,
331 gfor_fndecl_in_unpack, 2, parmse.expr, data);
332 else
333 {
334 /* ... except for class results where the copy is
335 unconditional. */
336 tmp = build_fold_indirect_ref_loc (input_location, parmse.expr);
337 tmp = gfc_conv_descriptor_data_get (tmp);
338 tmp = build_call_expr_loc (input_location,
339 builtin_decl_explicit (BUILT_IN_MEMCPY),
340 3, tmp, data,
341 fold_convert (size_type_node, size));
342 }
343 gfc_add_expr_to_block (&se->post, tmp);
344
345 /* parmse.pre is already added above. */
346 gfc_add_block_to_block (&se->post, &parmse.post);
347 gfc_add_block_to_block (&se->post, &temp_post);
348 }
349 }
350 }
351
352
353 /* Get the interface symbol for the procedure corresponding to the given call.
354 We can't get the procedure symbol directly as we have to handle the case
355 of (deferred) type-bound procedures. */
356
357 static gfc_symbol *
get_proc_ifc_for_call(gfc_code * c)358 get_proc_ifc_for_call (gfc_code *c)
359 {
360 gfc_symbol *sym;
361
362 gcc_assert (c->op == EXEC_ASSIGN_CALL || c->op == EXEC_CALL);
363
364 sym = gfc_get_proc_ifc_for_expr (c->expr1);
365
366 /* Fall back/last resort try. */
367 if (sym == NULL)
368 sym = c->resolved_sym;
369
370 return sym;
371 }
372
373
374 /* Translate the CALL statement. Builds a call to an F95 subroutine. */
375
376 tree
gfc_trans_call(gfc_code * code,bool dependency_check,tree mask,tree count1,bool invert)377 gfc_trans_call (gfc_code * code, bool dependency_check,
378 tree mask, tree count1, bool invert)
379 {
380 gfc_se se;
381 gfc_ss * ss;
382 int has_alternate_specifier;
383 gfc_dep_check check_variable;
384 tree index = NULL_TREE;
385 tree maskexpr = NULL_TREE;
386 tree tmp;
387
388 /* A CALL starts a new block because the actual arguments may have to
389 be evaluated first. */
390 gfc_init_se (&se, NULL);
391 gfc_start_block (&se.pre);
392
393 gcc_assert (code->resolved_sym);
394
395 ss = gfc_ss_terminator;
396 if (code->resolved_sym->attr.elemental)
397 ss = gfc_walk_elemental_function_args (ss, code->ext.actual,
398 get_proc_ifc_for_call (code),
399 GFC_SS_REFERENCE);
400
401 /* Is not an elemental subroutine call with array valued arguments. */
402 if (ss == gfc_ss_terminator)
403 {
404
405 /* Translate the call. */
406 has_alternate_specifier
407 = gfc_conv_procedure_call (&se, code->resolved_sym, code->ext.actual,
408 code->expr1, NULL);
409
410 /* A subroutine without side-effect, by definition, does nothing! */
411 TREE_SIDE_EFFECTS (se.expr) = 1;
412
413 /* Chain the pieces together and return the block. */
414 if (has_alternate_specifier)
415 {
416 gfc_code *select_code;
417 gfc_symbol *sym;
418 select_code = code->next;
419 gcc_assert(select_code->op == EXEC_SELECT);
420 sym = select_code->expr1->symtree->n.sym;
421 se.expr = convert (gfc_typenode_for_spec (&sym->ts), se.expr);
422 if (sym->backend_decl == NULL)
423 sym->backend_decl = gfc_get_symbol_decl (sym);
424 gfc_add_modify (&se.pre, sym->backend_decl, se.expr);
425 }
426 else
427 gfc_add_expr_to_block (&se.pre, se.expr);
428
429 gfc_add_block_to_block (&se.pre, &se.post);
430 }
431
432 else
433 {
434 /* An elemental subroutine call with array valued arguments has
435 to be scalarized. */
436 gfc_loopinfo loop;
437 stmtblock_t body;
438 stmtblock_t block;
439 gfc_se loopse;
440 gfc_se depse;
441
442 /* gfc_walk_elemental_function_args renders the ss chain in the
443 reverse order to the actual argument order. */
444 ss = gfc_reverse_ss (ss);
445
446 /* Initialize the loop. */
447 gfc_init_se (&loopse, NULL);
448 gfc_init_loopinfo (&loop);
449 gfc_add_ss_to_loop (&loop, ss);
450
451 gfc_conv_ss_startstride (&loop);
452 /* TODO: gfc_conv_loop_setup generates a temporary for vector
453 subscripts. This could be prevented in the elemental case
454 as temporaries are handled separatedly
455 (below in gfc_conv_elemental_dependencies). */
456 gfc_conv_loop_setup (&loop, &code->expr1->where);
457 gfc_mark_ss_chain_used (ss, 1);
458
459 /* Convert the arguments, checking for dependencies. */
460 gfc_copy_loopinfo_to_se (&loopse, &loop);
461 loopse.ss = ss;
462
463 /* For operator assignment, do dependency checking. */
464 if (dependency_check)
465 check_variable = ELEM_CHECK_VARIABLE;
466 else
467 check_variable = ELEM_DONT_CHECK_VARIABLE;
468
469 gfc_init_se (&depse, NULL);
470 gfc_conv_elemental_dependencies (&depse, &loopse, code->resolved_sym,
471 code->ext.actual, check_variable);
472
473 gfc_add_block_to_block (&loop.pre, &depse.pre);
474 gfc_add_block_to_block (&loop.post, &depse.post);
475
476 /* Generate the loop body. */
477 gfc_start_scalarized_body (&loop, &body);
478 gfc_init_block (&block);
479
480 if (mask && count1)
481 {
482 /* Form the mask expression according to the mask. */
483 index = count1;
484 maskexpr = gfc_build_array_ref (mask, index, NULL);
485 if (invert)
486 maskexpr = fold_build1_loc (input_location, TRUTH_NOT_EXPR,
487 TREE_TYPE (maskexpr), maskexpr);
488 }
489
490 /* Add the subroutine call to the block. */
491 gfc_conv_procedure_call (&loopse, code->resolved_sym,
492 code->ext.actual, code->expr1,
493 NULL);
494
495 if (mask && count1)
496 {
497 tmp = build3_v (COND_EXPR, maskexpr, loopse.expr,
498 build_empty_stmt (input_location));
499 gfc_add_expr_to_block (&loopse.pre, tmp);
500 tmp = fold_build2_loc (input_location, PLUS_EXPR,
501 gfc_array_index_type,
502 count1, gfc_index_one_node);
503 gfc_add_modify (&loopse.pre, count1, tmp);
504 }
505 else
506 gfc_add_expr_to_block (&loopse.pre, loopse.expr);
507
508 gfc_add_block_to_block (&block, &loopse.pre);
509 gfc_add_block_to_block (&block, &loopse.post);
510
511 /* Finish up the loop block and the loop. */
512 gfc_add_expr_to_block (&body, gfc_finish_block (&block));
513 gfc_trans_scalarizing_loops (&loop, &body);
514 gfc_add_block_to_block (&se.pre, &loop.pre);
515 gfc_add_block_to_block (&se.pre, &loop.post);
516 gfc_add_block_to_block (&se.pre, &se.post);
517 gfc_cleanup_loop (&loop);
518 }
519
520 return gfc_finish_block (&se.pre);
521 }
522
523
524 /* Translate the RETURN statement. */
525
526 tree
gfc_trans_return(gfc_code * code)527 gfc_trans_return (gfc_code * code)
528 {
529 if (code->expr1)
530 {
531 gfc_se se;
532 tree tmp;
533 tree result;
534
535 /* If code->expr is not NULL, this return statement must appear
536 in a subroutine and current_fake_result_decl has already
537 been generated. */
538
539 result = gfc_get_fake_result_decl (NULL, 0);
540 if (!result)
541 {
542 gfc_warning ("An alternate return at %L without a * dummy argument",
543 &code->expr1->where);
544 return gfc_generate_return ();
545 }
546
547 /* Start a new block for this statement. */
548 gfc_init_se (&se, NULL);
549 gfc_start_block (&se.pre);
550
551 gfc_conv_expr (&se, code->expr1);
552
553 /* Note that the actually returned expression is a simple value and
554 does not depend on any pointers or such; thus we can clean-up with
555 se.post before returning. */
556 tmp = fold_build2_loc (input_location, MODIFY_EXPR, TREE_TYPE (result),
557 result, fold_convert (TREE_TYPE (result),
558 se.expr));
559 gfc_add_expr_to_block (&se.pre, tmp);
560 gfc_add_block_to_block (&se.pre, &se.post);
561
562 tmp = gfc_generate_return ();
563 gfc_add_expr_to_block (&se.pre, tmp);
564 return gfc_finish_block (&se.pre);
565 }
566
567 return gfc_generate_return ();
568 }
569
570
571 /* Translate the PAUSE statement. We have to translate this statement
572 to a runtime library call. */
573
574 tree
gfc_trans_pause(gfc_code * code)575 gfc_trans_pause (gfc_code * code)
576 {
577 tree gfc_int4_type_node = gfc_get_int_type (4);
578 gfc_se se;
579 tree tmp;
580
581 /* Start a new block for this statement. */
582 gfc_init_se (&se, NULL);
583 gfc_start_block (&se.pre);
584
585
586 if (code->expr1 == NULL)
587 {
588 tmp = build_int_cst (gfc_int4_type_node, 0);
589 tmp = build_call_expr_loc (input_location,
590 gfor_fndecl_pause_string, 2,
591 build_int_cst (pchar_type_node, 0), tmp);
592 }
593 else if (code->expr1->ts.type == BT_INTEGER)
594 {
595 gfc_conv_expr (&se, code->expr1);
596 tmp = build_call_expr_loc (input_location,
597 gfor_fndecl_pause_numeric, 1,
598 fold_convert (gfc_int4_type_node, se.expr));
599 }
600 else
601 {
602 gfc_conv_expr_reference (&se, code->expr1);
603 tmp = build_call_expr_loc (input_location,
604 gfor_fndecl_pause_string, 2,
605 se.expr, se.string_length);
606 }
607
608 gfc_add_expr_to_block (&se.pre, tmp);
609
610 gfc_add_block_to_block (&se.pre, &se.post);
611
612 return gfc_finish_block (&se.pre);
613 }
614
615
616 /* Translate the STOP statement. We have to translate this statement
617 to a runtime library call. */
618
619 tree
gfc_trans_stop(gfc_code * code,bool error_stop)620 gfc_trans_stop (gfc_code *code, bool error_stop)
621 {
622 tree gfc_int4_type_node = gfc_get_int_type (4);
623 gfc_se se;
624 tree tmp;
625
626 /* Start a new block for this statement. */
627 gfc_init_se (&se, NULL);
628 gfc_start_block (&se.pre);
629
630 if (gfc_option.coarray == GFC_FCOARRAY_LIB && !error_stop)
631 {
632 /* Per F2008, 8.5.1 STOP implies a SYNC MEMORY. */
633 tmp = builtin_decl_explicit (BUILT_IN_SYNC_SYNCHRONIZE);
634 tmp = build_call_expr_loc (input_location, tmp, 0);
635 gfc_add_expr_to_block (&se.pre, tmp);
636
637 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_finalize, 0);
638 gfc_add_expr_to_block (&se.pre, tmp);
639 }
640
641 if (code->expr1 == NULL)
642 {
643 tmp = build_int_cst (gfc_int4_type_node, 0);
644 tmp = build_call_expr_loc (input_location,
645 error_stop
646 ? (gfc_option.coarray == GFC_FCOARRAY_LIB
647 ? gfor_fndecl_caf_error_stop_str
648 : gfor_fndecl_error_stop_string)
649 : gfor_fndecl_stop_string,
650 2, build_int_cst (pchar_type_node, 0), tmp);
651 }
652 else if (code->expr1->ts.type == BT_INTEGER)
653 {
654 gfc_conv_expr (&se, code->expr1);
655 tmp = build_call_expr_loc (input_location,
656 error_stop
657 ? (gfc_option.coarray == GFC_FCOARRAY_LIB
658 ? gfor_fndecl_caf_error_stop
659 : gfor_fndecl_error_stop_numeric)
660 : gfor_fndecl_stop_numeric_f08, 1,
661 fold_convert (gfc_int4_type_node, se.expr));
662 }
663 else
664 {
665 gfc_conv_expr_reference (&se, code->expr1);
666 tmp = build_call_expr_loc (input_location,
667 error_stop
668 ? (gfc_option.coarray == GFC_FCOARRAY_LIB
669 ? gfor_fndecl_caf_error_stop_str
670 : gfor_fndecl_error_stop_string)
671 : gfor_fndecl_stop_string,
672 2, se.expr, se.string_length);
673 }
674
675 gfc_add_expr_to_block (&se.pre, tmp);
676
677 gfc_add_block_to_block (&se.pre, &se.post);
678
679 return gfc_finish_block (&se.pre);
680 }
681
682
683 tree
gfc_trans_lock_unlock(gfc_code * code,gfc_exec_op type ATTRIBUTE_UNUSED)684 gfc_trans_lock_unlock (gfc_code *code, gfc_exec_op type ATTRIBUTE_UNUSED)
685 {
686 gfc_se se, argse;
687 tree stat = NULL_TREE, lock_acquired = NULL_TREE;
688
689 /* Short cut: For single images without STAT= or LOCK_ACQUIRED
690 return early. (ERRMSG= is always untouched for -fcoarray=single.) */
691 if (!code->expr2 && !code->expr4 && gfc_option.coarray != GFC_FCOARRAY_LIB)
692 return NULL_TREE;
693
694 gfc_init_se (&se, NULL);
695 gfc_start_block (&se.pre);
696
697 if (code->expr2)
698 {
699 gcc_assert (code->expr2->expr_type == EXPR_VARIABLE);
700 gfc_init_se (&argse, NULL);
701 gfc_conv_expr_val (&argse, code->expr2);
702 stat = argse.expr;
703 }
704
705 if (code->expr4)
706 {
707 gcc_assert (code->expr4->expr_type == EXPR_VARIABLE);
708 gfc_init_se (&argse, NULL);
709 gfc_conv_expr_val (&argse, code->expr4);
710 lock_acquired = argse.expr;
711 }
712
713 if (stat != NULL_TREE)
714 gfc_add_modify (&se.pre, stat, build_int_cst (TREE_TYPE (stat), 0));
715
716 if (lock_acquired != NULL_TREE)
717 gfc_add_modify (&se.pre, lock_acquired,
718 fold_convert (TREE_TYPE (lock_acquired),
719 boolean_true_node));
720
721 return gfc_finish_block (&se.pre);
722 }
723
724
725 tree
gfc_trans_sync(gfc_code * code,gfc_exec_op type)726 gfc_trans_sync (gfc_code *code, gfc_exec_op type)
727 {
728 gfc_se se, argse;
729 tree tmp;
730 tree images = NULL_TREE, stat = NULL_TREE,
731 errmsg = NULL_TREE, errmsglen = NULL_TREE;
732
733 /* Short cut: For single images without bound checking or without STAT=,
734 return early. (ERRMSG= is always untouched for -fcoarray=single.) */
735 if (!code->expr2 && !(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
736 && gfc_option.coarray != GFC_FCOARRAY_LIB)
737 return NULL_TREE;
738
739 gfc_init_se (&se, NULL);
740 gfc_start_block (&se.pre);
741
742 if (code->expr1 && code->expr1->rank == 0)
743 {
744 gfc_init_se (&argse, NULL);
745 gfc_conv_expr_val (&argse, code->expr1);
746 images = argse.expr;
747 }
748
749 if (code->expr2)
750 {
751 gcc_assert (code->expr2->expr_type == EXPR_VARIABLE);
752 gfc_init_se (&argse, NULL);
753 gfc_conv_expr_val (&argse, code->expr2);
754 stat = argse.expr;
755 }
756 else
757 stat = null_pointer_node;
758
759 if (code->expr3 && gfc_option.coarray == GFC_FCOARRAY_LIB
760 && type != EXEC_SYNC_MEMORY)
761 {
762 gcc_assert (code->expr3->expr_type == EXPR_VARIABLE);
763 gfc_init_se (&argse, NULL);
764 gfc_conv_expr (&argse, code->expr3);
765 gfc_conv_string_parameter (&argse);
766 errmsg = gfc_build_addr_expr (NULL, argse.expr);
767 errmsglen = argse.string_length;
768 }
769 else if (gfc_option.coarray == GFC_FCOARRAY_LIB && type != EXEC_SYNC_MEMORY)
770 {
771 errmsg = null_pointer_node;
772 errmsglen = build_int_cst (integer_type_node, 0);
773 }
774
775 /* Check SYNC IMAGES(imageset) for valid image index.
776 FIXME: Add a check for image-set arrays. */
777 if (code->expr1 && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
778 && code->expr1->rank == 0)
779 {
780 tree cond;
781 if (gfc_option.coarray != GFC_FCOARRAY_LIB)
782 cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
783 images, build_int_cst (TREE_TYPE (images), 1));
784 else
785 {
786 tree cond2;
787 cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
788 images, gfort_gvar_caf_num_images);
789 cond2 = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
790 images,
791 build_int_cst (TREE_TYPE (images), 1));
792 cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
793 boolean_type_node, cond, cond2);
794 }
795 gfc_trans_runtime_check (true, false, cond, &se.pre,
796 &code->expr1->where, "Invalid image number "
797 "%d in SYNC IMAGES",
798 fold_convert (integer_type_node, images));
799 }
800
801 /* Per F2008, 8.5.1, a SYNC MEMORY is implied by calling the
802 image control statements SYNC IMAGES and SYNC ALL. */
803 if (gfc_option.coarray == GFC_FCOARRAY_LIB)
804 {
805 tmp = builtin_decl_explicit (BUILT_IN_SYNC_SYNCHRONIZE);
806 tmp = build_call_expr_loc (input_location, tmp, 0);
807 gfc_add_expr_to_block (&se.pre, tmp);
808 }
809
810 if (gfc_option.coarray != GFC_FCOARRAY_LIB || type == EXEC_SYNC_MEMORY)
811 {
812 /* Set STAT to zero. */
813 if (code->expr2)
814 gfc_add_modify (&se.pre, stat, build_int_cst (TREE_TYPE (stat), 0));
815 }
816 else if (type == EXEC_SYNC_ALL)
817 {
818 /* SYNC ALL => stat == null_pointer_node
819 SYNC ALL(stat=s) => stat has an integer type
820
821 If "stat" has the wrong integer type, use a temp variable of
822 the right type and later cast the result back into "stat". */
823 if (stat == null_pointer_node || TREE_TYPE (stat) == integer_type_node)
824 {
825 if (TREE_TYPE (stat) == integer_type_node)
826 stat = gfc_build_addr_expr (NULL, stat);
827
828 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_all,
829 3, stat, errmsg, errmsglen);
830 gfc_add_expr_to_block (&se.pre, tmp);
831 }
832 else
833 {
834 tree tmp_stat = gfc_create_var (integer_type_node, "stat");
835
836 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_all,
837 3, gfc_build_addr_expr (NULL, tmp_stat),
838 errmsg, errmsglen);
839 gfc_add_expr_to_block (&se.pre, tmp);
840
841 gfc_add_modify (&se.pre, stat,
842 fold_convert (TREE_TYPE (stat), tmp_stat));
843 }
844 }
845 else
846 {
847 tree len;
848
849 gcc_assert (type == EXEC_SYNC_IMAGES);
850
851 if (!code->expr1)
852 {
853 len = build_int_cst (integer_type_node, -1);
854 images = null_pointer_node;
855 }
856 else if (code->expr1->rank == 0)
857 {
858 len = build_int_cst (integer_type_node, 1);
859 images = gfc_build_addr_expr (NULL_TREE, images);
860 }
861 else
862 {
863 /* FIXME. */
864 if (code->expr1->ts.kind != gfc_c_int_kind)
865 gfc_fatal_error ("Sorry, only support for integer kind %d "
866 "implemented for image-set at %L",
867 gfc_c_int_kind, &code->expr1->where);
868
869 gfc_conv_array_parameter (&se, code->expr1, true, NULL, NULL, &len);
870 images = se.expr;
871
872 tmp = gfc_typenode_for_spec (&code->expr1->ts);
873 if (GFC_ARRAY_TYPE_P (tmp) || GFC_DESCRIPTOR_TYPE_P (tmp))
874 tmp = gfc_get_element_type (tmp);
875
876 len = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
877 TREE_TYPE (len), len,
878 fold_convert (TREE_TYPE (len),
879 TYPE_SIZE_UNIT (tmp)));
880 len = fold_convert (integer_type_node, len);
881 }
882
883 /* SYNC IMAGES(imgs) => stat == null_pointer_node
884 SYNC IMAGES(imgs,stat=s) => stat has an integer type
885
886 If "stat" has the wrong integer type, use a temp variable of
887 the right type and later cast the result back into "stat". */
888 if (stat == null_pointer_node || TREE_TYPE (stat) == integer_type_node)
889 {
890 if (TREE_TYPE (stat) == integer_type_node)
891 stat = gfc_build_addr_expr (NULL, stat);
892
893 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_images,
894 5, fold_convert (integer_type_node, len),
895 images, stat, errmsg, errmsglen);
896 gfc_add_expr_to_block (&se.pre, tmp);
897 }
898 else
899 {
900 tree tmp_stat = gfc_create_var (integer_type_node, "stat");
901
902 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_images,
903 5, fold_convert (integer_type_node, len),
904 images, gfc_build_addr_expr (NULL, tmp_stat),
905 errmsg, errmsglen);
906 gfc_add_expr_to_block (&se.pre, tmp);
907
908 gfc_add_modify (&se.pre, stat,
909 fold_convert (TREE_TYPE (stat), tmp_stat));
910 }
911 }
912
913 return gfc_finish_block (&se.pre);
914 }
915
916
917 /* Generate GENERIC for the IF construct. This function also deals with
918 the simple IF statement, because the front end translates the IF
919 statement into an IF construct.
920
921 We translate:
922
923 IF (cond) THEN
924 then_clause
925 ELSEIF (cond2)
926 elseif_clause
927 ELSE
928 else_clause
929 ENDIF
930
931 into:
932
933 pre_cond_s;
934 if (cond_s)
935 {
936 then_clause;
937 }
938 else
939 {
940 pre_cond_s
941 if (cond_s)
942 {
943 elseif_clause
944 }
945 else
946 {
947 else_clause;
948 }
949 }
950
951 where COND_S is the simplified version of the predicate. PRE_COND_S
952 are the pre side-effects produced by the translation of the
953 conditional.
954 We need to build the chain recursively otherwise we run into
955 problems with folding incomplete statements. */
956
957 static tree
gfc_trans_if_1(gfc_code * code)958 gfc_trans_if_1 (gfc_code * code)
959 {
960 gfc_se if_se;
961 tree stmt, elsestmt;
962 locus saved_loc;
963 location_t loc;
964
965 /* Check for an unconditional ELSE clause. */
966 if (!code->expr1)
967 return gfc_trans_code (code->next);
968
969 /* Initialize a statement builder for each block. Puts in NULL_TREEs. */
970 gfc_init_se (&if_se, NULL);
971 gfc_start_block (&if_se.pre);
972
973 /* Calculate the IF condition expression. */
974 if (code->expr1->where.lb)
975 {
976 gfc_save_backend_locus (&saved_loc);
977 gfc_set_backend_locus (&code->expr1->where);
978 }
979
980 gfc_conv_expr_val (&if_se, code->expr1);
981
982 if (code->expr1->where.lb)
983 gfc_restore_backend_locus (&saved_loc);
984
985 /* Translate the THEN clause. */
986 stmt = gfc_trans_code (code->next);
987
988 /* Translate the ELSE clause. */
989 if (code->block)
990 elsestmt = gfc_trans_if_1 (code->block);
991 else
992 elsestmt = build_empty_stmt (input_location);
993
994 /* Build the condition expression and add it to the condition block. */
995 loc = code->expr1->where.lb ? code->expr1->where.lb->location : input_location;
996 stmt = fold_build3_loc (loc, COND_EXPR, void_type_node, if_se.expr, stmt,
997 elsestmt);
998
999 gfc_add_expr_to_block (&if_se.pre, stmt);
1000
1001 /* Finish off this statement. */
1002 return gfc_finish_block (&if_se.pre);
1003 }
1004
1005 tree
gfc_trans_if(gfc_code * code)1006 gfc_trans_if (gfc_code * code)
1007 {
1008 stmtblock_t body;
1009 tree exit_label;
1010
1011 /* Create exit label so it is available for trans'ing the body code. */
1012 exit_label = gfc_build_label_decl (NULL_TREE);
1013 code->exit_label = exit_label;
1014
1015 /* Translate the actual code in code->block. */
1016 gfc_init_block (&body);
1017 gfc_add_expr_to_block (&body, gfc_trans_if_1 (code->block));
1018
1019 /* Add exit label. */
1020 gfc_add_expr_to_block (&body, build1_v (LABEL_EXPR, exit_label));
1021
1022 return gfc_finish_block (&body);
1023 }
1024
1025
1026 /* Translate an arithmetic IF expression.
1027
1028 IF (cond) label1, label2, label3 translates to
1029
1030 if (cond <= 0)
1031 {
1032 if (cond < 0)
1033 goto label1;
1034 else // cond == 0
1035 goto label2;
1036 }
1037 else // cond > 0
1038 goto label3;
1039
1040 An optimized version can be generated in case of equal labels.
1041 E.g., if label1 is equal to label2, we can translate it to
1042
1043 if (cond <= 0)
1044 goto label1;
1045 else
1046 goto label3;
1047 */
1048
1049 tree
gfc_trans_arithmetic_if(gfc_code * code)1050 gfc_trans_arithmetic_if (gfc_code * code)
1051 {
1052 gfc_se se;
1053 tree tmp;
1054 tree branch1;
1055 tree branch2;
1056 tree zero;
1057
1058 /* Start a new block. */
1059 gfc_init_se (&se, NULL);
1060 gfc_start_block (&se.pre);
1061
1062 /* Pre-evaluate COND. */
1063 gfc_conv_expr_val (&se, code->expr1);
1064 se.expr = gfc_evaluate_now (se.expr, &se.pre);
1065
1066 /* Build something to compare with. */
1067 zero = gfc_build_const (TREE_TYPE (se.expr), integer_zero_node);
1068
1069 if (code->label1->value != code->label2->value)
1070 {
1071 /* If (cond < 0) take branch1 else take branch2.
1072 First build jumps to the COND .LT. 0 and the COND .EQ. 0 cases. */
1073 branch1 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label1));
1074 branch2 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label2));
1075
1076 if (code->label1->value != code->label3->value)
1077 tmp = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
1078 se.expr, zero);
1079 else
1080 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
1081 se.expr, zero);
1082
1083 branch1 = fold_build3_loc (input_location, COND_EXPR, void_type_node,
1084 tmp, branch1, branch2);
1085 }
1086 else
1087 branch1 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label1));
1088
1089 if (code->label1->value != code->label3->value
1090 && code->label2->value != code->label3->value)
1091 {
1092 /* if (cond <= 0) take branch1 else take branch2. */
1093 branch2 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label3));
1094 tmp = fold_build2_loc (input_location, LE_EXPR, boolean_type_node,
1095 se.expr, zero);
1096 branch1 = fold_build3_loc (input_location, COND_EXPR, void_type_node,
1097 tmp, branch1, branch2);
1098 }
1099
1100 /* Append the COND_EXPR to the evaluation of COND, and return. */
1101 gfc_add_expr_to_block (&se.pre, branch1);
1102 return gfc_finish_block (&se.pre);
1103 }
1104
1105
1106 /* Translate a CRITICAL block. */
1107 tree
gfc_trans_critical(gfc_code * code)1108 gfc_trans_critical (gfc_code *code)
1109 {
1110 stmtblock_t block;
1111 tree tmp;
1112
1113 gfc_start_block (&block);
1114
1115 if (gfc_option.coarray == GFC_FCOARRAY_LIB)
1116 {
1117 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_critical, 0);
1118 gfc_add_expr_to_block (&block, tmp);
1119 }
1120
1121 tmp = gfc_trans_code (code->block->next);
1122 gfc_add_expr_to_block (&block, tmp);
1123
1124 if (gfc_option.coarray == GFC_FCOARRAY_LIB)
1125 {
1126 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_end_critical,
1127 0);
1128 gfc_add_expr_to_block (&block, tmp);
1129 }
1130
1131
1132 return gfc_finish_block (&block);
1133 }
1134
1135
1136 /* Do proper initialization for ASSOCIATE names. */
1137
1138 static void
trans_associate_var(gfc_symbol * sym,gfc_wrapped_block * block)1139 trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
1140 {
1141 gfc_expr *e;
1142 tree tmp;
1143 bool class_target;
1144 bool unlimited;
1145 tree desc;
1146 tree offset;
1147 tree dim;
1148 int n;
1149
1150 gcc_assert (sym->assoc);
1151 e = sym->assoc->target;
1152
1153 class_target = (e->expr_type == EXPR_VARIABLE)
1154 && (gfc_is_class_scalar_expr (e)
1155 || gfc_is_class_array_ref (e, NULL));
1156
1157 unlimited = UNLIMITED_POLY (e);
1158
1159 /* Do a `pointer assignment' with updated descriptor (or assign descriptor
1160 to array temporary) for arrays with either unknown shape or if associating
1161 to a variable. */
1162 if (sym->attr.dimension && !class_target
1163 && (sym->as->type == AS_DEFERRED || sym->assoc->variable))
1164 {
1165 gfc_se se;
1166 tree desc;
1167 bool cst_array_ctor;
1168
1169 desc = sym->backend_decl;
1170 cst_array_ctor = e->expr_type == EXPR_ARRAY
1171 && gfc_constant_array_constructor_p (e->value.constructor);
1172
1173 /* If association is to an expression, evaluate it and create temporary.
1174 Otherwise, get descriptor of target for pointer assignment. */
1175 gfc_init_se (&se, NULL);
1176 if (sym->assoc->variable || cst_array_ctor)
1177 {
1178 se.direct_byref = 1;
1179 se.use_offset = 1;
1180 se.expr = desc;
1181 }
1182
1183 gfc_conv_expr_descriptor (&se, e);
1184
1185 /* If we didn't already do the pointer assignment, set associate-name
1186 descriptor to the one generated for the temporary. */
1187 if (!sym->assoc->variable && !cst_array_ctor)
1188 {
1189 int dim;
1190
1191 gfc_add_modify (&se.pre, desc, se.expr);
1192
1193 /* The generated descriptor has lower bound zero (as array
1194 temporary), shift bounds so we get lower bounds of 1. */
1195 for (dim = 0; dim < e->rank; ++dim)
1196 gfc_conv_shift_descriptor_lbound (&se.pre, desc,
1197 dim, gfc_index_one_node);
1198 }
1199
1200 /* If this is a subreference array pointer associate name use the
1201 associate variable element size for the value of 'span'. */
1202 if (sym->attr.subref_array_pointer)
1203 {
1204 gcc_assert (e->expr_type == EXPR_VARIABLE);
1205 tmp = e->symtree->n.sym->backend_decl;
1206 tmp = gfc_get_element_type (TREE_TYPE (tmp));
1207 tmp = fold_convert (gfc_array_index_type, size_in_bytes (tmp));
1208 gfc_add_modify (&se.pre, GFC_DECL_SPAN(desc), tmp);
1209 }
1210
1211 /* Done, register stuff as init / cleanup code. */
1212 gfc_add_init_cleanup (block, gfc_finish_block (&se.pre),
1213 gfc_finish_block (&se.post));
1214 }
1215
1216 /* Temporaries, arising from TYPE IS, just need the descriptor of class
1217 arrays to be assigned directly. */
1218 else if (class_target && sym->attr.dimension
1219 && (sym->ts.type == BT_DERIVED || unlimited))
1220 {
1221 gfc_se se;
1222
1223 gfc_init_se (&se, NULL);
1224 se.descriptor_only = 1;
1225 gfc_conv_expr (&se, e);
1226
1227 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr)));
1228 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (sym->backend_decl)));
1229
1230 gfc_add_modify (&se.pre, sym->backend_decl, se.expr);
1231
1232 if (unlimited)
1233 {
1234 /* Recover the dtype, which has been overwritten by the
1235 assignment from an unlimited polymorphic object. */
1236 tmp = gfc_conv_descriptor_dtype (sym->backend_decl);
1237 gfc_add_modify (&se.pre, tmp,
1238 gfc_get_dtype (TREE_TYPE (sym->backend_decl)));
1239 }
1240
1241 gfc_add_init_cleanup (block, gfc_finish_block( &se.pre),
1242 gfc_finish_block (&se.post));
1243 }
1244
1245 /* Do a scalar pointer assignment; this is for scalar variable targets. */
1246 else if (gfc_is_associate_pointer (sym))
1247 {
1248 gfc_se se;
1249
1250 gcc_assert (!sym->attr.dimension);
1251
1252 gfc_init_se (&se, NULL);
1253
1254 /* Class associate-names come this way because they are
1255 unconditionally associate pointers and the symbol is scalar. */
1256 if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.dimension)
1257 {
1258 /* For a class array we need a descriptor for the selector. */
1259 gfc_conv_expr_descriptor (&se, e);
1260
1261 /* Obtain a temporary class container for the result. */
1262 gfc_conv_class_to_class (&se, e, sym->ts, false, true, false, false);
1263 se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
1264
1265 /* Set the offset. */
1266 desc = gfc_class_data_get (se.expr);
1267 offset = gfc_index_zero_node;
1268 for (n = 0; n < e->rank; n++)
1269 {
1270 dim = gfc_rank_cst[n];
1271 tmp = fold_build2_loc (input_location, MULT_EXPR,
1272 gfc_array_index_type,
1273 gfc_conv_descriptor_stride_get (desc, dim),
1274 gfc_conv_descriptor_lbound_get (desc, dim));
1275 offset = fold_build2_loc (input_location, MINUS_EXPR,
1276 gfc_array_index_type,
1277 offset, tmp);
1278 }
1279 gfc_conv_descriptor_offset_set (&se.pre, desc, offset);
1280 }
1281 else if (sym->ts.type == BT_CLASS && e->ts.type == BT_CLASS
1282 && CLASS_DATA (e)->attr.dimension)
1283 {
1284 /* This is bound to be a class array element. */
1285 gfc_conv_expr_reference (&se, e);
1286 /* Get the _vptr component of the class object. */
1287 tmp = gfc_get_vptr_from_expr (se.expr);
1288 /* Obtain a temporary class container for the result. */
1289 gfc_conv_derived_to_class (&se, e, sym->ts, tmp, false, false);
1290 se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
1291 }
1292 else
1293 gfc_conv_expr (&se, e);
1294
1295 tmp = TREE_TYPE (sym->backend_decl);
1296 tmp = gfc_build_addr_expr (tmp, se.expr);
1297 gfc_add_modify (&se.pre, sym->backend_decl, tmp);
1298
1299 gfc_add_init_cleanup (block, gfc_finish_block( &se.pre),
1300 gfc_finish_block (&se.post));
1301 }
1302
1303 /* Do a simple assignment. This is for scalar expressions, where we
1304 can simply use expression assignment. */
1305 else
1306 {
1307 gfc_expr *lhs;
1308
1309 lhs = gfc_lval_expr_from_sym (sym);
1310 tmp = gfc_trans_assignment (lhs, e, false, true);
1311 gfc_add_init_cleanup (block, tmp, NULL_TREE);
1312 }
1313
1314 /* Set the stringlength from the vtable size. */
1315 if (sym->ts.type == BT_CHARACTER && sym->attr.select_type_temporary)
1316 {
1317 tree charlen;
1318 gfc_se se;
1319 gfc_init_se (&se, NULL);
1320 gcc_assert (UNLIMITED_POLY (e->symtree->n.sym));
1321 tmp = gfc_get_symbol_decl (e->symtree->n.sym);
1322 tmp = gfc_vtable_size_get (tmp);
1323 gfc_get_symbol_decl (sym);
1324 charlen = sym->ts.u.cl->backend_decl;
1325 gfc_add_modify (&se.pre, charlen,
1326 fold_convert (TREE_TYPE (charlen), tmp));
1327 gfc_add_init_cleanup (block, gfc_finish_block( &se.pre),
1328 gfc_finish_block (&se.post));
1329 }
1330 }
1331
1332
1333 /* Translate a BLOCK construct. This is basically what we would do for a
1334 procedure body. */
1335
1336 tree
gfc_trans_block_construct(gfc_code * code)1337 gfc_trans_block_construct (gfc_code* code)
1338 {
1339 gfc_namespace* ns;
1340 gfc_symbol* sym;
1341 gfc_wrapped_block block;
1342 tree exit_label;
1343 stmtblock_t body;
1344 gfc_association_list *ass;
1345
1346 ns = code->ext.block.ns;
1347 gcc_assert (ns);
1348 sym = ns->proc_name;
1349 gcc_assert (sym);
1350
1351 /* Process local variables. */
1352 gcc_assert (!sym->tlink);
1353 sym->tlink = sym;
1354 gfc_process_block_locals (ns);
1355
1356 /* Generate code including exit-label. */
1357 gfc_init_block (&body);
1358 exit_label = gfc_build_label_decl (NULL_TREE);
1359 code->exit_label = exit_label;
1360 gfc_add_expr_to_block (&body, gfc_trans_code (ns->code));
1361 gfc_add_expr_to_block (&body, build1_v (LABEL_EXPR, exit_label));
1362
1363 /* Finish everything. */
1364 gfc_start_wrapped_block (&block, gfc_finish_block (&body));
1365 gfc_trans_deferred_vars (sym, &block);
1366 for (ass = code->ext.block.assoc; ass; ass = ass->next)
1367 trans_associate_var (ass->st->n.sym, &block);
1368
1369 return gfc_finish_wrapped_block (&block);
1370 }
1371
1372
1373 /* Translate the simple DO construct. This is where the loop variable has
1374 integer type and step +-1. We can't use this in the general case
1375 because integer overflow and floating point errors could give incorrect
1376 results.
1377 We translate a do loop from:
1378
1379 DO dovar = from, to, step
1380 body
1381 END DO
1382
1383 to:
1384
1385 [Evaluate loop bounds and step]
1386 dovar = from;
1387 if ((step > 0) ? (dovar <= to) : (dovar => to))
1388 {
1389 for (;;)
1390 {
1391 body;
1392 cycle_label:
1393 cond = (dovar == to);
1394 dovar += step;
1395 if (cond) goto end_label;
1396 }
1397 }
1398 end_label:
1399
1400 This helps the optimizers by avoiding the extra induction variable
1401 used in the general case. */
1402
1403 static tree
gfc_trans_simple_do(gfc_code * code,stmtblock_t * pblock,tree dovar,tree from,tree to,tree step,tree exit_cond)1404 gfc_trans_simple_do (gfc_code * code, stmtblock_t *pblock, tree dovar,
1405 tree from, tree to, tree step, tree exit_cond)
1406 {
1407 stmtblock_t body;
1408 tree type;
1409 tree cond;
1410 tree tmp;
1411 tree saved_dovar = NULL;
1412 tree cycle_label;
1413 tree exit_label;
1414 location_t loc;
1415
1416 type = TREE_TYPE (dovar);
1417
1418 loc = code->ext.iterator->start->where.lb->location;
1419
1420 /* Initialize the DO variable: dovar = from. */
1421 gfc_add_modify_loc (loc, pblock, dovar,
1422 fold_convert (TREE_TYPE(dovar), from));
1423
1424 /* Save value for do-tinkering checking. */
1425 if (gfc_option.rtcheck & GFC_RTCHECK_DO)
1426 {
1427 saved_dovar = gfc_create_var (type, ".saved_dovar");
1428 gfc_add_modify_loc (loc, pblock, saved_dovar, dovar);
1429 }
1430
1431 /* Cycle and exit statements are implemented with gotos. */
1432 cycle_label = gfc_build_label_decl (NULL_TREE);
1433 exit_label = gfc_build_label_decl (NULL_TREE);
1434
1435 /* Put the labels where they can be found later. See gfc_trans_do(). */
1436 code->cycle_label = cycle_label;
1437 code->exit_label = exit_label;
1438
1439 /* Loop body. */
1440 gfc_start_block (&body);
1441
1442 /* Main loop body. */
1443 tmp = gfc_trans_code_cond (code->block->next, exit_cond);
1444 gfc_add_expr_to_block (&body, tmp);
1445
1446 /* Label for cycle statements (if needed). */
1447 if (TREE_USED (cycle_label))
1448 {
1449 tmp = build1_v (LABEL_EXPR, cycle_label);
1450 gfc_add_expr_to_block (&body, tmp);
1451 }
1452
1453 /* Check whether someone has modified the loop variable. */
1454 if (gfc_option.rtcheck & GFC_RTCHECK_DO)
1455 {
1456 tmp = fold_build2_loc (loc, NE_EXPR, boolean_type_node,
1457 dovar, saved_dovar);
1458 gfc_trans_runtime_check (true, false, tmp, &body, &code->loc,
1459 "Loop variable has been modified");
1460 }
1461
1462 /* Exit the loop if there is an I/O result condition or error. */
1463 if (exit_cond)
1464 {
1465 tmp = build1_v (GOTO_EXPR, exit_label);
1466 tmp = fold_build3_loc (loc, COND_EXPR, void_type_node,
1467 exit_cond, tmp,
1468 build_empty_stmt (loc));
1469 gfc_add_expr_to_block (&body, tmp);
1470 }
1471
1472 /* Evaluate the loop condition. */
1473 cond = fold_build2_loc (loc, EQ_EXPR, boolean_type_node, dovar,
1474 to);
1475 cond = gfc_evaluate_now_loc (loc, cond, &body);
1476
1477 /* Increment the loop variable. */
1478 tmp = fold_build2_loc (loc, PLUS_EXPR, type, dovar, step);
1479 gfc_add_modify_loc (loc, &body, dovar, tmp);
1480
1481 if (gfc_option.rtcheck & GFC_RTCHECK_DO)
1482 gfc_add_modify_loc (loc, &body, saved_dovar, dovar);
1483
1484 /* The loop exit. */
1485 tmp = fold_build1_loc (loc, GOTO_EXPR, void_type_node, exit_label);
1486 TREE_USED (exit_label) = 1;
1487 tmp = fold_build3_loc (loc, COND_EXPR, void_type_node,
1488 cond, tmp, build_empty_stmt (loc));
1489 gfc_add_expr_to_block (&body, tmp);
1490
1491 /* Finish the loop body. */
1492 tmp = gfc_finish_block (&body);
1493 tmp = fold_build1_loc (loc, LOOP_EXPR, void_type_node, tmp);
1494
1495 /* Only execute the loop if the number of iterations is positive. */
1496 if (tree_int_cst_sgn (step) > 0)
1497 cond = fold_build2_loc (loc, LE_EXPR, boolean_type_node, dovar,
1498 to);
1499 else
1500 cond = fold_build2_loc (loc, GE_EXPR, boolean_type_node, dovar,
1501 to);
1502 tmp = fold_build3_loc (loc, COND_EXPR, void_type_node, cond, tmp,
1503 build_empty_stmt (loc));
1504 gfc_add_expr_to_block (pblock, tmp);
1505
1506 /* Add the exit label. */
1507 tmp = build1_v (LABEL_EXPR, exit_label);
1508 gfc_add_expr_to_block (pblock, tmp);
1509
1510 return gfc_finish_block (pblock);
1511 }
1512
1513 /* Translate the DO construct. This obviously is one of the most
1514 important ones to get right with any compiler, but especially
1515 so for Fortran.
1516
1517 We special case some loop forms as described in gfc_trans_simple_do.
1518 For other cases we implement them with a separate loop count,
1519 as described in the standard.
1520
1521 We translate a do loop from:
1522
1523 DO dovar = from, to, step
1524 body
1525 END DO
1526
1527 to:
1528
1529 [evaluate loop bounds and step]
1530 empty = (step > 0 ? to < from : to > from);
1531 countm1 = (to - from) / step;
1532 dovar = from;
1533 if (empty) goto exit_label;
1534 for (;;)
1535 {
1536 body;
1537 cycle_label:
1538 dovar += step
1539 countm1t = countm1;
1540 countm1--;
1541 if (countm1t == 0) goto exit_label;
1542 }
1543 exit_label:
1544
1545 countm1 is an unsigned integer. It is equal to the loop count minus one,
1546 because the loop count itself can overflow. */
1547
1548 tree
gfc_trans_do(gfc_code * code,tree exit_cond)1549 gfc_trans_do (gfc_code * code, tree exit_cond)
1550 {
1551 gfc_se se;
1552 tree dovar;
1553 tree saved_dovar = NULL;
1554 tree from;
1555 tree to;
1556 tree step;
1557 tree countm1;
1558 tree type;
1559 tree utype;
1560 tree cond;
1561 tree cycle_label;
1562 tree exit_label;
1563 tree tmp;
1564 stmtblock_t block;
1565 stmtblock_t body;
1566 location_t loc;
1567
1568 gfc_start_block (&block);
1569
1570 loc = code->ext.iterator->start->where.lb->location;
1571
1572 /* Evaluate all the expressions in the iterator. */
1573 gfc_init_se (&se, NULL);
1574 gfc_conv_expr_lhs (&se, code->ext.iterator->var);
1575 gfc_add_block_to_block (&block, &se.pre);
1576 dovar = se.expr;
1577 type = TREE_TYPE (dovar);
1578
1579 gfc_init_se (&se, NULL);
1580 gfc_conv_expr_val (&se, code->ext.iterator->start);
1581 gfc_add_block_to_block (&block, &se.pre);
1582 from = gfc_evaluate_now (se.expr, &block);
1583
1584 gfc_init_se (&se, NULL);
1585 gfc_conv_expr_val (&se, code->ext.iterator->end);
1586 gfc_add_block_to_block (&block, &se.pre);
1587 to = gfc_evaluate_now (se.expr, &block);
1588
1589 gfc_init_se (&se, NULL);
1590 gfc_conv_expr_val (&se, code->ext.iterator->step);
1591 gfc_add_block_to_block (&block, &se.pre);
1592 step = gfc_evaluate_now (se.expr, &block);
1593
1594 if (gfc_option.rtcheck & GFC_RTCHECK_DO)
1595 {
1596 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, step,
1597 build_zero_cst (type));
1598 gfc_trans_runtime_check (true, false, tmp, &block, &code->loc,
1599 "DO step value is zero");
1600 }
1601
1602 /* Special case simple loops. */
1603 if (TREE_CODE (type) == INTEGER_TYPE
1604 && (integer_onep (step)
1605 || tree_int_cst_equal (step, integer_minus_one_node)))
1606 return gfc_trans_simple_do (code, &block, dovar, from, to, step, exit_cond);
1607
1608
1609 if (TREE_CODE (type) == INTEGER_TYPE)
1610 utype = unsigned_type_for (type);
1611 else
1612 utype = unsigned_type_for (gfc_array_index_type);
1613 countm1 = gfc_create_var (utype, "countm1");
1614
1615 /* Cycle and exit statements are implemented with gotos. */
1616 cycle_label = gfc_build_label_decl (NULL_TREE);
1617 exit_label = gfc_build_label_decl (NULL_TREE);
1618 TREE_USED (exit_label) = 1;
1619
1620 /* Put these labels where they can be found later. */
1621 code->cycle_label = cycle_label;
1622 code->exit_label = exit_label;
1623
1624 /* Initialize the DO variable: dovar = from. */
1625 gfc_add_modify (&block, dovar, from);
1626
1627 /* Save value for do-tinkering checking. */
1628 if (gfc_option.rtcheck & GFC_RTCHECK_DO)
1629 {
1630 saved_dovar = gfc_create_var (type, ".saved_dovar");
1631 gfc_add_modify_loc (loc, &block, saved_dovar, dovar);
1632 }
1633
1634 /* Initialize loop count and jump to exit label if the loop is empty.
1635 This code is executed before we enter the loop body. We generate:
1636 if (step > 0)
1637 {
1638 if (to < from)
1639 goto exit_label;
1640 countm1 = (to - from) / step;
1641 }
1642 else
1643 {
1644 if (to > from)
1645 goto exit_label;
1646 countm1 = (from - to) / -step;
1647 }
1648 */
1649
1650 if (TREE_CODE (type) == INTEGER_TYPE)
1651 {
1652 tree pos, neg, tou, fromu, stepu, tmp2;
1653
1654 /* The distance from FROM to TO cannot always be represented in a signed
1655 type, thus use unsigned arithmetic, also to avoid any undefined
1656 overflow issues. */
1657 tou = fold_convert (utype, to);
1658 fromu = fold_convert (utype, from);
1659 stepu = fold_convert (utype, step);
1660
1661 /* For a positive step, when to < from, exit, otherwise compute
1662 countm1 = ((unsigned)to - (unsigned)from) / (unsigned)step */
1663 tmp = fold_build2_loc (loc, LT_EXPR, boolean_type_node, to, from);
1664 tmp2 = fold_build2_loc (loc, TRUNC_DIV_EXPR, utype,
1665 fold_build2_loc (loc, MINUS_EXPR, utype,
1666 tou, fromu),
1667 stepu);
1668 pos = fold_build3_loc (loc, COND_EXPR, void_type_node, tmp,
1669 fold_build1_loc (loc, GOTO_EXPR, void_type_node,
1670 exit_label),
1671 fold_build2 (MODIFY_EXPR, void_type_node,
1672 countm1, tmp2));
1673
1674 /* For a negative step, when to > from, exit, otherwise compute
1675 countm1 = ((unsigned)from - (unsigned)to) / -(unsigned)step */
1676 tmp = fold_build2_loc (loc, GT_EXPR, boolean_type_node, to, from);
1677 tmp2 = fold_build2_loc (loc, TRUNC_DIV_EXPR, utype,
1678 fold_build2_loc (loc, MINUS_EXPR, utype,
1679 fromu, tou),
1680 fold_build1_loc (loc, NEGATE_EXPR, utype, stepu));
1681 neg = fold_build3_loc (loc, COND_EXPR, void_type_node, tmp,
1682 fold_build1_loc (loc, GOTO_EXPR, void_type_node,
1683 exit_label),
1684 fold_build2 (MODIFY_EXPR, void_type_node,
1685 countm1, tmp2));
1686
1687 tmp = fold_build2_loc (loc, LT_EXPR, boolean_type_node, step,
1688 build_int_cst (TREE_TYPE (step), 0));
1689 tmp = fold_build3_loc (loc, COND_EXPR, void_type_node, tmp, neg, pos);
1690
1691 gfc_add_expr_to_block (&block, tmp);
1692 }
1693 else
1694 {
1695 tree pos_step;
1696
1697 /* TODO: We could use the same width as the real type.
1698 This would probably cause more problems that it solves
1699 when we implement "long double" types. */
1700
1701 tmp = fold_build2_loc (loc, MINUS_EXPR, type, to, from);
1702 tmp = fold_build2_loc (loc, RDIV_EXPR, type, tmp, step);
1703 tmp = fold_build1_loc (loc, FIX_TRUNC_EXPR, utype, tmp);
1704 gfc_add_modify (&block, countm1, tmp);
1705
1706 /* We need a special check for empty loops:
1707 empty = (step > 0 ? to < from : to > from); */
1708 pos_step = fold_build2_loc (loc, GT_EXPR, boolean_type_node, step,
1709 build_zero_cst (type));
1710 tmp = fold_build3_loc (loc, COND_EXPR, boolean_type_node, pos_step,
1711 fold_build2_loc (loc, LT_EXPR,
1712 boolean_type_node, to, from),
1713 fold_build2_loc (loc, GT_EXPR,
1714 boolean_type_node, to, from));
1715 /* If the loop is empty, go directly to the exit label. */
1716 tmp = fold_build3_loc (loc, COND_EXPR, void_type_node, tmp,
1717 build1_v (GOTO_EXPR, exit_label),
1718 build_empty_stmt (input_location));
1719 gfc_add_expr_to_block (&block, tmp);
1720 }
1721
1722 /* Loop body. */
1723 gfc_start_block (&body);
1724
1725 /* Main loop body. */
1726 tmp = gfc_trans_code_cond (code->block->next, exit_cond);
1727 gfc_add_expr_to_block (&body, tmp);
1728
1729 /* Label for cycle statements (if needed). */
1730 if (TREE_USED (cycle_label))
1731 {
1732 tmp = build1_v (LABEL_EXPR, cycle_label);
1733 gfc_add_expr_to_block (&body, tmp);
1734 }
1735
1736 /* Check whether someone has modified the loop variable. */
1737 if (gfc_option.rtcheck & GFC_RTCHECK_DO)
1738 {
1739 tmp = fold_build2_loc (loc, NE_EXPR, boolean_type_node, dovar,
1740 saved_dovar);
1741 gfc_trans_runtime_check (true, false, tmp, &body, &code->loc,
1742 "Loop variable has been modified");
1743 }
1744
1745 /* Exit the loop if there is an I/O result condition or error. */
1746 if (exit_cond)
1747 {
1748 tmp = build1_v (GOTO_EXPR, exit_label);
1749 tmp = fold_build3_loc (loc, COND_EXPR, void_type_node,
1750 exit_cond, tmp,
1751 build_empty_stmt (input_location));
1752 gfc_add_expr_to_block (&body, tmp);
1753 }
1754
1755 /* Increment the loop variable. */
1756 tmp = fold_build2_loc (loc, PLUS_EXPR, type, dovar, step);
1757 gfc_add_modify_loc (loc, &body, dovar, tmp);
1758
1759 if (gfc_option.rtcheck & GFC_RTCHECK_DO)
1760 gfc_add_modify_loc (loc, &body, saved_dovar, dovar);
1761
1762 /* Initialize countm1t. */
1763 tree countm1t = gfc_create_var (utype, "countm1t");
1764 gfc_add_modify_loc (loc, &body, countm1t, countm1);
1765
1766 /* Decrement the loop count. */
1767 tmp = fold_build2_loc (loc, MINUS_EXPR, utype, countm1,
1768 build_int_cst (utype, 1));
1769 gfc_add_modify_loc (loc, &body, countm1, tmp);
1770
1771 /* End with the loop condition. Loop until countm1t == 0. */
1772 cond = fold_build2_loc (loc, EQ_EXPR, boolean_type_node, countm1t,
1773 build_int_cst (utype, 0));
1774 tmp = fold_build1_loc (loc, GOTO_EXPR, void_type_node, exit_label);
1775 tmp = fold_build3_loc (loc, COND_EXPR, void_type_node,
1776 cond, tmp, build_empty_stmt (loc));
1777 gfc_add_expr_to_block (&body, tmp);
1778
1779 /* End of loop body. */
1780 tmp = gfc_finish_block (&body);
1781
1782 /* The for loop itself. */
1783 tmp = fold_build1_loc (loc, LOOP_EXPR, void_type_node, tmp);
1784 gfc_add_expr_to_block (&block, tmp);
1785
1786 /* Add the exit label. */
1787 tmp = build1_v (LABEL_EXPR, exit_label);
1788 gfc_add_expr_to_block (&block, tmp);
1789
1790 return gfc_finish_block (&block);
1791 }
1792
1793
1794 /* Translate the DO WHILE construct.
1795
1796 We translate
1797
1798 DO WHILE (cond)
1799 body
1800 END DO
1801
1802 to:
1803
1804 for ( ; ; )
1805 {
1806 pre_cond;
1807 if (! cond) goto exit_label;
1808 body;
1809 cycle_label:
1810 }
1811 exit_label:
1812
1813 Because the evaluation of the exit condition `cond' may have side
1814 effects, we can't do much for empty loop bodies. The backend optimizers
1815 should be smart enough to eliminate any dead loops. */
1816
1817 tree
gfc_trans_do_while(gfc_code * code)1818 gfc_trans_do_while (gfc_code * code)
1819 {
1820 gfc_se cond;
1821 tree tmp;
1822 tree cycle_label;
1823 tree exit_label;
1824 stmtblock_t block;
1825
1826 /* Everything we build here is part of the loop body. */
1827 gfc_start_block (&block);
1828
1829 /* Cycle and exit statements are implemented with gotos. */
1830 cycle_label = gfc_build_label_decl (NULL_TREE);
1831 exit_label = gfc_build_label_decl (NULL_TREE);
1832
1833 /* Put the labels where they can be found later. See gfc_trans_do(). */
1834 code->cycle_label = cycle_label;
1835 code->exit_label = exit_label;
1836
1837 /* Create a GIMPLE version of the exit condition. */
1838 gfc_init_se (&cond, NULL);
1839 gfc_conv_expr_val (&cond, code->expr1);
1840 gfc_add_block_to_block (&block, &cond.pre);
1841 cond.expr = fold_build1_loc (code->expr1->where.lb->location,
1842 TRUTH_NOT_EXPR, TREE_TYPE (cond.expr), cond.expr);
1843
1844 /* Build "IF (! cond) GOTO exit_label". */
1845 tmp = build1_v (GOTO_EXPR, exit_label);
1846 TREE_USED (exit_label) = 1;
1847 tmp = fold_build3_loc (code->expr1->where.lb->location, COND_EXPR,
1848 void_type_node, cond.expr, tmp,
1849 build_empty_stmt (code->expr1->where.lb->location));
1850 gfc_add_expr_to_block (&block, tmp);
1851
1852 /* The main body of the loop. */
1853 tmp = gfc_trans_code (code->block->next);
1854 gfc_add_expr_to_block (&block, tmp);
1855
1856 /* Label for cycle statements (if needed). */
1857 if (TREE_USED (cycle_label))
1858 {
1859 tmp = build1_v (LABEL_EXPR, cycle_label);
1860 gfc_add_expr_to_block (&block, tmp);
1861 }
1862
1863 /* End of loop body. */
1864 tmp = gfc_finish_block (&block);
1865
1866 gfc_init_block (&block);
1867 /* Build the loop. */
1868 tmp = fold_build1_loc (code->expr1->where.lb->location, LOOP_EXPR,
1869 void_type_node, tmp);
1870 gfc_add_expr_to_block (&block, tmp);
1871
1872 /* Add the exit label. */
1873 tmp = build1_v (LABEL_EXPR, exit_label);
1874 gfc_add_expr_to_block (&block, tmp);
1875
1876 return gfc_finish_block (&block);
1877 }
1878
1879
1880 /* Translate the SELECT CASE construct for INTEGER case expressions,
1881 without killing all potential optimizations. The problem is that
1882 Fortran allows unbounded cases, but the back-end does not, so we
1883 need to intercept those before we enter the equivalent SWITCH_EXPR
1884 we can build.
1885
1886 For example, we translate this,
1887
1888 SELECT CASE (expr)
1889 CASE (:100,101,105:115)
1890 block_1
1891 CASE (190:199,200:)
1892 block_2
1893 CASE (300)
1894 block_3
1895 CASE DEFAULT
1896 block_4
1897 END SELECT
1898
1899 to the GENERIC equivalent,
1900
1901 switch (expr)
1902 {
1903 case (minimum value for typeof(expr) ... 100:
1904 case 101:
1905 case 105 ... 114:
1906 block1:
1907 goto end_label;
1908
1909 case 200 ... (maximum value for typeof(expr):
1910 case 190 ... 199:
1911 block2;
1912 goto end_label;
1913
1914 case 300:
1915 block_3;
1916 goto end_label;
1917
1918 default:
1919 block_4;
1920 goto end_label;
1921 }
1922
1923 end_label: */
1924
1925 static tree
gfc_trans_integer_select(gfc_code * code)1926 gfc_trans_integer_select (gfc_code * code)
1927 {
1928 gfc_code *c;
1929 gfc_case *cp;
1930 tree end_label;
1931 tree tmp;
1932 gfc_se se;
1933 stmtblock_t block;
1934 stmtblock_t body;
1935
1936 gfc_start_block (&block);
1937
1938 /* Calculate the switch expression. */
1939 gfc_init_se (&se, NULL);
1940 gfc_conv_expr_val (&se, code->expr1);
1941 gfc_add_block_to_block (&block, &se.pre);
1942
1943 end_label = gfc_build_label_decl (NULL_TREE);
1944
1945 gfc_init_block (&body);
1946
1947 for (c = code->block; c; c = c->block)
1948 {
1949 for (cp = c->ext.block.case_list; cp; cp = cp->next)
1950 {
1951 tree low, high;
1952 tree label;
1953
1954 /* Assume it's the default case. */
1955 low = high = NULL_TREE;
1956
1957 if (cp->low)
1958 {
1959 low = gfc_conv_mpz_to_tree (cp->low->value.integer,
1960 cp->low->ts.kind);
1961
1962 /* If there's only a lower bound, set the high bound to the
1963 maximum value of the case expression. */
1964 if (!cp->high)
1965 high = TYPE_MAX_VALUE (TREE_TYPE (se.expr));
1966 }
1967
1968 if (cp->high)
1969 {
1970 /* Three cases are possible here:
1971
1972 1) There is no lower bound, e.g. CASE (:N).
1973 2) There is a lower bound .NE. high bound, that is
1974 a case range, e.g. CASE (N:M) where M>N (we make
1975 sure that M>N during type resolution).
1976 3) There is a lower bound, and it has the same value
1977 as the high bound, e.g. CASE (N:N). This is our
1978 internal representation of CASE(N).
1979
1980 In the first and second case, we need to set a value for
1981 high. In the third case, we don't because the GCC middle
1982 end represents a single case value by just letting high be
1983 a NULL_TREE. We can't do that because we need to be able
1984 to represent unbounded cases. */
1985
1986 if (!cp->low
1987 || (cp->low
1988 && mpz_cmp (cp->low->value.integer,
1989 cp->high->value.integer) != 0))
1990 high = gfc_conv_mpz_to_tree (cp->high->value.integer,
1991 cp->high->ts.kind);
1992
1993 /* Unbounded case. */
1994 if (!cp->low)
1995 low = TYPE_MIN_VALUE (TREE_TYPE (se.expr));
1996 }
1997
1998 /* Build a label. */
1999 label = gfc_build_label_decl (NULL_TREE);
2000
2001 /* Add this case label.
2002 Add parameter 'label', make it match GCC backend. */
2003 tmp = build_case_label (low, high, label);
2004 gfc_add_expr_to_block (&body, tmp);
2005 }
2006
2007 /* Add the statements for this case. */
2008 tmp = gfc_trans_code (c->next);
2009 gfc_add_expr_to_block (&body, tmp);
2010
2011 /* Break to the end of the construct. */
2012 tmp = build1_v (GOTO_EXPR, end_label);
2013 gfc_add_expr_to_block (&body, tmp);
2014 }
2015
2016 tmp = gfc_finish_block (&body);
2017 tmp = fold_build3_loc (input_location, SWITCH_EXPR, NULL_TREE,
2018 se.expr, tmp, NULL_TREE);
2019 gfc_add_expr_to_block (&block, tmp);
2020
2021 tmp = build1_v (LABEL_EXPR, end_label);
2022 gfc_add_expr_to_block (&block, tmp);
2023
2024 return gfc_finish_block (&block);
2025 }
2026
2027
2028 /* Translate the SELECT CASE construct for LOGICAL case expressions.
2029
2030 There are only two cases possible here, even though the standard
2031 does allow three cases in a LOGICAL SELECT CASE construct: .TRUE.,
2032 .FALSE., and DEFAULT.
2033
2034 We never generate more than two blocks here. Instead, we always
2035 try to eliminate the DEFAULT case. This way, we can translate this
2036 kind of SELECT construct to a simple
2037
2038 if {} else {};
2039
2040 expression in GENERIC. */
2041
2042 static tree
gfc_trans_logical_select(gfc_code * code)2043 gfc_trans_logical_select (gfc_code * code)
2044 {
2045 gfc_code *c;
2046 gfc_code *t, *f, *d;
2047 gfc_case *cp;
2048 gfc_se se;
2049 stmtblock_t block;
2050
2051 /* Assume we don't have any cases at all. */
2052 t = f = d = NULL;
2053
2054 /* Now see which ones we actually do have. We can have at most two
2055 cases in a single case list: one for .TRUE. and one for .FALSE.
2056 The default case is always separate. If the cases for .TRUE. and
2057 .FALSE. are in the same case list, the block for that case list
2058 always executed, and we don't generate code a COND_EXPR. */
2059 for (c = code->block; c; c = c->block)
2060 {
2061 for (cp = c->ext.block.case_list; cp; cp = cp->next)
2062 {
2063 if (cp->low)
2064 {
2065 if (cp->low->value.logical == 0) /* .FALSE. */
2066 f = c;
2067 else /* if (cp->value.logical != 0), thus .TRUE. */
2068 t = c;
2069 }
2070 else
2071 d = c;
2072 }
2073 }
2074
2075 /* Start a new block. */
2076 gfc_start_block (&block);
2077
2078 /* Calculate the switch expression. We always need to do this
2079 because it may have side effects. */
2080 gfc_init_se (&se, NULL);
2081 gfc_conv_expr_val (&se, code->expr1);
2082 gfc_add_block_to_block (&block, &se.pre);
2083
2084 if (t == f && t != NULL)
2085 {
2086 /* Cases for .TRUE. and .FALSE. are in the same block. Just
2087 translate the code for these cases, append it to the current
2088 block. */
2089 gfc_add_expr_to_block (&block, gfc_trans_code (t->next));
2090 }
2091 else
2092 {
2093 tree true_tree, false_tree, stmt;
2094
2095 true_tree = build_empty_stmt (input_location);
2096 false_tree = build_empty_stmt (input_location);
2097
2098 /* If we have a case for .TRUE. and for .FALSE., discard the default case.
2099 Otherwise, if .TRUE. or .FALSE. is missing and there is a default case,
2100 make the missing case the default case. */
2101 if (t != NULL && f != NULL)
2102 d = NULL;
2103 else if (d != NULL)
2104 {
2105 if (t == NULL)
2106 t = d;
2107 else
2108 f = d;
2109 }
2110
2111 /* Translate the code for each of these blocks, and append it to
2112 the current block. */
2113 if (t != NULL)
2114 true_tree = gfc_trans_code (t->next);
2115
2116 if (f != NULL)
2117 false_tree = gfc_trans_code (f->next);
2118
2119 stmt = fold_build3_loc (input_location, COND_EXPR, void_type_node,
2120 se.expr, true_tree, false_tree);
2121 gfc_add_expr_to_block (&block, stmt);
2122 }
2123
2124 return gfc_finish_block (&block);
2125 }
2126
2127
2128 /* The jump table types are stored in static variables to avoid
2129 constructing them from scratch every single time. */
2130 static GTY(()) tree select_struct[2];
2131
2132 /* Translate the SELECT CASE construct for CHARACTER case expressions.
2133 Instead of generating compares and jumps, it is far simpler to
2134 generate a data structure describing the cases in order and call a
2135 library subroutine that locates the right case.
2136 This is particularly true because this is the only case where we
2137 might have to dispose of a temporary.
2138 The library subroutine returns a pointer to jump to or NULL if no
2139 branches are to be taken. */
2140
2141 static tree
gfc_trans_character_select(gfc_code * code)2142 gfc_trans_character_select (gfc_code *code)
2143 {
2144 tree init, end_label, tmp, type, case_num, label, fndecl;
2145 stmtblock_t block, body;
2146 gfc_case *cp, *d;
2147 gfc_code *c;
2148 gfc_se se, expr1se;
2149 int n, k;
2150 vec<constructor_elt, va_gc> *inits = NULL;
2151
2152 tree pchartype = gfc_get_pchar_type (code->expr1->ts.kind);
2153
2154 /* The jump table types are stored in static variables to avoid
2155 constructing them from scratch every single time. */
2156 static tree ss_string1[2], ss_string1_len[2];
2157 static tree ss_string2[2], ss_string2_len[2];
2158 static tree ss_target[2];
2159
2160 cp = code->block->ext.block.case_list;
2161 while (cp->left != NULL)
2162 cp = cp->left;
2163
2164 /* Generate the body */
2165 gfc_start_block (&block);
2166 gfc_init_se (&expr1se, NULL);
2167 gfc_conv_expr_reference (&expr1se, code->expr1);
2168
2169 gfc_add_block_to_block (&block, &expr1se.pre);
2170
2171 end_label = gfc_build_label_decl (NULL_TREE);
2172
2173 gfc_init_block (&body);
2174
2175 /* Attempt to optimize length 1 selects. */
2176 if (integer_onep (expr1se.string_length))
2177 {
2178 for (d = cp; d; d = d->right)
2179 {
2180 int i;
2181 if (d->low)
2182 {
2183 gcc_assert (d->low->expr_type == EXPR_CONSTANT
2184 && d->low->ts.type == BT_CHARACTER);
2185 if (d->low->value.character.length > 1)
2186 {
2187 for (i = 1; i < d->low->value.character.length; i++)
2188 if (d->low->value.character.string[i] != ' ')
2189 break;
2190 if (i != d->low->value.character.length)
2191 {
2192 if (optimize && d->high && i == 1)
2193 {
2194 gcc_assert (d->high->expr_type == EXPR_CONSTANT
2195 && d->high->ts.type == BT_CHARACTER);
2196 if (d->high->value.character.length > 1
2197 && (d->low->value.character.string[0]
2198 == d->high->value.character.string[0])
2199 && d->high->value.character.string[1] != ' '
2200 && ((d->low->value.character.string[1] < ' ')
2201 == (d->high->value.character.string[1]
2202 < ' ')))
2203 continue;
2204 }
2205 break;
2206 }
2207 }
2208 }
2209 if (d->high)
2210 {
2211 gcc_assert (d->high->expr_type == EXPR_CONSTANT
2212 && d->high->ts.type == BT_CHARACTER);
2213 if (d->high->value.character.length > 1)
2214 {
2215 for (i = 1; i < d->high->value.character.length; i++)
2216 if (d->high->value.character.string[i] != ' ')
2217 break;
2218 if (i != d->high->value.character.length)
2219 break;
2220 }
2221 }
2222 }
2223 if (d == NULL)
2224 {
2225 tree ctype = gfc_get_char_type (code->expr1->ts.kind);
2226
2227 for (c = code->block; c; c = c->block)
2228 {
2229 for (cp = c->ext.block.case_list; cp; cp = cp->next)
2230 {
2231 tree low, high;
2232 tree label;
2233 gfc_char_t r;
2234
2235 /* Assume it's the default case. */
2236 low = high = NULL_TREE;
2237
2238 if (cp->low)
2239 {
2240 /* CASE ('ab') or CASE ('ab':'az') will never match
2241 any length 1 character. */
2242 if (cp->low->value.character.length > 1
2243 && cp->low->value.character.string[1] != ' ')
2244 continue;
2245
2246 if (cp->low->value.character.length > 0)
2247 r = cp->low->value.character.string[0];
2248 else
2249 r = ' ';
2250 low = build_int_cst (ctype, r);
2251
2252 /* If there's only a lower bound, set the high bound
2253 to the maximum value of the case expression. */
2254 if (!cp->high)
2255 high = TYPE_MAX_VALUE (ctype);
2256 }
2257
2258 if (cp->high)
2259 {
2260 if (!cp->low
2261 || (cp->low->value.character.string[0]
2262 != cp->high->value.character.string[0]))
2263 {
2264 if (cp->high->value.character.length > 0)
2265 r = cp->high->value.character.string[0];
2266 else
2267 r = ' ';
2268 high = build_int_cst (ctype, r);
2269 }
2270
2271 /* Unbounded case. */
2272 if (!cp->low)
2273 low = TYPE_MIN_VALUE (ctype);
2274 }
2275
2276 /* Build a label. */
2277 label = gfc_build_label_decl (NULL_TREE);
2278
2279 /* Add this case label.
2280 Add parameter 'label', make it match GCC backend. */
2281 tmp = build_case_label (low, high, label);
2282 gfc_add_expr_to_block (&body, tmp);
2283 }
2284
2285 /* Add the statements for this case. */
2286 tmp = gfc_trans_code (c->next);
2287 gfc_add_expr_to_block (&body, tmp);
2288
2289 /* Break to the end of the construct. */
2290 tmp = build1_v (GOTO_EXPR, end_label);
2291 gfc_add_expr_to_block (&body, tmp);
2292 }
2293
2294 tmp = gfc_string_to_single_character (expr1se.string_length,
2295 expr1se.expr,
2296 code->expr1->ts.kind);
2297 case_num = gfc_create_var (ctype, "case_num");
2298 gfc_add_modify (&block, case_num, tmp);
2299
2300 gfc_add_block_to_block (&block, &expr1se.post);
2301
2302 tmp = gfc_finish_block (&body);
2303 tmp = fold_build3_loc (input_location, SWITCH_EXPR, NULL_TREE,
2304 case_num, tmp, NULL_TREE);
2305 gfc_add_expr_to_block (&block, tmp);
2306
2307 tmp = build1_v (LABEL_EXPR, end_label);
2308 gfc_add_expr_to_block (&block, tmp);
2309
2310 return gfc_finish_block (&block);
2311 }
2312 }
2313
2314 if (code->expr1->ts.kind == 1)
2315 k = 0;
2316 else if (code->expr1->ts.kind == 4)
2317 k = 1;
2318 else
2319 gcc_unreachable ();
2320
2321 if (select_struct[k] == NULL)
2322 {
2323 tree *chain = NULL;
2324 select_struct[k] = make_node (RECORD_TYPE);
2325
2326 if (code->expr1->ts.kind == 1)
2327 TYPE_NAME (select_struct[k]) = get_identifier ("_jump_struct_char1");
2328 else if (code->expr1->ts.kind == 4)
2329 TYPE_NAME (select_struct[k]) = get_identifier ("_jump_struct_char4");
2330 else
2331 gcc_unreachable ();
2332
2333 #undef ADD_FIELD
2334 #define ADD_FIELD(NAME, TYPE) \
2335 ss_##NAME[k] = gfc_add_field_to_struct (select_struct[k], \
2336 get_identifier (stringize(NAME)), \
2337 TYPE, \
2338 &chain)
2339
2340 ADD_FIELD (string1, pchartype);
2341 ADD_FIELD (string1_len, gfc_charlen_type_node);
2342
2343 ADD_FIELD (string2, pchartype);
2344 ADD_FIELD (string2_len, gfc_charlen_type_node);
2345
2346 ADD_FIELD (target, integer_type_node);
2347 #undef ADD_FIELD
2348
2349 gfc_finish_type (select_struct[k]);
2350 }
2351
2352 n = 0;
2353 for (d = cp; d; d = d->right)
2354 d->n = n++;
2355
2356 for (c = code->block; c; c = c->block)
2357 {
2358 for (d = c->ext.block.case_list; d; d = d->next)
2359 {
2360 label = gfc_build_label_decl (NULL_TREE);
2361 tmp = build_case_label ((d->low == NULL && d->high == NULL)
2362 ? NULL
2363 : build_int_cst (integer_type_node, d->n),
2364 NULL, label);
2365 gfc_add_expr_to_block (&body, tmp);
2366 }
2367
2368 tmp = gfc_trans_code (c->next);
2369 gfc_add_expr_to_block (&body, tmp);
2370
2371 tmp = build1_v (GOTO_EXPR, end_label);
2372 gfc_add_expr_to_block (&body, tmp);
2373 }
2374
2375 /* Generate the structure describing the branches */
2376 for (d = cp; d; d = d->right)
2377 {
2378 vec<constructor_elt, va_gc> *node = NULL;
2379
2380 gfc_init_se (&se, NULL);
2381
2382 if (d->low == NULL)
2383 {
2384 CONSTRUCTOR_APPEND_ELT (node, ss_string1[k], null_pointer_node);
2385 CONSTRUCTOR_APPEND_ELT (node, ss_string1_len[k], integer_zero_node);
2386 }
2387 else
2388 {
2389 gfc_conv_expr_reference (&se, d->low);
2390
2391 CONSTRUCTOR_APPEND_ELT (node, ss_string1[k], se.expr);
2392 CONSTRUCTOR_APPEND_ELT (node, ss_string1_len[k], se.string_length);
2393 }
2394
2395 if (d->high == NULL)
2396 {
2397 CONSTRUCTOR_APPEND_ELT (node, ss_string2[k], null_pointer_node);
2398 CONSTRUCTOR_APPEND_ELT (node, ss_string2_len[k], integer_zero_node);
2399 }
2400 else
2401 {
2402 gfc_init_se (&se, NULL);
2403 gfc_conv_expr_reference (&se, d->high);
2404
2405 CONSTRUCTOR_APPEND_ELT (node, ss_string2[k], se.expr);
2406 CONSTRUCTOR_APPEND_ELT (node, ss_string2_len[k], se.string_length);
2407 }
2408
2409 CONSTRUCTOR_APPEND_ELT (node, ss_target[k],
2410 build_int_cst (integer_type_node, d->n));
2411
2412 tmp = build_constructor (select_struct[k], node);
2413 CONSTRUCTOR_APPEND_ELT (inits, NULL_TREE, tmp);
2414 }
2415
2416 type = build_array_type (select_struct[k],
2417 build_index_type (size_int (n-1)));
2418
2419 init = build_constructor (type, inits);
2420 TREE_CONSTANT (init) = 1;
2421 TREE_STATIC (init) = 1;
2422 /* Create a static variable to hold the jump table. */
2423 tmp = gfc_create_var (type, "jumptable");
2424 TREE_CONSTANT (tmp) = 1;
2425 TREE_STATIC (tmp) = 1;
2426 TREE_READONLY (tmp) = 1;
2427 DECL_INITIAL (tmp) = init;
2428 init = tmp;
2429
2430 /* Build the library call */
2431 init = gfc_build_addr_expr (pvoid_type_node, init);
2432
2433 if (code->expr1->ts.kind == 1)
2434 fndecl = gfor_fndecl_select_string;
2435 else if (code->expr1->ts.kind == 4)
2436 fndecl = gfor_fndecl_select_string_char4;
2437 else
2438 gcc_unreachable ();
2439
2440 tmp = build_call_expr_loc (input_location,
2441 fndecl, 4, init,
2442 build_int_cst (gfc_charlen_type_node, n),
2443 expr1se.expr, expr1se.string_length);
2444 case_num = gfc_create_var (integer_type_node, "case_num");
2445 gfc_add_modify (&block, case_num, tmp);
2446
2447 gfc_add_block_to_block (&block, &expr1se.post);
2448
2449 tmp = gfc_finish_block (&body);
2450 tmp = fold_build3_loc (input_location, SWITCH_EXPR, NULL_TREE,
2451 case_num, tmp, NULL_TREE);
2452 gfc_add_expr_to_block (&block, tmp);
2453
2454 tmp = build1_v (LABEL_EXPR, end_label);
2455 gfc_add_expr_to_block (&block, tmp);
2456
2457 return gfc_finish_block (&block);
2458 }
2459
2460
2461 /* Translate the three variants of the SELECT CASE construct.
2462
2463 SELECT CASEs with INTEGER case expressions can be translated to an
2464 equivalent GENERIC switch statement, and for LOGICAL case
2465 expressions we build one or two if-else compares.
2466
2467 SELECT CASEs with CHARACTER case expressions are a whole different
2468 story, because they don't exist in GENERIC. So we sort them and
2469 do a binary search at runtime.
2470
2471 Fortran has no BREAK statement, and it does not allow jumps from
2472 one case block to another. That makes things a lot easier for
2473 the optimizers. */
2474
2475 tree
gfc_trans_select(gfc_code * code)2476 gfc_trans_select (gfc_code * code)
2477 {
2478 stmtblock_t block;
2479 tree body;
2480 tree exit_label;
2481
2482 gcc_assert (code && code->expr1);
2483 gfc_init_block (&block);
2484
2485 /* Build the exit label and hang it in. */
2486 exit_label = gfc_build_label_decl (NULL_TREE);
2487 code->exit_label = exit_label;
2488
2489 /* Empty SELECT constructs are legal. */
2490 if (code->block == NULL)
2491 body = build_empty_stmt (input_location);
2492
2493 /* Select the correct translation function. */
2494 else
2495 switch (code->expr1->ts.type)
2496 {
2497 case BT_LOGICAL:
2498 body = gfc_trans_logical_select (code);
2499 break;
2500
2501 case BT_INTEGER:
2502 body = gfc_trans_integer_select (code);
2503 break;
2504
2505 case BT_CHARACTER:
2506 body = gfc_trans_character_select (code);
2507 break;
2508
2509 default:
2510 gfc_internal_error ("gfc_trans_select(): Bad type for case expr.");
2511 /* Not reached */
2512 }
2513
2514 /* Build everything together. */
2515 gfc_add_expr_to_block (&block, body);
2516 gfc_add_expr_to_block (&block, build1_v (LABEL_EXPR, exit_label));
2517
2518 return gfc_finish_block (&block);
2519 }
2520
2521
2522 /* Traversal function to substitute a replacement symtree if the symbol
2523 in the expression is the same as that passed. f == 2 signals that
2524 that variable itself is not to be checked - only the references.
2525 This group of functions is used when the variable expression in a
2526 FORALL assignment has internal references. For example:
2527 FORALL (i = 1:4) p(p(i)) = i
2528 The only recourse here is to store a copy of 'p' for the index
2529 expression. */
2530
2531 static gfc_symtree *new_symtree;
2532 static gfc_symtree *old_symtree;
2533
2534 static bool
forall_replace(gfc_expr * expr,gfc_symbol * sym,int * f)2535 forall_replace (gfc_expr *expr, gfc_symbol *sym, int *f)
2536 {
2537 if (expr->expr_type != EXPR_VARIABLE)
2538 return false;
2539
2540 if (*f == 2)
2541 *f = 1;
2542 else if (expr->symtree->n.sym == sym)
2543 expr->symtree = new_symtree;
2544
2545 return false;
2546 }
2547
2548 static void
forall_replace_symtree(gfc_expr * e,gfc_symbol * sym,int f)2549 forall_replace_symtree (gfc_expr *e, gfc_symbol *sym, int f)
2550 {
2551 gfc_traverse_expr (e, sym, forall_replace, f);
2552 }
2553
2554 static bool
forall_restore(gfc_expr * expr,gfc_symbol * sym ATTRIBUTE_UNUSED,int * f ATTRIBUTE_UNUSED)2555 forall_restore (gfc_expr *expr,
2556 gfc_symbol *sym ATTRIBUTE_UNUSED,
2557 int *f ATTRIBUTE_UNUSED)
2558 {
2559 if (expr->expr_type != EXPR_VARIABLE)
2560 return false;
2561
2562 if (expr->symtree == new_symtree)
2563 expr->symtree = old_symtree;
2564
2565 return false;
2566 }
2567
2568 static void
forall_restore_symtree(gfc_expr * e)2569 forall_restore_symtree (gfc_expr *e)
2570 {
2571 gfc_traverse_expr (e, NULL, forall_restore, 0);
2572 }
2573
2574 static void
forall_make_variable_temp(gfc_code * c,stmtblock_t * pre,stmtblock_t * post)2575 forall_make_variable_temp (gfc_code *c, stmtblock_t *pre, stmtblock_t *post)
2576 {
2577 gfc_se tse;
2578 gfc_se rse;
2579 gfc_expr *e;
2580 gfc_symbol *new_sym;
2581 gfc_symbol *old_sym;
2582 gfc_symtree *root;
2583 tree tmp;
2584
2585 /* Build a copy of the lvalue. */
2586 old_symtree = c->expr1->symtree;
2587 old_sym = old_symtree->n.sym;
2588 e = gfc_lval_expr_from_sym (old_sym);
2589 if (old_sym->attr.dimension)
2590 {
2591 gfc_init_se (&tse, NULL);
2592 gfc_conv_subref_array_arg (&tse, e, 0, INTENT_IN, false);
2593 gfc_add_block_to_block (pre, &tse.pre);
2594 gfc_add_block_to_block (post, &tse.post);
2595 tse.expr = build_fold_indirect_ref_loc (input_location, tse.expr);
2596
2597 if (e->ts.type != BT_CHARACTER)
2598 {
2599 /* Use the variable offset for the temporary. */
2600 tmp = gfc_conv_array_offset (old_sym->backend_decl);
2601 gfc_conv_descriptor_offset_set (pre, tse.expr, tmp);
2602 }
2603 }
2604 else
2605 {
2606 gfc_init_se (&tse, NULL);
2607 gfc_init_se (&rse, NULL);
2608 gfc_conv_expr (&rse, e);
2609 if (e->ts.type == BT_CHARACTER)
2610 {
2611 tse.string_length = rse.string_length;
2612 tmp = gfc_get_character_type_len (gfc_default_character_kind,
2613 tse.string_length);
2614 tse.expr = gfc_conv_string_tmp (&tse, build_pointer_type (tmp),
2615 rse.string_length);
2616 gfc_add_block_to_block (pre, &tse.pre);
2617 gfc_add_block_to_block (post, &tse.post);
2618 }
2619 else
2620 {
2621 tmp = gfc_typenode_for_spec (&e->ts);
2622 tse.expr = gfc_create_var (tmp, "temp");
2623 }
2624
2625 tmp = gfc_trans_scalar_assign (&tse, &rse, e->ts, true,
2626 e->expr_type == EXPR_VARIABLE, true);
2627 gfc_add_expr_to_block (pre, tmp);
2628 }
2629 gfc_free_expr (e);
2630
2631 /* Create a new symbol to represent the lvalue. */
2632 new_sym = gfc_new_symbol (old_sym->name, NULL);
2633 new_sym->ts = old_sym->ts;
2634 new_sym->attr.referenced = 1;
2635 new_sym->attr.temporary = 1;
2636 new_sym->attr.dimension = old_sym->attr.dimension;
2637 new_sym->attr.flavor = old_sym->attr.flavor;
2638
2639 /* Use the temporary as the backend_decl. */
2640 new_sym->backend_decl = tse.expr;
2641
2642 /* Create a fake symtree for it. */
2643 root = NULL;
2644 new_symtree = gfc_new_symtree (&root, old_sym->name);
2645 new_symtree->n.sym = new_sym;
2646 gcc_assert (new_symtree == root);
2647
2648 /* Go through the expression reference replacing the old_symtree
2649 with the new. */
2650 forall_replace_symtree (c->expr1, old_sym, 2);
2651
2652 /* Now we have made this temporary, we might as well use it for
2653 the right hand side. */
2654 forall_replace_symtree (c->expr2, old_sym, 1);
2655 }
2656
2657
2658 /* Handles dependencies in forall assignments. */
2659 static int
check_forall_dependencies(gfc_code * c,stmtblock_t * pre,stmtblock_t * post)2660 check_forall_dependencies (gfc_code *c, stmtblock_t *pre, stmtblock_t *post)
2661 {
2662 gfc_ref *lref;
2663 gfc_ref *rref;
2664 int need_temp;
2665 gfc_symbol *lsym;
2666
2667 lsym = c->expr1->symtree->n.sym;
2668 need_temp = gfc_check_dependency (c->expr1, c->expr2, 0);
2669
2670 /* Now check for dependencies within the 'variable'
2671 expression itself. These are treated by making a complete
2672 copy of variable and changing all the references to it
2673 point to the copy instead. Note that the shallow copy of
2674 the variable will not suffice for derived types with
2675 pointer components. We therefore leave these to their
2676 own devices. */
2677 if (lsym->ts.type == BT_DERIVED
2678 && lsym->ts.u.derived->attr.pointer_comp)
2679 return need_temp;
2680
2681 new_symtree = NULL;
2682 if (find_forall_index (c->expr1, lsym, 2))
2683 {
2684 forall_make_variable_temp (c, pre, post);
2685 need_temp = 0;
2686 }
2687
2688 /* Substrings with dependencies are treated in the same
2689 way. */
2690 if (c->expr1->ts.type == BT_CHARACTER
2691 && c->expr1->ref
2692 && c->expr2->expr_type == EXPR_VARIABLE
2693 && lsym == c->expr2->symtree->n.sym)
2694 {
2695 for (lref = c->expr1->ref; lref; lref = lref->next)
2696 if (lref->type == REF_SUBSTRING)
2697 break;
2698 for (rref = c->expr2->ref; rref; rref = rref->next)
2699 if (rref->type == REF_SUBSTRING)
2700 break;
2701
2702 if (rref && lref
2703 && gfc_dep_compare_expr (rref->u.ss.start, lref->u.ss.start) < 0)
2704 {
2705 forall_make_variable_temp (c, pre, post);
2706 need_temp = 0;
2707 }
2708 }
2709 return need_temp;
2710 }
2711
2712
2713 static void
cleanup_forall_symtrees(gfc_code * c)2714 cleanup_forall_symtrees (gfc_code *c)
2715 {
2716 forall_restore_symtree (c->expr1);
2717 forall_restore_symtree (c->expr2);
2718 free (new_symtree->n.sym);
2719 free (new_symtree);
2720 }
2721
2722
2723 /* Generate the loops for a FORALL block, specified by FORALL_TMP. BODY
2724 is the contents of the FORALL block/stmt to be iterated. MASK_FLAG
2725 indicates whether we should generate code to test the FORALLs mask
2726 array. OUTER is the loop header to be used for initializing mask
2727 indices.
2728
2729 The generated loop format is:
2730 count = (end - start + step) / step
2731 loopvar = start
2732 while (1)
2733 {
2734 if (count <=0 )
2735 goto end_of_loop
2736 <body>
2737 loopvar += step
2738 count --
2739 }
2740 end_of_loop: */
2741
2742 static tree
gfc_trans_forall_loop(forall_info * forall_tmp,tree body,int mask_flag,stmtblock_t * outer)2743 gfc_trans_forall_loop (forall_info *forall_tmp, tree body,
2744 int mask_flag, stmtblock_t *outer)
2745 {
2746 int n, nvar;
2747 tree tmp;
2748 tree cond;
2749 stmtblock_t block;
2750 tree exit_label;
2751 tree count;
2752 tree var, start, end, step;
2753 iter_info *iter;
2754
2755 /* Initialize the mask index outside the FORALL nest. */
2756 if (mask_flag && forall_tmp->mask)
2757 gfc_add_modify (outer, forall_tmp->maskindex, gfc_index_zero_node);
2758
2759 iter = forall_tmp->this_loop;
2760 nvar = forall_tmp->nvar;
2761 for (n = 0; n < nvar; n++)
2762 {
2763 var = iter->var;
2764 start = iter->start;
2765 end = iter->end;
2766 step = iter->step;
2767
2768 exit_label = gfc_build_label_decl (NULL_TREE);
2769 TREE_USED (exit_label) = 1;
2770
2771 /* The loop counter. */
2772 count = gfc_create_var (TREE_TYPE (var), "count");
2773
2774 /* The body of the loop. */
2775 gfc_init_block (&block);
2776
2777 /* The exit condition. */
2778 cond = fold_build2_loc (input_location, LE_EXPR, boolean_type_node,
2779 count, build_int_cst (TREE_TYPE (count), 0));
2780 if (forall_tmp->do_concurrent)
2781 cond = build2 (ANNOTATE_EXPR, TREE_TYPE (cond), cond,
2782 build_int_cst (integer_type_node,
2783 annot_expr_ivdep_kind));
2784
2785 tmp = build1_v (GOTO_EXPR, exit_label);
2786 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
2787 cond, tmp, build_empty_stmt (input_location));
2788 gfc_add_expr_to_block (&block, tmp);
2789
2790 /* The main loop body. */
2791 gfc_add_expr_to_block (&block, body);
2792
2793 /* Increment the loop variable. */
2794 tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (var), var,
2795 step);
2796 gfc_add_modify (&block, var, tmp);
2797
2798 /* Advance to the next mask element. Only do this for the
2799 innermost loop. */
2800 if (n == 0 && mask_flag && forall_tmp->mask)
2801 {
2802 tree maskindex = forall_tmp->maskindex;
2803 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
2804 maskindex, gfc_index_one_node);
2805 gfc_add_modify (&block, maskindex, tmp);
2806 }
2807
2808 /* Decrement the loop counter. */
2809 tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (var), count,
2810 build_int_cst (TREE_TYPE (var), 1));
2811 gfc_add_modify (&block, count, tmp);
2812
2813 body = gfc_finish_block (&block);
2814
2815 /* Loop var initialization. */
2816 gfc_init_block (&block);
2817 gfc_add_modify (&block, var, start);
2818
2819
2820 /* Initialize the loop counter. */
2821 tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (var), step,
2822 start);
2823 tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (var), end,
2824 tmp);
2825 tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR, TREE_TYPE (var),
2826 tmp, step);
2827 gfc_add_modify (&block, count, tmp);
2828
2829 /* The loop expression. */
2830 tmp = build1_v (LOOP_EXPR, body);
2831 gfc_add_expr_to_block (&block, tmp);
2832
2833 /* The exit label. */
2834 tmp = build1_v (LABEL_EXPR, exit_label);
2835 gfc_add_expr_to_block (&block, tmp);
2836
2837 body = gfc_finish_block (&block);
2838 iter = iter->next;
2839 }
2840 return body;
2841 }
2842
2843
2844 /* Generate the body and loops according to MASK_FLAG. If MASK_FLAG
2845 is nonzero, the body is controlled by all masks in the forall nest.
2846 Otherwise, the innermost loop is not controlled by it's mask. This
2847 is used for initializing that mask. */
2848
2849 static tree
gfc_trans_nested_forall_loop(forall_info * nested_forall_info,tree body,int mask_flag)2850 gfc_trans_nested_forall_loop (forall_info * nested_forall_info, tree body,
2851 int mask_flag)
2852 {
2853 tree tmp;
2854 stmtblock_t header;
2855 forall_info *forall_tmp;
2856 tree mask, maskindex;
2857
2858 gfc_start_block (&header);
2859
2860 forall_tmp = nested_forall_info;
2861 while (forall_tmp != NULL)
2862 {
2863 /* Generate body with masks' control. */
2864 if (mask_flag)
2865 {
2866 mask = forall_tmp->mask;
2867 maskindex = forall_tmp->maskindex;
2868
2869 /* If a mask was specified make the assignment conditional. */
2870 if (mask)
2871 {
2872 tmp = gfc_build_array_ref (mask, maskindex, NULL);
2873 body = build3_v (COND_EXPR, tmp, body,
2874 build_empty_stmt (input_location));
2875 }
2876 }
2877 body = gfc_trans_forall_loop (forall_tmp, body, mask_flag, &header);
2878 forall_tmp = forall_tmp->prev_nest;
2879 mask_flag = 1;
2880 }
2881
2882 gfc_add_expr_to_block (&header, body);
2883 return gfc_finish_block (&header);
2884 }
2885
2886
2887 /* Allocate data for holding a temporary array. Returns either a local
2888 temporary array or a pointer variable. */
2889
2890 static tree
gfc_do_allocate(tree bytesize,tree size,tree * pdata,stmtblock_t * pblock,tree elem_type)2891 gfc_do_allocate (tree bytesize, tree size, tree * pdata, stmtblock_t * pblock,
2892 tree elem_type)
2893 {
2894 tree tmpvar;
2895 tree type;
2896 tree tmp;
2897
2898 if (INTEGER_CST_P (size))
2899 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
2900 size, gfc_index_one_node);
2901 else
2902 tmp = NULL_TREE;
2903
2904 type = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp);
2905 type = build_array_type (elem_type, type);
2906 if (gfc_can_put_var_on_stack (bytesize))
2907 {
2908 gcc_assert (INTEGER_CST_P (size));
2909 tmpvar = gfc_create_var (type, "temp");
2910 *pdata = NULL_TREE;
2911 }
2912 else
2913 {
2914 tmpvar = gfc_create_var (build_pointer_type (type), "temp");
2915 *pdata = convert (pvoid_type_node, tmpvar);
2916
2917 tmp = gfc_call_malloc (pblock, TREE_TYPE (tmpvar), bytesize);
2918 gfc_add_modify (pblock, tmpvar, tmp);
2919 }
2920 return tmpvar;
2921 }
2922
2923
2924 /* Generate codes to copy the temporary to the actual lhs. */
2925
2926 static tree
generate_loop_for_temp_to_lhs(gfc_expr * expr,tree tmp1,tree count3,tree count1,tree wheremask,bool invert)2927 generate_loop_for_temp_to_lhs (gfc_expr *expr, tree tmp1, tree count3,
2928 tree count1, tree wheremask, bool invert)
2929 {
2930 gfc_ss *lss;
2931 gfc_se lse, rse;
2932 stmtblock_t block, body;
2933 gfc_loopinfo loop1;
2934 tree tmp;
2935 tree wheremaskexpr;
2936
2937 /* Walk the lhs. */
2938 lss = gfc_walk_expr (expr);
2939
2940 if (lss == gfc_ss_terminator)
2941 {
2942 gfc_start_block (&block);
2943
2944 gfc_init_se (&lse, NULL);
2945
2946 /* Translate the expression. */
2947 gfc_conv_expr (&lse, expr);
2948
2949 /* Form the expression for the temporary. */
2950 tmp = gfc_build_array_ref (tmp1, count1, NULL);
2951
2952 /* Use the scalar assignment as is. */
2953 gfc_add_block_to_block (&block, &lse.pre);
2954 gfc_add_modify (&block, lse.expr, tmp);
2955 gfc_add_block_to_block (&block, &lse.post);
2956
2957 /* Increment the count1. */
2958 tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (count1),
2959 count1, gfc_index_one_node);
2960 gfc_add_modify (&block, count1, tmp);
2961
2962 tmp = gfc_finish_block (&block);
2963 }
2964 else
2965 {
2966 gfc_start_block (&block);
2967
2968 gfc_init_loopinfo (&loop1);
2969 gfc_init_se (&rse, NULL);
2970 gfc_init_se (&lse, NULL);
2971
2972 /* Associate the lss with the loop. */
2973 gfc_add_ss_to_loop (&loop1, lss);
2974
2975 /* Calculate the bounds of the scalarization. */
2976 gfc_conv_ss_startstride (&loop1);
2977 /* Setup the scalarizing loops. */
2978 gfc_conv_loop_setup (&loop1, &expr->where);
2979
2980 gfc_mark_ss_chain_used (lss, 1);
2981
2982 /* Start the scalarized loop body. */
2983 gfc_start_scalarized_body (&loop1, &body);
2984
2985 /* Setup the gfc_se structures. */
2986 gfc_copy_loopinfo_to_se (&lse, &loop1);
2987 lse.ss = lss;
2988
2989 /* Form the expression of the temporary. */
2990 if (lss != gfc_ss_terminator)
2991 rse.expr = gfc_build_array_ref (tmp1, count1, NULL);
2992 /* Translate expr. */
2993 gfc_conv_expr (&lse, expr);
2994
2995 /* Use the scalar assignment. */
2996 rse.string_length = lse.string_length;
2997 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, true, true);
2998
2999 /* Form the mask expression according to the mask tree list. */
3000 if (wheremask)
3001 {
3002 wheremaskexpr = gfc_build_array_ref (wheremask, count3, NULL);
3003 if (invert)
3004 wheremaskexpr = fold_build1_loc (input_location, TRUTH_NOT_EXPR,
3005 TREE_TYPE (wheremaskexpr),
3006 wheremaskexpr);
3007 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
3008 wheremaskexpr, tmp,
3009 build_empty_stmt (input_location));
3010 }
3011
3012 gfc_add_expr_to_block (&body, tmp);
3013
3014 /* Increment count1. */
3015 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
3016 count1, gfc_index_one_node);
3017 gfc_add_modify (&body, count1, tmp);
3018
3019 /* Increment count3. */
3020 if (count3)
3021 {
3022 tmp = fold_build2_loc (input_location, PLUS_EXPR,
3023 gfc_array_index_type, count3,
3024 gfc_index_one_node);
3025 gfc_add_modify (&body, count3, tmp);
3026 }
3027
3028 /* Generate the copying loops. */
3029 gfc_trans_scalarizing_loops (&loop1, &body);
3030 gfc_add_block_to_block (&block, &loop1.pre);
3031 gfc_add_block_to_block (&block, &loop1.post);
3032 gfc_cleanup_loop (&loop1);
3033
3034 tmp = gfc_finish_block (&block);
3035 }
3036 return tmp;
3037 }
3038
3039
3040 /* Generate codes to copy rhs to the temporary. TMP1 is the address of
3041 temporary, LSS and RSS are formed in function compute_inner_temp_size(),
3042 and should not be freed. WHEREMASK is the conditional execution mask
3043 whose sense may be inverted by INVERT. */
3044
3045 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)3046 generate_loop_for_rhs_to_temp (gfc_expr *expr2, tree tmp1, tree count3,
3047 tree count1, gfc_ss *lss, gfc_ss *rss,
3048 tree wheremask, bool invert)
3049 {
3050 stmtblock_t block, body1;
3051 gfc_loopinfo loop;
3052 gfc_se lse;
3053 gfc_se rse;
3054 tree tmp;
3055 tree wheremaskexpr;
3056
3057 gfc_start_block (&block);
3058
3059 gfc_init_se (&rse, NULL);
3060 gfc_init_se (&lse, NULL);
3061
3062 if (lss == gfc_ss_terminator)
3063 {
3064 gfc_init_block (&body1);
3065 gfc_conv_expr (&rse, expr2);
3066 lse.expr = gfc_build_array_ref (tmp1, count1, NULL);
3067 }
3068 else
3069 {
3070 /* Initialize the loop. */
3071 gfc_init_loopinfo (&loop);
3072
3073 /* We may need LSS to determine the shape of the expression. */
3074 gfc_add_ss_to_loop (&loop, lss);
3075 gfc_add_ss_to_loop (&loop, rss);
3076
3077 gfc_conv_ss_startstride (&loop);
3078 gfc_conv_loop_setup (&loop, &expr2->where);
3079
3080 gfc_mark_ss_chain_used (rss, 1);
3081 /* Start the loop body. */
3082 gfc_start_scalarized_body (&loop, &body1);
3083
3084 /* Translate the expression. */
3085 gfc_copy_loopinfo_to_se (&rse, &loop);
3086 rse.ss = rss;
3087 gfc_conv_expr (&rse, expr2);
3088
3089 /* Form the expression of the temporary. */
3090 lse.expr = gfc_build_array_ref (tmp1, count1, NULL);
3091 }
3092
3093 /* Use the scalar assignment. */
3094 lse.string_length = rse.string_length;
3095 tmp = gfc_trans_scalar_assign (&lse, &rse, expr2->ts, true,
3096 expr2->expr_type == EXPR_VARIABLE, true);
3097
3098 /* Form the mask expression according to the mask tree list. */
3099 if (wheremask)
3100 {
3101 wheremaskexpr = gfc_build_array_ref (wheremask, count3, NULL);
3102 if (invert)
3103 wheremaskexpr = fold_build1_loc (input_location, TRUTH_NOT_EXPR,
3104 TREE_TYPE (wheremaskexpr),
3105 wheremaskexpr);
3106 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
3107 wheremaskexpr, tmp,
3108 build_empty_stmt (input_location));
3109 }
3110
3111 gfc_add_expr_to_block (&body1, tmp);
3112
3113 if (lss == gfc_ss_terminator)
3114 {
3115 gfc_add_block_to_block (&block, &body1);
3116
3117 /* Increment count1. */
3118 tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (count1),
3119 count1, gfc_index_one_node);
3120 gfc_add_modify (&block, count1, tmp);
3121 }
3122 else
3123 {
3124 /* Increment count1. */
3125 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
3126 count1, gfc_index_one_node);
3127 gfc_add_modify (&body1, count1, tmp);
3128
3129 /* Increment count3. */
3130 if (count3)
3131 {
3132 tmp = fold_build2_loc (input_location, PLUS_EXPR,
3133 gfc_array_index_type,
3134 count3, gfc_index_one_node);
3135 gfc_add_modify (&body1, count3, tmp);
3136 }
3137
3138 /* Generate the copying loops. */
3139 gfc_trans_scalarizing_loops (&loop, &body1);
3140
3141 gfc_add_block_to_block (&block, &loop.pre);
3142 gfc_add_block_to_block (&block, &loop.post);
3143
3144 gfc_cleanup_loop (&loop);
3145 /* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful
3146 as tree nodes in SS may not be valid in different scope. */
3147 }
3148
3149 tmp = gfc_finish_block (&block);
3150 return tmp;
3151 }
3152
3153
3154 /* Calculate the size of temporary needed in the assignment inside forall.
3155 LSS and RSS are filled in this function. */
3156
3157 static tree
compute_inner_temp_size(gfc_expr * expr1,gfc_expr * expr2,stmtblock_t * pblock,gfc_ss ** lss,gfc_ss ** rss)3158 compute_inner_temp_size (gfc_expr *expr1, gfc_expr *expr2,
3159 stmtblock_t * pblock,
3160 gfc_ss **lss, gfc_ss **rss)
3161 {
3162 gfc_loopinfo loop;
3163 tree size;
3164 int i;
3165 int save_flag;
3166 tree tmp;
3167
3168 *lss = gfc_walk_expr (expr1);
3169 *rss = NULL;
3170
3171 size = gfc_index_one_node;
3172 if (*lss != gfc_ss_terminator)
3173 {
3174 gfc_init_loopinfo (&loop);
3175
3176 /* Walk the RHS of the expression. */
3177 *rss = gfc_walk_expr (expr2);
3178 if (*rss == gfc_ss_terminator)
3179 /* The rhs is scalar. Add a ss for the expression. */
3180 *rss = gfc_get_scalar_ss (gfc_ss_terminator, expr2);
3181
3182 /* Associate the SS with the loop. */
3183 gfc_add_ss_to_loop (&loop, *lss);
3184 /* We don't actually need to add the rhs at this point, but it might
3185 make guessing the loop bounds a bit easier. */
3186 gfc_add_ss_to_loop (&loop, *rss);
3187
3188 /* We only want the shape of the expression, not rest of the junk
3189 generated by the scalarizer. */
3190 loop.array_parameter = 1;
3191
3192 /* Calculate the bounds of the scalarization. */
3193 save_flag = gfc_option.rtcheck;
3194 gfc_option.rtcheck &= ~GFC_RTCHECK_BOUNDS;
3195 gfc_conv_ss_startstride (&loop);
3196 gfc_option.rtcheck = save_flag;
3197 gfc_conv_loop_setup (&loop, &expr2->where);
3198
3199 /* Figure out how many elements we need. */
3200 for (i = 0; i < loop.dimen; i++)
3201 {
3202 tmp = fold_build2_loc (input_location, MINUS_EXPR,
3203 gfc_array_index_type,
3204 gfc_index_one_node, loop.from[i]);
3205 tmp = fold_build2_loc (input_location, PLUS_EXPR,
3206 gfc_array_index_type, tmp, loop.to[i]);
3207 size = fold_build2_loc (input_location, MULT_EXPR,
3208 gfc_array_index_type, size, tmp);
3209 }
3210 gfc_add_block_to_block (pblock, &loop.pre);
3211 size = gfc_evaluate_now (size, pblock);
3212 gfc_add_block_to_block (pblock, &loop.post);
3213
3214 /* TODO: write a function that cleans up a loopinfo without freeing
3215 the SS chains. Currently a NOP. */
3216 }
3217
3218 return size;
3219 }
3220
3221
3222 /* Calculate the overall iterator number of the nested forall construct.
3223 This routine actually calculates the number of times the body of the
3224 nested forall specified by NESTED_FORALL_INFO is executed and multiplies
3225 that by the expression INNER_SIZE. The BLOCK argument specifies the
3226 block in which to calculate the result, and the optional INNER_SIZE_BODY
3227 argument contains any statements that need to executed (inside the loop)
3228 to initialize or calculate INNER_SIZE. */
3229
3230 static tree
compute_overall_iter_number(forall_info * nested_forall_info,tree inner_size,stmtblock_t * inner_size_body,stmtblock_t * block)3231 compute_overall_iter_number (forall_info *nested_forall_info, tree inner_size,
3232 stmtblock_t *inner_size_body, stmtblock_t *block)
3233 {
3234 forall_info *forall_tmp = nested_forall_info;
3235 tree tmp, number;
3236 stmtblock_t body;
3237
3238 /* We can eliminate the innermost unconditional loops with constant
3239 array bounds. */
3240 if (INTEGER_CST_P (inner_size))
3241 {
3242 while (forall_tmp
3243 && !forall_tmp->mask
3244 && INTEGER_CST_P (forall_tmp->size))
3245 {
3246 inner_size = fold_build2_loc (input_location, MULT_EXPR,
3247 gfc_array_index_type,
3248 inner_size, forall_tmp->size);
3249 forall_tmp = forall_tmp->prev_nest;
3250 }
3251
3252 /* If there are no loops left, we have our constant result. */
3253 if (!forall_tmp)
3254 return inner_size;
3255 }
3256
3257 /* Otherwise, create a temporary variable to compute the result. */
3258 number = gfc_create_var (gfc_array_index_type, "num");
3259 gfc_add_modify (block, number, gfc_index_zero_node);
3260
3261 gfc_start_block (&body);
3262 if (inner_size_body)
3263 gfc_add_block_to_block (&body, inner_size_body);
3264 if (forall_tmp)
3265 tmp = fold_build2_loc (input_location, PLUS_EXPR,
3266 gfc_array_index_type, number, inner_size);
3267 else
3268 tmp = inner_size;
3269 gfc_add_modify (&body, number, tmp);
3270 tmp = gfc_finish_block (&body);
3271
3272 /* Generate loops. */
3273 if (forall_tmp != NULL)
3274 tmp = gfc_trans_nested_forall_loop (forall_tmp, tmp, 1);
3275
3276 gfc_add_expr_to_block (block, tmp);
3277
3278 return number;
3279 }
3280
3281
3282 /* Allocate temporary for forall construct. SIZE is the size of temporary
3283 needed. PTEMP1 is returned for space free. */
3284
3285 static tree
allocate_temp_for_forall_nest_1(tree type,tree size,stmtblock_t * block,tree * ptemp1)3286 allocate_temp_for_forall_nest_1 (tree type, tree size, stmtblock_t * block,
3287 tree * ptemp1)
3288 {
3289 tree bytesize;
3290 tree unit;
3291 tree tmp;
3292
3293 unit = fold_convert (gfc_array_index_type, TYPE_SIZE_UNIT (type));
3294 if (!integer_onep (unit))
3295 bytesize = fold_build2_loc (input_location, MULT_EXPR,
3296 gfc_array_index_type, size, unit);
3297 else
3298 bytesize = size;
3299
3300 *ptemp1 = NULL;
3301 tmp = gfc_do_allocate (bytesize, size, ptemp1, block, type);
3302
3303 if (*ptemp1)
3304 tmp = build_fold_indirect_ref_loc (input_location, tmp);
3305 return tmp;
3306 }
3307
3308
3309 /* Allocate temporary for forall construct according to the information in
3310 nested_forall_info. INNER_SIZE is the size of temporary needed in the
3311 assignment inside forall. PTEMP1 is returned for space free. */
3312
3313 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)3314 allocate_temp_for_forall_nest (forall_info * nested_forall_info, tree type,
3315 tree inner_size, stmtblock_t * inner_size_body,
3316 stmtblock_t * block, tree * ptemp1)
3317 {
3318 tree size;
3319
3320 /* Calculate the total size of temporary needed in forall construct. */
3321 size = compute_overall_iter_number (nested_forall_info, inner_size,
3322 inner_size_body, block);
3323
3324 return allocate_temp_for_forall_nest_1 (type, size, block, ptemp1);
3325 }
3326
3327
3328 /* Handle assignments inside forall which need temporary.
3329
3330 forall (i=start:end:stride; maskexpr)
3331 e<i> = f<i>
3332 end forall
3333 (where e,f<i> are arbitrary expressions possibly involving i
3334 and there is a dependency between e<i> and f<i>)
3335 Translates to:
3336 masktmp(:) = maskexpr(:)
3337
3338 maskindex = 0;
3339 count1 = 0;
3340 num = 0;
3341 for (i = start; i <= end; i += stride)
3342 num += SIZE (f<i>)
3343 count1 = 0;
3344 ALLOCATE (tmp(num))
3345 for (i = start; i <= end; i += stride)
3346 {
3347 if (masktmp[maskindex++])
3348 tmp[count1++] = f<i>
3349 }
3350 maskindex = 0;
3351 count1 = 0;
3352 for (i = start; i <= end; i += stride)
3353 {
3354 if (masktmp[maskindex++])
3355 e<i> = tmp[count1++]
3356 }
3357 DEALLOCATE (tmp)
3358 */
3359 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)3360 gfc_trans_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2,
3361 tree wheremask, bool invert,
3362 forall_info * nested_forall_info,
3363 stmtblock_t * block)
3364 {
3365 tree type;
3366 tree inner_size;
3367 gfc_ss *lss, *rss;
3368 tree count, count1;
3369 tree tmp, tmp1;
3370 tree ptemp1;
3371 stmtblock_t inner_size_body;
3372
3373 /* Create vars. count1 is the current iterator number of the nested
3374 forall. */
3375 count1 = gfc_create_var (gfc_array_index_type, "count1");
3376
3377 /* Count is the wheremask index. */
3378 if (wheremask)
3379 {
3380 count = gfc_create_var (gfc_array_index_type, "count");
3381 gfc_add_modify (block, count, gfc_index_zero_node);
3382 }
3383 else
3384 count = NULL;
3385
3386 /* Initialize count1. */
3387 gfc_add_modify (block, count1, gfc_index_zero_node);
3388
3389 /* Calculate the size of temporary needed in the assignment. Return loop, lss
3390 and rss which are used in function generate_loop_for_rhs_to_temp(). */
3391 gfc_init_block (&inner_size_body);
3392 inner_size = compute_inner_temp_size (expr1, expr2, &inner_size_body,
3393 &lss, &rss);
3394
3395 /* The type of LHS. Used in function allocate_temp_for_forall_nest */
3396 if (expr1->ts.type == BT_CHARACTER && expr1->ts.u.cl->length)
3397 {
3398 if (!expr1->ts.u.cl->backend_decl)
3399 {
3400 gfc_se tse;
3401 gfc_init_se (&tse, NULL);
3402 gfc_conv_expr (&tse, expr1->ts.u.cl->length);
3403 expr1->ts.u.cl->backend_decl = tse.expr;
3404 }
3405 type = gfc_get_character_type_len (gfc_default_character_kind,
3406 expr1->ts.u.cl->backend_decl);
3407 }
3408 else
3409 type = gfc_typenode_for_spec (&expr1->ts);
3410
3411 /* Allocate temporary for nested forall construct according to the
3412 information in nested_forall_info and inner_size. */
3413 tmp1 = allocate_temp_for_forall_nest (nested_forall_info, type, inner_size,
3414 &inner_size_body, block, &ptemp1);
3415
3416 /* Generate codes to copy rhs to the temporary . */
3417 tmp = generate_loop_for_rhs_to_temp (expr2, tmp1, count, count1, lss, rss,
3418 wheremask, invert);
3419
3420 /* Generate body and loops according to the information in
3421 nested_forall_info. */
3422 tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
3423 gfc_add_expr_to_block (block, tmp);
3424
3425 /* Reset count1. */
3426 gfc_add_modify (block, count1, gfc_index_zero_node);
3427
3428 /* Reset count. */
3429 if (wheremask)
3430 gfc_add_modify (block, count, gfc_index_zero_node);
3431
3432 /* Generate codes to copy the temporary to lhs. */
3433 tmp = generate_loop_for_temp_to_lhs (expr1, tmp1, count, count1,
3434 wheremask, invert);
3435
3436 /* Generate body and loops according to the information in
3437 nested_forall_info. */
3438 tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
3439 gfc_add_expr_to_block (block, tmp);
3440
3441 if (ptemp1)
3442 {
3443 /* Free the temporary. */
3444 tmp = gfc_call_free (ptemp1);
3445 gfc_add_expr_to_block (block, tmp);
3446 }
3447 }
3448
3449
3450 /* Translate pointer assignment inside FORALL which need temporary. */
3451
3452 static void
gfc_trans_pointer_assign_need_temp(gfc_expr * expr1,gfc_expr * expr2,forall_info * nested_forall_info,stmtblock_t * block)3453 gfc_trans_pointer_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2,
3454 forall_info * nested_forall_info,
3455 stmtblock_t * block)
3456 {
3457 tree type;
3458 tree inner_size;
3459 gfc_ss *lss, *rss;
3460 gfc_se lse;
3461 gfc_se rse;
3462 gfc_array_info *info;
3463 gfc_loopinfo loop;
3464 tree desc;
3465 tree parm;
3466 tree parmtype;
3467 stmtblock_t body;
3468 tree count;
3469 tree tmp, tmp1, ptemp1;
3470
3471 count = gfc_create_var (gfc_array_index_type, "count");
3472 gfc_add_modify (block, count, gfc_index_zero_node);
3473
3474 inner_size = gfc_index_one_node;
3475 lss = gfc_walk_expr (expr1);
3476 rss = gfc_walk_expr (expr2);
3477 if (lss == gfc_ss_terminator)
3478 {
3479 type = gfc_typenode_for_spec (&expr1->ts);
3480 type = build_pointer_type (type);
3481
3482 /* Allocate temporary for nested forall construct according to the
3483 information in nested_forall_info and inner_size. */
3484 tmp1 = allocate_temp_for_forall_nest (nested_forall_info, type,
3485 inner_size, NULL, block, &ptemp1);
3486 gfc_start_block (&body);
3487 gfc_init_se (&lse, NULL);
3488 lse.expr = gfc_build_array_ref (tmp1, count, NULL);
3489 gfc_init_se (&rse, NULL);
3490 rse.want_pointer = 1;
3491 gfc_conv_expr (&rse, expr2);
3492 gfc_add_block_to_block (&body, &rse.pre);
3493 gfc_add_modify (&body, lse.expr,
3494 fold_convert (TREE_TYPE (lse.expr), rse.expr));
3495 gfc_add_block_to_block (&body, &rse.post);
3496
3497 /* Increment count. */
3498 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
3499 count, gfc_index_one_node);
3500 gfc_add_modify (&body, count, tmp);
3501
3502 tmp = gfc_finish_block (&body);
3503
3504 /* Generate body and loops according to the information in
3505 nested_forall_info. */
3506 tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
3507 gfc_add_expr_to_block (block, tmp);
3508
3509 /* Reset count. */
3510 gfc_add_modify (block, count, gfc_index_zero_node);
3511
3512 gfc_start_block (&body);
3513 gfc_init_se (&lse, NULL);
3514 gfc_init_se (&rse, NULL);
3515 rse.expr = gfc_build_array_ref (tmp1, count, NULL);
3516 lse.want_pointer = 1;
3517 gfc_conv_expr (&lse, expr1);
3518 gfc_add_block_to_block (&body, &lse.pre);
3519 gfc_add_modify (&body, lse.expr, rse.expr);
3520 gfc_add_block_to_block (&body, &lse.post);
3521 /* Increment count. */
3522 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
3523 count, gfc_index_one_node);
3524 gfc_add_modify (&body, count, tmp);
3525 tmp = gfc_finish_block (&body);
3526
3527 /* Generate body and loops according to the information in
3528 nested_forall_info. */
3529 tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
3530 gfc_add_expr_to_block (block, tmp);
3531 }
3532 else
3533 {
3534 gfc_init_loopinfo (&loop);
3535
3536 /* Associate the SS with the loop. */
3537 gfc_add_ss_to_loop (&loop, rss);
3538
3539 /* Setup the scalarizing loops and bounds. */
3540 gfc_conv_ss_startstride (&loop);
3541
3542 gfc_conv_loop_setup (&loop, &expr2->where);
3543
3544 info = &rss->info->data.array;
3545 desc = info->descriptor;
3546
3547 /* Make a new descriptor. */
3548 parmtype = gfc_get_element_type (TREE_TYPE (desc));
3549 parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen, 0,
3550 loop.from, loop.to, 1,
3551 GFC_ARRAY_UNKNOWN, true);
3552
3553 /* Allocate temporary for nested forall construct. */
3554 tmp1 = allocate_temp_for_forall_nest (nested_forall_info, parmtype,
3555 inner_size, NULL, block, &ptemp1);
3556 gfc_start_block (&body);
3557 gfc_init_se (&lse, NULL);
3558 lse.expr = gfc_build_array_ref (tmp1, count, NULL);
3559 lse.direct_byref = 1;
3560 gfc_conv_expr_descriptor (&lse, expr2);
3561
3562 gfc_add_block_to_block (&body, &lse.pre);
3563 gfc_add_block_to_block (&body, &lse.post);
3564
3565 /* Increment count. */
3566 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
3567 count, gfc_index_one_node);
3568 gfc_add_modify (&body, count, tmp);
3569
3570 tmp = gfc_finish_block (&body);
3571
3572 /* Generate body and loops according to the information in
3573 nested_forall_info. */
3574 tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
3575 gfc_add_expr_to_block (block, tmp);
3576
3577 /* Reset count. */
3578 gfc_add_modify (block, count, gfc_index_zero_node);
3579
3580 parm = gfc_build_array_ref (tmp1, count, NULL);
3581 gfc_init_se (&lse, NULL);
3582 gfc_conv_expr_descriptor (&lse, expr1);
3583 gfc_add_modify (&lse.pre, lse.expr, parm);
3584 gfc_start_block (&body);
3585 gfc_add_block_to_block (&body, &lse.pre);
3586 gfc_add_block_to_block (&body, &lse.post);
3587
3588 /* Increment count. */
3589 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
3590 count, gfc_index_one_node);
3591 gfc_add_modify (&body, count, tmp);
3592
3593 tmp = gfc_finish_block (&body);
3594
3595 tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
3596 gfc_add_expr_to_block (block, tmp);
3597 }
3598 /* Free the temporary. */
3599 if (ptemp1)
3600 {
3601 tmp = gfc_call_free (ptemp1);
3602 gfc_add_expr_to_block (block, tmp);
3603 }
3604 }
3605
3606
3607 /* FORALL and WHERE statements are really nasty, especially when you nest
3608 them. All the rhs of a forall assignment must be evaluated before the
3609 actual assignments are performed. Presumably this also applies to all the
3610 assignments in an inner where statement. */
3611
3612 /* Generate code for a FORALL statement. Any temporaries are allocated as a
3613 linear array, relying on the fact that we process in the same order in all
3614 loops.
3615
3616 forall (i=start:end:stride; maskexpr)
3617 e<i> = f<i>
3618 g<i> = h<i>
3619 end forall
3620 (where e,f,g,h<i> are arbitrary expressions possibly involving i)
3621 Translates to:
3622 count = ((end + 1 - start) / stride)
3623 masktmp(:) = maskexpr(:)
3624
3625 maskindex = 0;
3626 for (i = start; i <= end; i += stride)
3627 {
3628 if (masktmp[maskindex++])
3629 e<i> = f<i>
3630 }
3631 maskindex = 0;
3632 for (i = start; i <= end; i += stride)
3633 {
3634 if (masktmp[maskindex++])
3635 g<i> = h<i>
3636 }
3637
3638 Note that this code only works when there are no dependencies.
3639 Forall loop with array assignments and data dependencies are a real pain,
3640 because the size of the temporary cannot always be determined before the
3641 loop is executed. This problem is compounded by the presence of nested
3642 FORALL constructs.
3643 */
3644
3645 static tree
gfc_trans_forall_1(gfc_code * code,forall_info * nested_forall_info)3646 gfc_trans_forall_1 (gfc_code * code, forall_info * nested_forall_info)
3647 {
3648 stmtblock_t pre;
3649 stmtblock_t post;
3650 stmtblock_t block;
3651 stmtblock_t body;
3652 tree *var;
3653 tree *start;
3654 tree *end;
3655 tree *step;
3656 gfc_expr **varexpr;
3657 tree tmp;
3658 tree assign;
3659 tree size;
3660 tree maskindex;
3661 tree mask;
3662 tree pmask;
3663 tree cycle_label = NULL_TREE;
3664 int n;
3665 int nvar;
3666 int need_temp;
3667 gfc_forall_iterator *fa;
3668 gfc_se se;
3669 gfc_code *c;
3670 gfc_saved_var *saved_vars;
3671 iter_info *this_forall;
3672 forall_info *info;
3673 bool need_mask;
3674
3675 /* Do nothing if the mask is false. */
3676 if (code->expr1
3677 && code->expr1->expr_type == EXPR_CONSTANT
3678 && !code->expr1->value.logical)
3679 return build_empty_stmt (input_location);
3680
3681 n = 0;
3682 /* Count the FORALL index number. */
3683 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
3684 n++;
3685 nvar = n;
3686
3687 /* Allocate the space for var, start, end, step, varexpr. */
3688 var = XCNEWVEC (tree, nvar);
3689 start = XCNEWVEC (tree, nvar);
3690 end = XCNEWVEC (tree, nvar);
3691 step = XCNEWVEC (tree, nvar);
3692 varexpr = XCNEWVEC (gfc_expr *, nvar);
3693 saved_vars = XCNEWVEC (gfc_saved_var, nvar);
3694
3695 /* Allocate the space for info. */
3696 info = XCNEW (forall_info);
3697
3698 gfc_start_block (&pre);
3699 gfc_init_block (&post);
3700 gfc_init_block (&block);
3701
3702 n = 0;
3703 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
3704 {
3705 gfc_symbol *sym = fa->var->symtree->n.sym;
3706
3707 /* Allocate space for this_forall. */
3708 this_forall = XCNEW (iter_info);
3709
3710 /* Create a temporary variable for the FORALL index. */
3711 tmp = gfc_typenode_for_spec (&sym->ts);
3712 var[n] = gfc_create_var (tmp, sym->name);
3713 gfc_shadow_sym (sym, var[n], &saved_vars[n]);
3714
3715 /* Record it in this_forall. */
3716 this_forall->var = var[n];
3717
3718 /* Replace the index symbol's backend_decl with the temporary decl. */
3719 sym->backend_decl = var[n];
3720
3721 /* Work out the start, end and stride for the loop. */
3722 gfc_init_se (&se, NULL);
3723 gfc_conv_expr_val (&se, fa->start);
3724 /* Record it in this_forall. */
3725 this_forall->start = se.expr;
3726 gfc_add_block_to_block (&block, &se.pre);
3727 start[n] = se.expr;
3728
3729 gfc_init_se (&se, NULL);
3730 gfc_conv_expr_val (&se, fa->end);
3731 /* Record it in this_forall. */
3732 this_forall->end = se.expr;
3733 gfc_make_safe_expr (&se);
3734 gfc_add_block_to_block (&block, &se.pre);
3735 end[n] = se.expr;
3736
3737 gfc_init_se (&se, NULL);
3738 gfc_conv_expr_val (&se, fa->stride);
3739 /* Record it in this_forall. */
3740 this_forall->step = se.expr;
3741 gfc_make_safe_expr (&se);
3742 gfc_add_block_to_block (&block, &se.pre);
3743 step[n] = se.expr;
3744
3745 /* Set the NEXT field of this_forall to NULL. */
3746 this_forall->next = NULL;
3747 /* Link this_forall to the info construct. */
3748 if (info->this_loop)
3749 {
3750 iter_info *iter_tmp = info->this_loop;
3751 while (iter_tmp->next != NULL)
3752 iter_tmp = iter_tmp->next;
3753 iter_tmp->next = this_forall;
3754 }
3755 else
3756 info->this_loop = this_forall;
3757
3758 n++;
3759 }
3760 nvar = n;
3761
3762 /* Calculate the size needed for the current forall level. */
3763 size = gfc_index_one_node;
3764 for (n = 0; n < nvar; n++)
3765 {
3766 /* size = (end + step - start) / step. */
3767 tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (start[n]),
3768 step[n], start[n]);
3769 tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (end[n]),
3770 end[n], tmp);
3771 tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR, TREE_TYPE (tmp),
3772 tmp, step[n]);
3773 tmp = convert (gfc_array_index_type, tmp);
3774
3775 size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
3776 size, tmp);
3777 }
3778
3779 /* Record the nvar and size of current forall level. */
3780 info->nvar = nvar;
3781 info->size = size;
3782
3783 if (code->expr1)
3784 {
3785 /* If the mask is .true., consider the FORALL unconditional. */
3786 if (code->expr1->expr_type == EXPR_CONSTANT
3787 && code->expr1->value.logical)
3788 need_mask = false;
3789 else
3790 need_mask = true;
3791 }
3792 else
3793 need_mask = false;
3794
3795 /* First we need to allocate the mask. */
3796 if (need_mask)
3797 {
3798 /* As the mask array can be very big, prefer compact boolean types. */
3799 tree mask_type = gfc_get_logical_type (gfc_logical_kinds[0].kind);
3800 mask = allocate_temp_for_forall_nest (nested_forall_info, mask_type,
3801 size, NULL, &block, &pmask);
3802 maskindex = gfc_create_var_np (gfc_array_index_type, "mi");
3803
3804 /* Record them in the info structure. */
3805 info->maskindex = maskindex;
3806 info->mask = mask;
3807 }
3808 else
3809 {
3810 /* No mask was specified. */
3811 maskindex = NULL_TREE;
3812 mask = pmask = NULL_TREE;
3813 }
3814
3815 /* Link the current forall level to nested_forall_info. */
3816 info->prev_nest = nested_forall_info;
3817 nested_forall_info = info;
3818
3819 /* Copy the mask into a temporary variable if required.
3820 For now we assume a mask temporary is needed. */
3821 if (need_mask)
3822 {
3823 /* As the mask array can be very big, prefer compact boolean types. */
3824 tree mask_type = gfc_get_logical_type (gfc_logical_kinds[0].kind);
3825
3826 gfc_add_modify (&block, maskindex, gfc_index_zero_node);
3827
3828 /* Start of mask assignment loop body. */
3829 gfc_start_block (&body);
3830
3831 /* Evaluate the mask expression. */
3832 gfc_init_se (&se, NULL);
3833 gfc_conv_expr_val (&se, code->expr1);
3834 gfc_add_block_to_block (&body, &se.pre);
3835
3836 /* Store the mask. */
3837 se.expr = convert (mask_type, se.expr);
3838
3839 tmp = gfc_build_array_ref (mask, maskindex, NULL);
3840 gfc_add_modify (&body, tmp, se.expr);
3841
3842 /* Advance to the next mask element. */
3843 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
3844 maskindex, gfc_index_one_node);
3845 gfc_add_modify (&body, maskindex, tmp);
3846
3847 /* Generate the loops. */
3848 tmp = gfc_finish_block (&body);
3849 tmp = gfc_trans_nested_forall_loop (info, tmp, 0);
3850 gfc_add_expr_to_block (&block, tmp);
3851 }
3852
3853 if (code->op == EXEC_DO_CONCURRENT)
3854 {
3855 gfc_init_block (&body);
3856 cycle_label = gfc_build_label_decl (NULL_TREE);
3857 code->cycle_label = cycle_label;
3858 tmp = gfc_trans_code (code->block->next);
3859 gfc_add_expr_to_block (&body, tmp);
3860
3861 if (TREE_USED (cycle_label))
3862 {
3863 tmp = build1_v (LABEL_EXPR, cycle_label);
3864 gfc_add_expr_to_block (&body, tmp);
3865 }
3866
3867 tmp = gfc_finish_block (&body);
3868 nested_forall_info->do_concurrent = true;
3869 tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
3870 gfc_add_expr_to_block (&block, tmp);
3871 goto done;
3872 }
3873
3874 c = code->block->next;
3875
3876 /* TODO: loop merging in FORALL statements. */
3877 /* Now that we've got a copy of the mask, generate the assignment loops. */
3878 while (c)
3879 {
3880 switch (c->op)
3881 {
3882 case EXEC_ASSIGN:
3883 /* A scalar or array assignment. DO the simple check for
3884 lhs to rhs dependencies. These make a temporary for the
3885 rhs and form a second forall block to copy to variable. */
3886 need_temp = check_forall_dependencies(c, &pre, &post);
3887
3888 /* Temporaries due to array assignment data dependencies introduce
3889 no end of problems. */
3890 if (need_temp)
3891 gfc_trans_assign_need_temp (c->expr1, c->expr2, NULL, false,
3892 nested_forall_info, &block);
3893 else
3894 {
3895 /* Use the normal assignment copying routines. */
3896 assign = gfc_trans_assignment (c->expr1, c->expr2, false, true);
3897
3898 /* Generate body and loops. */
3899 tmp = gfc_trans_nested_forall_loop (nested_forall_info,
3900 assign, 1);
3901 gfc_add_expr_to_block (&block, tmp);
3902 }
3903
3904 /* Cleanup any temporary symtrees that have been made to deal
3905 with dependencies. */
3906 if (new_symtree)
3907 cleanup_forall_symtrees (c);
3908
3909 break;
3910
3911 case EXEC_WHERE:
3912 /* Translate WHERE or WHERE construct nested in FORALL. */
3913 gfc_trans_where_2 (c, NULL, false, nested_forall_info, &block);
3914 break;
3915
3916 /* Pointer assignment inside FORALL. */
3917 case EXEC_POINTER_ASSIGN:
3918 need_temp = gfc_check_dependency (c->expr1, c->expr2, 0);
3919 if (need_temp)
3920 gfc_trans_pointer_assign_need_temp (c->expr1, c->expr2,
3921 nested_forall_info, &block);
3922 else
3923 {
3924 /* Use the normal assignment copying routines. */
3925 assign = gfc_trans_pointer_assignment (c->expr1, c->expr2);
3926
3927 /* Generate body and loops. */
3928 tmp = gfc_trans_nested_forall_loop (nested_forall_info,
3929 assign, 1);
3930 gfc_add_expr_to_block (&block, tmp);
3931 }
3932 break;
3933
3934 case EXEC_FORALL:
3935 tmp = gfc_trans_forall_1 (c, nested_forall_info);
3936 gfc_add_expr_to_block (&block, tmp);
3937 break;
3938
3939 /* Explicit subroutine calls are prevented by the frontend but interface
3940 assignments can legitimately produce them. */
3941 case EXEC_ASSIGN_CALL:
3942 assign = gfc_trans_call (c, true, NULL_TREE, NULL_TREE, false);
3943 tmp = gfc_trans_nested_forall_loop (nested_forall_info, assign, 1);
3944 gfc_add_expr_to_block (&block, tmp);
3945 break;
3946
3947 default:
3948 gcc_unreachable ();
3949 }
3950
3951 c = c->next;
3952 }
3953
3954 done:
3955 /* Restore the original index variables. */
3956 for (fa = code->ext.forall_iterator, n = 0; fa; fa = fa->next, n++)
3957 gfc_restore_sym (fa->var->symtree->n.sym, &saved_vars[n]);
3958
3959 /* Free the space for var, start, end, step, varexpr. */
3960 free (var);
3961 free (start);
3962 free (end);
3963 free (step);
3964 free (varexpr);
3965 free (saved_vars);
3966
3967 for (this_forall = info->this_loop; this_forall;)
3968 {
3969 iter_info *next = this_forall->next;
3970 free (this_forall);
3971 this_forall = next;
3972 }
3973
3974 /* Free the space for this forall_info. */
3975 free (info);
3976
3977 if (pmask)
3978 {
3979 /* Free the temporary for the mask. */
3980 tmp = gfc_call_free (pmask);
3981 gfc_add_expr_to_block (&block, tmp);
3982 }
3983 if (maskindex)
3984 pushdecl (maskindex);
3985
3986 gfc_add_block_to_block (&pre, &block);
3987 gfc_add_block_to_block (&pre, &post);
3988
3989 return gfc_finish_block (&pre);
3990 }
3991
3992
3993 /* Translate the FORALL statement or construct. */
3994
gfc_trans_forall(gfc_code * code)3995 tree gfc_trans_forall (gfc_code * code)
3996 {
3997 return gfc_trans_forall_1 (code, NULL);
3998 }
3999
4000
4001 /* Translate the DO CONCURRENT construct. */
4002
gfc_trans_do_concurrent(gfc_code * code)4003 tree gfc_trans_do_concurrent (gfc_code * code)
4004 {
4005 return gfc_trans_forall_1 (code, NULL);
4006 }
4007
4008
4009 /* Evaluate the WHERE mask expression, copy its value to a temporary.
4010 If the WHERE construct is nested in FORALL, compute the overall temporary
4011 needed by the WHERE mask expression multiplied by the iterator number of
4012 the nested forall.
4013 ME is the WHERE mask expression.
4014 MASK is the current execution mask upon input, whose sense may or may
4015 not be inverted as specified by the INVERT argument.
4016 CMASK is the updated execution mask on output, or NULL if not required.
4017 PMASK is the pending execution mask on output, or NULL if not required.
4018 BLOCK is the block in which to place the condition evaluation loops. */
4019
4020 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)4021 gfc_evaluate_where_mask (gfc_expr * me, forall_info * nested_forall_info,
4022 tree mask, bool invert, tree cmask, tree pmask,
4023 tree mask_type, stmtblock_t * block)
4024 {
4025 tree tmp, tmp1;
4026 gfc_ss *lss, *rss;
4027 gfc_loopinfo loop;
4028 stmtblock_t body, body1;
4029 tree count, cond, mtmp;
4030 gfc_se lse, rse;
4031
4032 gfc_init_loopinfo (&loop);
4033
4034 lss = gfc_walk_expr (me);
4035 rss = gfc_walk_expr (me);
4036
4037 /* Variable to index the temporary. */
4038 count = gfc_create_var (gfc_array_index_type, "count");
4039 /* Initialize count. */
4040 gfc_add_modify (block, count, gfc_index_zero_node);
4041
4042 gfc_start_block (&body);
4043
4044 gfc_init_se (&rse, NULL);
4045 gfc_init_se (&lse, NULL);
4046
4047 if (lss == gfc_ss_terminator)
4048 {
4049 gfc_init_block (&body1);
4050 }
4051 else
4052 {
4053 /* Initialize the loop. */
4054 gfc_init_loopinfo (&loop);
4055
4056 /* We may need LSS to determine the shape of the expression. */
4057 gfc_add_ss_to_loop (&loop, lss);
4058 gfc_add_ss_to_loop (&loop, rss);
4059
4060 gfc_conv_ss_startstride (&loop);
4061 gfc_conv_loop_setup (&loop, &me->where);
4062
4063 gfc_mark_ss_chain_used (rss, 1);
4064 /* Start the loop body. */
4065 gfc_start_scalarized_body (&loop, &body1);
4066
4067 /* Translate the expression. */
4068 gfc_copy_loopinfo_to_se (&rse, &loop);
4069 rse.ss = rss;
4070 gfc_conv_expr (&rse, me);
4071 }
4072
4073 /* Variable to evaluate mask condition. */
4074 cond = gfc_create_var (mask_type, "cond");
4075 if (mask && (cmask || pmask))
4076 mtmp = gfc_create_var (mask_type, "mask");
4077 else mtmp = NULL_TREE;
4078
4079 gfc_add_block_to_block (&body1, &lse.pre);
4080 gfc_add_block_to_block (&body1, &rse.pre);
4081
4082 gfc_add_modify (&body1, cond, fold_convert (mask_type, rse.expr));
4083
4084 if (mask && (cmask || pmask))
4085 {
4086 tmp = gfc_build_array_ref (mask, count, NULL);
4087 if (invert)
4088 tmp = fold_build1_loc (input_location, TRUTH_NOT_EXPR, mask_type, tmp);
4089 gfc_add_modify (&body1, mtmp, tmp);
4090 }
4091
4092 if (cmask)
4093 {
4094 tmp1 = gfc_build_array_ref (cmask, count, NULL);
4095 tmp = cond;
4096 if (mask)
4097 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, mask_type,
4098 mtmp, tmp);
4099 gfc_add_modify (&body1, tmp1, tmp);
4100 }
4101
4102 if (pmask)
4103 {
4104 tmp1 = gfc_build_array_ref (pmask, count, NULL);
4105 tmp = fold_build1_loc (input_location, TRUTH_NOT_EXPR, mask_type, cond);
4106 if (mask)
4107 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, mask_type, mtmp,
4108 tmp);
4109 gfc_add_modify (&body1, tmp1, tmp);
4110 }
4111
4112 gfc_add_block_to_block (&body1, &lse.post);
4113 gfc_add_block_to_block (&body1, &rse.post);
4114
4115 if (lss == gfc_ss_terminator)
4116 {
4117 gfc_add_block_to_block (&body, &body1);
4118 }
4119 else
4120 {
4121 /* Increment count. */
4122 tmp1 = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
4123 count, gfc_index_one_node);
4124 gfc_add_modify (&body1, count, tmp1);
4125
4126 /* Generate the copying loops. */
4127 gfc_trans_scalarizing_loops (&loop, &body1);
4128
4129 gfc_add_block_to_block (&body, &loop.pre);
4130 gfc_add_block_to_block (&body, &loop.post);
4131
4132 gfc_cleanup_loop (&loop);
4133 /* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful
4134 as tree nodes in SS may not be valid in different scope. */
4135 }
4136
4137 tmp1 = gfc_finish_block (&body);
4138 /* If the WHERE construct is inside FORALL, fill the full temporary. */
4139 if (nested_forall_info != NULL)
4140 tmp1 = gfc_trans_nested_forall_loop (nested_forall_info, tmp1, 1);
4141
4142 gfc_add_expr_to_block (block, tmp1);
4143 }
4144
4145
4146 /* Translate an assignment statement in a WHERE statement or construct
4147 statement. The MASK expression is used to control which elements
4148 of EXPR1 shall be assigned. The sense of MASK is specified by
4149 INVERT. */
4150
4151 static tree
gfc_trans_where_assign(gfc_expr * expr1,gfc_expr * expr2,tree mask,bool invert,tree count1,tree count2,gfc_code * cnext)4152 gfc_trans_where_assign (gfc_expr *expr1, gfc_expr *expr2,
4153 tree mask, bool invert,
4154 tree count1, tree count2,
4155 gfc_code *cnext)
4156 {
4157 gfc_se lse;
4158 gfc_se rse;
4159 gfc_ss *lss;
4160 gfc_ss *lss_section;
4161 gfc_ss *rss;
4162
4163 gfc_loopinfo loop;
4164 tree tmp;
4165 stmtblock_t block;
4166 stmtblock_t body;
4167 tree index, maskexpr;
4168
4169 /* A defined assignment. */
4170 if (cnext && cnext->resolved_sym)
4171 return gfc_trans_call (cnext, true, mask, count1, invert);
4172
4173 #if 0
4174 /* TODO: handle this special case.
4175 Special case a single function returning an array. */
4176 if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
4177 {
4178 tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
4179 if (tmp)
4180 return tmp;
4181 }
4182 #endif
4183
4184 /* Assignment of the form lhs = rhs. */
4185 gfc_start_block (&block);
4186
4187 gfc_init_se (&lse, NULL);
4188 gfc_init_se (&rse, NULL);
4189
4190 /* Walk the lhs. */
4191 lss = gfc_walk_expr (expr1);
4192 rss = NULL;
4193
4194 /* In each where-assign-stmt, the mask-expr and the variable being
4195 defined shall be arrays of the same shape. */
4196 gcc_assert (lss != gfc_ss_terminator);
4197
4198 /* The assignment needs scalarization. */
4199 lss_section = lss;
4200
4201 /* Find a non-scalar SS from the lhs. */
4202 while (lss_section != gfc_ss_terminator
4203 && lss_section->info->type != GFC_SS_SECTION)
4204 lss_section = lss_section->next;
4205
4206 gcc_assert (lss_section != gfc_ss_terminator);
4207
4208 /* Initialize the scalarizer. */
4209 gfc_init_loopinfo (&loop);
4210
4211 /* Walk the rhs. */
4212 rss = gfc_walk_expr (expr2);
4213 if (rss == gfc_ss_terminator)
4214 {
4215 /* The rhs is scalar. Add a ss for the expression. */
4216 rss = gfc_get_scalar_ss (gfc_ss_terminator, expr2);
4217 rss->info->where = 1;
4218 }
4219
4220 /* Associate the SS with the loop. */
4221 gfc_add_ss_to_loop (&loop, lss);
4222 gfc_add_ss_to_loop (&loop, rss);
4223
4224 /* Calculate the bounds of the scalarization. */
4225 gfc_conv_ss_startstride (&loop);
4226
4227 /* Resolve any data dependencies in the statement. */
4228 gfc_conv_resolve_dependencies (&loop, lss_section, rss);
4229
4230 /* Setup the scalarizing loops. */
4231 gfc_conv_loop_setup (&loop, &expr2->where);
4232
4233 /* Setup the gfc_se structures. */
4234 gfc_copy_loopinfo_to_se (&lse, &loop);
4235 gfc_copy_loopinfo_to_se (&rse, &loop);
4236
4237 rse.ss = rss;
4238 gfc_mark_ss_chain_used (rss, 1);
4239 if (loop.temp_ss == NULL)
4240 {
4241 lse.ss = lss;
4242 gfc_mark_ss_chain_used (lss, 1);
4243 }
4244 else
4245 {
4246 lse.ss = loop.temp_ss;
4247 gfc_mark_ss_chain_used (lss, 3);
4248 gfc_mark_ss_chain_used (loop.temp_ss, 3);
4249 }
4250
4251 /* Start the scalarized loop body. */
4252 gfc_start_scalarized_body (&loop, &body);
4253
4254 /* Translate the expression. */
4255 gfc_conv_expr (&rse, expr2);
4256 if (lss != gfc_ss_terminator && loop.temp_ss != NULL)
4257 gfc_conv_tmp_array_ref (&lse);
4258 else
4259 gfc_conv_expr (&lse, expr1);
4260
4261 /* Form the mask expression according to the mask. */
4262 index = count1;
4263 maskexpr = gfc_build_array_ref (mask, index, NULL);
4264 if (invert)
4265 maskexpr = fold_build1_loc (input_location, TRUTH_NOT_EXPR,
4266 TREE_TYPE (maskexpr), maskexpr);
4267
4268 /* Use the scalar assignment as is. */
4269 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
4270 loop.temp_ss != NULL, false, true);
4271
4272 tmp = build3_v (COND_EXPR, maskexpr, tmp, build_empty_stmt (input_location));
4273
4274 gfc_add_expr_to_block (&body, tmp);
4275
4276 if (lss == gfc_ss_terminator)
4277 {
4278 /* Increment count1. */
4279 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
4280 count1, gfc_index_one_node);
4281 gfc_add_modify (&body, count1, tmp);
4282
4283 /* Use the scalar assignment as is. */
4284 gfc_add_block_to_block (&block, &body);
4285 }
4286 else
4287 {
4288 gcc_assert (lse.ss == gfc_ss_terminator
4289 && rse.ss == gfc_ss_terminator);
4290
4291 if (loop.temp_ss != NULL)
4292 {
4293 /* Increment count1 before finish the main body of a scalarized
4294 expression. */
4295 tmp = fold_build2_loc (input_location, PLUS_EXPR,
4296 gfc_array_index_type, count1, gfc_index_one_node);
4297 gfc_add_modify (&body, count1, tmp);
4298 gfc_trans_scalarized_loop_boundary (&loop, &body);
4299
4300 /* We need to copy the temporary to the actual lhs. */
4301 gfc_init_se (&lse, NULL);
4302 gfc_init_se (&rse, NULL);
4303 gfc_copy_loopinfo_to_se (&lse, &loop);
4304 gfc_copy_loopinfo_to_se (&rse, &loop);
4305
4306 rse.ss = loop.temp_ss;
4307 lse.ss = lss;
4308
4309 gfc_conv_tmp_array_ref (&rse);
4310 gfc_conv_expr (&lse, expr1);
4311
4312 gcc_assert (lse.ss == gfc_ss_terminator
4313 && rse.ss == gfc_ss_terminator);
4314
4315 /* Form the mask expression according to the mask tree list. */
4316 index = count2;
4317 maskexpr = gfc_build_array_ref (mask, index, NULL);
4318 if (invert)
4319 maskexpr = fold_build1_loc (input_location, TRUTH_NOT_EXPR,
4320 TREE_TYPE (maskexpr), maskexpr);
4321
4322 /* Use the scalar assignment as is. */
4323 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts, false, false,
4324 true);
4325 tmp = build3_v (COND_EXPR, maskexpr, tmp,
4326 build_empty_stmt (input_location));
4327 gfc_add_expr_to_block (&body, tmp);
4328
4329 /* Increment count2. */
4330 tmp = fold_build2_loc (input_location, PLUS_EXPR,
4331 gfc_array_index_type, count2,
4332 gfc_index_one_node);
4333 gfc_add_modify (&body, count2, tmp);
4334 }
4335 else
4336 {
4337 /* Increment count1. */
4338 tmp = fold_build2_loc (input_location, PLUS_EXPR,
4339 gfc_array_index_type, count1,
4340 gfc_index_one_node);
4341 gfc_add_modify (&body, count1, tmp);
4342 }
4343
4344 /* Generate the copying loops. */
4345 gfc_trans_scalarizing_loops (&loop, &body);
4346
4347 /* Wrap the whole thing up. */
4348 gfc_add_block_to_block (&block, &loop.pre);
4349 gfc_add_block_to_block (&block, &loop.post);
4350 gfc_cleanup_loop (&loop);
4351 }
4352
4353 return gfc_finish_block (&block);
4354 }
4355
4356
4357 /* Translate the WHERE construct or statement.
4358 This function can be called iteratively to translate the nested WHERE
4359 construct or statement.
4360 MASK is the control mask. */
4361
4362 static void
gfc_trans_where_2(gfc_code * code,tree mask,bool invert,forall_info * nested_forall_info,stmtblock_t * block)4363 gfc_trans_where_2 (gfc_code * code, tree mask, bool invert,
4364 forall_info * nested_forall_info, stmtblock_t * block)
4365 {
4366 stmtblock_t inner_size_body;
4367 tree inner_size, size;
4368 gfc_ss *lss, *rss;
4369 tree mask_type;
4370 gfc_expr *expr1;
4371 gfc_expr *expr2;
4372 gfc_code *cblock;
4373 gfc_code *cnext;
4374 tree tmp;
4375 tree cond;
4376 tree count1, count2;
4377 bool need_cmask;
4378 bool need_pmask;
4379 int need_temp;
4380 tree pcmask = NULL_TREE;
4381 tree ppmask = NULL_TREE;
4382 tree cmask = NULL_TREE;
4383 tree pmask = NULL_TREE;
4384 gfc_actual_arglist *arg;
4385
4386 /* the WHERE statement or the WHERE construct statement. */
4387 cblock = code->block;
4388
4389 /* As the mask array can be very big, prefer compact boolean types. */
4390 mask_type = gfc_get_logical_type (gfc_logical_kinds[0].kind);
4391
4392 /* Determine which temporary masks are needed. */
4393 if (!cblock->block)
4394 {
4395 /* One clause: No ELSEWHEREs. */
4396 need_cmask = (cblock->next != 0);
4397 need_pmask = false;
4398 }
4399 else if (cblock->block->block)
4400 {
4401 /* Three or more clauses: Conditional ELSEWHEREs. */
4402 need_cmask = true;
4403 need_pmask = true;
4404 }
4405 else if (cblock->next)
4406 {
4407 /* Two clauses, the first non-empty. */
4408 need_cmask = true;
4409 need_pmask = (mask != NULL_TREE
4410 && cblock->block->next != 0);
4411 }
4412 else if (!cblock->block->next)
4413 {
4414 /* Two clauses, both empty. */
4415 need_cmask = false;
4416 need_pmask = false;
4417 }
4418 /* Two clauses, the first empty, the second non-empty. */
4419 else if (mask)
4420 {
4421 need_cmask = (cblock->block->expr1 != 0);
4422 need_pmask = true;
4423 }
4424 else
4425 {
4426 need_cmask = true;
4427 need_pmask = false;
4428 }
4429
4430 if (need_cmask || need_pmask)
4431 {
4432 /* Calculate the size of temporary needed by the mask-expr. */
4433 gfc_init_block (&inner_size_body);
4434 inner_size = compute_inner_temp_size (cblock->expr1, cblock->expr1,
4435 &inner_size_body, &lss, &rss);
4436
4437 gfc_free_ss_chain (lss);
4438 gfc_free_ss_chain (rss);
4439
4440 /* Calculate the total size of temporary needed. */
4441 size = compute_overall_iter_number (nested_forall_info, inner_size,
4442 &inner_size_body, block);
4443
4444 /* Check whether the size is negative. */
4445 cond = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, size,
4446 gfc_index_zero_node);
4447 size = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type,
4448 cond, gfc_index_zero_node, size);
4449 size = gfc_evaluate_now (size, block);
4450
4451 /* Allocate temporary for WHERE mask if needed. */
4452 if (need_cmask)
4453 cmask = allocate_temp_for_forall_nest_1 (mask_type, size, block,
4454 &pcmask);
4455
4456 /* Allocate temporary for !mask if needed. */
4457 if (need_pmask)
4458 pmask = allocate_temp_for_forall_nest_1 (mask_type, size, block,
4459 &ppmask);
4460 }
4461
4462 while (cblock)
4463 {
4464 /* Each time around this loop, the where clause is conditional
4465 on the value of mask and invert, which are updated at the
4466 bottom of the loop. */
4467
4468 /* Has mask-expr. */
4469 if (cblock->expr1)
4470 {
4471 /* Ensure that the WHERE mask will be evaluated exactly once.
4472 If there are no statements in this WHERE/ELSEWHERE clause,
4473 then we don't need to update the control mask (cmask).
4474 If this is the last clause of the WHERE construct, then
4475 we don't need to update the pending control mask (pmask). */
4476 if (mask)
4477 gfc_evaluate_where_mask (cblock->expr1, nested_forall_info,
4478 mask, invert,
4479 cblock->next ? cmask : NULL_TREE,
4480 cblock->block ? pmask : NULL_TREE,
4481 mask_type, block);
4482 else
4483 gfc_evaluate_where_mask (cblock->expr1, nested_forall_info,
4484 NULL_TREE, false,
4485 (cblock->next || cblock->block)
4486 ? cmask : NULL_TREE,
4487 NULL_TREE, mask_type, block);
4488
4489 invert = false;
4490 }
4491 /* It's a final elsewhere-stmt. No mask-expr is present. */
4492 else
4493 cmask = mask;
4494
4495 /* The body of this where clause are controlled by cmask with
4496 sense specified by invert. */
4497
4498 /* Get the assignment statement of a WHERE statement, or the first
4499 statement in where-body-construct of a WHERE construct. */
4500 cnext = cblock->next;
4501 while (cnext)
4502 {
4503 switch (cnext->op)
4504 {
4505 /* WHERE assignment statement. */
4506 case EXEC_ASSIGN_CALL:
4507
4508 arg = cnext->ext.actual;
4509 expr1 = expr2 = NULL;
4510 for (; arg; arg = arg->next)
4511 {
4512 if (!arg->expr)
4513 continue;
4514 if (expr1 == NULL)
4515 expr1 = arg->expr;
4516 else
4517 expr2 = arg->expr;
4518 }
4519 goto evaluate;
4520
4521 case EXEC_ASSIGN:
4522 expr1 = cnext->expr1;
4523 expr2 = cnext->expr2;
4524 evaluate:
4525 if (nested_forall_info != NULL)
4526 {
4527 need_temp = gfc_check_dependency (expr1, expr2, 0);
4528 if (need_temp && cnext->op != EXEC_ASSIGN_CALL)
4529 gfc_trans_assign_need_temp (expr1, expr2,
4530 cmask, invert,
4531 nested_forall_info, block);
4532 else
4533 {
4534 /* Variables to control maskexpr. */
4535 count1 = gfc_create_var (gfc_array_index_type, "count1");
4536 count2 = gfc_create_var (gfc_array_index_type, "count2");
4537 gfc_add_modify (block, count1, gfc_index_zero_node);
4538 gfc_add_modify (block, count2, gfc_index_zero_node);
4539
4540 tmp = gfc_trans_where_assign (expr1, expr2,
4541 cmask, invert,
4542 count1, count2,
4543 cnext);
4544
4545 tmp = gfc_trans_nested_forall_loop (nested_forall_info,
4546 tmp, 1);
4547 gfc_add_expr_to_block (block, tmp);
4548 }
4549 }
4550 else
4551 {
4552 /* Variables to control maskexpr. */
4553 count1 = gfc_create_var (gfc_array_index_type, "count1");
4554 count2 = gfc_create_var (gfc_array_index_type, "count2");
4555 gfc_add_modify (block, count1, gfc_index_zero_node);
4556 gfc_add_modify (block, count2, gfc_index_zero_node);
4557
4558 tmp = gfc_trans_where_assign (expr1, expr2,
4559 cmask, invert,
4560 count1, count2,
4561 cnext);
4562 gfc_add_expr_to_block (block, tmp);
4563
4564 }
4565 break;
4566
4567 /* WHERE or WHERE construct is part of a where-body-construct. */
4568 case EXEC_WHERE:
4569 gfc_trans_where_2 (cnext, cmask, invert,
4570 nested_forall_info, block);
4571 break;
4572
4573 default:
4574 gcc_unreachable ();
4575 }
4576
4577 /* The next statement within the same where-body-construct. */
4578 cnext = cnext->next;
4579 }
4580 /* The next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt. */
4581 cblock = cblock->block;
4582 if (mask == NULL_TREE)
4583 {
4584 /* If we're the initial WHERE, we can simply invert the sense
4585 of the current mask to obtain the "mask" for the remaining
4586 ELSEWHEREs. */
4587 invert = true;
4588 mask = cmask;
4589 }
4590 else
4591 {
4592 /* Otherwise, for nested WHERE's we need to use the pending mask. */
4593 invert = false;
4594 mask = pmask;
4595 }
4596 }
4597
4598 /* If we allocated a pending mask array, deallocate it now. */
4599 if (ppmask)
4600 {
4601 tmp = gfc_call_free (ppmask);
4602 gfc_add_expr_to_block (block, tmp);
4603 }
4604
4605 /* If we allocated a current mask array, deallocate it now. */
4606 if (pcmask)
4607 {
4608 tmp = gfc_call_free (pcmask);
4609 gfc_add_expr_to_block (block, tmp);
4610 }
4611 }
4612
4613 /* Translate a simple WHERE construct or statement without dependencies.
4614 CBLOCK is the "then" clause of the WHERE statement, where CBLOCK->EXPR
4615 is the mask condition, and EBLOCK if non-NULL is the "else" clause.
4616 Currently both CBLOCK and EBLOCK are restricted to single assignments. */
4617
4618 static tree
gfc_trans_where_3(gfc_code * cblock,gfc_code * eblock)4619 gfc_trans_where_3 (gfc_code * cblock, gfc_code * eblock)
4620 {
4621 stmtblock_t block, body;
4622 gfc_expr *cond, *tdst, *tsrc, *edst, *esrc;
4623 tree tmp, cexpr, tstmt, estmt;
4624 gfc_ss *css, *tdss, *tsss;
4625 gfc_se cse, tdse, tsse, edse, esse;
4626 gfc_loopinfo loop;
4627 gfc_ss *edss = 0;
4628 gfc_ss *esss = 0;
4629
4630 /* Allow the scalarizer to workshare simple where loops. */
4631 if (ompws_flags & OMPWS_WORKSHARE_FLAG)
4632 ompws_flags |= OMPWS_SCALARIZER_WS;
4633
4634 cond = cblock->expr1;
4635 tdst = cblock->next->expr1;
4636 tsrc = cblock->next->expr2;
4637 edst = eblock ? eblock->next->expr1 : NULL;
4638 esrc = eblock ? eblock->next->expr2 : NULL;
4639
4640 gfc_start_block (&block);
4641 gfc_init_loopinfo (&loop);
4642
4643 /* Handle the condition. */
4644 gfc_init_se (&cse, NULL);
4645 css = gfc_walk_expr (cond);
4646 gfc_add_ss_to_loop (&loop, css);
4647
4648 /* Handle the then-clause. */
4649 gfc_init_se (&tdse, NULL);
4650 gfc_init_se (&tsse, NULL);
4651 tdss = gfc_walk_expr (tdst);
4652 tsss = gfc_walk_expr (tsrc);
4653 if (tsss == gfc_ss_terminator)
4654 {
4655 tsss = gfc_get_scalar_ss (gfc_ss_terminator, tsrc);
4656 tsss->info->where = 1;
4657 }
4658 gfc_add_ss_to_loop (&loop, tdss);
4659 gfc_add_ss_to_loop (&loop, tsss);
4660
4661 if (eblock)
4662 {
4663 /* Handle the else clause. */
4664 gfc_init_se (&edse, NULL);
4665 gfc_init_se (&esse, NULL);
4666 edss = gfc_walk_expr (edst);
4667 esss = gfc_walk_expr (esrc);
4668 if (esss == gfc_ss_terminator)
4669 {
4670 esss = gfc_get_scalar_ss (gfc_ss_terminator, esrc);
4671 esss->info->where = 1;
4672 }
4673 gfc_add_ss_to_loop (&loop, edss);
4674 gfc_add_ss_to_loop (&loop, esss);
4675 }
4676
4677 gfc_conv_ss_startstride (&loop);
4678 gfc_conv_loop_setup (&loop, &tdst->where);
4679
4680 gfc_mark_ss_chain_used (css, 1);
4681 gfc_mark_ss_chain_used (tdss, 1);
4682 gfc_mark_ss_chain_used (tsss, 1);
4683 if (eblock)
4684 {
4685 gfc_mark_ss_chain_used (edss, 1);
4686 gfc_mark_ss_chain_used (esss, 1);
4687 }
4688
4689 gfc_start_scalarized_body (&loop, &body);
4690
4691 gfc_copy_loopinfo_to_se (&cse, &loop);
4692 gfc_copy_loopinfo_to_se (&tdse, &loop);
4693 gfc_copy_loopinfo_to_se (&tsse, &loop);
4694 cse.ss = css;
4695 tdse.ss = tdss;
4696 tsse.ss = tsss;
4697 if (eblock)
4698 {
4699 gfc_copy_loopinfo_to_se (&edse, &loop);
4700 gfc_copy_loopinfo_to_se (&esse, &loop);
4701 edse.ss = edss;
4702 esse.ss = esss;
4703 }
4704
4705 gfc_conv_expr (&cse, cond);
4706 gfc_add_block_to_block (&body, &cse.pre);
4707 cexpr = cse.expr;
4708
4709 gfc_conv_expr (&tsse, tsrc);
4710 if (tdss != gfc_ss_terminator && loop.temp_ss != NULL)
4711 gfc_conv_tmp_array_ref (&tdse);
4712 else
4713 gfc_conv_expr (&tdse, tdst);
4714
4715 if (eblock)
4716 {
4717 gfc_conv_expr (&esse, esrc);
4718 if (edss != gfc_ss_terminator && loop.temp_ss != NULL)
4719 gfc_conv_tmp_array_ref (&edse);
4720 else
4721 gfc_conv_expr (&edse, edst);
4722 }
4723
4724 tstmt = gfc_trans_scalar_assign (&tdse, &tsse, tdst->ts, false, false, true);
4725 estmt = eblock ? gfc_trans_scalar_assign (&edse, &esse, edst->ts, false,
4726 false, true)
4727 : build_empty_stmt (input_location);
4728 tmp = build3_v (COND_EXPR, cexpr, tstmt, estmt);
4729 gfc_add_expr_to_block (&body, tmp);
4730 gfc_add_block_to_block (&body, &cse.post);
4731
4732 gfc_trans_scalarizing_loops (&loop, &body);
4733 gfc_add_block_to_block (&block, &loop.pre);
4734 gfc_add_block_to_block (&block, &loop.post);
4735 gfc_cleanup_loop (&loop);
4736
4737 return gfc_finish_block (&block);
4738 }
4739
4740 /* As the WHERE or WHERE construct statement can be nested, we call
4741 gfc_trans_where_2 to do the translation, and pass the initial
4742 NULL values for both the control mask and the pending control mask. */
4743
4744 tree
gfc_trans_where(gfc_code * code)4745 gfc_trans_where (gfc_code * code)
4746 {
4747 stmtblock_t block;
4748 gfc_code *cblock;
4749 gfc_code *eblock;
4750
4751 cblock = code->block;
4752 if (cblock->next
4753 && cblock->next->op == EXEC_ASSIGN
4754 && !cblock->next->next)
4755 {
4756 eblock = cblock->block;
4757 if (!eblock)
4758 {
4759 /* A simple "WHERE (cond) x = y" statement or block is
4760 dependence free if cond is not dependent upon writing x,
4761 and the source y is unaffected by the destination x. */
4762 if (!gfc_check_dependency (cblock->next->expr1,
4763 cblock->expr1, 0)
4764 && !gfc_check_dependency (cblock->next->expr1,
4765 cblock->next->expr2, 0))
4766 return gfc_trans_where_3 (cblock, NULL);
4767 }
4768 else if (!eblock->expr1
4769 && !eblock->block
4770 && eblock->next
4771 && eblock->next->op == EXEC_ASSIGN
4772 && !eblock->next->next)
4773 {
4774 /* A simple "WHERE (cond) x1 = y1 ELSEWHERE x2 = y2 ENDWHERE"
4775 block is dependence free if cond is not dependent on writes
4776 to x1 and x2, y1 is not dependent on writes to x2, and y2
4777 is not dependent on writes to x1, and both y's are not
4778 dependent upon their own x's. In addition to this, the
4779 final two dependency checks below exclude all but the same
4780 array reference if the where and elswhere destinations
4781 are the same. In short, this is VERY conservative and this
4782 is needed because the two loops, required by the standard
4783 are coalesced in gfc_trans_where_3. */
4784 if (!gfc_check_dependency (cblock->next->expr1,
4785 cblock->expr1, 0)
4786 && !gfc_check_dependency (eblock->next->expr1,
4787 cblock->expr1, 0)
4788 && !gfc_check_dependency (cblock->next->expr1,
4789 eblock->next->expr2, 1)
4790 && !gfc_check_dependency (eblock->next->expr1,
4791 cblock->next->expr2, 1)
4792 && !gfc_check_dependency (cblock->next->expr1,
4793 cblock->next->expr2, 1)
4794 && !gfc_check_dependency (eblock->next->expr1,
4795 eblock->next->expr2, 1)
4796 && !gfc_check_dependency (cblock->next->expr1,
4797 eblock->next->expr1, 0)
4798 && !gfc_check_dependency (eblock->next->expr1,
4799 cblock->next->expr1, 0))
4800 return gfc_trans_where_3 (cblock, eblock);
4801 }
4802 }
4803
4804 gfc_start_block (&block);
4805
4806 gfc_trans_where_2 (code, NULL, false, NULL, &block);
4807
4808 return gfc_finish_block (&block);
4809 }
4810
4811
4812 /* CYCLE a DO loop. The label decl has already been created by
4813 gfc_trans_do(), it's in TREE_PURPOSE (backend_decl) of the gfc_code
4814 node at the head of the loop. We must mark the label as used. */
4815
4816 tree
gfc_trans_cycle(gfc_code * code)4817 gfc_trans_cycle (gfc_code * code)
4818 {
4819 tree cycle_label;
4820
4821 cycle_label = code->ext.which_construct->cycle_label;
4822 gcc_assert (cycle_label);
4823
4824 TREE_USED (cycle_label) = 1;
4825 return build1_v (GOTO_EXPR, cycle_label);
4826 }
4827
4828
4829 /* EXIT a DO loop. Similar to CYCLE, but now the label is in
4830 TREE_VALUE (backend_decl) of the gfc_code node at the head of the
4831 loop. */
4832
4833 tree
gfc_trans_exit(gfc_code * code)4834 gfc_trans_exit (gfc_code * code)
4835 {
4836 tree exit_label;
4837
4838 exit_label = code->ext.which_construct->exit_label;
4839 gcc_assert (exit_label);
4840
4841 TREE_USED (exit_label) = 1;
4842 return build1_v (GOTO_EXPR, exit_label);
4843 }
4844
4845
4846 /* Translate the ALLOCATE statement. */
4847
4848 tree
gfc_trans_allocate(gfc_code * code)4849 gfc_trans_allocate (gfc_code * code)
4850 {
4851 gfc_alloc *al;
4852 gfc_expr *e;
4853 gfc_expr *expr;
4854 gfc_se se;
4855 tree tmp;
4856 tree parm;
4857 tree stat;
4858 tree errmsg;
4859 tree errlen;
4860 tree label_errmsg;
4861 tree label_finish;
4862 tree memsz;
4863 tree expr3;
4864 tree slen3;
4865 stmtblock_t block;
4866 stmtblock_t post;
4867 gfc_expr *sz;
4868 gfc_se se_sz;
4869 tree class_expr;
4870 tree nelems;
4871 tree memsize = NULL_TREE;
4872 tree classexpr = NULL_TREE;
4873
4874 if (!code->ext.alloc.list)
4875 return NULL_TREE;
4876
4877 stat = tmp = memsz = NULL_TREE;
4878 label_errmsg = label_finish = errmsg = errlen = NULL_TREE;
4879
4880 gfc_init_block (&block);
4881 gfc_init_block (&post);
4882
4883 /* STAT= (and maybe ERRMSG=) is present. */
4884 if (code->expr1)
4885 {
4886 /* STAT=. */
4887 tree gfc_int4_type_node = gfc_get_int_type (4);
4888 stat = gfc_create_var (gfc_int4_type_node, "stat");
4889
4890 /* ERRMSG= only makes sense with STAT=. */
4891 if (code->expr2)
4892 {
4893 gfc_init_se (&se, NULL);
4894 se.want_pointer = 1;
4895 gfc_conv_expr_lhs (&se, code->expr2);
4896 errmsg = se.expr;
4897 errlen = se.string_length;
4898 }
4899 else
4900 {
4901 errmsg = null_pointer_node;
4902 errlen = build_int_cst (gfc_charlen_type_node, 0);
4903 }
4904
4905 /* GOTO destinations. */
4906 label_errmsg = gfc_build_label_decl (NULL_TREE);
4907 label_finish = gfc_build_label_decl (NULL_TREE);
4908 TREE_USED (label_finish) = 0;
4909 }
4910
4911 expr3 = NULL_TREE;
4912 slen3 = NULL_TREE;
4913
4914 for (al = code->ext.alloc.list; al != NULL; al = al->next)
4915 {
4916 expr = gfc_copy_expr (al->expr);
4917
4918 if (expr->ts.type == BT_CLASS)
4919 gfc_add_data_component (expr);
4920
4921 gfc_init_se (&se, NULL);
4922
4923 se.want_pointer = 1;
4924 se.descriptor_only = 1;
4925 gfc_conv_expr (&se, expr);
4926
4927 /* Evaluate expr3 just once if not a variable. */
4928 if (al == code->ext.alloc.list
4929 && al->expr->ts.type == BT_CLASS
4930 && code->expr3
4931 && code->expr3->ts.type == BT_CLASS
4932 && code->expr3->expr_type != EXPR_VARIABLE)
4933 {
4934 gfc_init_se (&se_sz, NULL);
4935 gfc_conv_expr_reference (&se_sz, code->expr3);
4936 gfc_conv_class_to_class (&se_sz, code->expr3,
4937 code->expr3->ts, false, true, false, false);
4938 gfc_add_block_to_block (&se.pre, &se_sz.pre);
4939 gfc_add_block_to_block (&se.post, &se_sz.post);
4940 classexpr = build_fold_indirect_ref_loc (input_location,
4941 se_sz.expr);
4942 classexpr = gfc_evaluate_now (classexpr, &se.pre);
4943 memsize = gfc_vtable_size_get (classexpr);
4944 memsize = fold_convert (sizetype, memsize);
4945 }
4946
4947 memsz = memsize;
4948 class_expr = classexpr;
4949
4950 nelems = NULL_TREE;
4951 if (!gfc_array_allocate (&se, expr, stat, errmsg, errlen, label_finish,
4952 memsz, &nelems, code->expr3, &code->ext.alloc.ts))
4953 {
4954 bool unlimited_char;
4955
4956 unlimited_char = UNLIMITED_POLY (al->expr)
4957 && ((code->expr3 && code->expr3->ts.type == BT_CHARACTER)
4958 || (code->ext.alloc.ts.type == BT_CHARACTER
4959 && code->ext.alloc.ts.u.cl
4960 && code->ext.alloc.ts.u.cl->length));
4961
4962 /* A scalar or derived type. */
4963
4964 /* Determine allocate size. */
4965 if (al->expr->ts.type == BT_CLASS
4966 && !unlimited_char
4967 && code->expr3
4968 && memsz == NULL_TREE)
4969 {
4970 if (code->expr3->ts.type == BT_CLASS)
4971 {
4972 sz = gfc_copy_expr (code->expr3);
4973 gfc_add_vptr_component (sz);
4974 gfc_add_size_component (sz);
4975 gfc_init_se (&se_sz, NULL);
4976 gfc_conv_expr (&se_sz, sz);
4977 gfc_free_expr (sz);
4978 memsz = se_sz.expr;
4979 }
4980 else
4981 memsz = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->expr3->ts));
4982 }
4983 else if (((al->expr->ts.type == BT_CHARACTER && al->expr->ts.deferred)
4984 || unlimited_char) && code->expr3)
4985 {
4986 if (!code->expr3->ts.u.cl->backend_decl)
4987 {
4988 /* Convert and use the length expression. */
4989 gfc_init_se (&se_sz, NULL);
4990 if (code->expr3->expr_type == EXPR_VARIABLE
4991 || code->expr3->expr_type == EXPR_CONSTANT)
4992 {
4993 gfc_conv_expr (&se_sz, code->expr3);
4994 gfc_add_block_to_block (&se.pre, &se_sz.pre);
4995 se_sz.string_length
4996 = gfc_evaluate_now (se_sz.string_length, &se.pre);
4997 gfc_add_block_to_block (&se.pre, &se_sz.post);
4998 memsz = se_sz.string_length;
4999 }
5000 else if (code->expr3->mold
5001 && code->expr3->ts.u.cl
5002 && code->expr3->ts.u.cl->length)
5003 {
5004 gfc_conv_expr (&se_sz, code->expr3->ts.u.cl->length);
5005 gfc_add_block_to_block (&se.pre, &se_sz.pre);
5006 se_sz.expr = gfc_evaluate_now (se_sz.expr, &se.pre);
5007 gfc_add_block_to_block (&se.pre, &se_sz.post);
5008 memsz = se_sz.expr;
5009 }
5010 else
5011 {
5012 /* This is would be inefficient and possibly could
5013 generate wrong code if the result were not stored
5014 in expr3/slen3. */
5015 if (slen3 == NULL_TREE)
5016 {
5017 gfc_conv_expr (&se_sz, code->expr3);
5018 gfc_add_block_to_block (&se.pre, &se_sz.pre);
5019 expr3 = gfc_evaluate_now (se_sz.expr, &se.pre);
5020 gfc_add_block_to_block (&post, &se_sz.post);
5021 slen3 = gfc_evaluate_now (se_sz.string_length,
5022 &se.pre);
5023 }
5024 memsz = slen3;
5025 }
5026 }
5027 else
5028 /* Otherwise use the stored string length. */
5029 memsz = code->expr3->ts.u.cl->backend_decl;
5030 tmp = al->expr->ts.u.cl->backend_decl;
5031
5032 /* Store the string length. */
5033 if (tmp && TREE_CODE (tmp) == VAR_DECL)
5034 gfc_add_modify (&se.pre, tmp, fold_convert (TREE_TYPE (tmp),
5035 memsz));
5036 else if (al->expr->ts.type == BT_CHARACTER
5037 && al->expr->ts.deferred && se.string_length)
5038 gfc_add_modify (&se.pre, se.string_length,
5039 fold_convert (TREE_TYPE (se.string_length),
5040 memsz));
5041
5042 /* Convert to size in bytes, using the character KIND. */
5043 if (unlimited_char)
5044 tmp = TREE_TYPE (gfc_typenode_for_spec (&code->expr3->ts));
5045 else
5046 tmp = TREE_TYPE (gfc_typenode_for_spec (&al->expr->ts));
5047 tmp = TYPE_SIZE_UNIT (tmp);
5048 memsz = fold_build2_loc (input_location, MULT_EXPR,
5049 TREE_TYPE (tmp), tmp,
5050 fold_convert (TREE_TYPE (tmp), memsz));
5051 }
5052 else if ((al->expr->ts.type == BT_CHARACTER && al->expr->ts.deferred)
5053 || unlimited_char)
5054 {
5055 gcc_assert (code->ext.alloc.ts.u.cl && code->ext.alloc.ts.u.cl->length);
5056 gfc_init_se (&se_sz, NULL);
5057 gfc_conv_expr (&se_sz, code->ext.alloc.ts.u.cl->length);
5058 gfc_add_block_to_block (&se.pre, &se_sz.pre);
5059 se_sz.expr = gfc_evaluate_now (se_sz.expr, &se.pre);
5060 gfc_add_block_to_block (&se.pre, &se_sz.post);
5061 /* Store the string length. */
5062 tmp = al->expr->ts.u.cl->backend_decl;
5063 gfc_add_modify (&se.pre, tmp, fold_convert (TREE_TYPE (tmp),
5064 se_sz.expr));
5065 tmp = TREE_TYPE (gfc_typenode_for_spec (&code->ext.alloc.ts));
5066 tmp = TYPE_SIZE_UNIT (tmp);
5067 memsz = fold_build2_loc (input_location, MULT_EXPR,
5068 TREE_TYPE (tmp), tmp,
5069 fold_convert (TREE_TYPE (se_sz.expr),
5070 se_sz.expr));
5071 }
5072 else if (code->ext.alloc.ts.type != BT_UNKNOWN)
5073 memsz = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->ext.alloc.ts));
5074 else if (memsz == NULL_TREE)
5075 memsz = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (se.expr)));
5076
5077 if (expr->ts.type == BT_CHARACTER && memsz == NULL_TREE)
5078 {
5079 memsz = se.string_length;
5080
5081 /* Convert to size in bytes, using the character KIND. */
5082 tmp = TREE_TYPE (gfc_typenode_for_spec (&code->ext.alloc.ts));
5083 tmp = TYPE_SIZE_UNIT (tmp);
5084 memsz = fold_build2_loc (input_location, MULT_EXPR,
5085 TREE_TYPE (tmp), tmp,
5086 fold_convert (TREE_TYPE (tmp), memsz));
5087 }
5088
5089 /* Allocate - for non-pointers with re-alloc checking. */
5090 if (gfc_expr_attr (expr).allocatable)
5091 gfc_allocate_allocatable (&se.pre, se.expr, memsz, NULL_TREE,
5092 stat, errmsg, errlen, label_finish, expr);
5093 else
5094 gfc_allocate_using_malloc (&se.pre, se.expr, memsz, stat);
5095
5096 if (al->expr->ts.type == BT_DERIVED
5097 && expr->ts.u.derived->attr.alloc_comp)
5098 {
5099 tmp = build_fold_indirect_ref_loc (input_location, se.expr);
5100 tmp = gfc_nullify_alloc_comp (expr->ts.u.derived, tmp, 0);
5101 gfc_add_expr_to_block (&se.pre, tmp);
5102 }
5103 }
5104
5105 gfc_add_block_to_block (&block, &se.pre);
5106
5107 /* Error checking -- Note: ERRMSG only makes sense with STAT. */
5108 if (code->expr1)
5109 {
5110 tmp = build1_v (GOTO_EXPR, label_errmsg);
5111 parm = fold_build2_loc (input_location, NE_EXPR,
5112 boolean_type_node, stat,
5113 build_int_cst (TREE_TYPE (stat), 0));
5114 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
5115 gfc_unlikely (parm, PRED_FORTRAN_FAIL_ALLOC),
5116 tmp, build_empty_stmt (input_location));
5117 gfc_add_expr_to_block (&block, tmp);
5118 }
5119
5120 /* We need the vptr of CLASS objects to be initialized. */
5121 e = gfc_copy_expr (al->expr);
5122 if (e->ts.type == BT_CLASS)
5123 {
5124 gfc_expr *lhs, *rhs;
5125 gfc_se lse;
5126 gfc_ref *ref, *class_ref, *tail;
5127
5128 /* Find the last class reference. */
5129 class_ref = NULL;
5130 for (ref = e->ref; ref; ref = ref->next)
5131 {
5132 if (ref->type == REF_COMPONENT
5133 && ref->u.c.component->ts.type == BT_CLASS)
5134 class_ref = ref;
5135
5136 if (ref->next == NULL)
5137 break;
5138 }
5139
5140 /* Remove and store all subsequent references after the
5141 CLASS reference. */
5142 if (class_ref)
5143 {
5144 tail = class_ref->next;
5145 class_ref->next = NULL;
5146 }
5147 else
5148 {
5149 tail = e->ref;
5150 e->ref = NULL;
5151 }
5152
5153 lhs = gfc_expr_to_initialize (e);
5154 gfc_add_vptr_component (lhs);
5155
5156 /* Remove the _vptr component and restore the original tail
5157 references. */
5158 if (class_ref)
5159 {
5160 gfc_free_ref_list (class_ref->next);
5161 class_ref->next = tail;
5162 }
5163 else
5164 {
5165 gfc_free_ref_list (e->ref);
5166 e->ref = tail;
5167 }
5168
5169 if (class_expr != NULL_TREE)
5170 {
5171 /* Polymorphic SOURCE: VPTR must be determined at run time. */
5172 gfc_init_se (&lse, NULL);
5173 lse.want_pointer = 1;
5174 gfc_conv_expr (&lse, lhs);
5175 tmp = gfc_class_vptr_get (class_expr);
5176 gfc_add_modify (&block, lse.expr,
5177 fold_convert (TREE_TYPE (lse.expr), tmp));
5178 }
5179 else if (code->expr3 && code->expr3->ts.type == BT_CLASS)
5180 {
5181 /* Polymorphic SOURCE: VPTR must be determined at run time. */
5182 rhs = gfc_copy_expr (code->expr3);
5183 gfc_add_vptr_component (rhs);
5184 tmp = gfc_trans_pointer_assignment (lhs, rhs);
5185 gfc_add_expr_to_block (&block, tmp);
5186 gfc_free_expr (rhs);
5187 rhs = gfc_expr_to_initialize (e);
5188 }
5189 else
5190 {
5191 /* VPTR is fixed at compile time. */
5192 gfc_symbol *vtab;
5193 gfc_typespec *ts;
5194 if (code->expr3)
5195 ts = &code->expr3->ts;
5196 else if (e->ts.type == BT_DERIVED)
5197 ts = &e->ts;
5198 else if (code->ext.alloc.ts.type == BT_DERIVED || UNLIMITED_POLY (al->expr))
5199 ts = &code->ext.alloc.ts;
5200 else if (e->ts.type == BT_CLASS)
5201 ts = &CLASS_DATA (e)->ts;
5202 else
5203 ts = &e->ts;
5204
5205 if (ts->type == BT_DERIVED || UNLIMITED_POLY (e))
5206 {
5207 vtab = gfc_find_vtab (ts);
5208 gcc_assert (vtab);
5209 gfc_init_se (&lse, NULL);
5210 lse.want_pointer = 1;
5211 gfc_conv_expr (&lse, lhs);
5212 tmp = gfc_build_addr_expr (NULL_TREE,
5213 gfc_get_symbol_decl (vtab));
5214 gfc_add_modify (&block, lse.expr,
5215 fold_convert (TREE_TYPE (lse.expr), tmp));
5216 }
5217 }
5218 gfc_free_expr (lhs);
5219 }
5220
5221 gfc_free_expr (e);
5222
5223 if (code->expr3 && !code->expr3->mold)
5224 {
5225 /* Initialization via SOURCE block
5226 (or static default initializer). */
5227 gfc_expr *rhs = gfc_copy_expr (code->expr3);
5228 if (class_expr != NULL_TREE)
5229 {
5230 tree to;
5231 to = TREE_OPERAND (se.expr, 0);
5232
5233 tmp = gfc_copy_class_to_class (class_expr, to, nelems);
5234 }
5235 else if (al->expr->ts.type == BT_CLASS)
5236 {
5237 gfc_actual_arglist *actual;
5238 gfc_expr *ppc;
5239 gfc_code *ppc_code;
5240 gfc_ref *ref, *dataref;
5241
5242 /* Do a polymorphic deep copy. */
5243 actual = gfc_get_actual_arglist ();
5244 actual->expr = gfc_copy_expr (rhs);
5245 if (rhs->ts.type == BT_CLASS)
5246 gfc_add_data_component (actual->expr);
5247 actual->next = gfc_get_actual_arglist ();
5248 actual->next->expr = gfc_copy_expr (al->expr);
5249 actual->next->expr->ts.type = BT_CLASS;
5250 gfc_add_data_component (actual->next->expr);
5251
5252 dataref = NULL;
5253 /* Make sure we go up through the reference chain to
5254 the _data reference, where the arrayspec is found. */
5255 for (ref = actual->next->expr->ref; ref; ref = ref->next)
5256 if (ref->type == REF_COMPONENT
5257 && strcmp (ref->u.c.component->name, "_data") == 0)
5258 dataref = ref;
5259
5260 if (dataref && dataref->u.c.component->as)
5261 {
5262 int dim;
5263 gfc_expr *temp;
5264 gfc_ref *ref = dataref->next;
5265 ref->u.ar.type = AR_SECTION;
5266 /* We have to set up the array reference to give ranges
5267 in all dimensions and ensure that the end and stride
5268 are set so that the copy can be scalarized. */
5269 dim = 0;
5270 for (; dim < dataref->u.c.component->as->rank; dim++)
5271 {
5272 ref->u.ar.dimen_type[dim] = DIMEN_RANGE;
5273 if (ref->u.ar.end[dim] == NULL)
5274 {
5275 ref->u.ar.end[dim] = ref->u.ar.start[dim];
5276 temp = gfc_get_int_expr (gfc_default_integer_kind,
5277 &al->expr->where, 1);
5278 ref->u.ar.start[dim] = temp;
5279 }
5280 temp = gfc_subtract (gfc_copy_expr (ref->u.ar.end[dim]),
5281 gfc_copy_expr (ref->u.ar.start[dim]));
5282 temp = gfc_add (gfc_get_int_expr (gfc_default_integer_kind,
5283 &al->expr->where, 1),
5284 temp);
5285 }
5286 }
5287 if (rhs->ts.type == BT_CLASS)
5288 {
5289 ppc = gfc_copy_expr (rhs);
5290 gfc_add_vptr_component (ppc);
5291 }
5292 else
5293 ppc = gfc_lval_expr_from_sym (gfc_find_vtab (&rhs->ts));
5294 gfc_add_component_ref (ppc, "_copy");
5295
5296 ppc_code = gfc_get_code (EXEC_CALL);
5297 ppc_code->resolved_sym = ppc->symtree->n.sym;
5298 /* Although '_copy' is set to be elemental in class.c, it is
5299 not staying that way. Find out why, sometime.... */
5300 ppc_code->resolved_sym->attr.elemental = 1;
5301 ppc_code->ext.actual = actual;
5302 ppc_code->expr1 = ppc;
5303 /* Since '_copy' is elemental, the scalarizer will take care
5304 of arrays in gfc_trans_call. */
5305 tmp = gfc_trans_call (ppc_code, true, NULL, NULL, false);
5306 gfc_free_statements (ppc_code);
5307 }
5308 else if (expr3 != NULL_TREE)
5309 {
5310 tmp = build_fold_indirect_ref_loc (input_location, se.expr);
5311 gfc_trans_string_copy (&block, slen3, tmp, code->expr3->ts.kind,
5312 slen3, expr3, code->expr3->ts.kind);
5313 tmp = NULL_TREE;
5314 }
5315 else
5316 {
5317 /* Switch off automatic reallocation since we have just done
5318 the ALLOCATE. */
5319 int realloc_lhs = gfc_option.flag_realloc_lhs;
5320 gfc_option.flag_realloc_lhs = 0;
5321 tmp = gfc_trans_assignment (gfc_expr_to_initialize (expr),
5322 rhs, false, false);
5323 gfc_option.flag_realloc_lhs = realloc_lhs;
5324 }
5325 gfc_free_expr (rhs);
5326 gfc_add_expr_to_block (&block, tmp);
5327 }
5328 else if (code->expr3 && code->expr3->mold
5329 && code->expr3->ts.type == BT_CLASS)
5330 {
5331 /* Since the _vptr has already been assigned to the allocate
5332 object, we can use gfc_copy_class_to_class in its
5333 initialization mode. */
5334 tmp = TREE_OPERAND (se.expr, 0);
5335 tmp = gfc_copy_class_to_class (NULL_TREE, tmp, nelems);
5336 gfc_add_expr_to_block (&block, tmp);
5337 }
5338
5339 gfc_free_expr (expr);
5340 }
5341
5342 /* STAT. */
5343 if (code->expr1)
5344 {
5345 tmp = build1_v (LABEL_EXPR, label_errmsg);
5346 gfc_add_expr_to_block (&block, tmp);
5347 }
5348
5349 /* ERRMSG - only useful if STAT is present. */
5350 if (code->expr1 && code->expr2)
5351 {
5352 const char *msg = "Attempt to allocate an allocated object";
5353 tree slen, dlen, errmsg_str;
5354 stmtblock_t errmsg_block;
5355
5356 gfc_init_block (&errmsg_block);
5357
5358 errmsg_str = gfc_create_var (pchar_type_node, "ERRMSG");
5359 gfc_add_modify (&errmsg_block, errmsg_str,
5360 gfc_build_addr_expr (pchar_type_node,
5361 gfc_build_localized_cstring_const (msg)));
5362
5363 slen = build_int_cst (gfc_charlen_type_node, ((int) strlen (msg)));
5364 dlen = gfc_get_expr_charlen (code->expr2);
5365 slen = fold_build2_loc (input_location, MIN_EXPR, TREE_TYPE (slen), dlen,
5366 slen);
5367
5368 gfc_trans_string_copy (&errmsg_block, dlen, errmsg, code->expr2->ts.kind,
5369 slen, errmsg_str, gfc_default_character_kind);
5370 dlen = gfc_finish_block (&errmsg_block);
5371
5372 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, stat,
5373 build_int_cst (TREE_TYPE (stat), 0));
5374
5375 tmp = build3_v (COND_EXPR, tmp, dlen, build_empty_stmt (input_location));
5376
5377 gfc_add_expr_to_block (&block, tmp);
5378 }
5379
5380 /* STAT block. */
5381 if (code->expr1)
5382 {
5383 if (TREE_USED (label_finish))
5384 {
5385 tmp = build1_v (LABEL_EXPR, label_finish);
5386 gfc_add_expr_to_block (&block, tmp);
5387 }
5388
5389 gfc_init_se (&se, NULL);
5390 gfc_conv_expr_lhs (&se, code->expr1);
5391 tmp = convert (TREE_TYPE (se.expr), stat);
5392 gfc_add_modify (&block, se.expr, tmp);
5393 }
5394
5395 gfc_add_block_to_block (&block, &se.post);
5396 gfc_add_block_to_block (&block, &post);
5397
5398 return gfc_finish_block (&block);
5399 }
5400
5401
5402 /* Translate a DEALLOCATE statement. */
5403
5404 tree
gfc_trans_deallocate(gfc_code * code)5405 gfc_trans_deallocate (gfc_code *code)
5406 {
5407 gfc_se se;
5408 gfc_alloc *al;
5409 tree apstat, pstat, stat, errmsg, errlen, tmp;
5410 tree label_finish, label_errmsg;
5411 stmtblock_t block;
5412
5413 pstat = apstat = stat = errmsg = errlen = tmp = NULL_TREE;
5414 label_finish = label_errmsg = NULL_TREE;
5415
5416 gfc_start_block (&block);
5417
5418 /* Count the number of failed deallocations. If deallocate() was
5419 called with STAT= , then set STAT to the count. If deallocate
5420 was called with ERRMSG, then set ERRMG to a string. */
5421 if (code->expr1)
5422 {
5423 tree gfc_int4_type_node = gfc_get_int_type (4);
5424
5425 stat = gfc_create_var (gfc_int4_type_node, "stat");
5426 pstat = gfc_build_addr_expr (NULL_TREE, stat);
5427
5428 /* GOTO destinations. */
5429 label_errmsg = gfc_build_label_decl (NULL_TREE);
5430 label_finish = gfc_build_label_decl (NULL_TREE);
5431 TREE_USED (label_finish) = 0;
5432 }
5433
5434 /* Set ERRMSG - only needed if STAT is available. */
5435 if (code->expr1 && code->expr2)
5436 {
5437 gfc_init_se (&se, NULL);
5438 se.want_pointer = 1;
5439 gfc_conv_expr_lhs (&se, code->expr2);
5440 errmsg = se.expr;
5441 errlen = se.string_length;
5442 }
5443
5444 for (al = code->ext.alloc.list; al != NULL; al = al->next)
5445 {
5446 gfc_expr *expr = gfc_copy_expr (al->expr);
5447 gcc_assert (expr->expr_type == EXPR_VARIABLE);
5448
5449 if (expr->ts.type == BT_CLASS)
5450 gfc_add_data_component (expr);
5451
5452 gfc_init_se (&se, NULL);
5453 gfc_start_block (&se.pre);
5454
5455 se.want_pointer = 1;
5456 se.descriptor_only = 1;
5457 gfc_conv_expr (&se, expr);
5458
5459 if (expr->rank || gfc_is_coarray (expr))
5460 {
5461 if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->attr.alloc_comp
5462 && !gfc_is_finalizable (expr->ts.u.derived, NULL))
5463 {
5464 gfc_ref *ref;
5465 gfc_ref *last = NULL;
5466 for (ref = expr->ref; ref; ref = ref->next)
5467 if (ref->type == REF_COMPONENT)
5468 last = ref;
5469
5470 /* Do not deallocate the components of a derived type
5471 ultimate pointer component. */
5472 if (!(last && last->u.c.component->attr.pointer)
5473 && !(!last && expr->symtree->n.sym->attr.pointer))
5474 {
5475 tmp = gfc_deallocate_alloc_comp (expr->ts.u.derived, se.expr,
5476 expr->rank);
5477 gfc_add_expr_to_block (&se.pre, tmp);
5478 }
5479 }
5480 tmp = gfc_array_deallocate (se.expr, pstat, errmsg, errlen,
5481 label_finish, expr);
5482 gfc_add_expr_to_block (&se.pre, tmp);
5483 if (al->expr->ts.type == BT_CLASS)
5484 gfc_reset_vptr (&se.pre, al->expr);
5485 }
5486 else
5487 {
5488 tmp = gfc_deallocate_scalar_with_status (se.expr, pstat, false,
5489 al->expr, al->expr->ts);
5490 gfc_add_expr_to_block (&se.pre, tmp);
5491
5492 /* Set to zero after deallocation. */
5493 tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
5494 se.expr,
5495 build_int_cst (TREE_TYPE (se.expr), 0));
5496 gfc_add_expr_to_block (&se.pre, tmp);
5497
5498 if (al->expr->ts.type == BT_CLASS)
5499 gfc_reset_vptr (&se.pre, al->expr);
5500 }
5501
5502 if (code->expr1)
5503 {
5504 tree cond;
5505
5506 cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, stat,
5507 build_int_cst (TREE_TYPE (stat), 0));
5508 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
5509 gfc_unlikely (cond, PRED_FORTRAN_FAIL_ALLOC),
5510 build1_v (GOTO_EXPR, label_errmsg),
5511 build_empty_stmt (input_location));
5512 gfc_add_expr_to_block (&se.pre, tmp);
5513 }
5514
5515 tmp = gfc_finish_block (&se.pre);
5516 gfc_add_expr_to_block (&block, tmp);
5517 gfc_free_expr (expr);
5518 }
5519
5520 if (code->expr1)
5521 {
5522 tmp = build1_v (LABEL_EXPR, label_errmsg);
5523 gfc_add_expr_to_block (&block, tmp);
5524 }
5525
5526 /* Set ERRMSG - only needed if STAT is available. */
5527 if (code->expr1 && code->expr2)
5528 {
5529 const char *msg = "Attempt to deallocate an unallocated object";
5530 stmtblock_t errmsg_block;
5531 tree errmsg_str, slen, dlen, cond;
5532
5533 gfc_init_block (&errmsg_block);
5534
5535 errmsg_str = gfc_create_var (pchar_type_node, "ERRMSG");
5536 gfc_add_modify (&errmsg_block, errmsg_str,
5537 gfc_build_addr_expr (pchar_type_node,
5538 gfc_build_localized_cstring_const (msg)));
5539 slen = build_int_cst (gfc_charlen_type_node, ((int) strlen (msg)));
5540 dlen = gfc_get_expr_charlen (code->expr2);
5541
5542 gfc_trans_string_copy (&errmsg_block, dlen, errmsg, code->expr2->ts.kind,
5543 slen, errmsg_str, gfc_default_character_kind);
5544 tmp = gfc_finish_block (&errmsg_block);
5545
5546 cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, stat,
5547 build_int_cst (TREE_TYPE (stat), 0));
5548 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
5549 gfc_unlikely (cond, PRED_FORTRAN_FAIL_ALLOC), tmp,
5550 build_empty_stmt (input_location));
5551
5552 gfc_add_expr_to_block (&block, tmp);
5553 }
5554
5555 if (code->expr1 && TREE_USED (label_finish))
5556 {
5557 tmp = build1_v (LABEL_EXPR, label_finish);
5558 gfc_add_expr_to_block (&block, tmp);
5559 }
5560
5561 /* Set STAT. */
5562 if (code->expr1)
5563 {
5564 gfc_init_se (&se, NULL);
5565 gfc_conv_expr_lhs (&se, code->expr1);
5566 tmp = convert (TREE_TYPE (se.expr), stat);
5567 gfc_add_modify (&block, se.expr, tmp);
5568 }
5569
5570 return gfc_finish_block (&block);
5571 }
5572
5573 #include "gt-fortran-trans-stmt.h"
5574