OSDN Git Service

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