OSDN Git Service

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