gcc/fortran/trans-stmt.c

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