OSDN Git Service

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