OSDN Git Service

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