OSDN Git Service

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