OSDN Git Service

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