OSDN Git Service

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