gcc/fortran/trans-stmt.c

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