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