OSDN Git Service

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