OSDN Git Service

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