OSDN Git Service

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