OSDN Git Service

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