OSDN Git Service

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