gcc/fortran/trans-stmt.c

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