gcc/fortran/trans-stmt.c

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