OSDN Git Service

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