gcc/fortran/trans-stmt.c

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