]> git.ipfire.org Git - thirdparty/gcc.git/blame - gcc/fortran/trans-stmt.c
projects / thirdparty / gcc.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
sse.md (mulv4si3): New.
[thirdparty/gcc.git] / gcc / fortran / trans-stmt.c
CommitLineData
6de9cd9a 1/* Statement translation -- generate GCC trees from gfc_code.
ec378180 2 Copyright (C) 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
6de9cd9a
DN		 3 Contributed by Paul Brook <paul@nowt.org>
4 and Steven Bosscher <s.bosscher@student.tudelft.nl>
5
9fc4d79b 6This file is part of GCC.
6de9cd9a 7
9fc4d79b
TS		 8GCC is free software; you can redistribute it and/or modify it under
9the terms of the GNU General Public License as published by the Free
10Software Foundation; either version 2, or (at your option) any later
11version.
6de9cd9a 12
9fc4d79b
TS		 13GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14WARRANTY; without even the implied warranty of MERCHANTABILITY or
15FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
16for more details.
6de9cd9a
DN		 17
18You should have received a copy of the GNU General Public License
9fc4d79b
TS		 19along with GCC; see the file COPYING. If not, write to the Free
20Software Foundation, 59 Temple Place - Suite 330, Boston, MA
2102111-1307, USA. */
6de9cd9a
DN		 22
23
24#include "config.h"
25#include "system.h"
26#include "coretypes.h"
27#include "tree.h"
eadf906f 28#include "tree-gimple.h"
6de9cd9a
DN		 29#include "ggc.h"
30#include "toplev.h"
31#include "real.h"
6de9cd9a
DN		 32#include "gfortran.h"
33#include "trans.h"
34#include "trans-stmt.h"
35#include "trans-types.h"
36#include "trans-array.h"
37#include "trans-const.h"
38#include "arith.h"
39
40int has_alternate_specifier;
41
42typedef struct iter_info
43{
44 tree var;
45 tree start;
46 tree end;
47 tree step;
48 struct iter_info *next;
49}
50iter_info;
51
52typedef struct temporary_list
53{
54 tree temporary;
55 struct temporary_list *next;
56}
57temporary_list;
58
59typedef struct forall_info
60{
61 iter_info *this_loop;
62 tree mask;
63 tree pmask;
64 tree maskindex;
65 int nvar;
66 tree size;
67 struct forall_info *outer;
68 struct forall_info *next_nest;
69}
70forall_info;
71
72static void gfc_trans_where_2 (gfc_code *, tree, tree, forall_info *,
73 stmtblock_t *, temporary_list **temp);
74
75/* Translate a F95 label number to a LABEL_EXPR. */
76
77tree
78gfc_trans_label_here (gfc_code * code)
79{
80 return build1_v (LABEL_EXPR, gfc_get_label_decl (code->here));
81}
82
ce2df7c6
FW		 83
84/* Given a variable expression which has been ASSIGNed to, find the decl
85 containing the auxiliary variables. For variables in common blocks this
86 is a field_decl. */
87
88void
89gfc_conv_label_variable (gfc_se * se, gfc_expr * expr)
90{
91 gcc_assert (expr->symtree->n.sym->attr.assign == 1);
92 gfc_conv_expr (se, expr);
93 /* Deals with variable in common block. Get the field declaration. */
94 if (TREE_CODE (se->expr) == COMPONENT_REF)
95 se->expr = TREE_OPERAND (se->expr, 1);
96}
97
6de9cd9a 98/* Translate a label assignment statement. */
ce2df7c6 99
6de9cd9a
DN		 100tree
101gfc_trans_label_assign (gfc_code * code)
102{
103 tree label_tree;
104 gfc_se se;
105 tree len;
106 tree addr;
107 tree len_tree;
108 char *label_str;
109 int label_len;
110
111 /* Start a new block. */
112 gfc_init_se (&se, NULL);
113 gfc_start_block (&se.pre);
ce2df7c6
FW		 114 gfc_conv_label_variable (&se, code->expr);
115
6de9cd9a
DN		 116 len = GFC_DECL_STRING_LEN (se.expr);
117 addr = GFC_DECL_ASSIGN_ADDR (se.expr);
118
119 label_tree = gfc_get_label_decl (code->label);
120
121 if (code->label->defined == ST_LABEL_TARGET)
122 {
123 label_tree = gfc_build_addr_expr (pvoid_type_node, label_tree);
124 len_tree = integer_minus_one_node;
125 }
126 else
127 {
128 label_str = code->label->format->value.character.string;
129 label_len = code->label->format->value.character.length;
7d60be94 130 len_tree = build_int_cst (NULL_TREE, label_len);
6de9cd9a 131 label_tree = gfc_build_string_const (label_len + 1, label_str);
b078dfbf 132 label_tree = gfc_build_addr_expr (pvoid_type_node, label_tree);
6de9cd9a
DN		 133 }
134
135 gfc_add_modify_expr (&se.pre, len, len_tree);
136 gfc_add_modify_expr (&se.pre, addr, label_tree);
137
138 return gfc_finish_block (&se.pre);
139}
140
141/* Translate a GOTO statement. */
142
143tree
144gfc_trans_goto (gfc_code * code)
145{
146 tree assigned_goto;
147 tree target;
148 tree tmp;
149 tree assign_error;
150 tree range_error;
151 gfc_se se;
152
153
154 if (code->label != NULL)
155 return build1_v (GOTO_EXPR, gfc_get_label_decl (code->label));
156
157 /* ASSIGNED GOTO. */
158 gfc_init_se (&se, NULL);
159 gfc_start_block (&se.pre);
ce2df7c6 160 gfc_conv_label_variable (&se, code->expr);
6de9cd9a 161 assign_error =
95638988 162 gfc_build_cstring_const ("Assigned label is not a target label");
6de9cd9a 163 tmp = GFC_DECL_STRING_LEN (se.expr);
923ab88c 164 tmp = build2 (NE_EXPR, boolean_type_node, tmp, integer_minus_one_node);
6de9cd9a
DN		 165 gfc_trans_runtime_check (tmp, assign_error, &se.pre);
166
167 assigned_goto = GFC_DECL_ASSIGN_ADDR (se.expr);
168 target = build1 (GOTO_EXPR, void_type_node, assigned_goto);
169
170 code = code->block;
171 if (code == NULL)
172 {
173 gfc_add_expr_to_block (&se.pre, target);
174 return gfc_finish_block (&se.pre);
175 }
176
177 /* Check the label list. */
95638988 178 range_error = gfc_build_cstring_const ("Assigned label is not in the list");
6de9cd9a
DN		 179
180 do
181 {
182 tmp = gfc_get_label_decl (code->label);
183 tmp = gfc_build_addr_expr (pvoid_type_node, tmp);
923ab88c
TS		 184 tmp = build2 (EQ_EXPR, boolean_type_node, tmp, assigned_goto);
185 tmp = build3_v (COND_EXPR, tmp, target, build_empty_stmt ());
6de9cd9a
DN		 186 gfc_add_expr_to_block (&se.pre, tmp);
187 code = code->block;
188 }
189 while (code != NULL);
190 gfc_trans_runtime_check (boolean_true_node, range_error, &se.pre);
191 return gfc_finish_block (&se.pre);
192}
193
194
3d79abbd
PB		 195/* Translate an ENTRY statement. Just adds a label for this entry point. */
196tree
197gfc_trans_entry (gfc_code * code)
198{
199 return build1_v (LABEL_EXPR, code->ext.entry->label);
200}
201
202
6de9cd9a
DN		 203/* Translate the CALL statement. Builds a call to an F95 subroutine. */
204
205tree
206gfc_trans_call (gfc_code * code)
207{
208 gfc_se se;
209
210 /* A CALL starts a new block because the actual arguments may have to
211 be evaluated first. */
212 gfc_init_se (&se, NULL);
213 gfc_start_block (&se.pre);
214
6e45f57b 215 gcc_assert (code->resolved_sym);
6de9cd9a
DN		 216 has_alternate_specifier = 0;
217
218 /* Translate the call. */
219 gfc_conv_function_call (&se, code->resolved_sym, code->ext.actual);
220
221 /* A subroutine without side-effect, by definition, does nothing! */
222 TREE_SIDE_EFFECTS (se.expr) = 1;
223
224 /* Chain the pieces together and return the block. */
225 if (has_alternate_specifier)
226 {
227 gfc_code *select_code;
228 gfc_symbol *sym;
229 select_code = code->next;
6e45f57b 230 gcc_assert(select_code->op == EXEC_SELECT);
6de9cd9a
DN		 231 sym = select_code->expr->symtree->n.sym;
232 se.expr = convert (gfc_typenode_for_spec (&sym->ts), se.expr);
233 gfc_add_modify_expr (&se.pre, sym->backend_decl, se.expr);
234 }
235 else
236 gfc_add_expr_to_block (&se.pre, se.expr);
237
238 gfc_add_block_to_block (&se.pre, &se.post);
239 return gfc_finish_block (&se.pre);
240}
241
242
243/* Translate the RETURN statement. */
244
245tree
246gfc_trans_return (gfc_code * code ATTRIBUTE_UNUSED)
247{
248 if (code->expr)
249 {
250 gfc_se se;
251 tree tmp;
252 tree result;
253
254 /* if code->expr is not NULL, this return statement must appear
255 in a subroutine and current_fake_result_decl has already
256 been generated. */
257
258 result = gfc_get_fake_result_decl (NULL);
259 if (!result)
260 {
261 gfc_warning ("An alternate return at %L without a * dummy argument",
262 &code->expr->where);
263 return build1_v (GOTO_EXPR, gfc_get_return_label ());
264 }
265
266 /* Start a new block for this statement. */
267 gfc_init_se (&se, NULL);
268 gfc_start_block (&se.pre);
269
270 gfc_conv_expr (&se, code->expr);
271
923ab88c 272 tmp = build2 (MODIFY_EXPR, TREE_TYPE (result), result, se.expr);
6de9cd9a
DN		 273 gfc_add_expr_to_block (&se.pre, tmp);
274
275 tmp = build1_v (GOTO_EXPR, gfc_get_return_label ());
276 gfc_add_expr_to_block (&se.pre, tmp);
277 gfc_add_block_to_block (&se.pre, &se.post);
278 return gfc_finish_block (&se.pre);
279 }
280 else
281 return build1_v (GOTO_EXPR, gfc_get_return_label ());
282}
283
284
285/* Translate the PAUSE statement. We have to translate this statement
286 to a runtime library call. */
287
288tree
289gfc_trans_pause (gfc_code * code)
290{
e2cad04b 291 tree gfc_int4_type_node = gfc_get_int_type (4);
6de9cd9a
DN		 292 gfc_se se;
293 tree args;
294 tree tmp;
295 tree fndecl;
296
297 /* Start a new block for this statement. */
298 gfc_init_se (&se, NULL);
299 gfc_start_block (&se.pre);
300
301
302 if (code->expr == NULL)
303 {
7d60be94 304 tmp = build_int_cst (gfc_int4_type_node, code->ext.stop_code);
6de9cd9a
DN		 305 args = gfc_chainon_list (NULL_TREE, tmp);
306 fndecl = gfor_fndecl_pause_numeric;
307 }
308 else
309 {
310 gfc_conv_expr_reference (&se, code->expr);
311 args = gfc_chainon_list (NULL_TREE, se.expr);
312 args = gfc_chainon_list (args, se.string_length);
313 fndecl = gfor_fndecl_pause_string;
314 }
315
316 tmp = gfc_build_function_call (fndecl, args);
317 gfc_add_expr_to_block (&se.pre, tmp);
318
319 gfc_add_block_to_block (&se.pre, &se.post);
320
321 return gfc_finish_block (&se.pre);
322}
323
324
325/* Translate the STOP statement. We have to translate this statement
326 to a runtime library call. */
327
328tree
329gfc_trans_stop (gfc_code * code)
330{
e2cad04b 331 tree gfc_int4_type_node = gfc_get_int_type (4);
6de9cd9a
DN		 332 gfc_se se;
333 tree args;
334 tree tmp;
335 tree fndecl;
336
337 /* Start a new block for this statement. */
338 gfc_init_se (&se, NULL);
339 gfc_start_block (&se.pre);
340
341
342 if (code->expr == NULL)
343 {
7d60be94 344 tmp = build_int_cst (gfc_int4_type_node, code->ext.stop_code);
6de9cd9a
DN		 345 args = gfc_chainon_list (NULL_TREE, tmp);
346 fndecl = gfor_fndecl_stop_numeric;
347 }
348 else
349 {
350 gfc_conv_expr_reference (&se, code->expr);
351 args = gfc_chainon_list (NULL_TREE, se.expr);
352 args = gfc_chainon_list (args, se.string_length);
353 fndecl = gfor_fndecl_stop_string;
354 }
355
356 tmp = gfc_build_function_call (fndecl, args);
357 gfc_add_expr_to_block (&se.pre, tmp);
358
359 gfc_add_block_to_block (&se.pre, &se.post);
360
361 return gfc_finish_block (&se.pre);
362}
363
364
365/* Generate GENERIC for the IF construct. This function also deals with
366 the simple IF statement, because the front end translates the IF
367 statement into an IF construct.
368
369 We translate:
370
371 IF (cond) THEN
372 then_clause
373 ELSEIF (cond2)
374 elseif_clause
375 ELSE
376 else_clause
377 ENDIF
378
379 into:
380
381 pre_cond_s;
382 if (cond_s)
383 {
384 then_clause;
385 }
386 else
387 {
388 pre_cond_s
389 if (cond_s)
390 {
391 elseif_clause
392 }
393 else
394 {
395 else_clause;
396 }
397 }
398
399 where COND_S is the simplified version of the predicate. PRE_COND_S
400 are the pre side-effects produced by the translation of the
401 conditional.
402 We need to build the chain recursively otherwise we run into
403 problems with folding incomplete statements. */
404
405static tree
406gfc_trans_if_1 (gfc_code * code)
407{
408 gfc_se if_se;
409 tree stmt, elsestmt;
410
411 /* Check for an unconditional ELSE clause. */
412 if (!code->expr)
413 return gfc_trans_code (code->next);
414
415 /* Initialize a statement builder for each block. Puts in NULL_TREEs. */
416 gfc_init_se (&if_se, NULL);
417 gfc_start_block (&if_se.pre);
418
419 /* Calculate the IF condition expression. */
420 gfc_conv_expr_val (&if_se, code->expr);
421
422 /* Translate the THEN clause. */
423 stmt = gfc_trans_code (code->next);
424
425 /* Translate the ELSE clause. */
426 if (code->block)
427 elsestmt = gfc_trans_if_1 (code->block);
428 else
429 elsestmt = build_empty_stmt ();
430
431 /* Build the condition expression and add it to the condition block. */
923ab88c 432 stmt = build3_v (COND_EXPR, if_se.expr, stmt, elsestmt);
6de9cd9a
DN		 433
434 gfc_add_expr_to_block (&if_se.pre, stmt);
435
436 /* Finish off this statement. */
437 return gfc_finish_block (&if_se.pre);
438}
439
440tree
441gfc_trans_if (gfc_code * code)
442{
443 /* Ignore the top EXEC_IF, it only announces an IF construct. The
444 actual code we must translate is in code->block. */
445
446 return gfc_trans_if_1 (code->block);
447}
448
449
450/* Translage an arithmetic IF expression.
451
452 IF (cond) label1, label2, label3 translates to
453
454 if (cond <= 0)
455 {
456 if (cond < 0)
457 goto label1;
458 else // cond == 0
459 goto label2;
460 }
461 else // cond > 0
462 goto label3;
463*/
464
465tree
466gfc_trans_arithmetic_if (gfc_code * code)
467{
468 gfc_se se;
469 tree tmp;
470 tree branch1;
471 tree branch2;
472 tree zero;
473
474 /* Start a new block. */
475 gfc_init_se (&se, NULL);
476 gfc_start_block (&se.pre);
477
478 /* Pre-evaluate COND. */
479 gfc_conv_expr_val (&se, code->expr);
480
481 /* Build something to compare with. */
482 zero = gfc_build_const (TREE_TYPE (se.expr), integer_zero_node);
483
484 /* If (cond < 0) take branch1 else take branch2.
485 First build jumps to the COND .LT. 0 and the COND .EQ. 0 cases. */
486 branch1 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label));
487 branch2 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label2));
488
923ab88c
TS		 489 tmp = build2 (LT_EXPR, boolean_type_node, se.expr, zero);
490 branch1 = build3_v (COND_EXPR, tmp, branch1, branch2);
6de9cd9a
DN		 491
492 /* if (cond <= 0) take branch1 else take branch2. */
493 branch2 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label3));
923ab88c
TS		 494 tmp = build2 (LE_EXPR, boolean_type_node, se.expr, zero);
495 branch1 = build3_v (COND_EXPR, tmp, branch1, branch2);
6de9cd9a
DN		 496
497 /* Append the COND_EXPR to the evaluation of COND, and return. */
498 gfc_add_expr_to_block (&se.pre, branch1);
499 return gfc_finish_block (&se.pre);
500}
501
502
54c2d931 503/* Translate the simple DO construct. This is where the loop variable has
fbdad37d
PB		 504 integer type and step +-1. We can't use this in the general case
505 because integer overflow and floating point errors could give incorrect
506 results.
507 We translate a do loop from:
508
509 DO dovar = from, to, step
510 body
511 END DO
512
513 to:
514
515 [Evaluate loop bounds and step]
516 dovar = from;
517 if ((step > 0) ? (dovar <= to) : (dovar => to))
518 {
519 for (;;)
520 {
521 body;
522 cycle_label:
523 cond = (dovar == to);
524 dovar += step;
525 if (cond) goto end_label;
526 }
527 }
528 end_label:
529
530 This helps the optimizers by avoiding the extra induction variable
531 used in the general case. */
532
533static tree
534gfc_trans_simple_do (gfc_code * code, stmtblock_t *pblock, tree dovar,
535 tree from, tree to, tree step)
536{
537 stmtblock_t body;
538 tree type;
539 tree cond;
540 tree tmp;
541 tree cycle_label;
542 tree exit_label;
543
544 type = TREE_TYPE (dovar);
545
546 /* Initialize the DO variable: dovar = from. */
547 gfc_add_modify_expr (pblock, dovar, from);
548
549 /* Cycle and exit statements are implemented with gotos. */
550 cycle_label = gfc_build_label_decl (NULL_TREE);
551 exit_label = gfc_build_label_decl (NULL_TREE);
552
553 /* Put the labels where they can be found later. See gfc_trans_do(). */
554 code->block->backend_decl = tree_cons (cycle_label, exit_label, NULL);
555
556 /* Loop body. */
557 gfc_start_block (&body);
558
559 /* Main loop body. */
560 tmp = gfc_trans_code (code->block->next);
561 gfc_add_expr_to_block (&body, tmp);
562
563 /* Label for cycle statements (if needed). */
564 if (TREE_USED (cycle_label))
565 {
566 tmp = build1_v (LABEL_EXPR, cycle_label);
567 gfc_add_expr_to_block (&body, tmp);
568 }
569
570 /* Evaluate the loop condition. */
571 cond = build2 (EQ_EXPR, boolean_type_node, dovar, to);
572 cond = gfc_evaluate_now (cond, &body);
573
574 /* Increment the loop variable. */
575 tmp = build2 (PLUS_EXPR, type, dovar, step);
576 gfc_add_modify_expr (&body, dovar, tmp);
577
578 /* The loop exit. */
579 tmp = build1_v (GOTO_EXPR, exit_label);
580 TREE_USED (exit_label) = 1;
581 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
582 gfc_add_expr_to_block (&body, tmp);
583
584 /* Finish the loop body. */
585 tmp = gfc_finish_block (&body);
586 tmp = build1_v (LOOP_EXPR, tmp);
587
588 /* Only execute the loop if the number of iterations is positive. */
589 if (tree_int_cst_sgn (step) > 0)
10c7a96f 590 cond = fold_build2 (LE_EXPR, boolean_type_node, dovar, to);
fbdad37d 591 else
10c7a96f 592 cond = fold_build2 (GE_EXPR, boolean_type_node, dovar, to);
fbdad37d
PB		 593 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
594 gfc_add_expr_to_block (pblock, tmp);
595
596 /* Add the exit label. */
597 tmp = build1_v (LABEL_EXPR, exit_label);
598 gfc_add_expr_to_block (pblock, tmp);
599
600 return gfc_finish_block (pblock);
601}
602
6de9cd9a
DN		 603/* Translate the DO construct. This obviously is one of the most
604 important ones to get right with any compiler, but especially
605 so for Fortran.
606
fbdad37d
PB		 607 We special case some loop forms as described in gfc_trans_simple_do.
608 For other cases we implement them with a separate loop count,
609 as described in the standard.
6de9cd9a
DN		 610
611 We translate a do loop from:
612
613 DO dovar = from, to, step
614 body
615 END DO
616
617 to:
618
fbdad37d
PB		 619 [evaluate loop bounds and step]
620 count = to + step - from;
621 dovar = from;
622 for (;;)
6de9cd9a
DN		 623 {
624 body;
625cycle_label:
fbdad37d
PB		 626 dovar += step
627 count--;
628 if (count <=0) goto exit_label;
6de9cd9a
DN		 629 }
630exit_label:
631
6de9cd9a 632 TODO: Large loop counts
fbdad37d 633 The code above assumes the loop count fits into a signed integer kind,
13795658 634 i.e. Does not work for loop counts > 2^31 for integer(kind=4) variables
8d5cfa27 635 We must support the full range. */
6de9cd9a
DN		 636
637tree
638gfc_trans_do (gfc_code * code)
639{
640 gfc_se se;
641 tree dovar;
642 tree from;
643 tree to;
644 tree step;
645 tree count;
8d5cfa27 646 tree count_one;
6de9cd9a
DN		 647 tree type;
648 tree cond;
649 tree cycle_label;
650 tree exit_label;
651 tree tmp;
652 stmtblock_t block;
653 stmtblock_t body;
654
655 gfc_start_block (&block);
656
fbdad37d 657 /* Evaluate all the expressions in the iterator. */
6de9cd9a
DN		 658 gfc_init_se (&se, NULL);
659 gfc_conv_expr_lhs (&se, code->ext.iterator->var);
660 gfc_add_block_to_block (&block, &se.pre);
661 dovar = se.expr;
662 type = TREE_TYPE (dovar);
663
664 gfc_init_se (&se, NULL);
8d5cfa27 665 gfc_conv_expr_val (&se, code->ext.iterator->start);
6de9cd9a 666 gfc_add_block_to_block (&block, &se.pre);
fbdad37d 667 from = gfc_evaluate_now (se.expr, &block);
6de9cd9a
DN		 668
669 gfc_init_se (&se, NULL);
8d5cfa27 670 gfc_conv_expr_val (&se, code->ext.iterator->end);
6de9cd9a 671 gfc_add_block_to_block (&block, &se.pre);
fbdad37d 672 to = gfc_evaluate_now (se.expr, &block);
6de9cd9a
DN		 673
674 gfc_init_se (&se, NULL);
8d5cfa27 675 gfc_conv_expr_val (&se, code->ext.iterator->step);
6de9cd9a 676 gfc_add_block_to_block (&block, &se.pre);
fbdad37d
PB		 677 step = gfc_evaluate_now (se.expr, &block);
678
679 /* Special case simple loops. */
680 if (TREE_CODE (type) == INTEGER_TYPE
681 && (integer_onep (step)
682 || tree_int_cst_equal (step, integer_minus_one_node)))
683 return gfc_trans_simple_do (code, &block, dovar, from, to, step);
684
1f2959f0 685 /* Initialize loop count. This code is executed before we enter the
6de9cd9a
DN		 686 loop body. We generate: count = (to + step - from) / step. */
687
10c7a96f
SB		 688 tmp = fold_build2 (MINUS_EXPR, type, step, from);
689 tmp = fold_build2 (PLUS_EXPR, type, to, tmp);
8d5cfa27
SK		 690 if (TREE_CODE (type) == INTEGER_TYPE)
691 {
10c7a96f 692 tmp = fold_build2 (TRUNC_DIV_EXPR, type, tmp, step);
8d5cfa27
SK		 693 count = gfc_create_var (type, "count");
694 }
695 else
696 {
697 /* TODO: We could use the same width as the real type.
698 This would probably cause more problems that it solves
699 when we implement "long double" types. */
10c7a96f
SB		 700 tmp = fold_build2 (RDIV_EXPR, type, tmp, step);
701 tmp = fold_build1 (FIX_TRUNC_EXPR, gfc_array_index_type, tmp);
8d5cfa27
SK		 702 count = gfc_create_var (gfc_array_index_type, "count");
703 }
6de9cd9a
DN		 704 gfc_add_modify_expr (&block, count, tmp);
705
8d5cfa27
SK		 706 count_one = convert (TREE_TYPE (count), integer_one_node);
707
1f2959f0 708 /* Initialize the DO variable: dovar = from. */
6de9cd9a
DN		 709 gfc_add_modify_expr (&block, dovar, from);
710
711 /* Loop body. */
712 gfc_start_block (&body);
713
714 /* Cycle and exit statements are implemented with gotos. */
715 cycle_label = gfc_build_label_decl (NULL_TREE);
716 exit_label = gfc_build_label_decl (NULL_TREE);
717
718 /* Start with the loop condition. Loop until count <= 0. */
8d5cfa27
SK		 719 cond = build2 (LE_EXPR, boolean_type_node, count,
720 convert (TREE_TYPE (count), integer_zero_node));
6de9cd9a
DN		 721 tmp = build1_v (GOTO_EXPR, exit_label);
722 TREE_USED (exit_label) = 1;
923ab88c 723 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
6de9cd9a
DN		 724 gfc_add_expr_to_block (&body, tmp);
725
726 /* Put these labels where they can be found later. We put the
727 labels in a TREE_LIST node (because TREE_CHAIN is already
728 used). cycle_label goes in TREE_PURPOSE (backend_decl), exit
729 label in TREE_VALUE (backend_decl). */
730
731 code->block->backend_decl = tree_cons (cycle_label, exit_label, NULL);
732
733 /* Main loop body. */
734 tmp = gfc_trans_code (code->block->next);
735 gfc_add_expr_to_block (&body, tmp);
736
737 /* Label for cycle statements (if needed). */
738 if (TREE_USED (cycle_label))
739 {
740 tmp = build1_v (LABEL_EXPR, cycle_label);
741 gfc_add_expr_to_block (&body, tmp);
742 }
743
744 /* Increment the loop variable. */
923ab88c 745 tmp = build2 (PLUS_EXPR, type, dovar, step);
6de9cd9a
DN		 746 gfc_add_modify_expr (&body, dovar, tmp);
747
748 /* Decrement the loop count. */
8d5cfa27 749 tmp = build2 (MINUS_EXPR, TREE_TYPE (count), count, count_one);
6de9cd9a
DN		 750 gfc_add_modify_expr (&body, count, tmp);
751
752 /* End of loop body. */
753 tmp = gfc_finish_block (&body);
754
755 /* The for loop itself. */
923ab88c 756 tmp = build1_v (LOOP_EXPR, tmp);
6de9cd9a
DN		 757 gfc_add_expr_to_block (&block, tmp);
758
759 /* Add the exit label. */
760 tmp = build1_v (LABEL_EXPR, exit_label);
761 gfc_add_expr_to_block (&block, tmp);
762
763 return gfc_finish_block (&block);
764}
765
766
767/* Translate the DO WHILE construct.
768
769 We translate
770
771 DO WHILE (cond)
772 body
773 END DO
774
775 to:
776
777 for ( ; ; )
778 {
779 pre_cond;
780 if (! cond) goto exit_label;
781 body;
782cycle_label:
783 }
784exit_label:
785
786 Because the evaluation of the exit condition `cond' may have side
787 effects, we can't do much for empty loop bodies. The backend optimizers
788 should be smart enough to eliminate any dead loops. */
789
790tree
791gfc_trans_do_while (gfc_code * code)
792{
793 gfc_se cond;
794 tree tmp;
795 tree cycle_label;
796 tree exit_label;
797 stmtblock_t block;
798
799 /* Everything we build here is part of the loop body. */
800 gfc_start_block (&block);
801
802 /* Cycle and exit statements are implemented with gotos. */
803 cycle_label = gfc_build_label_decl (NULL_TREE);
804 exit_label = gfc_build_label_decl (NULL_TREE);
805
806 /* Put the labels where they can be found later. See gfc_trans_do(). */
807 code->block->backend_decl = tree_cons (cycle_label, exit_label, NULL);
808
809 /* Create a GIMPLE version of the exit condition. */
810 gfc_init_se (&cond, NULL);
811 gfc_conv_expr_val (&cond, code->expr);
812 gfc_add_block_to_block (&block, &cond.pre);
10c7a96f 813 cond.expr = fold_build1 (TRUTH_NOT_EXPR, boolean_type_node, cond.expr);
6de9cd9a
DN		 814
815 /* Build "IF (! cond) GOTO exit_label". */
816 tmp = build1_v (GOTO_EXPR, exit_label);
817 TREE_USED (exit_label) = 1;
923ab88c 818 tmp = build3_v (COND_EXPR, cond.expr, tmp, build_empty_stmt ());
6de9cd9a
DN		 819 gfc_add_expr_to_block (&block, tmp);
820
821 /* The main body of the loop. */
822 tmp = gfc_trans_code (code->block->next);
823 gfc_add_expr_to_block (&block, tmp);
824
825 /* Label for cycle statements (if needed). */
826 if (TREE_USED (cycle_label))
827 {
828 tmp = build1_v (LABEL_EXPR, cycle_label);
829 gfc_add_expr_to_block (&block, tmp);
830 }
831
832 /* End of loop body. */
833 tmp = gfc_finish_block (&block);
834
835 gfc_init_block (&block);
836 /* Build the loop. */
923ab88c 837 tmp = build1_v (LOOP_EXPR, tmp);
6de9cd9a
DN		 838 gfc_add_expr_to_block (&block, tmp);
839
840 /* Add the exit label. */
841 tmp = build1_v (LABEL_EXPR, exit_label);
842 gfc_add_expr_to_block (&block, tmp);
843
844 return gfc_finish_block (&block);
845}
846
847
848/* Translate the SELECT CASE construct for INTEGER case expressions,
849 without killing all potential optimizations. The problem is that
850 Fortran allows unbounded cases, but the back-end does not, so we
851 need to intercept those before we enter the equivalent SWITCH_EXPR
852 we can build.
853
854 For example, we translate this,
855
856 SELECT CASE (expr)
857 CASE (:100,101,105:115)
858 block_1
859 CASE (190:199,200:)
860 block_2
861 CASE (300)
862 block_3
863 CASE DEFAULT
864 block_4
865 END SELECT
866
867 to the GENERIC equivalent,
868
869 switch (expr)
870 {
871 case (minimum value for typeof(expr) ... 100:
872 case 101:
873 case 105 ... 114:
874 block1:
875 goto end_label;
876
877 case 200 ... (maximum value for typeof(expr):
878 case 190 ... 199:
879 block2;
880 goto end_label;
881
882 case 300:
883 block_3;
884 goto end_label;
885
886 default:
887 block_4;
888 goto end_label;
889 }
890
891 end_label: */
892
893static tree
894gfc_trans_integer_select (gfc_code * code)
895{
896 gfc_code *c;
897 gfc_case *cp;
898 tree end_label;
899 tree tmp;
900 gfc_se se;
901 stmtblock_t block;
902 stmtblock_t body;
903
904 gfc_start_block (&block);
905
906 /* Calculate the switch expression. */
907 gfc_init_se (&se, NULL);
908 gfc_conv_expr_val (&se, code->expr);
909 gfc_add_block_to_block (&block, &se.pre);
910
911 end_label = gfc_build_label_decl (NULL_TREE);
912
913 gfc_init_block (&body);
914
915 for (c = code->block; c; c = c->block)
916 {
917 for (cp = c->ext.case_list; cp; cp = cp->next)
918 {
919 tree low, high;
920 tree label;
921
922 /* Assume it's the default case. */
923 low = high = NULL_TREE;
924
925 if (cp->low)
926 {
927 low = gfc_conv_constant_to_tree (cp->low);
928
929 /* If there's only a lower bound, set the high bound to the
930 maximum value of the case expression. */
931 if (!cp->high)
932 high = TYPE_MAX_VALUE (TREE_TYPE (se.expr));
933 }
934
935 if (cp->high)
936 {
937 /* Three cases are possible here:
938
939 1) There is no lower bound, e.g. CASE (:N).
940 2) There is a lower bound .NE. high bound, that is
941 a case range, e.g. CASE (N:M) where M>N (we make
942 sure that M>N during type resolution).
943 3) There is a lower bound, and it has the same value
944 as the high bound, e.g. CASE (N:N). This is our
945 internal representation of CASE(N).
946
947 In the first and second case, we need to set a value for
948 high. In the thirth case, we don't because the GCC middle
949 end represents a single case value by just letting high be
950 a NULL_TREE. We can't do that because we need to be able
951 to represent unbounded cases. */
952
953 if (!cp->low
954 || (cp->low
955 && mpz_cmp (cp->low->value.integer,
956 cp->high->value.integer) != 0))
957 high = gfc_conv_constant_to_tree (cp->high);
958
959 /* Unbounded case. */
960 if (!cp->low)
961 low = TYPE_MIN_VALUE (TREE_TYPE (se.expr));
962 }
963
964 /* Build a label. */
c006df4e 965 label = gfc_build_label_decl (NULL_TREE);
6de9cd9a
DN		 966
967 /* Add this case label.
968 Add parameter 'label', make it match GCC backend. */
923ab88c 969 tmp = build3 (CASE_LABEL_EXPR, void_type_node, low, high, label);
6de9cd9a
DN		 970 gfc_add_expr_to_block (&body, tmp);
971 }
972
973 /* Add the statements for this case. */
974 tmp = gfc_trans_code (c->next);
975 gfc_add_expr_to_block (&body, tmp);
976
977 /* Break to the end of the construct. */
978 tmp = build1_v (GOTO_EXPR, end_label);
979 gfc_add_expr_to_block (&body, tmp);
980 }
981
982 tmp = gfc_finish_block (&body);
923ab88c 983 tmp = build3_v (SWITCH_EXPR, se.expr, tmp, NULL_TREE);
6de9cd9a
DN		 984 gfc_add_expr_to_block (&block, tmp);
985
986 tmp = build1_v (LABEL_EXPR, end_label);
987 gfc_add_expr_to_block (&block, tmp);
988
989 return gfc_finish_block (&block);
990}
991
992
993/* Translate the SELECT CASE construct for LOGICAL case expressions.
994
995 There are only two cases possible here, even though the standard
996 does allow three cases in a LOGICAL SELECT CASE construct: .TRUE.,
997 .FALSE., and DEFAULT.
998
999 We never generate more than two blocks here. Instead, we always
1000 try to eliminate the DEFAULT case. This way, we can translate this
1001 kind of SELECT construct to a simple
1002
1003 if {} else {};
1004
1005 expression in GENERIC. */
1006
1007static tree
1008gfc_trans_logical_select (gfc_code * code)
1009{
1010 gfc_code *c;
1011 gfc_code *t, *f, *d;
1012 gfc_case *cp;
1013 gfc_se se;
1014 stmtblock_t block;
1015
1016 /* Assume we don't have any cases at all. */
1017 t = f = d = NULL;
1018
1019 /* Now see which ones we actually do have. We can have at most two
1020 cases in a single case list: one for .TRUE. and one for .FALSE.
1021 The default case is always separate. If the cases for .TRUE. and
1022 .FALSE. are in the same case list, the block for that case list
1023 always executed, and we don't generate code a COND_EXPR. */
1024 for (c = code->block; c; c = c->block)
1025 {
1026 for (cp = c->ext.case_list; cp; cp = cp->next)
1027 {
1028 if (cp->low)
1029 {
1030 if (cp->low->value.logical == 0) /* .FALSE. */
1031 f = c;
1032 else /* if (cp->value.logical != 0), thus .TRUE. */
1033 t = c;
1034 }
1035 else
1036 d = c;
1037 }
1038 }
1039
1040 /* Start a new block. */
1041 gfc_start_block (&block);
1042
1043 /* Calculate the switch expression. We always need to do this
1044 because it may have side effects. */
1045 gfc_init_se (&se, NULL);
1046 gfc_conv_expr_val (&se, code->expr);
1047 gfc_add_block_to_block (&block, &se.pre);
1048
1049 if (t == f && t != NULL)
1050 {
1051 /* Cases for .TRUE. and .FALSE. are in the same block. Just
1052 translate the code for these cases, append it to the current
1053 block. */
1054 gfc_add_expr_to_block (&block, gfc_trans_code (t->next));
1055 }
1056 else
1057 {
1058 tree true_tree, false_tree;
1059
1060 true_tree = build_empty_stmt ();
1061 false_tree = build_empty_stmt ();
1062
1063 /* If we have a case for .TRUE. and for .FALSE., discard the default case.
1064 Otherwise, if .TRUE. or .FALSE. is missing and there is a default case,
1065 make the missing case the default case. */
1066 if (t != NULL && f != NULL)
1067 d = NULL;
1068 else if (d != NULL)
1069 {
1070 if (t == NULL)
1071 t = d;
1072 else
1073 f = d;
1074 }
1075
1076 /* Translate the code for each of these blocks, and append it to
1077 the current block. */
1078 if (t != NULL)
1079 true_tree = gfc_trans_code (t->next);
1080
1081 if (f != NULL)
1082 false_tree = gfc_trans_code (f->next);
1083
923ab88c
TS		 1084 gfc_add_expr_to_block (&block, build3_v (COND_EXPR, se.expr,
1085 true_tree, false_tree));
6de9cd9a
DN		 1086 }
1087
1088 return gfc_finish_block (&block);
1089}
1090
1091
1092/* Translate the SELECT CASE construct for CHARACTER case expressions.
1093 Instead of generating compares and jumps, it is far simpler to
1094 generate a data structure describing the cases in order and call a
1095 library subroutine that locates the right case.
1096 This is particularly true because this is the only case where we
1097 might have to dispose of a temporary.
1098 The library subroutine returns a pointer to jump to or NULL if no
1099 branches are to be taken. */
1100
1101static tree
1102gfc_trans_character_select (gfc_code *code)
1103{
1104 tree init, node, end_label, tmp, type, args, *labels;
1105 stmtblock_t block, body;
1106 gfc_case *cp, *d;
1107 gfc_code *c;
1108 gfc_se se;
1109 int i, n;
1110
1111 static tree select_struct;
1112 static tree ss_string1, ss_string1_len;
1113 static tree ss_string2, ss_string2_len;
1114 static tree ss_target;
1115
1116 if (select_struct == NULL)
1117 {
e2cad04b
RH		 1118 tree gfc_int4_type_node = gfc_get_int_type (4);
1119
6de9cd9a
DN		 1120 select_struct = make_node (RECORD_TYPE);
1121 TYPE_NAME (select_struct) = get_identifier ("_jump_struct");
1122
1123#undef ADD_FIELD
1124#define ADD_FIELD(NAME, TYPE) \
1125 ss_##NAME = gfc_add_field_to_struct \
1126 (&(TYPE_FIELDS (select_struct)), select_struct, \
1127 get_identifier (stringize(NAME)), TYPE)
1128
1129 ADD_FIELD (string1, pchar_type_node);
1130 ADD_FIELD (string1_len, gfc_int4_type_node);
1131
1132 ADD_FIELD (string2, pchar_type_node);
1133 ADD_FIELD (string2_len, gfc_int4_type_node);
1134
1135 ADD_FIELD (target, pvoid_type_node);
1136#undef ADD_FIELD
1137
1138 gfc_finish_type (select_struct);
1139 }
1140
1141 cp = code->block->ext.case_list;
1142 while (cp->left != NULL)
1143 cp = cp->left;
1144
1145 n = 0;
1146 for (d = cp; d; d = d->right)
1147 d->n = n++;
1148
1149 if (n != 0)
1150 labels = gfc_getmem (n * sizeof (tree));
1151 else
1152 labels = NULL;
1153
1154 for(i = 0; i < n; i++)
1155 {
1156 labels[i] = gfc_build_label_decl (NULL_TREE);
1157 TREE_USED (labels[i]) = 1;
1158 /* TODO: The gimplifier should do this for us, but it has
1159 inadequacies when dealing with static initializers. */
1160 FORCED_LABEL (labels[i]) = 1;
1161 }
1162
1163 end_label = gfc_build_label_decl (NULL_TREE);
1164
1165 /* Generate the body */
1166 gfc_start_block (&block);
1167 gfc_init_block (&body);
1168
1169 for (c = code->block; c; c = c->block)
1170 {
1171 for (d = c->ext.case_list; d; d = d->next)
1172 {
923ab88c 1173 tmp = build1_v (LABEL_EXPR, labels[d->n]);
6de9cd9a
DN		 1174 gfc_add_expr_to_block (&body, tmp);
1175 }
1176
1177 tmp = gfc_trans_code (c->next);
1178 gfc_add_expr_to_block (&body, tmp);
1179
923ab88c 1180 tmp = build1_v (GOTO_EXPR, end_label);
6de9cd9a
DN		 1181 gfc_add_expr_to_block (&body, tmp);
1182 }
1183
1184 /* Generate the structure describing the branches */
1185 init = NULL_TREE;
1186 i = 0;
1187
1188 for(d = cp; d; d = d->right, i++)
1189 {
1190 node = NULL_TREE;
1191
1192 gfc_init_se (&se, NULL);
1193
1194 if (d->low == NULL)
1195 {
1196 node = tree_cons (ss_string1, null_pointer_node, node);
1197 node = tree_cons (ss_string1_len, integer_zero_node, node);
1198 }
1199 else
1200 {
1201 gfc_conv_expr_reference (&se, d->low);
1202
1203 node = tree_cons (ss_string1, se.expr, node);
1204 node = tree_cons (ss_string1_len, se.string_length, node);
1205 }
1206
1207 if (d->high == NULL)
1208 {
1209 node = tree_cons (ss_string2, null_pointer_node, node);
1210 node = tree_cons (ss_string2_len, integer_zero_node, node);
1211 }
1212 else
1213 {
1214 gfc_init_se (&se, NULL);
1215 gfc_conv_expr_reference (&se, d->high);
1216
1217 node = tree_cons (ss_string2, se.expr, node);
1218 node = tree_cons (ss_string2_len, se.string_length, node);
1219 }
1220
1221 tmp = gfc_build_addr_expr (pvoid_type_node, labels[i]);
1222 node = tree_cons (ss_target, tmp, node);
1223
1224 tmp = build1 (CONSTRUCTOR, select_struct, nreverse (node));
1225 init = tree_cons (NULL_TREE, tmp, init);
1226 }
1227
4a90aeeb 1228 type = build_array_type (select_struct, build_index_type
7d60be94 1229 (build_int_cst (NULL_TREE, n - 1)));
6de9cd9a
DN		 1230
1231 init = build1 (CONSTRUCTOR, type, nreverse(init));
1232 TREE_CONSTANT (init) = 1;
1233 TREE_INVARIANT (init) = 1;
1234 TREE_STATIC (init) = 1;
1235 /* Create a static variable to hold the jump table. */
1236 tmp = gfc_create_var (type, "jumptable");
1237 TREE_CONSTANT (tmp) = 1;
1238 TREE_INVARIANT (tmp) = 1;
1239 TREE_STATIC (tmp) = 1;
1240 DECL_INITIAL (tmp) = init;
1241 init = tmp;
1242
1243 /* Build an argument list for the library call */
1244 init = gfc_build_addr_expr (pvoid_type_node, init);
1245 args = gfc_chainon_list (NULL_TREE, init);
1246
7d60be94 1247 tmp = build_int_cst (NULL_TREE, n);
6de9cd9a
DN		 1248 args = gfc_chainon_list (args, tmp);
1249
1250 tmp = gfc_build_addr_expr (pvoid_type_node, end_label);
1251 args = gfc_chainon_list (args, tmp);
1252
1253 gfc_init_se (&se, NULL);
1254 gfc_conv_expr_reference (&se, code->expr);
1255
1256 args = gfc_chainon_list (args, se.expr);
1257 args = gfc_chainon_list (args, se.string_length);
1258
1259 gfc_add_block_to_block (&block, &se.pre);
1260
1261 tmp = gfc_build_function_call (gfor_fndecl_select_string, args);
1262 tmp = build1 (GOTO_EXPR, void_type_node, tmp);
1263 gfc_add_expr_to_block (&block, tmp);
1264
1265 tmp = gfc_finish_block (&body);
1266 gfc_add_expr_to_block (&block, tmp);
923ab88c 1267 tmp = build1_v (LABEL_EXPR, end_label);
6de9cd9a
DN		 1268 gfc_add_expr_to_block (&block, tmp);
1269
1270 if (n != 0)
1271 gfc_free (labels);
1272
1273 return gfc_finish_block (&block);
1274}
1275
1276
1277/* Translate the three variants of the SELECT CASE construct.
1278
1279 SELECT CASEs with INTEGER case expressions can be translated to an
1280 equivalent GENERIC switch statement, and for LOGICAL case
1281 expressions we build one or two if-else compares.
1282
1283 SELECT CASEs with CHARACTER case expressions are a whole different
1284 story, because they don't exist in GENERIC. So we sort them and
1285 do a binary search at runtime.
1286
1287 Fortran has no BREAK statement, and it does not allow jumps from
1288 one case block to another. That makes things a lot easier for
1289 the optimizers. */
1290
1291tree
1292gfc_trans_select (gfc_code * code)
1293{
6e45f57b 1294 gcc_assert (code && code->expr);
6de9cd9a
DN		 1295
1296 /* Empty SELECT constructs are legal. */
1297 if (code->block == NULL)
1298 return build_empty_stmt ();
1299
1300 /* Select the correct translation function. */
1301 switch (code->expr->ts.type)
1302 {
1303 case BT_LOGICAL: return gfc_trans_logical_select (code);
1304 case BT_INTEGER: return gfc_trans_integer_select (code);
1305 case BT_CHARACTER: return gfc_trans_character_select (code);
1306 default:
1307 gfc_internal_error ("gfc_trans_select(): Bad type for case expr.");
1308 /* Not reached */
1309 }
1310}
1311
1312
1313/* Generate the loops for a FORALL block. The normal loop format:
1314 count = (end - start + step) / step
1315 loopvar = start
1316 while (1)
1317 {
1318 if (count <=0 )
1319 goto end_of_loop
1320 <body>
1321 loopvar += step
1322 count --
1323 }
1324 end_of_loop: */
1325
1326static tree
1327gfc_trans_forall_loop (forall_info *forall_tmp, int nvar, tree body, int mask_flag)
1328{
1329 int n;
1330 tree tmp;
1331 tree cond;
1332 stmtblock_t block;
1333 tree exit_label;
1334 tree count;
1335 tree var, start, end, step, mask, maskindex;
1336 iter_info *iter;
1337
1338 iter = forall_tmp->this_loop;
1339 for (n = 0; n < nvar; n++)
1340 {
1341 var = iter->var;
1342 start = iter->start;
1343 end = iter->end;
1344 step = iter->step;
1345
1346 exit_label = gfc_build_label_decl (NULL_TREE);
1347 TREE_USED (exit_label) = 1;
1348
1349 /* The loop counter. */
1350 count = gfc_create_var (TREE_TYPE (var), "count");
1351
1352 /* The body of the loop. */
1353 gfc_init_block (&block);
1354
1355 /* The exit condition. */
923ab88c 1356 cond = build2 (LE_EXPR, boolean_type_node, count, integer_zero_node);
6de9cd9a 1357 tmp = build1_v (GOTO_EXPR, exit_label);
923ab88c 1358 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
6de9cd9a
DN		 1359 gfc_add_expr_to_block (&block, tmp);
1360
1361 /* The main loop body. */
1362 gfc_add_expr_to_block (&block, body);
1363
1364 /* Increment the loop variable. */
923ab88c 1365 tmp = build2 (PLUS_EXPR, TREE_TYPE (var), var, step);
6de9cd9a
DN		 1366 gfc_add_modify_expr (&block, var, tmp);
1367
1368 /* Advance to the next mask element. */
1369 if (mask_flag)
1370 {
1371 mask = forall_tmp->mask;
1372 maskindex = forall_tmp->maskindex;
1373 if (mask)
1374 {
923ab88c
TS		 1375 tmp = build2 (PLUS_EXPR, gfc_array_index_type,
1376 maskindex, gfc_index_one_node);
6de9cd9a
DN		 1377 gfc_add_modify_expr (&block, maskindex, tmp);
1378 }
1379 }
1380 /* Decrement the loop counter. */
923ab88c 1381 tmp = build2 (MINUS_EXPR, TREE_TYPE (var), count, gfc_index_one_node);
6de9cd9a
DN		 1382 gfc_add_modify_expr (&block, count, tmp);
1383
1384 body = gfc_finish_block (&block);
1385
1386 /* Loop var initialization. */
1387 gfc_init_block (&block);
1388 gfc_add_modify_expr (&block, var, start);
1389
1390 /* Initialize the loop counter. */
10c7a96f
SB		 1391 tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (var), step, start);
1392 tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (var), end, tmp);
1393 tmp = fold_build2 (TRUNC_DIV_EXPR, TREE_TYPE (var), tmp, step);
6de9cd9a
DN		 1394 gfc_add_modify_expr (&block, count, tmp);
1395
1396 /* The loop expression. */
923ab88c 1397 tmp = build1_v (LOOP_EXPR, body);
6de9cd9a
DN		 1398 gfc_add_expr_to_block (&block, tmp);
1399
1400 /* The exit label. */
1401 tmp = build1_v (LABEL_EXPR, exit_label);
1402 gfc_add_expr_to_block (&block, tmp);
1403
1404 body = gfc_finish_block (&block);
1405 iter = iter->next;
1406 }
1407 return body;
1408}
1409
1410
1411/* Generate the body and loops according to MASK_FLAG and NEST_FLAG.
13795658 1412 if MASK_FLAG is nonzero, the body is controlled by maskes in forall
6de9cd9a 1413 nest, otherwise, the body is not controlled by maskes.
13795658 1414 if NEST_FLAG is nonzero, generate loops for nested forall, otherwise,
6de9cd9a
DN		 1415 only generate loops for the current forall level. */
1416
1417static tree
1418gfc_trans_nested_forall_loop (forall_info * nested_forall_info, tree body,
1419 int mask_flag, int nest_flag)
1420{
1421 tree tmp;
1422 int nvar;
1423 forall_info *forall_tmp;
1424 tree pmask, mask, maskindex;
1425
1426 forall_tmp = nested_forall_info;
1427 /* Generate loops for nested forall. */
1428 if (nest_flag)
1429 {
1430 while (forall_tmp->next_nest != NULL)
1431 forall_tmp = forall_tmp->next_nest;
1432 while (forall_tmp != NULL)
1433 {
1434 /* Generate body with masks' control. */
1435 if (mask_flag)
1436 {
1437 pmask = forall_tmp->pmask;
1438 mask = forall_tmp->mask;
1439 maskindex = forall_tmp->maskindex;
1440
1441 if (mask)
1442 {
1f2959f0 1443 /* If a mask was specified make the assignment conditional. */
6de9cd9a
DN		 1444 if (pmask)
1445 tmp = gfc_build_indirect_ref (mask);
1446 else
1447 tmp = mask;
1448 tmp = gfc_build_array_ref (tmp, maskindex);
1449
923ab88c 1450 body = build3_v (COND_EXPR, tmp, body, build_empty_stmt ());
6de9cd9a
DN		 1451 }
1452 }
1453 nvar = forall_tmp->nvar;
1454 body = gfc_trans_forall_loop (forall_tmp, nvar, body, mask_flag);
1455 forall_tmp = forall_tmp->outer;
1456 }
1457 }
1458 else
1459 {
1460 nvar = forall_tmp->nvar;
1461 body = gfc_trans_forall_loop (forall_tmp, nvar, body, mask_flag);
1462 }
1463
1464 return body;
1465}
1466
1467
1468/* Allocate data for holding a temporary array. Returns either a local
1469 temporary array or a pointer variable. */
1470
1471static tree
1472gfc_do_allocate (tree bytesize, tree size, tree * pdata, stmtblock_t * pblock,
1473 tree elem_type)
1474{
1475 tree tmpvar;
1476 tree type;
1477 tree tmp;
1478 tree args;
1479
1480 if (INTEGER_CST_P (size))
1481 {
10c7a96f
SB		 1482 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, size,
1483 gfc_index_one_node);
6de9cd9a
DN		 1484 }
1485 else
1486 tmp = NULL_TREE;
1487
7ab92584 1488 type = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp);
6de9cd9a
DN		 1489 type = build_array_type (elem_type, type);
1490 if (gfc_can_put_var_on_stack (bytesize))
1491 {
6e45f57b 1492 gcc_assert (INTEGER_CST_P (size));
6de9cd9a
DN		 1493 tmpvar = gfc_create_var (type, "temp");
1494 *pdata = NULL_TREE;
1495 }
1496 else
1497 {
1498 tmpvar = gfc_create_var (build_pointer_type (type), "temp");
1499 *pdata = convert (pvoid_type_node, tmpvar);
1500
1501 args = gfc_chainon_list (NULL_TREE, bytesize);
1502 if (gfc_index_integer_kind == 4)
1503 tmp = gfor_fndecl_internal_malloc;
1504 else if (gfc_index_integer_kind == 8)
1505 tmp = gfor_fndecl_internal_malloc64;
1506 else
6e45f57b 1507 gcc_unreachable ();
6de9cd9a
DN		 1508 tmp = gfc_build_function_call (tmp, args);
1509 tmp = convert (TREE_TYPE (tmpvar), tmp);
1510 gfc_add_modify_expr (pblock, tmpvar, tmp);
1511 }
1512 return tmpvar;
1513}
1514
1515
1516/* Generate codes to copy the temporary to the actual lhs. */
1517
1518static tree
1519generate_loop_for_temp_to_lhs (gfc_expr *expr, tree tmp1, tree size,
1520 tree count3, tree count1, tree count2, tree wheremask)
1521{
1522 gfc_ss *lss;
1523 gfc_se lse, rse;
1524 stmtblock_t block, body;
1525 gfc_loopinfo loop1;
1526 tree tmp, tmp2;
1527 tree index;
1528 tree wheremaskexpr;
1529
1530 /* Walk the lhs. */
1531 lss = gfc_walk_expr (expr);
1532
1533 if (lss == gfc_ss_terminator)
1534 {
1535 gfc_start_block (&block);
1536
1537 gfc_init_se (&lse, NULL);
1538
1539 /* Translate the expression. */
1540 gfc_conv_expr (&lse, expr);
1541
1542 /* Form the expression for the temporary. */
1543 tmp = gfc_build_array_ref (tmp1, count1);
1544
1545 /* Use the scalar assignment as is. */
1546 gfc_add_block_to_block (&block, &lse.pre);
1547 gfc_add_modify_expr (&block, lse.expr, tmp);
1548 gfc_add_block_to_block (&block, &lse.post);
1549
1550 /* Increment the count1. */
10c7a96f 1551 tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (count1), count1, size);
6de9cd9a
DN		 1552 gfc_add_modify_expr (&block, count1, tmp);
1553 tmp = gfc_finish_block (&block);
1554 }
1555 else
1556 {
1557 gfc_start_block (&block);
1558
1559 gfc_init_loopinfo (&loop1);
1560 gfc_init_se (&rse, NULL);
1561 gfc_init_se (&lse, NULL);
1562
1563 /* Associate the lss with the loop. */
1564 gfc_add_ss_to_loop (&loop1, lss);
1565
1566 /* Calculate the bounds of the scalarization. */
1567 gfc_conv_ss_startstride (&loop1);
1568 /* Setup the scalarizing loops. */
1569 gfc_conv_loop_setup (&loop1);
1570
1571 gfc_mark_ss_chain_used (lss, 1);
1572 /* Initialize count2. */
7ab92584 1573 gfc_add_modify_expr (&block, count2, gfc_index_zero_node);
6de9cd9a
DN		 1574
1575 /* Start the scalarized loop body. */
1576 gfc_start_scalarized_body (&loop1, &body);
1577
1578 /* Setup the gfc_se structures. */
1579 gfc_copy_loopinfo_to_se (&lse, &loop1);
1580 lse.ss = lss;
1581
1582 /* Form the expression of the temporary. */
1583 if (lss != gfc_ss_terminator)
1584 {
10c7a96f
SB		 1585 index = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1586 count1, count2);
6de9cd9a
DN		 1587 rse.expr = gfc_build_array_ref (tmp1, index);
1588 }
1589 /* Translate expr. */
1590 gfc_conv_expr (&lse, expr);
1591
1592 /* Use the scalar assignment. */
1593 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts.type);
1594
1595 /* Form the mask expression according to the mask tree list. */
1596 if (wheremask)
1597 {
1ac26262
TS		 1598 wheremaskexpr = gfc_build_array_ref (wheremask, count3);
1599 tmp2 = TREE_CHAIN (wheremask);
6de9cd9a
DN		 1600 while (tmp2)
1601 {
1602 tmp1 = gfc_build_array_ref (tmp2, count3);
923ab88c
TS		 1603 wheremaskexpr = build2 (TRUTH_AND_EXPR, TREE_TYPE (tmp1),
1604 wheremaskexpr, tmp1);
6de9cd9a
DN		 1605 tmp2 = TREE_CHAIN (tmp2);
1606 }
923ab88c 1607 tmp = build3_v (COND_EXPR, wheremaskexpr, tmp, build_empty_stmt ());
6de9cd9a
DN		 1608 }
1609
1610 gfc_add_expr_to_block (&body, tmp);
1611
1612 /* Increment count2. */
10c7a96f
SB		 1613 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1614 count2, gfc_index_one_node);
6de9cd9a
DN		 1615 gfc_add_modify_expr (&body, count2, tmp);
1616
1617 /* Increment count3. */
1618 if (count3)
1619 {
10c7a96f
SB		 1620 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1621 count3, gfc_index_one_node);
6de9cd9a
DN		 1622 gfc_add_modify_expr (&body, count3, tmp);
1623 }
1624
1625 /* Generate the copying loops. */
1626 gfc_trans_scalarizing_loops (&loop1, &body);
1627 gfc_add_block_to_block (&block, &loop1.pre);
1628 gfc_add_block_to_block (&block, &loop1.post);
1629 gfc_cleanup_loop (&loop1);
1630
1631 /* Increment count1. */
10c7a96f 1632 tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (count1), count1, size);
6de9cd9a
DN		 1633 gfc_add_modify_expr (&block, count1, tmp);
1634 tmp = gfc_finish_block (&block);
1635 }
1636 return tmp;
1637}
1638
1639
1640/* Generate codes to copy rhs to the temporary. TMP1 is the address of temporary
1641 LSS and RSS are formed in function compute_inner_temp_size(), and should
1642 not be freed. */
1643
1644static tree
1645generate_loop_for_rhs_to_temp (gfc_expr *expr2, tree tmp1, tree size,
1646 tree count3, tree count1, tree count2,
1647 gfc_ss *lss, gfc_ss *rss, tree wheremask)
1648{
1649 stmtblock_t block, body1;
1650 gfc_loopinfo loop;
1651 gfc_se lse;
1652 gfc_se rse;
1653 tree tmp, tmp2, index;
1654 tree wheremaskexpr;
1655
1656 gfc_start_block (&block);
1657
1658 gfc_init_se (&rse, NULL);
1659 gfc_init_se (&lse, NULL);
1660
1661 if (lss == gfc_ss_terminator)
1662 {
1663 gfc_init_block (&body1);
1664 gfc_conv_expr (&rse, expr2);
1665 lse.expr = gfc_build_array_ref (tmp1, count1);
1666 }
1667 else
1668 {
1f2959f0 1669 /* Initialize count2. */
7ab92584 1670 gfc_add_modify_expr (&block, count2, gfc_index_zero_node);
6de9cd9a 1671
1f2959f0 1672 /* Initialize the loop. */
6de9cd9a
DN		 1673 gfc_init_loopinfo (&loop);
1674
1675 /* We may need LSS to determine the shape of the expression. */
1676 gfc_add_ss_to_loop (&loop, lss);
1677 gfc_add_ss_to_loop (&loop, rss);
1678
1679 gfc_conv_ss_startstride (&loop);
1680 gfc_conv_loop_setup (&loop);
1681
1682 gfc_mark_ss_chain_used (rss, 1);
1683 /* Start the loop body. */
1684 gfc_start_scalarized_body (&loop, &body1);
1685
1686 /* Translate the expression. */
1687 gfc_copy_loopinfo_to_se (&rse, &loop);
1688 rse.ss = rss;
1689 gfc_conv_expr (&rse, expr2);
1690
1691 /* Form the expression of the temporary. */
10c7a96f 1692 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, count1, count2);
6de9cd9a
DN		 1693 lse.expr = gfc_build_array_ref (tmp1, index);
1694 }
1695
1696 /* Use the scalar assignment. */
1697 tmp = gfc_trans_scalar_assign (&lse, &rse, expr2->ts.type);
1698
1699 /* Form the mask expression according to the mask tree list. */
1700 if (wheremask)
1701 {
1ac26262
TS		 1702 wheremaskexpr = gfc_build_array_ref (wheremask, count3);
1703 tmp2 = TREE_CHAIN (wheremask);
6de9cd9a
DN		 1704 while (tmp2)
1705 {
1706 tmp1 = gfc_build_array_ref (tmp2, count3);
923ab88c
TS		 1707 wheremaskexpr = build2 (TRUTH_AND_EXPR, TREE_TYPE (tmp1),
1708 wheremaskexpr, tmp1);
6de9cd9a
DN		 1709 tmp2 = TREE_CHAIN (tmp2);
1710 }
923ab88c 1711 tmp = build3_v (COND_EXPR, wheremaskexpr, tmp, build_empty_stmt ());
6de9cd9a
DN		 1712 }
1713
1714 gfc_add_expr_to_block (&body1, tmp);
1715
1716 if (lss == gfc_ss_terminator)
1717 {
1718 gfc_add_block_to_block (&block, &body1);
1719 }
1720 else
1721 {
1722 /* Increment count2. */
10c7a96f
SB		 1723 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1724 count2, gfc_index_one_node);
6de9cd9a
DN		 1725 gfc_add_modify_expr (&body1, count2, tmp);
1726
1727 /* Increment count3. */
1728 if (count3)
1729 {
10c7a96f
SB		 1730 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1731 count3, gfc_index_one_node);
6de9cd9a
DN		 1732 gfc_add_modify_expr (&body1, count3, tmp);
1733 }
1734
1735 /* Generate the copying loops. */
1736 gfc_trans_scalarizing_loops (&loop, &body1);
1737
1738 gfc_add_block_to_block (&block, &loop.pre);
1739 gfc_add_block_to_block (&block, &loop.post);
1740
1741 gfc_cleanup_loop (&loop);
1742 /* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful
1743 as tree nodes in SS may not be valid in different scope. */
1744 }
1745 /* Increment count1. */
10c7a96f 1746 tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (count1), count1, size);
6de9cd9a
DN		 1747 gfc_add_modify_expr (&block, count1, tmp);
1748
1749 tmp = gfc_finish_block (&block);
1750 return tmp;
1751}
1752
1753
1754/* Calculate the size of temporary needed in the assignment inside forall.
1755 LSS and RSS are filled in this function. */
1756
1757static tree
1758compute_inner_temp_size (gfc_expr *expr1, gfc_expr *expr2,
1759 stmtblock_t * pblock,
1760 gfc_ss **lss, gfc_ss **rss)
1761{
1762 gfc_loopinfo loop;
1763 tree size;
1764 int i;
1765 tree tmp;
1766
1767 *lss = gfc_walk_expr (expr1);
1768 *rss = NULL;
1769
7ab92584 1770 size = gfc_index_one_node;
6de9cd9a
DN		 1771 if (*lss != gfc_ss_terminator)
1772 {
1773 gfc_init_loopinfo (&loop);
1774
1775 /* Walk the RHS of the expression. */
1776 *rss = gfc_walk_expr (expr2);
1777 if (*rss == gfc_ss_terminator)
1778 {
1779 /* The rhs is scalar. Add a ss for the expression. */
1780 *rss = gfc_get_ss ();
1781 (*rss)->next = gfc_ss_terminator;
1782 (*rss)->type = GFC_SS_SCALAR;
1783 (*rss)->expr = expr2;
1784 }
1785
1786 /* Associate the SS with the loop. */
1787 gfc_add_ss_to_loop (&loop, *lss);
1788 /* We don't actually need to add the rhs at this point, but it might
1789 make guessing the loop bounds a bit easier. */
1790 gfc_add_ss_to_loop (&loop, *rss);
1791
1792 /* We only want the shape of the expression, not rest of the junk
1793 generated by the scalarizer. */
1794 loop.array_parameter = 1;
1795
1796 /* Calculate the bounds of the scalarization. */
1797 gfc_conv_ss_startstride (&loop);
1798 gfc_conv_loop_setup (&loop);
1799
1800 /* Figure out how many elements we need. */
1801 for (i = 0; i < loop.dimen; i++)
1802 {
10c7a96f
SB		 1803 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1804 gfc_index_one_node, loop.from[i]);
1805 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1806 tmp, loop.to[i]);
1807 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
6de9cd9a
DN		 1808 }
1809 gfc_add_block_to_block (pblock, &loop.pre);
1810 size = gfc_evaluate_now (size, pblock);
1811 gfc_add_block_to_block (pblock, &loop.post);
1812
1813 /* TODO: write a function that cleans up a loopinfo without freeing
1814 the SS chains. Currently a NOP. */
1815 }
1816
1817 return size;
1818}
1819
1820
1821/* Calculate the overall iterator number of the nested forall construct. */
1822
1823static tree
1824compute_overall_iter_number (forall_info *nested_forall_info, tree inner_size,
1825 stmtblock_t *block)
1826{
1827 tree tmp, number;
1828 stmtblock_t body;
1829
1830 /* TODO: optimizing the computing process. */
1831 number = gfc_create_var (gfc_array_index_type, "num");
7ab92584 1832 gfc_add_modify_expr (block, number, gfc_index_zero_node);
6de9cd9a
DN		 1833
1834 gfc_start_block (&body);
1835 if (nested_forall_info)
923ab88c
TS		 1836 tmp = build2 (PLUS_EXPR, gfc_array_index_type, number,
1837 inner_size);
6de9cd9a
DN		 1838 else
1839 tmp = inner_size;
1840 gfc_add_modify_expr (&body, number, tmp);
1841 tmp = gfc_finish_block (&body);
1842
1843 /* Generate loops. */
1844 if (nested_forall_info != NULL)
1845 tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 0, 1);
1846
1847 gfc_add_expr_to_block (block, tmp);
1848
1849 return number;
1850}
1851
1852
1853/* Allocate temporary for forall construct according to the information in
1854 nested_forall_info. INNER_SIZE is the size of temporary needed in the
1855 assignment inside forall. PTEMP1 is returned for space free. */
1856
1857static tree
1858allocate_temp_for_forall_nest (forall_info * nested_forall_info, tree type,
1859 tree inner_size, stmtblock_t * block,
1860 tree * ptemp1)
1861{
1862 tree unit;
1863 tree temp1;
1864 tree tmp;
1865 tree bytesize, size;
1866
1867 /* Calculate the total size of temporary needed in forall construct. */
1868 size = compute_overall_iter_number (nested_forall_info, inner_size, block);
1869
1870 unit = TYPE_SIZE_UNIT (type);
10c7a96f 1871 bytesize = fold_build2 (MULT_EXPR, gfc_array_index_type, size, unit);
6de9cd9a
DN		 1872
1873 *ptemp1 = NULL;
1874 temp1 = gfc_do_allocate (bytesize, size, ptemp1, block, type);
1875
1876 if (*ptemp1)
1877 tmp = gfc_build_indirect_ref (temp1);
1878 else
1879 tmp = temp1;
1880
1881 return tmp;
1882}
1883
1884
1885/* Handle assignments inside forall which need temporary. */
1886static void
1887gfc_trans_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2, tree wheremask,
1888 forall_info * nested_forall_info,
1889 stmtblock_t * block)
1890{
1891 tree type;
1892 tree inner_size;
1893 gfc_ss *lss, *rss;
1894 tree count, count1, count2;
1895 tree tmp, tmp1;
1896 tree ptemp1;
1897 tree mask, maskindex;
1898 forall_info *forall_tmp;
1899
1900 /* Create vars. count1 is the current iterator number of the nested forall.
1901 count2 is the current iterator number of the inner loops needed in the
1902 assignment. */
1903 count1 = gfc_create_var (gfc_array_index_type, "count1");
1904 count2 = gfc_create_var (gfc_array_index_type, "count2");
1905
1906 /* Count is the wheremask index. */
1907 if (wheremask)
1908 {
1909 count = gfc_create_var (gfc_array_index_type, "count");
7ab92584 1910 gfc_add_modify_expr (block, count, gfc_index_zero_node);
6de9cd9a
DN		 1911 }
1912 else
1913 count = NULL;
1914
1915 /* Initialize count1. */
7ab92584 1916 gfc_add_modify_expr (block, count1, gfc_index_zero_node);
6de9cd9a
DN		 1917
1918 /* Calculate the size of temporary needed in the assignment. Return loop, lss
1919 and rss which are used in function generate_loop_for_rhs_to_temp(). */
1920 inner_size = compute_inner_temp_size (expr1, expr2, block, &lss, &rss);
1921
1922 /* The type of LHS. Used in function allocate_temp_for_forall_nest */
1923 type = gfc_typenode_for_spec (&expr1->ts);
1924
1925 /* Allocate temporary for nested forall construct according to the
f7b529fa 1926 information in nested_forall_info and inner_size. */
6de9cd9a
DN		 1927 tmp1 = allocate_temp_for_forall_nest (nested_forall_info, type,
1928 inner_size, block, &ptemp1);
1929
1930 /* Initialize the maskindexes. */
1931 forall_tmp = nested_forall_info;
1932 while (forall_tmp != NULL)
1933 {
1934 mask = forall_tmp->mask;
1935 maskindex = forall_tmp->maskindex;
1936 if (mask)
7ab92584 1937 gfc_add_modify_expr (block, maskindex, gfc_index_zero_node);
6de9cd9a
DN		 1938 forall_tmp = forall_tmp->next_nest;
1939 }
1940
1941 /* Generate codes to copy rhs to the temporary . */
1942 tmp = generate_loop_for_rhs_to_temp (expr2, tmp1, inner_size, count,
1943 count1, count2, lss, rss, wheremask);
1944
1f2959f0 1945 /* Generate body and loops according to the information in
6de9cd9a
DN		 1946 nested_forall_info. */
1947 tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1, 1);
1948 gfc_add_expr_to_block (block, tmp);
1949
1950 /* Reset count1. */
7ab92584 1951 gfc_add_modify_expr (block, count1, gfc_index_zero_node);
6de9cd9a
DN		 1952
1953 /* Reset maskindexed. */
1954 forall_tmp = nested_forall_info;
1955 while (forall_tmp != NULL)
1956 {
1957 mask = forall_tmp->mask;
1958 maskindex = forall_tmp->maskindex;
1959 if (mask)
7ab92584 1960 gfc_add_modify_expr (block, maskindex, gfc_index_zero_node);
6de9cd9a
DN		 1961 forall_tmp = forall_tmp->next_nest;
1962 }
1963
1964 /* Reset count. */
1965 if (wheremask)
7ab92584 1966 gfc_add_modify_expr (block, count, gfc_index_zero_node);
6de9cd9a
DN		 1967
1968 /* Generate codes to copy the temporary to lhs. */
1969 tmp = generate_loop_for_temp_to_lhs (expr1, tmp1, inner_size, count,
1970 count1, count2, wheremask);
1971
1f2959f0 1972 /* Generate body and loops according to the information in
6de9cd9a
DN		 1973 nested_forall_info. */
1974 tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1, 1);
1975 gfc_add_expr_to_block (block, tmp);
1976
1977 if (ptemp1)
1978 {
1979 /* Free the temporary. */
1980 tmp = gfc_chainon_list (NULL_TREE, ptemp1);
1981 tmp = gfc_build_function_call (gfor_fndecl_internal_free, tmp);
1982 gfc_add_expr_to_block (block, tmp);
1983 }
1984}
1985
1986
1987/* Translate pointer assignment inside FORALL which need temporary. */
1988
1989static void
1990gfc_trans_pointer_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2,
1991 forall_info * nested_forall_info,
1992 stmtblock_t * block)
1993{
1994 tree type;
1995 tree inner_size;
1996 gfc_ss *lss, *rss;
1997 gfc_se lse;
1998 gfc_se rse;
1999 gfc_ss_info *info;
2000 gfc_loopinfo loop;
2001 tree desc;
2002 tree parm;
2003 tree parmtype;
2004 stmtblock_t body;
2005 tree count;
2006 tree tmp, tmp1, ptemp1;
2007 tree mask, maskindex;
2008 forall_info *forall_tmp;
2009
2010 count = gfc_create_var (gfc_array_index_type, "count");
7ab92584 2011 gfc_add_modify_expr (block, count, gfc_index_zero_node);
6de9cd9a
DN		 2012
2013 inner_size = integer_one_node;
2014 lss = gfc_walk_expr (expr1);
2015 rss = gfc_walk_expr (expr2);
2016 if (lss == gfc_ss_terminator)
2017 {
2018 type = gfc_typenode_for_spec (&expr1->ts);
2019 type = build_pointer_type (type);
2020
2021 /* Allocate temporary for nested forall construct according to the
2022 information in nested_forall_info and inner_size. */
2023 tmp1 = allocate_temp_for_forall_nest (nested_forall_info,
2024 type, inner_size, block, &ptemp1);
2025 gfc_start_block (&body);
2026 gfc_init_se (&lse, NULL);
2027 lse.expr = gfc_build_array_ref (tmp1, count);
2028 gfc_init_se (&rse, NULL);
2029 rse.want_pointer = 1;
2030 gfc_conv_expr (&rse, expr2);
2031 gfc_add_block_to_block (&body, &rse.pre);
2032 gfc_add_modify_expr (&body, lse.expr, rse.expr);
2033 gfc_add_block_to_block (&body, &rse.post);
2034
2035 /* Increment count. */
10c7a96f
SB		 2036 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2037 count, gfc_index_one_node);
6de9cd9a
DN		 2038 gfc_add_modify_expr (&body, count, tmp);
2039
2040 tmp = gfc_finish_block (&body);
2041
2042 /* Initialize the maskindexes. */
2043 forall_tmp = nested_forall_info;
2044 while (forall_tmp != NULL)
2045 {
2046 mask = forall_tmp->mask;
2047 maskindex = forall_tmp->maskindex;
2048 if (mask)
7ab92584 2049 gfc_add_modify_expr (block, maskindex, gfc_index_zero_node);
6de9cd9a
DN		 2050 forall_tmp = forall_tmp->next_nest;
2051 }
2052
1f2959f0 2053 /* Generate body and loops according to the information in
6de9cd9a
DN		 2054 nested_forall_info. */
2055 tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1, 1);
2056 gfc_add_expr_to_block (block, tmp);
2057
2058 /* Reset count. */
7ab92584 2059 gfc_add_modify_expr (block, count, gfc_index_zero_node);
6de9cd9a
DN		 2060
2061 /* Reset maskindexes. */
2062 forall_tmp = nested_forall_info;
2063 while (forall_tmp != NULL)
2064 {
2065 mask = forall_tmp->mask;
2066 maskindex = forall_tmp->maskindex;
2067 if (mask)
7ab92584 2068 gfc_add_modify_expr (block, maskindex, gfc_index_zero_node);
6de9cd9a
DN		 2069 forall_tmp = forall_tmp->next_nest;
2070 }
2071 gfc_start_block (&body);
2072 gfc_init_se (&lse, NULL);
2073 gfc_init_se (&rse, NULL);
2074 rse.expr = gfc_build_array_ref (tmp1, count);
2075 lse.want_pointer = 1;
2076 gfc_conv_expr (&lse, expr1);
2077 gfc_add_block_to_block (&body, &lse.pre);
2078 gfc_add_modify_expr (&body, lse.expr, rse.expr);
2079 gfc_add_block_to_block (&body, &lse.post);
2080 /* Increment count. */
10c7a96f
SB		 2081 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2082 count, gfc_index_one_node);
6de9cd9a
DN		 2083 gfc_add_modify_expr (&body, count, tmp);
2084 tmp = gfc_finish_block (&body);
2085
1f2959f0 2086 /* Generate body and loops according to the information in
6de9cd9a
DN		 2087 nested_forall_info. */
2088 tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1, 1);
2089 gfc_add_expr_to_block (block, tmp);
2090 }
2091 else
2092 {
2093 gfc_init_loopinfo (&loop);
2094
2095 /* Associate the SS with the loop. */
2096 gfc_add_ss_to_loop (&loop, rss);
2097
2098 /* Setup the scalarizing loops and bounds. */
2099 gfc_conv_ss_startstride (&loop);
2100
2101 gfc_conv_loop_setup (&loop);
2102
2103 info = &rss->data.info;
2104 desc = info->descriptor;
2105
2106 /* Make a new descriptor. */
2107 parmtype = gfc_get_element_type (TREE_TYPE (desc));
2108 parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen,
2109 loop.from, loop.to, 1);
2110
2111 /* Allocate temporary for nested forall construct. */
2112 tmp1 = allocate_temp_for_forall_nest (nested_forall_info, parmtype,
2113 inner_size, block, &ptemp1);
2114 gfc_start_block (&body);
2115 gfc_init_se (&lse, NULL);
2116 lse.expr = gfc_build_array_ref (tmp1, count);
2117 lse.direct_byref = 1;
2118 rss = gfc_walk_expr (expr2);
2119 gfc_conv_expr_descriptor (&lse, expr2, rss);
2120
2121 gfc_add_block_to_block (&body, &lse.pre);
2122 gfc_add_block_to_block (&body, &lse.post);
2123
2124 /* Increment count. */
10c7a96f
SB		 2125 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2126 count, gfc_index_one_node);
6de9cd9a
DN		 2127 gfc_add_modify_expr (&body, count, tmp);
2128
2129 tmp = gfc_finish_block (&body);
2130
2131 /* Initialize the maskindexes. */
2132 forall_tmp = nested_forall_info;
2133 while (forall_tmp != NULL)
2134 {
2135 mask = forall_tmp->mask;
2136 maskindex = forall_tmp->maskindex;
2137 if (mask)
7ab92584 2138 gfc_add_modify_expr (block, maskindex, gfc_index_zero_node);
6de9cd9a
DN		 2139 forall_tmp = forall_tmp->next_nest;
2140 }
2141
1f2959f0 2142 /* Generate body and loops according to the information in
6de9cd9a
DN		 2143 nested_forall_info. */
2144 tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1, 1);
2145 gfc_add_expr_to_block (block, tmp);
2146
2147 /* Reset count. */
7ab92584 2148 gfc_add_modify_expr (block, count, gfc_index_zero_node);
6de9cd9a
DN		 2149
2150 /* Reset maskindexes. */
2151 forall_tmp = nested_forall_info;
2152 while (forall_tmp != NULL)
2153 {
2154 mask = forall_tmp->mask;
2155 maskindex = forall_tmp->maskindex;
2156 if (mask)
7ab92584 2157 gfc_add_modify_expr (block, maskindex, gfc_index_zero_node);
6de9cd9a
DN		 2158 forall_tmp = forall_tmp->next_nest;
2159 }
2160 parm = gfc_build_array_ref (tmp1, count);
2161 lss = gfc_walk_expr (expr1);
2162 gfc_init_se (&lse, NULL);
2163 gfc_conv_expr_descriptor (&lse, expr1, lss);
2164 gfc_add_modify_expr (&lse.pre, lse.expr, parm);
2165 gfc_start_block (&body);
2166 gfc_add_block_to_block (&body, &lse.pre);
2167 gfc_add_block_to_block (&body, &lse.post);
2168
2169 /* Increment count. */
10c7a96f
SB		 2170 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2171 count, gfc_index_one_node);
6de9cd9a
DN		 2172 gfc_add_modify_expr (&body, count, tmp);
2173
2174 tmp = gfc_finish_block (&body);
2175
2176 tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1, 1);
2177 gfc_add_expr_to_block (block, tmp);
2178 }
2179 /* Free the temporary. */
2180 if (ptemp1)
2181 {
2182 tmp = gfc_chainon_list (NULL_TREE, ptemp1);
2183 tmp = gfc_build_function_call (gfor_fndecl_internal_free, tmp);
2184 gfc_add_expr_to_block (block, tmp);
2185 }
2186}
2187
2188
2189/* FORALL and WHERE statements are really nasty, especially when you nest
2190 them. All the rhs of a forall assignment must be evaluated before the
2191 actual assignments are performed. Presumably this also applies to all the
2192 assignments in an inner where statement. */
2193
2194/* Generate code for a FORALL statement. Any temporaries are allocated as a
2195 linear array, relying on the fact that we process in the same order in all
2196 loops.
2197
2198 forall (i=start:end:stride; maskexpr)
2199 e<i> = f<i>
2200 g<i> = h<i>
2201 end forall
e7dc5b4f 2202 (where e,f,g,h<i> are arbitrary expressions possibly involving i)
6de9cd9a
DN		 2203 Translates to:
2204 count = ((end + 1 - start) / staride)
2205 masktmp(:) = maskexpr(:)
2206
2207 maskindex = 0;
2208 for (i = start; i <= end; i += stride)
2209 {
2210 if (masktmp[maskindex++])
2211 e<i> = f<i>
2212 }
2213 maskindex = 0;
2214 for (i = start; i <= end; i += stride)
2215 {
2216 if (masktmp[maskindex++])
cafa34aa 2217 g<i> = h<i>
6de9cd9a
DN		 2218 }
2219
2220 Note that this code only works when there are no dependencies.
2221 Forall loop with array assignments and data dependencies are a real pain,
2222 because the size of the temporary cannot always be determined before the
1f2959f0 2223 loop is executed. This problem is compounded by the presence of nested
6de9cd9a
DN		 2224 FORALL constructs.
2225 */
2226
2227static tree
2228gfc_trans_forall_1 (gfc_code * code, forall_info * nested_forall_info)
2229{
2230 stmtblock_t block;
2231 stmtblock_t body;
2232 tree *var;
2233 tree *start;
2234 tree *end;
2235 tree *step;
2236 gfc_expr **varexpr;
2237 tree tmp;
2238 tree assign;
2239 tree size;
2240 tree bytesize;
2241 tree tmpvar;
2242 tree sizevar;
2243 tree lenvar;
2244 tree maskindex;
2245 tree mask;
2246 tree pmask;
2247 int n;
2248 int nvar;
2249 int need_temp;
2250 gfc_forall_iterator *fa;
2251 gfc_se se;
2252 gfc_code *c;
7b5b57b7 2253 gfc_saved_var *saved_vars;
6de9cd9a
DN		 2254 iter_info *this_forall, *iter_tmp;
2255 forall_info *info, *forall_tmp;
2256 temporary_list *temp;
2257
2258 gfc_start_block (&block);
2259
2260 n = 0;
2261 /* Count the FORALL index number. */
2262 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
2263 n++;
2264 nvar = n;
2265
2266 /* Allocate the space for var, start, end, step, varexpr. */
2267 var = (tree *) gfc_getmem (nvar * sizeof (tree));
2268 start = (tree *) gfc_getmem (nvar * sizeof (tree));
2269 end = (tree *) gfc_getmem (nvar * sizeof (tree));
2270 step = (tree *) gfc_getmem (nvar * sizeof (tree));
2271 varexpr = (gfc_expr **) gfc_getmem (nvar * sizeof (gfc_expr *));
7b5b57b7 2272 saved_vars = (gfc_saved_var *) gfc_getmem (nvar * sizeof (gfc_saved_var));
6de9cd9a
DN		 2273
2274 /* Allocate the space for info. */
2275 info = (forall_info *) gfc_getmem (sizeof (forall_info));
2276 n = 0;
2277 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
2278 {
2279 gfc_symbol *sym = fa->var->symtree->n.sym;
2280
2281 /* allocate space for this_forall. */
2282 this_forall = (iter_info *) gfc_getmem (sizeof (iter_info));
2283
6de9cd9a
DN		 2284 /* Create a temporary variable for the FORALL index. */
2285 tmp = gfc_typenode_for_spec (&sym->ts);
2286 var[n] = gfc_create_var (tmp, sym->name);
7b5b57b7
PB		 2287 gfc_shadow_sym (sym, var[n], &saved_vars[n]);
2288
6de9cd9a
DN		 2289 /* Record it in this_forall. */
2290 this_forall->var = var[n];
2291
2292 /* Replace the index symbol's backend_decl with the temporary decl. */
2293 sym->backend_decl = var[n];
2294
2295 /* Work out the start, end and stride for the loop. */
2296 gfc_init_se (&se, NULL);
2297 gfc_conv_expr_val (&se, fa->start);
2298 /* Record it in this_forall. */
2299 this_forall->start = se.expr;
2300 gfc_add_block_to_block (&block, &se.pre);
2301 start[n] = se.expr;
2302
2303 gfc_init_se (&se, NULL);
2304 gfc_conv_expr_val (&se, fa->end);
2305 /* Record it in this_forall. */
2306 this_forall->end = se.expr;
2307 gfc_make_safe_expr (&se);
2308 gfc_add_block_to_block (&block, &se.pre);
2309 end[n] = se.expr;
2310
2311 gfc_init_se (&se, NULL);
2312 gfc_conv_expr_val (&se, fa->stride);
2313 /* Record it in this_forall. */
2314 this_forall->step = se.expr;
2315 gfc_make_safe_expr (&se);
2316 gfc_add_block_to_block (&block, &se.pre);
2317 step[n] = se.expr;
2318
2319 /* Set the NEXT field of this_forall to NULL. */
2320 this_forall->next = NULL;
2321 /* Link this_forall to the info construct. */
2322 if (info->this_loop == NULL)
2323 info->this_loop = this_forall;
2324 else
2325 {
2326 iter_tmp = info->this_loop;
2327 while (iter_tmp->next != NULL)
2328 iter_tmp = iter_tmp->next;
2329 iter_tmp->next = this_forall;
2330 }
2331
2332 n++;
2333 }
2334 nvar = n;
2335
2336 /* Work out the number of elements in the mask array. */
2337 tmpvar = NULL_TREE;
2338 lenvar = NULL_TREE;
7ab92584 2339 size = gfc_index_one_node;
6de9cd9a
DN		 2340 sizevar = NULL_TREE;
2341
2342 for (n = 0; n < nvar; n++)
2343 {
2344 if (lenvar && TREE_TYPE (lenvar) != TREE_TYPE (start[n]))
2345 lenvar = NULL_TREE;
2346
2347 /* size = (end + step - start) / step. */
10c7a96f
SB		 2348 tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (start[n]),
2349 step[n], start[n]);
2350 tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (end[n]), end[n], tmp);
6de9cd9a 2351
10c7a96f 2352 tmp = fold_build2 (FLOOR_DIV_EXPR, TREE_TYPE (tmp), tmp, step[n]);
6de9cd9a
DN		 2353 tmp = convert (gfc_array_index_type, tmp);
2354
10c7a96f 2355 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
6de9cd9a
DN		 2356 }
2357
2358 /* Record the nvar and size of current forall level. */
2359 info->nvar = nvar;
2360 info->size = size;
2361
2362 /* Link the current forall level to nested_forall_info. */
2363 forall_tmp = nested_forall_info;
2364 if (forall_tmp == NULL)
2365 nested_forall_info = info;
2366 else
2367 {
2368 while (forall_tmp->next_nest != NULL)
2369 forall_tmp = forall_tmp->next_nest;
2370 info->outer = forall_tmp;
2371 forall_tmp->next_nest = info;
2372 }
2373
2374 /* Copy the mask into a temporary variable if required.
f7b529fa 2375 For now we assume a mask temporary is needed. */
6de9cd9a
DN		 2376 if (code->expr)
2377 {
2378 /* Allocate the mask temporary. */
10c7a96f
SB		 2379 bytesize = fold_build2 (MULT_EXPR, gfc_array_index_type, size,
2380 TYPE_SIZE_UNIT (boolean_type_node));
6de9cd9a
DN		 2381
2382 mask = gfc_do_allocate (bytesize, size, &pmask, &block, boolean_type_node);
2383
2384 maskindex = gfc_create_var_np (gfc_array_index_type, "mi");
2385 /* Record them in the info structure. */
2386 info->pmask = pmask;
2387 info->mask = mask;
2388 info->maskindex = maskindex;
2389
7ab92584 2390 gfc_add_modify_expr (&block, maskindex, gfc_index_zero_node);
6de9cd9a
DN		 2391
2392 /* Start of mask assignment loop body. */
2393 gfc_start_block (&body);
2394
2395 /* Evaluate the mask expression. */
2396 gfc_init_se (&se, NULL);
2397 gfc_conv_expr_val (&se, code->expr);
2398 gfc_add_block_to_block (&body, &se.pre);
2399
2400 /* Store the mask. */
2401 se.expr = convert (boolean_type_node, se.expr);
2402
2403 if (pmask)
2404 tmp = gfc_build_indirect_ref (mask);
2405 else
2406 tmp = mask;
2407 tmp = gfc_build_array_ref (tmp, maskindex);
2408 gfc_add_modify_expr (&body, tmp, se.expr);
2409
2410 /* Advance to the next mask element. */
923ab88c 2411 tmp = build2 (PLUS_EXPR, gfc_array_index_type,
7ab92584 2412 maskindex, gfc_index_one_node);
6de9cd9a
DN		 2413 gfc_add_modify_expr (&body, maskindex, tmp);
2414
2415 /* Generate the loops. */
2416 tmp = gfc_finish_block (&body);
2417 tmp = gfc_trans_nested_forall_loop (info, tmp, 0, 0);
2418 gfc_add_expr_to_block (&block, tmp);
2419 }
2420 else
2421 {
2422 /* No mask was specified. */
2423 maskindex = NULL_TREE;
2424 mask = pmask = NULL_TREE;
2425 }
2426
2427 c = code->block->next;
2428
2429 /* TODO: loop merging in FORALL statements. */
2430 /* Now that we've got a copy of the mask, generate the assignment loops. */
2431 while (c)
2432 {
2433 switch (c->op)
2434 {
2435 case EXEC_ASSIGN:
1f2959f0 2436 /* A scalar or array assignment. */
6de9cd9a 2437 need_temp = gfc_check_dependency (c->expr, c->expr2, varexpr, nvar);
69de3b83 2438 /* Temporaries due to array assignment data dependencies introduce
6de9cd9a
DN		 2439 no end of problems. */
2440 if (need_temp)
2441 gfc_trans_assign_need_temp (c->expr, c->expr2, NULL,
2442 nested_forall_info, &block);
2443 else
2444 {
2445 /* Use the normal assignment copying routines. */
2446 assign = gfc_trans_assignment (c->expr, c->expr2);
2447
2448 /* Reset the mask index. */
2449 if (mask)
7ab92584 2450 gfc_add_modify_expr (&block, maskindex, gfc_index_zero_node);
6de9cd9a
DN		 2451
2452 /* Generate body and loops. */
2453 tmp = gfc_trans_nested_forall_loop (nested_forall_info, assign, 1, 1);
2454 gfc_add_expr_to_block (&block, tmp);
2455 }
2456
2457 break;
2458
2459 case EXEC_WHERE:
2460
2461 /* Translate WHERE or WHERE construct nested in FORALL. */
2462 temp = NULL;
2463 gfc_trans_where_2 (c, NULL, NULL, nested_forall_info, &block, &temp);
2464
2465 while (temp)
2466 {
2467 tree args;
2468 temporary_list *p;
2469
2470 /* Free the temporary. */
2471 args = gfc_chainon_list (NULL_TREE, temp->temporary);
2472 tmp = gfc_build_function_call (gfor_fndecl_internal_free, args);
2473 gfc_add_expr_to_block (&block, tmp);
2474
2475 p = temp;
2476 temp = temp->next;
2477 gfc_free (p);
2478 }
2479
2480 break;
2481
2482 /* Pointer assignment inside FORALL. */
2483 case EXEC_POINTER_ASSIGN:
2484 need_temp = gfc_check_dependency (c->expr, c->expr2, varexpr, nvar);
2485 if (need_temp)
2486 gfc_trans_pointer_assign_need_temp (c->expr, c->expr2,
2487 nested_forall_info, &block);
2488 else
2489 {
2490 /* Use the normal assignment copying routines. */
2491 assign = gfc_trans_pointer_assignment (c->expr, c->expr2);
2492
2493 /* Reset the mask index. */
2494 if (mask)
7ab92584 2495 gfc_add_modify_expr (&block, maskindex, gfc_index_zero_node);
6de9cd9a
DN		 2496
2497 /* Generate body and loops. */
2498 tmp = gfc_trans_nested_forall_loop (nested_forall_info, assign,
2499 1, 1);
2500 gfc_add_expr_to_block (&block, tmp);
2501 }
2502 break;
2503
2504 case EXEC_FORALL:
2505 tmp = gfc_trans_forall_1 (c, nested_forall_info);
2506 gfc_add_expr_to_block (&block, tmp);
2507 break;
2508
2509 default:
6e45f57b 2510 gcc_unreachable ();
6de9cd9a
DN		 2511 }
2512
2513 c = c->next;
2514 }
2515
7b5b57b7
PB		 2516 /* Restore the original index variables. */
2517 for (fa = code->ext.forall_iterator, n = 0; fa; fa = fa->next, n++)
2518 gfc_restore_sym (fa->var->symtree->n.sym, &saved_vars[n]);
6de9cd9a
DN		 2519
2520 /* Free the space for var, start, end, step, varexpr. */
2521 gfc_free (var);
2522 gfc_free (start);
2523 gfc_free (end);
2524 gfc_free (step);
2525 gfc_free (varexpr);
7b5b57b7 2526 gfc_free (saved_vars);
6de9cd9a
DN		 2527
2528 if (pmask)
2529 {
2530 /* Free the temporary for the mask. */
2531 tmp = gfc_chainon_list (NULL_TREE, pmask);
2532 tmp = gfc_build_function_call (gfor_fndecl_internal_free, tmp);
2533 gfc_add_expr_to_block (&block, tmp);
2534 }
2535 if (maskindex)
2536 pushdecl (maskindex);
2537
2538 return gfc_finish_block (&block);
2539}
2540
2541
2542/* Translate the FORALL statement or construct. */
2543
2544tree gfc_trans_forall (gfc_code * code)
2545{
2546 return gfc_trans_forall_1 (code, NULL);
2547}
2548
2549
2550/* Evaluate the WHERE mask expression, copy its value to a temporary.
2551 If the WHERE construct is nested in FORALL, compute the overall temporary
2552 needed by the WHERE mask expression multiplied by the iterator number of
2553 the nested forall.
2554 ME is the WHERE mask expression.
2555 MASK is the temporary which value is mask's value.
2556 NMASK is another temporary which value is !mask.
2557 TEMP records the temporary's address allocated in this function in order to
2558 free them outside this function.
2559 MASK, NMASK and TEMP are all OUT arguments. */
2560
2561static tree
2562gfc_evaluate_where_mask (gfc_expr * me, forall_info * nested_forall_info,
2563 tree * mask, tree * nmask, temporary_list ** temp,
2564 stmtblock_t * block)
2565{
2566 tree tmp, tmp1;
2567 gfc_ss *lss, *rss;
2568 gfc_loopinfo loop;
2569 tree ptemp1, ntmp, ptemp2;
2570 tree inner_size;
2571 stmtblock_t body, body1;
2572 gfc_se lse, rse;
2573 tree count;
2574 tree tmpexpr;
2575
2576 gfc_init_loopinfo (&loop);
2577
2578 /* Calculate the size of temporary needed by the mask-expr. */
2579 inner_size = compute_inner_temp_size (me, me, block, &lss, &rss);
2580
2581 /* Allocate temporary for where mask. */
2582 tmp = allocate_temp_for_forall_nest (nested_forall_info, boolean_type_node,
2583 inner_size, block, &ptemp1);
2584 /* Record the temporary address in order to free it later. */
2585 if (ptemp1)
2586 {
2587 temporary_list *tempo;
2588 tempo = (temporary_list *) gfc_getmem (sizeof (temporary_list));
2589 tempo->temporary = ptemp1;
2590 tempo->next = *temp;
2591 *temp = tempo;
2592 }
2593
2594 /* Allocate temporary for !mask. */
2595 ntmp = allocate_temp_for_forall_nest (nested_forall_info, boolean_type_node,
2596 inner_size, block, &ptemp2);
2597 /* Record the temporary in order to free it later. */
2598 if (ptemp2)
2599 {
2600 temporary_list *tempo;
2601 tempo = (temporary_list *) gfc_getmem (sizeof (temporary_list));
2602 tempo->temporary = ptemp2;
2603 tempo->next = *temp;
2604 *temp = tempo;
2605 }
2606
2607 /* Variable to index the temporary. */
2608 count = gfc_create_var (gfc_array_index_type, "count");
1f2959f0 2609 /* Initialize count. */
7ab92584 2610 gfc_add_modify_expr (block, count, gfc_index_zero_node);
6de9cd9a
DN		 2611
2612 gfc_start_block (&body);
2613
2614 gfc_init_se (&rse, NULL);
2615 gfc_init_se (&lse, NULL);
2616
2617 if (lss == gfc_ss_terminator)
2618 {
2619 gfc_init_block (&body1);
2620 }
2621 else
2622 {
1f2959f0 2623 /* Initialize the loop. */
6de9cd9a
DN		 2624 gfc_init_loopinfo (&loop);
2625
2626 /* We may need LSS to determine the shape of the expression. */
2627 gfc_add_ss_to_loop (&loop, lss);
2628 gfc_add_ss_to_loop (&loop, rss);
2629
2630 gfc_conv_ss_startstride (&loop);
2631 gfc_conv_loop_setup (&loop);
2632
2633 gfc_mark_ss_chain_used (rss, 1);
2634 /* Start the loop body. */
2635 gfc_start_scalarized_body (&loop, &body1);
2636
2637 /* Translate the expression. */
2638 gfc_copy_loopinfo_to_se (&rse, &loop);
2639 rse.ss = rss;
2640 gfc_conv_expr (&rse, me);
2641 }
2642 /* Form the expression of the temporary. */
2643 lse.expr = gfc_build_array_ref (tmp, count);
2644 tmpexpr = gfc_build_array_ref (ntmp, count);
2645
2646 /* Use the scalar assignment to fill temporary TMP. */
2647 tmp1 = gfc_trans_scalar_assign (&lse, &rse, me->ts.type);
2648 gfc_add_expr_to_block (&body1, tmp1);
2649
2650 /* Fill temporary NTMP. */
2651 tmp1 = build1 (TRUTH_NOT_EXPR, TREE_TYPE (lse.expr), lse.expr);
2652 gfc_add_modify_expr (&body1, tmpexpr, tmp1);
2653
2654 if (lss == gfc_ss_terminator)
2655 {
2656 gfc_add_block_to_block (&body, &body1);
2657 }
2658 else
2659 {
2660 /* Increment count. */
10c7a96f
SB		 2661 tmp1 = fold_build2 (PLUS_EXPR, gfc_array_index_type, count,
2662 gfc_index_one_node);
6de9cd9a
DN		 2663 gfc_add_modify_expr (&body1, count, tmp1);
2664
2665 /* Generate the copying loops. */
2666 gfc_trans_scalarizing_loops (&loop, &body1);
2667
2668 gfc_add_block_to_block (&body, &loop.pre);
2669 gfc_add_block_to_block (&body, &loop.post);
2670
2671 gfc_cleanup_loop (&loop);
2672 /* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful
2673 as tree nodes in SS may not be valid in different scope. */
2674 }
2675
2676 tmp1 = gfc_finish_block (&body);
2677 /* If the WHERE construct is inside FORALL, fill the full temporary. */
2678 if (nested_forall_info != NULL)
2679 tmp1 = gfc_trans_nested_forall_loop (nested_forall_info, tmp1, 1, 1);
2680
2681
2682 gfc_add_expr_to_block (block, tmp1);
2683
2684 *mask = tmp;
2685 *nmask = ntmp;
2686
2687 return tmp1;
2688}
2689
2690
2691/* Translate an assignment statement in a WHERE statement or construct
2692 statement. The MASK expression is used to control which elements
2693 of EXPR1 shall be assigned. */
2694
2695static tree
2696gfc_trans_where_assign (gfc_expr *expr1, gfc_expr *expr2, tree mask,
2697 tree count1, tree count2)
2698{
2699 gfc_se lse;
2700 gfc_se rse;
2701 gfc_ss *lss;
2702 gfc_ss *lss_section;
2703 gfc_ss *rss;
2704
2705 gfc_loopinfo loop;
2706 tree tmp;
2707 stmtblock_t block;
2708 stmtblock_t body;
2709 tree index, maskexpr, tmp1;
2710
2711#if 0
2712 /* TODO: handle this special case.
2713 Special case a single function returning an array. */
2714 if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
2715 {
2716 tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
2717 if (tmp)
2718 return tmp;
2719 }
2720#endif
2721
2722 /* Assignment of the form lhs = rhs. */
2723 gfc_start_block (&block);
2724
2725 gfc_init_se (&lse, NULL);
2726 gfc_init_se (&rse, NULL);
2727
2728 /* Walk the lhs. */
2729 lss = gfc_walk_expr (expr1);
2730 rss = NULL;
2731
2732 /* In each where-assign-stmt, the mask-expr and the variable being
2733 defined shall be arrays of the same shape. */
6e45f57b 2734 gcc_assert (lss != gfc_ss_terminator);
6de9cd9a
DN		 2735
2736 /* The assignment needs scalarization. */
2737 lss_section = lss;
2738
2739 /* Find a non-scalar SS from the lhs. */
2740 while (lss_section != gfc_ss_terminator
2741 && lss_section->type != GFC_SS_SECTION)
2742 lss_section = lss_section->next;
2743
6e45f57b 2744 gcc_assert (lss_section != gfc_ss_terminator);
6de9cd9a
DN		 2745
2746 /* Initialize the scalarizer. */
2747 gfc_init_loopinfo (&loop);
2748
2749 /* Walk the rhs. */
2750 rss = gfc_walk_expr (expr2);
2751 if (rss == gfc_ss_terminator)
2752 {
2753 /* The rhs is scalar. Add a ss for the expression. */
2754 rss = gfc_get_ss ();
2755 rss->next = gfc_ss_terminator;
2756 rss->type = GFC_SS_SCALAR;
2757 rss->expr = expr2;
2758 }
2759
2760 /* Associate the SS with the loop. */
2761 gfc_add_ss_to_loop (&loop, lss);
2762 gfc_add_ss_to_loop (&loop, rss);
2763
2764 /* Calculate the bounds of the scalarization. */
2765 gfc_conv_ss_startstride (&loop);
2766
2767 /* Resolve any data dependencies in the statement. */
2768 gfc_conv_resolve_dependencies (&loop, lss_section, rss);
2769
2770 /* Setup the scalarizing loops. */
2771 gfc_conv_loop_setup (&loop);
2772
2773 /* Setup the gfc_se structures. */
2774 gfc_copy_loopinfo_to_se (&lse, &loop);
2775 gfc_copy_loopinfo_to_se (&rse, &loop);
2776
2777 rse.ss = rss;
2778 gfc_mark_ss_chain_used (rss, 1);
2779 if (loop.temp_ss == NULL)
2780 {
2781 lse.ss = lss;
2782 gfc_mark_ss_chain_used (lss, 1);
2783 }
2784 else
2785 {
2786 lse.ss = loop.temp_ss;
2787 gfc_mark_ss_chain_used (lss, 3);
2788 gfc_mark_ss_chain_used (loop.temp_ss, 3);
2789 }
2790
2791 /* Start the scalarized loop body. */
2792 gfc_start_scalarized_body (&loop, &body);
2793
2794 /* Translate the expression. */
2795 gfc_conv_expr (&rse, expr2);
2796 if (lss != gfc_ss_terminator && loop.temp_ss != NULL)
2797 {
2798 gfc_conv_tmp_array_ref (&lse);
2799 gfc_advance_se_ss_chain (&lse);
2800 }
2801 else
2802 gfc_conv_expr (&lse, expr1);
2803
2804 /* Form the mask expression according to the mask tree list. */
2805 index = count1;
2806 tmp = mask;
2807 if (tmp != NULL)
2808 maskexpr = gfc_build_array_ref (tmp, index);
2809 else
2810 maskexpr = NULL;
2811
2812 tmp = TREE_CHAIN (tmp);
2813 while (tmp)
2814 {
2815 tmp1 = gfc_build_array_ref (tmp, index);
923ab88c 2816 maskexpr = build2 (TRUTH_AND_EXPR, TREE_TYPE (tmp1), maskexpr, tmp1);
6de9cd9a
DN		 2817 tmp = TREE_CHAIN (tmp);
2818 }
2819 /* Use the scalar assignment as is. */
2820 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
923ab88c 2821 tmp = build3_v (COND_EXPR, maskexpr, tmp, build_empty_stmt ());
6de9cd9a
DN		 2822
2823 gfc_add_expr_to_block (&body, tmp);
2824
2825 if (lss == gfc_ss_terminator)
2826 {
2827 /* Increment count1. */
10c7a96f
SB		 2828 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2829 count1, gfc_index_one_node);
6de9cd9a
DN		 2830 gfc_add_modify_expr (&body, count1, tmp);
2831
2832 /* Use the scalar assignment as is. */
2833 gfc_add_block_to_block (&block, &body);
2834 }
2835 else
2836 {
6e45f57b
PB		 2837 gcc_assert (lse.ss == gfc_ss_terminator
2838 && rse.ss == gfc_ss_terminator);
6de9cd9a
DN		 2839
2840 if (loop.temp_ss != NULL)
2841 {
2842 /* Increment count1 before finish the main body of a scalarized
2843 expression. */
10c7a96f
SB		 2844 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2845 count1, gfc_index_one_node);
6de9cd9a
DN		 2846 gfc_add_modify_expr (&body, count1, tmp);
2847 gfc_trans_scalarized_loop_boundary (&loop, &body);
2848
2849 /* We need to copy the temporary to the actual lhs. */
2850 gfc_init_se (&lse, NULL);
2851 gfc_init_se (&rse, NULL);
2852 gfc_copy_loopinfo_to_se (&lse, &loop);
2853 gfc_copy_loopinfo_to_se (&rse, &loop);
2854
2855 rse.ss = loop.temp_ss;
2856 lse.ss = lss;
2857
2858 gfc_conv_tmp_array_ref (&rse);
2859 gfc_advance_se_ss_chain (&rse);
2860 gfc_conv_expr (&lse, expr1);
2861
6e45f57b
PB		 2862 gcc_assert (lse.ss == gfc_ss_terminator
2863 && rse.ss == gfc_ss_terminator);
6de9cd9a
DN		 2864
2865 /* Form the mask expression according to the mask tree list. */
2866 index = count2;
2867 tmp = mask;
2868 if (tmp != NULL)
2869 maskexpr = gfc_build_array_ref (tmp, index);
2870 else
2871 maskexpr = NULL;
2872
2873 tmp = TREE_CHAIN (tmp);
2874 while (tmp)
2875 {
2876 tmp1 = gfc_build_array_ref (tmp, index);
923ab88c
TS		 2877 maskexpr = build2 (TRUTH_AND_EXPR, TREE_TYPE (tmp1),
2878 maskexpr, tmp1);
6de9cd9a
DN		 2879 tmp = TREE_CHAIN (tmp);
2880 }
2881 /* Use the scalar assignment as is. */
2882 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
923ab88c 2883 tmp = build3_v (COND_EXPR, maskexpr, tmp, build_empty_stmt ());
6de9cd9a 2884 gfc_add_expr_to_block (&body, tmp);
7ab92584 2885
6de9cd9a 2886 /* Increment count2. */
10c7a96f
SB		 2887 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2888 count2, gfc_index_one_node);
6de9cd9a
DN		 2889 gfc_add_modify_expr (&body, count2, tmp);
2890 }
2891 else
2892 {
2893 /* Increment count1. */
10c7a96f
SB		 2894 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2895 count1, gfc_index_one_node);
6de9cd9a
DN		 2896 gfc_add_modify_expr (&body, count1, tmp);
2897 }
2898
2899 /* Generate the copying loops. */
2900 gfc_trans_scalarizing_loops (&loop, &body);
2901
2902 /* Wrap the whole thing up. */
2903 gfc_add_block_to_block (&block, &loop.pre);
2904 gfc_add_block_to_block (&block, &loop.post);
2905 gfc_cleanup_loop (&loop);
2906 }
2907
2908 return gfc_finish_block (&block);
2909}
2910
2911
2912/* Translate the WHERE construct or statement.
1f2959f0 2913 This fuction can be called iteratively to translate the nested WHERE
6de9cd9a
DN		 2914 construct or statement.
2915 MASK is the control mask, and PMASK is the pending control mask.
2916 TEMP records the temporary address which must be freed later. */
2917
2918static void
2919gfc_trans_where_2 (gfc_code * code, tree mask, tree pmask,
2920 forall_info * nested_forall_info, stmtblock_t * block,
2921 temporary_list ** temp)
2922{
2923 gfc_expr *expr1;
2924 gfc_expr *expr2;
2925 gfc_code *cblock;
2926 gfc_code *cnext;
2927 tree tmp, tmp1, tmp2;
2928 tree count1, count2;
2929 tree mask_copy;
2930 int need_temp;
2931
2932 /* the WHERE statement or the WHERE construct statement. */
2933 cblock = code->block;
2934 while (cblock)
2935 {
2936 /* Has mask-expr. */
2937 if (cblock->expr)
2938 {
2939 /* Ensure that the WHERE mask be evaluated only once. */
2940 tmp2 = gfc_evaluate_where_mask (cblock->expr, nested_forall_info,
2941 &tmp, &tmp1, temp, block);
2942
2943 /* Set the control mask and the pending control mask. */
2944 /* It's a where-stmt. */
2945 if (mask == NULL)
2946 {
2947 mask = tmp;
2948 pmask = tmp1;
2949 }
2950 /* It's a nested where-stmt. */
2951 else if (mask && pmask == NULL)
2952 {
2953 tree tmp2;
2954 /* Use the TREE_CHAIN to list the masks. */
2955 tmp2 = copy_list (mask);
2956 pmask = chainon (mask, tmp1);
2957 mask = chainon (tmp2, tmp);
2958 }
2959 /* It's a masked-elsewhere-stmt. */
2960 else if (mask && cblock->expr)
2961 {
2962 tree tmp2;
2963 tmp2 = copy_list (pmask);
2964
2965 mask = pmask;
2966 tmp2 = chainon (tmp2, tmp);
2967 pmask = chainon (mask, tmp1);
2968 mask = tmp2;
2969 }
2970 }
2971 /* It's a elsewhere-stmt. No mask-expr is present. */
2972 else
2973 mask = pmask;
2974
2975 /* Get the assignment statement of a WHERE statement, or the first
2976 statement in where-body-construct of a WHERE construct. */
2977 cnext = cblock->next;
2978 while (cnext)
2979 {
2980 switch (cnext->op)
2981 {
2982 /* WHERE assignment statement. */
2983 case EXEC_ASSIGN:
2984 expr1 = cnext->expr;
2985 expr2 = cnext->expr2;
2986 if (nested_forall_info != NULL)
2987 {
2988 int nvar;
2989 gfc_expr **varexpr;
2990
2991 nvar = nested_forall_info->nvar;
2992 varexpr = (gfc_expr **)
2993 gfc_getmem (nvar * sizeof (gfc_expr *));
2994 need_temp = gfc_check_dependency (expr1, expr2, varexpr,
2995 nvar);
2996 if (need_temp)
2997 gfc_trans_assign_need_temp (expr1, expr2, mask,
2998 nested_forall_info, block);
2999 else
3000 {
3001 /* Variables to control maskexpr. */
3002 count1 = gfc_create_var (gfc_array_index_type, "count1");
3003 count2 = gfc_create_var (gfc_array_index_type, "count2");
7ab92584
SB		 3004 gfc_add_modify_expr (block, count1, gfc_index_zero_node);
3005 gfc_add_modify_expr (block, count2, gfc_index_zero_node);
6de9cd9a
DN		 3006
3007 tmp = gfc_trans_where_assign (expr1, expr2, mask, count1,
3008 count2);
3009 tmp = gfc_trans_nested_forall_loop (nested_forall_info,
3010 tmp, 1, 1);
3011 gfc_add_expr_to_block (block, tmp);
3012 }
3013 }
3014 else
3015 {
3016 /* Variables to control maskexpr. */
3017 count1 = gfc_create_var (gfc_array_index_type, "count1");
3018 count2 = gfc_create_var (gfc_array_index_type, "count2");
7ab92584
SB		 3019 gfc_add_modify_expr (block, count1, gfc_index_zero_node);
3020 gfc_add_modify_expr (block, count2, gfc_index_zero_node);
6de9cd9a
DN		 3021
3022 tmp = gfc_trans_where_assign (expr1, expr2, mask, count1,
3023 count2);
3024 gfc_add_expr_to_block (block, tmp);
3025
3026 }
3027 break;
3028
3029 /* WHERE or WHERE construct is part of a where-body-construct. */
3030 case EXEC_WHERE:
3031 /* Ensure that MASK is not modified by next gfc_trans_where_2. */
3032 mask_copy = copy_list (mask);
3033 gfc_trans_where_2 (cnext, mask_copy, NULL, nested_forall_info,
3034 block, temp);
3035 break;
3036
3037 default:
6e45f57b 3038 gcc_unreachable ();
6de9cd9a
DN		 3039 }
3040
3041 /* The next statement within the same where-body-construct. */
3042 cnext = cnext->next;
3043 }
3044 /* The next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt. */
3045 cblock = cblock->block;
3046 }
3047}
3048
3049
3050/* As the WHERE or WHERE construct statement can be nested, we call
3051 gfc_trans_where_2 to do the translation, and pass the initial
f7b529fa 3052 NULL values for both the control mask and the pending control mask. */
6de9cd9a
DN		 3053
3054tree
3055gfc_trans_where (gfc_code * code)
3056{
3057 stmtblock_t block;
3058 temporary_list *temp, *p;
3059 tree args;
3060 tree tmp;
3061
3062 gfc_start_block (&block);
3063 temp = NULL;
3064
3065 gfc_trans_where_2 (code, NULL, NULL, NULL, &block, &temp);
3066
3067 /* Add calls to free temporaries which were dynamically allocated. */
3068 while (temp)
3069 {
3070 args = gfc_chainon_list (NULL_TREE, temp->temporary);
3071 tmp = gfc_build_function_call (gfor_fndecl_internal_free, args);
3072 gfc_add_expr_to_block (&block, tmp);
3073
3074 p = temp;
3075 temp = temp->next;
3076 gfc_free (p);
3077 }
3078 return gfc_finish_block (&block);
3079}
3080
3081
3082/* CYCLE a DO loop. The label decl has already been created by
3083 gfc_trans_do(), it's in TREE_PURPOSE (backend_decl) of the gfc_code
3084 node at the head of the loop. We must mark the label as used. */
3085
3086tree
3087gfc_trans_cycle (gfc_code * code)
3088{
3089 tree cycle_label;
3090
3091 cycle_label = TREE_PURPOSE (code->ext.whichloop->backend_decl);
3092 TREE_USED (cycle_label) = 1;
3093 return build1_v (GOTO_EXPR, cycle_label);
3094}
3095
3096
e7dc5b4f 3097/* EXIT a DO loop. Similar to CYCLE, but now the label is in
6de9cd9a
DN		 3098 TREE_VALUE (backend_decl) of the gfc_code node at the head of the
3099 loop. */
3100
3101tree
3102gfc_trans_exit (gfc_code * code)
3103{
3104 tree exit_label;
3105
3106 exit_label = TREE_VALUE (code->ext.whichloop->backend_decl);
3107 TREE_USED (exit_label) = 1;
3108 return build1_v (GOTO_EXPR, exit_label);
3109}
3110
3111
3112/* Translate the ALLOCATE statement. */
3113
3114tree
3115gfc_trans_allocate (gfc_code * code)
3116{
3117 gfc_alloc *al;
3118 gfc_expr *expr;
3119 gfc_se se;
3120 tree tmp;
3121 tree parm;
3122 gfc_ref *ref;
3123 tree stat;
3124 tree pstat;
3125 tree error_label;
3126 stmtblock_t block;
3127
3128 if (!code->ext.alloc_list)
3129 return NULL_TREE;
3130
3131 gfc_start_block (&block);
3132
3133 if (code->expr)
3134 {
e2cad04b
RH		 3135 tree gfc_int4_type_node = gfc_get_int_type (4);
3136
6de9cd9a
DN		 3137 stat = gfc_create_var (gfc_int4_type_node, "stat");
3138 pstat = gfc_build_addr_expr (NULL, stat);
3139
3140 error_label = gfc_build_label_decl (NULL_TREE);
3141 TREE_USED (error_label) = 1;
3142 }
3143 else
3144 {
3145 pstat = integer_zero_node;
3146 stat = error_label = NULL_TREE;
3147 }
3148
3149
3150 for (al = code->ext.alloc_list; al != NULL; al = al->next)
3151 {
3152 expr = al->expr;
3153
3154 gfc_init_se (&se, NULL);
3155 gfc_start_block (&se.pre);
3156
3157 se.want_pointer = 1;
3158 se.descriptor_only = 1;
3159 gfc_conv_expr (&se, expr);
3160
3161 ref = expr->ref;
3162
3163 /* Find the last reference in the chain. */
3164 while (ref && ref->next != NULL)
3165 {
6e45f57b 3166 gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT);
6de9cd9a
DN		 3167 ref = ref->next;
3168 }
3169
3170 if (ref != NULL && ref->type == REF_ARRAY)
3171 {
3172 /* An array. */
3173 gfc_array_allocate (&se, ref, pstat);
3174 }
3175 else
3176 {
3177 /* A scalar or derived type. */
3178 tree val;
3179
3180 val = gfc_create_var (ppvoid_type_node, "ptr");
3181 tmp = gfc_build_addr_expr (ppvoid_type_node, se.expr);
3182 gfc_add_modify_expr (&se.pre, val, tmp);
3183
3184 tmp = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (se.expr)));
3185 parm = gfc_chainon_list (NULL_TREE, val);
3186 parm = gfc_chainon_list (parm, tmp);
3187 parm = gfc_chainon_list (parm, pstat);
3188 tmp = gfc_build_function_call (gfor_fndecl_allocate, parm);
3189 gfc_add_expr_to_block (&se.pre, tmp);
3190
3191 if (code->expr)
3192 {
3193 tmp = build1_v (GOTO_EXPR, error_label);
3194 parm =
923ab88c
TS		 3195 build2 (NE_EXPR, boolean_type_node, stat, integer_zero_node);
3196 tmp = build3_v (COND_EXPR, parm, tmp, build_empty_stmt ());
6de9cd9a
DN		 3197 gfc_add_expr_to_block (&se.pre, tmp);
3198 }
3199 }
3200
3201 tmp = gfc_finish_block (&se.pre);
3202 gfc_add_expr_to_block (&block, tmp);
3203 }
3204
3205 /* Assign the value to the status variable. */
3206 if (code->expr)
3207 {
3208 tmp = build1_v (LABEL_EXPR, error_label);
3209 gfc_add_expr_to_block (&block, tmp);
3210
3211 gfc_init_se (&se, NULL);
3212 gfc_conv_expr_lhs (&se, code->expr);
3213 tmp = convert (TREE_TYPE (se.expr), stat);
3214 gfc_add_modify_expr (&block, se.expr, tmp);
3215 }
3216
3217 return gfc_finish_block (&block);
3218}
3219
3220
3221tree
3222gfc_trans_deallocate (gfc_code * code)
3223{
3224 gfc_se se;
3225 gfc_alloc *al;
3226 gfc_expr *expr;
3227 tree var;
3228 tree tmp;
3229 tree type;
3230 stmtblock_t block;
3231
3232 gfc_start_block (&block);
3233
3234 for (al = code->ext.alloc_list; al != NULL; al = al->next)
3235 {
3236 expr = al->expr;
6e45f57b 3237 gcc_assert (expr->expr_type == EXPR_VARIABLE);
6de9cd9a
DN		 3238
3239 gfc_init_se (&se, NULL);
3240 gfc_start_block (&se.pre);
3241
3242 se.want_pointer = 1;
3243 se.descriptor_only = 1;
3244 gfc_conv_expr (&se, expr);
3245
3246 if (expr->symtree->n.sym->attr.dimension)
3247 {
3248 tmp = gfc_array_deallocate (se.expr);
3249 gfc_add_expr_to_block (&se.pre, tmp);
3250 }
3251 else
3252 {
3253 type = build_pointer_type (TREE_TYPE (se.expr));
3254 var = gfc_create_var (type, "ptr");
3255 tmp = gfc_build_addr_expr (type, se.expr);
3256 gfc_add_modify_expr (&se.pre, var, tmp);
3257
3258 tmp = gfc_chainon_list (NULL_TREE, var);
3259 tmp = gfc_chainon_list (tmp, integer_zero_node);
3260 tmp = gfc_build_function_call (gfor_fndecl_deallocate, tmp);
3261 gfc_add_expr_to_block (&se.pre, tmp);
3262 }
3263 tmp = gfc_finish_block (&se.pre);
3264 gfc_add_expr_to_block (&block, tmp);
3265 }
3266
3267 return gfc_finish_block (&block);
3268}
3269
Mirror of https://gcc.gnu.org/git/gcc.git