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