OSDN Git Service

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