OSDN Git Service

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