OSDN Git Service

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