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 (pchar_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 size,
1520                           tree count3, tree count1, tree count2, 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 index;
1528   tree wheremaskexpr;
1529
1530   /* Walk the lhs.  */
1531   lss = gfc_walk_expr (expr);
1532
1533   if (lss == gfc_ss_terminator)
1534     {
1535       gfc_start_block (&block);
1536
1537       gfc_init_se (&lse, NULL);
1538
1539       /* Translate the expression.  */
1540       gfc_conv_expr (&lse, expr);
1541
1542       /* Form the expression for the temporary.  */
1543       tmp = gfc_build_array_ref (tmp1, count1);
1544
1545       /* Use the scalar assignment as is.  */
1546       gfc_add_block_to_block (&block, &lse.pre);
1547       gfc_add_modify_expr (&block, lse.expr, tmp);
1548       gfc_add_block_to_block (&block, &lse.post);
1549
1550       /* Increment the count1.  */
1551       tmp = fold (build2 (PLUS_EXPR, TREE_TYPE (count1), count1, size));
1552       gfc_add_modify_expr (&block, count1, tmp);
1553       tmp = gfc_finish_block (&block);
1554     }
1555   else
1556     {
1557       gfc_start_block (&block);
1558
1559       gfc_init_loopinfo (&loop1);
1560       gfc_init_se (&rse, NULL);
1561       gfc_init_se (&lse, NULL);
1562
1563       /* Associate the lss with the loop.  */
1564       gfc_add_ss_to_loop (&loop1, lss);
1565
1566       /* Calculate the bounds of the scalarization.  */
1567       gfc_conv_ss_startstride (&loop1);
1568       /* Setup the scalarizing loops.  */
1569       gfc_conv_loop_setup (&loop1);
1570
1571       gfc_mark_ss_chain_used (lss, 1);
1572       /* Initialize count2.  */
1573       gfc_add_modify_expr (&block, count2, gfc_index_zero_node);
1574
1575       /* Start the scalarized loop body.  */
1576       gfc_start_scalarized_body (&loop1, &body);
1577
1578       /* Setup the gfc_se structures.  */
1579       gfc_copy_loopinfo_to_se (&lse, &loop1);
1580       lse.ss = lss;
1581
1582       /* Form the expression of the temporary.  */
1583       if (lss != gfc_ss_terminator)
1584         {
1585           index = fold (build2 (PLUS_EXPR, gfc_array_index_type,
1586                                 count1, count2));
1587           rse.expr = gfc_build_array_ref (tmp1, index);
1588         }
1589       /* Translate expr.  */
1590       gfc_conv_expr (&lse, expr);
1591
1592       /* Use the scalar assignment.  */
1593       tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts.type);
1594
1595      /* Form the mask expression according to the mask tree list.  */
1596      if (wheremask)
1597        {
1598          wheremaskexpr = gfc_build_array_ref (wheremask, count3);
1599          tmp2 = TREE_CHAIN (wheremask);
1600          while (tmp2)
1601            {
1602              tmp1 = gfc_build_array_ref (tmp2, count3);
1603              wheremaskexpr = build2 (TRUTH_AND_EXPR, TREE_TYPE (tmp1),
1604                                      wheremaskexpr, tmp1);
1605              tmp2 = TREE_CHAIN (tmp2);
1606            }
1607          tmp = build3_v (COND_EXPR, wheremaskexpr, tmp, build_empty_stmt ());
1608        }
1609
1610       gfc_add_expr_to_block (&body, tmp);
1611
1612       /* Increment count2.  */
1613       tmp = fold (build2 (PLUS_EXPR, gfc_array_index_type,
1614                           count2, gfc_index_one_node));
1615       gfc_add_modify_expr (&body, count2, tmp);
1616
1617       /* Increment count3.  */
1618       if (count3)
1619         {
1620           tmp = fold (build2 (PLUS_EXPR, gfc_array_index_type,
1621                               count3, gfc_index_one_node));
1622           gfc_add_modify_expr (&body, count3, tmp);
1623         }
1624
1625       /* Generate the copying loops.  */
1626       gfc_trans_scalarizing_loops (&loop1, &body);
1627       gfc_add_block_to_block (&block, &loop1.pre);
1628       gfc_add_block_to_block (&block, &loop1.post);
1629       gfc_cleanup_loop (&loop1);
1630
1631       /* Increment count1.  */
1632       tmp = fold (build2 (PLUS_EXPR, TREE_TYPE (count1), count1, size));
1633       gfc_add_modify_expr (&block, count1, tmp);
1634       tmp = gfc_finish_block (&block);
1635     }
1636   return tmp;
1637 }
1638
1639
1640 /* Generate codes to copy rhs to the temporary. TMP1 is the address of temporary
1641    LSS and RSS are formed in function compute_inner_temp_size(), and should
1642    not be freed.  */
1643
1644 static tree
1645 generate_loop_for_rhs_to_temp (gfc_expr *expr2, tree tmp1, tree size,
1646                                tree count3, tree count1, tree count2,
1647                             gfc_ss *lss, gfc_ss *rss, tree wheremask)
1648 {
1649   stmtblock_t block, body1;
1650   gfc_loopinfo loop;
1651   gfc_se lse;
1652   gfc_se rse;
1653   tree tmp, tmp2, index;
1654   tree wheremaskexpr;
1655
1656   gfc_start_block (&block);
1657
1658   gfc_init_se (&rse, NULL);
1659   gfc_init_se (&lse, NULL);
1660
1661   if (lss == gfc_ss_terminator)
1662     {
1663       gfc_init_block (&body1);
1664       gfc_conv_expr (&rse, expr2);
1665       lse.expr = gfc_build_array_ref (tmp1, count1);
1666     }
1667   else
1668     {
1669       /* Initialize count2.  */
1670       gfc_add_modify_expr (&block, count2, gfc_index_zero_node);
1671
1672       /* Initialize the loop.  */
1673       gfc_init_loopinfo (&loop);
1674
1675       /* We may need LSS to determine the shape of the expression.  */
1676       gfc_add_ss_to_loop (&loop, lss);
1677       gfc_add_ss_to_loop (&loop, rss);
1678
1679       gfc_conv_ss_startstride (&loop);
1680       gfc_conv_loop_setup (&loop);
1681
1682       gfc_mark_ss_chain_used (rss, 1);
1683       /* Start the loop body.  */
1684       gfc_start_scalarized_body (&loop, &body1);
1685
1686       /* Translate the expression.  */
1687       gfc_copy_loopinfo_to_se (&rse, &loop);
1688       rse.ss = rss;
1689       gfc_conv_expr (&rse, expr2);
1690
1691       /* Form the expression of the temporary.  */
1692       index = fold (build2 (PLUS_EXPR, gfc_array_index_type, count1, count2));
1693       lse.expr = gfc_build_array_ref (tmp1, index);
1694     }
1695
1696   /* Use the scalar assignment.  */
1697   tmp = gfc_trans_scalar_assign (&lse, &rse, expr2->ts.type);
1698
1699   /* Form the mask expression according to the mask tree list.  */
1700   if (wheremask)
1701     {
1702       wheremaskexpr = gfc_build_array_ref (wheremask, count3);
1703       tmp2 = TREE_CHAIN (wheremask);
1704       while (tmp2)
1705         {
1706           tmp1 = gfc_build_array_ref (tmp2, count3);
1707           wheremaskexpr = build2 (TRUTH_AND_EXPR, TREE_TYPE (tmp1),
1708                                   wheremaskexpr, tmp1);
1709           tmp2 = TREE_CHAIN (tmp2);
1710         }
1711       tmp = build3_v (COND_EXPR, wheremaskexpr, tmp, build_empty_stmt ());
1712     }
1713
1714   gfc_add_expr_to_block (&body1, tmp);
1715
1716   if (lss == gfc_ss_terminator)
1717     {
1718       gfc_add_block_to_block (&block, &body1);
1719     }
1720   else
1721     {
1722       /* Increment count2.  */
1723       tmp = fold (build2 (PLUS_EXPR, gfc_array_index_type,
1724                           count2, gfc_index_one_node));
1725       gfc_add_modify_expr (&body1, count2, tmp);
1726
1727       /* Increment count3.  */
1728       if (count3)
1729         {
1730           tmp = fold (build2 (PLUS_EXPR, gfc_array_index_type,
1731                               count3, gfc_index_one_node));
1732           gfc_add_modify_expr (&body1, count3, tmp);
1733         }
1734
1735       /* Generate the copying loops.  */
1736       gfc_trans_scalarizing_loops (&loop, &body1);
1737
1738       gfc_add_block_to_block (&block, &loop.pre);
1739       gfc_add_block_to_block (&block, &loop.post);
1740
1741       gfc_cleanup_loop (&loop);
1742       /* TODO: Reuse lss and rss when copying temp->lhs.  Need to be careful
1743          as tree nodes in SS may not be valid in different scope.  */
1744     }
1745   /* Increment count1.  */
1746   tmp = fold (build2 (PLUS_EXPR, TREE_TYPE (count1), count1, size));
1747   gfc_add_modify_expr (&block, count1, tmp);
1748
1749   tmp = gfc_finish_block (&block);
1750   return tmp;
1751 }
1752
1753
1754 /* Calculate the size of temporary needed in the assignment inside forall.
1755    LSS and RSS are filled in this function.  */
1756
1757 static tree
1758 compute_inner_temp_size (gfc_expr *expr1, gfc_expr *expr2,
1759                          stmtblock_t * pblock,
1760                          gfc_ss **lss, gfc_ss **rss)
1761 {
1762   gfc_loopinfo loop;
1763   tree size;
1764   int i;
1765   tree tmp;
1766
1767   *lss = gfc_walk_expr (expr1);
1768   *rss = NULL;
1769
1770   size = gfc_index_one_node;
1771   if (*lss != gfc_ss_terminator)
1772     {
1773       gfc_init_loopinfo (&loop);
1774
1775       /* Walk the RHS of the expression.  */
1776       *rss = gfc_walk_expr (expr2);
1777       if (*rss == gfc_ss_terminator)
1778         {
1779           /* The rhs is scalar.  Add a ss for the expression.  */
1780           *rss = gfc_get_ss ();
1781           (*rss)->next = gfc_ss_terminator;
1782           (*rss)->type = GFC_SS_SCALAR;
1783           (*rss)->expr = expr2;
1784         }
1785
1786       /* Associate the SS with the loop.  */
1787       gfc_add_ss_to_loop (&loop, *lss);
1788       /* We don't actually need to add the rhs at this point, but it might
1789          make guessing the loop bounds a bit easier.  */
1790       gfc_add_ss_to_loop (&loop, *rss);
1791
1792       /* We only want the shape of the expression, not rest of the junk
1793          generated by the scalarizer.  */
1794       loop.array_parameter = 1;
1795
1796       /* Calculate the bounds of the scalarization.  */
1797       gfc_conv_ss_startstride (&loop);
1798       gfc_conv_loop_setup (&loop);
1799
1800       /* Figure out how many elements we need.  */
1801       for (i = 0; i < loop.dimen; i++)
1802         {
1803           tmp = fold (build2 (MINUS_EXPR, gfc_array_index_type,
1804                               gfc_index_one_node, loop.from[i]));
1805           tmp = fold (build2 (PLUS_EXPR, gfc_array_index_type,
1806                               tmp, loop.to[i]));
1807           size = fold (build2 (MULT_EXPR, gfc_array_index_type, size, tmp));
1808         }
1809       gfc_add_block_to_block (pblock, &loop.pre);
1810       size = gfc_evaluate_now (size, pblock);
1811       gfc_add_block_to_block (pblock, &loop.post);
1812
1813       /* TODO: write a function that cleans up a loopinfo without freeing
1814          the SS chains.  Currently a NOP.  */
1815     }
1816
1817   return size;
1818 }
1819
1820
1821 /* Calculate the overall iterator number of the nested forall construct.  */
1822
1823 static tree
1824 compute_overall_iter_number (forall_info *nested_forall_info, tree inner_size,
1825                              stmtblock_t *block)
1826 {
1827   tree tmp, number;
1828   stmtblock_t body;
1829
1830   /* TODO: optimizing the computing process.  */
1831   number = gfc_create_var (gfc_array_index_type, "num");
1832   gfc_add_modify_expr (block, number, gfc_index_zero_node);
1833
1834   gfc_start_block (&body);
1835   if (nested_forall_info)
1836     tmp = build2 (PLUS_EXPR, gfc_array_index_type, number,
1837                   inner_size);
1838   else
1839     tmp = inner_size;
1840   gfc_add_modify_expr (&body, number, tmp);
1841   tmp = gfc_finish_block (&body);
1842
1843   /* Generate loops.  */
1844   if (nested_forall_info != NULL)
1845     tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 0, 1);
1846
1847   gfc_add_expr_to_block (block, tmp);
1848
1849   return number;
1850 }
1851
1852
1853 /* Allocate temporary for forall construct according to the information in
1854    nested_forall_info.  INNER_SIZE is the size of temporary needed in the
1855    assignment inside forall.  PTEMP1 is returned for space free.  */
1856
1857 static tree
1858 allocate_temp_for_forall_nest (forall_info * nested_forall_info, tree type,
1859                                tree inner_size, stmtblock_t * block,
1860                                tree * ptemp1)
1861 {
1862   tree unit;
1863   tree temp1;
1864   tree tmp;
1865   tree bytesize, size;
1866
1867   /* Calculate the total size of temporary needed in forall construct.  */
1868   size = compute_overall_iter_number (nested_forall_info, inner_size, block);
1869
1870   unit = TYPE_SIZE_UNIT (type);
1871   bytesize = fold (build2 (MULT_EXPR, gfc_array_index_type, size, unit));
1872
1873   *ptemp1 = NULL;
1874   temp1 = gfc_do_allocate (bytesize, size, ptemp1, block, type);
1875
1876   if (*ptemp1)
1877     tmp = gfc_build_indirect_ref (temp1);
1878   else
1879     tmp = temp1;
1880
1881   return tmp;
1882 }
1883
1884
1885 /* Handle assignments inside forall which need temporary.  */
1886 static void
1887 gfc_trans_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2, tree wheremask,
1888                             forall_info * nested_forall_info,
1889                             stmtblock_t * block)
1890 {
1891   tree type;
1892   tree inner_size;
1893   gfc_ss *lss, *rss;
1894   tree count, count1, count2;
1895   tree tmp, tmp1;
1896   tree ptemp1;
1897   tree mask, maskindex;
1898   forall_info *forall_tmp;
1899
1900   /* Create vars. count1 is the current iterator number of the nested forall.
1901      count2 is the current iterator number of the inner loops needed in the
1902      assignment.  */
1903   count1 = gfc_create_var (gfc_array_index_type, "count1");
1904   count2 = gfc_create_var (gfc_array_index_type, "count2");
1905
1906   /* Count is the wheremask index.  */
1907   if (wheremask)
1908     {
1909       count = gfc_create_var (gfc_array_index_type, "count");
1910       gfc_add_modify_expr (block, count, gfc_index_zero_node);
1911     }
1912   else
1913     count = NULL;
1914
1915   /* Initialize count1.  */
1916   gfc_add_modify_expr (block, count1, gfc_index_zero_node);
1917
1918   /* Calculate the size of temporary needed in the assignment. Return loop, lss
1919      and rss which are used in function generate_loop_for_rhs_to_temp().  */
1920   inner_size = compute_inner_temp_size (expr1, expr2, block, &lss, &rss);
1921
1922   /* The type of LHS. Used in function allocate_temp_for_forall_nest */
1923   type = gfc_typenode_for_spec (&expr1->ts);
1924
1925   /* Allocate temporary for nested forall construct according to the
1926      information in nested_forall_info and inner_size.  */
1927   tmp1 = allocate_temp_for_forall_nest (nested_forall_info, type,
1928                                 inner_size, block, &ptemp1);
1929
1930   /* Initialize the maskindexes.  */
1931   forall_tmp = nested_forall_info;
1932   while (forall_tmp != NULL)
1933     {
1934       mask = forall_tmp->mask;
1935       maskindex = forall_tmp->maskindex;
1936       if (mask)
1937         gfc_add_modify_expr (block, maskindex, gfc_index_zero_node);
1938       forall_tmp = forall_tmp->next_nest;
1939     }
1940
1941   /* Generate codes to copy rhs to the temporary .  */
1942   tmp = generate_loop_for_rhs_to_temp (expr2, tmp1, inner_size, count,
1943                                        count1, count2, lss, rss, wheremask);
1944
1945   /* Generate body and loops according to the information in
1946      nested_forall_info.  */
1947   tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1, 1);
1948   gfc_add_expr_to_block (block, tmp);
1949
1950   /* Reset count1.  */
1951   gfc_add_modify_expr (block, count1, gfc_index_zero_node);
1952
1953   /* Reset maskindexed.  */
1954   forall_tmp = nested_forall_info;
1955   while (forall_tmp != NULL)
1956     {
1957       mask = forall_tmp->mask;
1958       maskindex = forall_tmp->maskindex;
1959       if (mask)
1960         gfc_add_modify_expr (block, maskindex, gfc_index_zero_node);
1961       forall_tmp = forall_tmp->next_nest;
1962     }
1963
1964   /* Reset count.  */
1965   if (wheremask)
1966     gfc_add_modify_expr (block, count, gfc_index_zero_node);
1967
1968   /* Generate codes to copy the temporary to lhs.  */
1969   tmp = generate_loop_for_temp_to_lhs (expr1, tmp1, inner_size, count,
1970                                        count1, count2, wheremask);
1971
1972   /* Generate body and loops according to the information in
1973      nested_forall_info.  */
1974   tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1, 1);
1975   gfc_add_expr_to_block (block, tmp);
1976
1977   if (ptemp1)
1978     {
1979       /* Free the temporary.  */
1980       tmp = gfc_chainon_list (NULL_TREE, ptemp1);
1981       tmp = gfc_build_function_call (gfor_fndecl_internal_free, tmp);
1982       gfc_add_expr_to_block (block, tmp);
1983     }
1984 }
1985
1986
1987 /* Translate pointer assignment inside FORALL which need temporary.  */
1988
1989 static void
1990 gfc_trans_pointer_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2,
1991                                     forall_info * nested_forall_info,
1992                                     stmtblock_t * block)
1993 {
1994   tree type;
1995   tree inner_size;
1996   gfc_ss *lss, *rss;
1997   gfc_se lse;
1998   gfc_se rse;
1999   gfc_ss_info *info;
2000   gfc_loopinfo loop;
2001   tree desc;
2002   tree parm;
2003   tree parmtype;
2004   stmtblock_t body;
2005   tree count;
2006   tree tmp, tmp1, ptemp1;
2007   tree mask, maskindex;
2008   forall_info *forall_tmp;
2009
2010   count = gfc_create_var (gfc_array_index_type, "count");
2011   gfc_add_modify_expr (block, count, gfc_index_zero_node);
2012
2013   inner_size = integer_one_node;
2014   lss = gfc_walk_expr (expr1);
2015   rss = gfc_walk_expr (expr2);
2016   if (lss == gfc_ss_terminator)
2017     {
2018       type = gfc_typenode_for_spec (&expr1->ts);
2019       type = build_pointer_type (type);
2020
2021       /* Allocate temporary for nested forall construct according to the
2022          information in nested_forall_info and inner_size.  */
2023       tmp1 = allocate_temp_for_forall_nest (nested_forall_info,
2024                                             type, inner_size, block, &ptemp1);
2025       gfc_start_block (&body);
2026       gfc_init_se (&lse, NULL);
2027       lse.expr = gfc_build_array_ref (tmp1, count);
2028       gfc_init_se (&rse, NULL);
2029       rse.want_pointer = 1;
2030       gfc_conv_expr (&rse, expr2);
2031       gfc_add_block_to_block (&body, &rse.pre);
2032       gfc_add_modify_expr (&body, lse.expr, rse.expr);
2033       gfc_add_block_to_block (&body, &rse.post);
2034
2035       /* Increment count.  */
2036       tmp = fold (build2 (PLUS_EXPR, gfc_array_index_type,
2037                           count, gfc_index_one_node));
2038       gfc_add_modify_expr (&body, count, tmp);
2039
2040       tmp = gfc_finish_block (&body);
2041
2042       /* Initialize the maskindexes.  */
2043       forall_tmp = nested_forall_info;
2044       while (forall_tmp != NULL)
2045         {
2046           mask = forall_tmp->mask;
2047           maskindex = forall_tmp->maskindex;
2048           if (mask)
2049             gfc_add_modify_expr (block, maskindex, gfc_index_zero_node);
2050           forall_tmp = forall_tmp->next_nest;
2051         }
2052
2053       /* Generate body and loops according to the information in
2054          nested_forall_info.  */
2055       tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1, 1);
2056       gfc_add_expr_to_block (block, tmp);
2057
2058       /* Reset count.  */
2059       gfc_add_modify_expr (block, count, gfc_index_zero_node);
2060
2061       /* Reset maskindexes.  */
2062       forall_tmp = nested_forall_info;
2063       while (forall_tmp != NULL)
2064         {
2065           mask = forall_tmp->mask;
2066           maskindex = forall_tmp->maskindex;
2067           if (mask)
2068             gfc_add_modify_expr (block, maskindex, gfc_index_zero_node);
2069           forall_tmp = forall_tmp->next_nest;
2070         }
2071       gfc_start_block (&body);
2072       gfc_init_se (&lse, NULL);
2073       gfc_init_se (&rse, NULL);
2074       rse.expr = gfc_build_array_ref (tmp1, count);
2075       lse.want_pointer = 1;
2076       gfc_conv_expr (&lse, expr1);
2077       gfc_add_block_to_block (&body, &lse.pre);
2078       gfc_add_modify_expr (&body, lse.expr, rse.expr);
2079       gfc_add_block_to_block (&body, &lse.post);
2080       /* Increment count.  */
2081       tmp = fold (build2 (PLUS_EXPR, gfc_array_index_type,
2082                           count, gfc_index_one_node));
2083       gfc_add_modify_expr (&body, count, tmp);
2084       tmp = gfc_finish_block (&body);
2085
2086       /* Generate body and loops according to the information in
2087          nested_forall_info.  */
2088       tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1, 1);
2089       gfc_add_expr_to_block (block, tmp);
2090     }
2091   else
2092     {
2093       gfc_init_loopinfo (&loop);
2094
2095       /* Associate the SS with the loop.  */
2096       gfc_add_ss_to_loop (&loop, rss);
2097
2098       /* Setup the scalarizing loops and bounds.  */
2099       gfc_conv_ss_startstride (&loop);
2100
2101       gfc_conv_loop_setup (&loop);
2102
2103       info = &rss->data.info;
2104       desc = info->descriptor;
2105
2106       /* Make a new descriptor.  */
2107       parmtype = gfc_get_element_type (TREE_TYPE (desc));
2108       parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen,
2109                                             loop.from, loop.to, 1);
2110
2111       /* Allocate temporary for nested forall construct.  */
2112       tmp1 = allocate_temp_for_forall_nest (nested_forall_info, parmtype,
2113                                             inner_size, block, &ptemp1);
2114       gfc_start_block (&body);
2115       gfc_init_se (&lse, NULL);
2116       lse.expr = gfc_build_array_ref (tmp1, count);
2117       lse.direct_byref = 1;
2118       rss = gfc_walk_expr (expr2);
2119       gfc_conv_expr_descriptor (&lse, expr2, rss);
2120
2121       gfc_add_block_to_block (&body, &lse.pre);
2122       gfc_add_block_to_block (&body, &lse.post);
2123
2124       /* Increment count.  */
2125       tmp = fold (build2 (PLUS_EXPR, gfc_array_index_type,
2126                           count, gfc_index_one_node));
2127       gfc_add_modify_expr (&body, count, tmp);
2128
2129       tmp = gfc_finish_block (&body);
2130
2131       /* Initialize the maskindexes.  */
2132       forall_tmp = nested_forall_info;
2133       while (forall_tmp != NULL)
2134         {
2135           mask = forall_tmp->mask;
2136           maskindex = forall_tmp->maskindex;
2137           if (mask)
2138             gfc_add_modify_expr (block, maskindex, gfc_index_zero_node);
2139           forall_tmp = forall_tmp->next_nest;
2140         }
2141
2142       /* Generate body and loops according to the information in
2143          nested_forall_info.  */
2144       tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1, 1);
2145       gfc_add_expr_to_block (block, tmp);
2146
2147       /* Reset count.  */
2148       gfc_add_modify_expr (block, count, gfc_index_zero_node);
2149
2150       /* Reset maskindexes.  */
2151       forall_tmp = nested_forall_info;
2152       while (forall_tmp != NULL)
2153         {
2154           mask = forall_tmp->mask;
2155           maskindex = forall_tmp->maskindex;
2156           if (mask)
2157             gfc_add_modify_expr (block, maskindex, gfc_index_zero_node);
2158           forall_tmp = forall_tmp->next_nest;
2159         }
2160       parm = gfc_build_array_ref (tmp1, count);
2161       lss = gfc_walk_expr (expr1);
2162       gfc_init_se (&lse, NULL);
2163       gfc_conv_expr_descriptor (&lse, expr1, lss);
2164       gfc_add_modify_expr (&lse.pre, lse.expr, parm);
2165       gfc_start_block (&body);
2166       gfc_add_block_to_block (&body, &lse.pre);
2167       gfc_add_block_to_block (&body, &lse.post);
2168
2169       /* Increment count.  */
2170       tmp = fold (build2 (PLUS_EXPR, gfc_array_index_type,
2171                           count, gfc_index_one_node));
2172       gfc_add_modify_expr (&body, count, tmp);
2173
2174       tmp = gfc_finish_block (&body);
2175
2176       tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1, 1);
2177       gfc_add_expr_to_block (block, tmp);
2178     }
2179   /* Free the temporary.  */
2180   if (ptemp1)
2181     {
2182       tmp = gfc_chainon_list (NULL_TREE, ptemp1);
2183       tmp = gfc_build_function_call (gfor_fndecl_internal_free, tmp);
2184       gfc_add_expr_to_block (block, tmp);
2185     }
2186 }
2187
2188
2189 /* FORALL and WHERE statements are really nasty, especially when you nest
2190    them. All the rhs of a forall assignment must be evaluated before the
2191    actual assignments are performed. Presumably this also applies to all the
2192    assignments in an inner where statement.  */
2193
2194 /* Generate code for a FORALL statement.  Any temporaries are allocated as a
2195    linear array, relying on the fact that we process in the same order in all
2196    loops.
2197
2198     forall (i=start:end:stride; maskexpr)
2199       e<i> = f<i>
2200       g<i> = h<i>
2201     end forall
2202    (where e,f,g,h<i> are arbitrary expressions possibly involving i)
2203    Translates to:
2204     count = ((end + 1 - start) / staride)
2205     masktmp(:) = maskexpr(:)
2206
2207     maskindex = 0;
2208     for (i = start; i <= end; i += stride)
2209       {
2210         if (masktmp[maskindex++])
2211           e<i> = f<i>
2212       }
2213     maskindex = 0;
2214     for (i = start; i <= end; i += stride)
2215       {
2216         if (masktmp[maskindex++])
2217           e<i> = f<i>
2218       }
2219
2220     Note that this code only works when there are no dependencies.
2221     Forall loop with array assignments and data dependencies are a real pain,
2222     because the size of the temporary cannot always be determined before the
2223     loop is executed.  This problem is compounded by the presence of nested
2224     FORALL constructs.
2225  */
2226
2227 static tree
2228 gfc_trans_forall_1 (gfc_code * code, forall_info * nested_forall_info)
2229 {
2230   stmtblock_t block;
2231   stmtblock_t body;
2232   tree *var;
2233   tree *start;
2234   tree *end;
2235   tree *step;
2236   gfc_expr **varexpr;
2237   tree tmp;
2238   tree assign;
2239   tree size;
2240   tree bytesize;
2241   tree tmpvar;
2242   tree sizevar;
2243   tree lenvar;
2244   tree maskindex;
2245   tree mask;
2246   tree pmask;
2247   int n;
2248   int nvar;
2249   int need_temp;
2250   gfc_forall_iterator *fa;
2251   gfc_se se;
2252   gfc_code *c;
2253   gfc_saved_var *saved_vars;
2254   iter_info *this_forall, *iter_tmp;
2255   forall_info *info, *forall_tmp;
2256   temporary_list *temp;
2257
2258   gfc_start_block (&block);
2259
2260   n = 0;
2261   /* Count the FORALL index number.  */
2262   for (fa = code->ext.forall_iterator; fa; fa = fa->next)
2263     n++;
2264   nvar = n;
2265
2266   /* Allocate the space for var, start, end, step, varexpr.  */
2267   var = (tree *) gfc_getmem (nvar * sizeof (tree));
2268   start = (tree *) gfc_getmem (nvar * sizeof (tree));
2269   end = (tree *) gfc_getmem (nvar * sizeof (tree));
2270   step = (tree *) gfc_getmem (nvar * sizeof (tree));
2271   varexpr = (gfc_expr **) gfc_getmem (nvar * sizeof (gfc_expr *));
2272   saved_vars = (gfc_saved_var *) gfc_getmem (nvar * sizeof (gfc_saved_var));
2273
2274   /* Allocate the space for info.  */
2275   info = (forall_info *) gfc_getmem (sizeof (forall_info));
2276   n = 0;
2277   for (fa = code->ext.forall_iterator; fa; fa = fa->next)
2278     {
2279       gfc_symbol *sym = fa->var->symtree->n.sym;
2280
2281       /* allocate space for this_forall.  */
2282       this_forall = (iter_info *) gfc_getmem (sizeof (iter_info));
2283
2284       /* Create a temporary variable for the FORALL index.  */
2285       tmp = gfc_typenode_for_spec (&sym->ts);
2286       var[n] = gfc_create_var (tmp, sym->name);
2287       gfc_shadow_sym (sym, var[n], &saved_vars[n]);
2288
2289       /* Record it in this_forall.  */
2290       this_forall->var = var[n];
2291
2292       /* Replace the index symbol's backend_decl with the temporary decl.  */
2293       sym->backend_decl = var[n];
2294
2295       /* Work out the start, end and stride for the loop.  */
2296       gfc_init_se (&se, NULL);
2297       gfc_conv_expr_val (&se, fa->start);
2298       /* Record it in this_forall.  */
2299       this_forall->start = se.expr;
2300       gfc_add_block_to_block (&block, &se.pre);
2301       start[n] = se.expr;
2302
2303       gfc_init_se (&se, NULL);
2304       gfc_conv_expr_val (&se, fa->end);
2305       /* Record it in this_forall.  */
2306       this_forall->end = se.expr;
2307       gfc_make_safe_expr (&se);
2308       gfc_add_block_to_block (&block, &se.pre);
2309       end[n] = se.expr;
2310
2311       gfc_init_se (&se, NULL);
2312       gfc_conv_expr_val (&se, fa->stride);
2313       /* Record it in this_forall.  */
2314       this_forall->step = se.expr;
2315       gfc_make_safe_expr (&se);
2316       gfc_add_block_to_block (&block, &se.pre);
2317       step[n] = se.expr;
2318
2319       /* Set the NEXT field of this_forall to NULL.  */
2320       this_forall->next = NULL;
2321       /* Link this_forall to the info construct.  */
2322       if (info->this_loop == NULL)
2323         info->this_loop = this_forall;
2324       else
2325         {
2326           iter_tmp = info->this_loop;
2327           while (iter_tmp->next != NULL)
2328             iter_tmp = iter_tmp->next;
2329           iter_tmp->next = this_forall;
2330         }
2331
2332       n++;
2333     }
2334   nvar = n;
2335
2336   /* Work out the number of elements in the mask array.  */
2337   tmpvar = NULL_TREE;
2338   lenvar = NULL_TREE;
2339   size = gfc_index_one_node;
2340   sizevar = NULL_TREE;
2341
2342   for (n = 0; n < nvar; n++)
2343     {
2344       if (lenvar && TREE_TYPE (lenvar) != TREE_TYPE (start[n]))
2345         lenvar = NULL_TREE;
2346
2347       /* size = (end + step - start) / step.  */
2348       tmp = fold (build2 (MINUS_EXPR, TREE_TYPE (start[n]),
2349                           step[n], start[n]));
2350       tmp = fold (build2 (PLUS_EXPR, TREE_TYPE (end[n]), end[n], tmp));
2351
2352       tmp = fold (build2 (FLOOR_DIV_EXPR, TREE_TYPE (tmp), tmp, step[n]));
2353       tmp = convert (gfc_array_index_type, tmp);
2354
2355       size = fold (build2 (MULT_EXPR, gfc_array_index_type, size, tmp));
2356     }
2357
2358   /* Record the nvar and size of current forall level.  */
2359   info->nvar = nvar;
2360   info->size = size;
2361
2362   /* Link the current forall level to nested_forall_info.  */
2363   forall_tmp = nested_forall_info;
2364   if (forall_tmp == NULL)
2365     nested_forall_info = info;
2366   else
2367     {
2368       while (forall_tmp->next_nest != NULL)
2369         forall_tmp = forall_tmp->next_nest;
2370       info->outer = forall_tmp;
2371       forall_tmp->next_nest = info;
2372     }
2373
2374   /* Copy the mask into a temporary variable if required.
2375      For now we assume a mask temporary is needed.  */
2376   if (code->expr)
2377     {
2378       /* Allocate the mask temporary.  */
2379       bytesize = fold (build2 (MULT_EXPR, gfc_array_index_type, size,
2380                                TYPE_SIZE_UNIT (boolean_type_node)));
2381
2382       mask = gfc_do_allocate (bytesize, size, &pmask, &block, boolean_type_node);
2383
2384       maskindex = gfc_create_var_np (gfc_array_index_type, "mi");
2385       /* Record them in the info structure.  */
2386       info->pmask = pmask;
2387       info->mask = mask;
2388       info->maskindex = maskindex;
2389
2390       gfc_add_modify_expr (&block, maskindex, gfc_index_zero_node);
2391
2392       /* Start of mask assignment loop body.  */
2393       gfc_start_block (&body);
2394
2395       /* Evaluate the mask expression.  */
2396       gfc_init_se (&se, NULL);
2397       gfc_conv_expr_val (&se, code->expr);
2398       gfc_add_block_to_block (&body, &se.pre);
2399
2400       /* Store the mask.  */
2401       se.expr = convert (boolean_type_node, se.expr);
2402
2403       if (pmask)
2404         tmp = gfc_build_indirect_ref (mask);
2405       else
2406         tmp = mask;
2407       tmp = gfc_build_array_ref (tmp, maskindex);
2408       gfc_add_modify_expr (&body, tmp, se.expr);
2409
2410       /* Advance to the next mask element.  */
2411       tmp = build2 (PLUS_EXPR, gfc_array_index_type,
2412                    maskindex, gfc_index_one_node);
2413       gfc_add_modify_expr (&body, maskindex, tmp);
2414
2415       /* Generate the loops.  */
2416       tmp = gfc_finish_block (&body);
2417       tmp = gfc_trans_nested_forall_loop (info, tmp, 0, 0);
2418       gfc_add_expr_to_block (&block, tmp);
2419     }
2420   else
2421     {
2422       /* No mask was specified.  */
2423       maskindex = NULL_TREE;
2424       mask = pmask = NULL_TREE;
2425     }
2426
2427   c = code->block->next;
2428
2429   /* TODO: loop merging in FORALL statements.  */
2430   /* Now that we've got a copy of the mask, generate the assignment loops.  */
2431   while (c)
2432     {
2433       switch (c->op)
2434         {
2435         case EXEC_ASSIGN:
2436           /* A scalar or array assignment.  */
2437           need_temp = gfc_check_dependency (c->expr, c->expr2, varexpr, nvar);
2438           /* Teporaries due to array assignment data dependencies introduce
2439              no end of problems.  */
2440           if (need_temp)
2441             gfc_trans_assign_need_temp (c->expr, c->expr2, NULL,
2442                                         nested_forall_info, &block);
2443           else
2444             {
2445               /* Use the normal assignment copying routines.  */
2446               assign = gfc_trans_assignment (c->expr, c->expr2);
2447
2448               /* Reset the mask index.  */
2449               if (mask)
2450                 gfc_add_modify_expr (&block, maskindex, gfc_index_zero_node);
2451
2452               /* Generate body and loops.  */
2453               tmp = gfc_trans_nested_forall_loop (nested_forall_info, assign, 1, 1);
2454               gfc_add_expr_to_block (&block, tmp);
2455             }
2456
2457           break;
2458
2459         case EXEC_WHERE:
2460
2461           /* Translate WHERE or WHERE construct nested in FORALL.  */
2462           temp = NULL;
2463           gfc_trans_where_2 (c, NULL, NULL, nested_forall_info, &block, &temp);
2464
2465           while (temp)
2466             {
2467               tree args;
2468               temporary_list *p;
2469
2470               /* Free the temporary.  */
2471               args = gfc_chainon_list (NULL_TREE, temp->temporary);
2472               tmp = gfc_build_function_call (gfor_fndecl_internal_free, args);
2473               gfc_add_expr_to_block (&block, tmp);
2474
2475               p = temp;
2476               temp = temp->next;
2477               gfc_free (p);
2478             }
2479
2480           break;
2481
2482         /* Pointer assignment inside FORALL.  */
2483         case EXEC_POINTER_ASSIGN:
2484           need_temp = gfc_check_dependency (c->expr, c->expr2, varexpr, nvar);
2485           if (need_temp)
2486             gfc_trans_pointer_assign_need_temp (c->expr, c->expr2,
2487                                                 nested_forall_info, &block);
2488           else
2489             {
2490               /* Use the normal assignment copying routines.  */
2491               assign = gfc_trans_pointer_assignment (c->expr, c->expr2);
2492
2493               /* Reset the mask index.  */
2494               if (mask)
2495                 gfc_add_modify_expr (&block, maskindex, gfc_index_zero_node);
2496
2497               /* Generate body and loops.  */
2498               tmp = gfc_trans_nested_forall_loop (nested_forall_info, assign,
2499                                                   1, 1);
2500               gfc_add_expr_to_block (&block, tmp);
2501             }
2502           break;
2503
2504         case EXEC_FORALL:
2505           tmp = gfc_trans_forall_1 (c, nested_forall_info);
2506           gfc_add_expr_to_block (&block, tmp);
2507           break;
2508
2509         default:
2510           gcc_unreachable ();
2511         }
2512
2513       c = c->next;
2514     }
2515
2516   /* Restore the original index variables.  */
2517   for (fa = code->ext.forall_iterator, n = 0; fa; fa = fa->next, n++)
2518     gfc_restore_sym (fa->var->symtree->n.sym, &saved_vars[n]);
2519
2520   /* Free the space for var, start, end, step, varexpr.  */
2521   gfc_free (var);
2522   gfc_free (start);
2523   gfc_free (end);
2524   gfc_free (step);
2525   gfc_free (varexpr);
2526   gfc_free (saved_vars);
2527
2528   if (pmask)
2529     {
2530       /* Free the temporary for the mask.  */
2531       tmp = gfc_chainon_list (NULL_TREE, pmask);
2532       tmp = gfc_build_function_call (gfor_fndecl_internal_free, tmp);
2533       gfc_add_expr_to_block (&block, tmp);
2534     }
2535   if (maskindex)
2536     pushdecl (maskindex);
2537
2538   return gfc_finish_block (&block);
2539 }
2540
2541
2542 /* Translate the FORALL statement or construct.  */
2543
2544 tree gfc_trans_forall (gfc_code * code)
2545 {
2546   return gfc_trans_forall_1 (code, NULL);
2547 }
2548
2549
2550 /* Evaluate the WHERE mask expression, copy its value to a temporary.
2551    If the WHERE construct is nested in FORALL, compute the overall temporary
2552    needed by the WHERE mask expression multiplied by the iterator number of
2553    the nested forall.
2554    ME is the WHERE mask expression.
2555    MASK is the temporary which value is mask's value.
2556    NMASK is another temporary which value is !mask.
2557    TEMP records the temporary's address allocated in this function in order to
2558    free them outside this function.
2559    MASK, NMASK and TEMP are all OUT arguments.  */
2560
2561 static tree
2562 gfc_evaluate_where_mask (gfc_expr * me, forall_info * nested_forall_info,
2563                          tree * mask, tree * nmask, temporary_list ** temp,
2564                          stmtblock_t * block)
2565 {
2566   tree tmp, tmp1;
2567   gfc_ss *lss, *rss;
2568   gfc_loopinfo loop;
2569   tree ptemp1, ntmp, ptemp2;
2570   tree inner_size;
2571   stmtblock_t body, body1;
2572   gfc_se lse, rse;
2573   tree count;
2574   tree tmpexpr;
2575
2576   gfc_init_loopinfo (&loop);
2577
2578   /* Calculate the size of temporary needed by the mask-expr.  */
2579   inner_size = compute_inner_temp_size (me, me, block, &lss, &rss);
2580
2581   /* Allocate temporary for where mask.  */
2582   tmp = allocate_temp_for_forall_nest (nested_forall_info, boolean_type_node,
2583                                        inner_size, block, &ptemp1);
2584   /* Record the temporary address in order to free it later.  */
2585   if (ptemp1)
2586     {
2587       temporary_list *tempo;
2588       tempo = (temporary_list *) gfc_getmem (sizeof (temporary_list));
2589       tempo->temporary = ptemp1;
2590       tempo->next = *temp;
2591       *temp = tempo;
2592     }
2593
2594   /* Allocate temporary for !mask.  */
2595   ntmp = allocate_temp_for_forall_nest (nested_forall_info, boolean_type_node,
2596                                         inner_size, block, &ptemp2);
2597   /* Record the temporary  in order to free it later.  */
2598   if (ptemp2)
2599     {
2600       temporary_list *tempo;
2601       tempo = (temporary_list *) gfc_getmem (sizeof (temporary_list));
2602       tempo->temporary = ptemp2;
2603       tempo->next = *temp;
2604       *temp = tempo;
2605     }
2606
2607   /* Variable to index the temporary.  */
2608   count = gfc_create_var (gfc_array_index_type, "count");
2609   /* Initialize count.  */
2610   gfc_add_modify_expr (block, count, gfc_index_zero_node);
2611
2612   gfc_start_block (&body);
2613
2614   gfc_init_se (&rse, NULL);
2615   gfc_init_se (&lse, NULL);
2616
2617   if (lss == gfc_ss_terminator)
2618     {
2619       gfc_init_block (&body1);
2620     }
2621   else
2622     {
2623       /* Initialize the loop.  */
2624       gfc_init_loopinfo (&loop);
2625
2626       /* We may need LSS to determine the shape of the expression.  */
2627       gfc_add_ss_to_loop (&loop, lss);
2628       gfc_add_ss_to_loop (&loop, rss);
2629
2630       gfc_conv_ss_startstride (&loop);
2631       gfc_conv_loop_setup (&loop);
2632
2633       gfc_mark_ss_chain_used (rss, 1);
2634       /* Start the loop body.  */
2635       gfc_start_scalarized_body (&loop, &body1);
2636
2637       /* Translate the expression.  */
2638       gfc_copy_loopinfo_to_se (&rse, &loop);
2639       rse.ss = rss;
2640       gfc_conv_expr (&rse, me);
2641     }
2642   /* Form the expression of the temporary.  */
2643   lse.expr = gfc_build_array_ref (tmp, count);
2644   tmpexpr = gfc_build_array_ref (ntmp, count);
2645
2646   /* Use the scalar assignment to fill temporary TMP.  */
2647   tmp1 = gfc_trans_scalar_assign (&lse, &rse, me->ts.type);
2648   gfc_add_expr_to_block (&body1, tmp1);
2649
2650   /* Fill temporary NTMP.  */
2651   tmp1 = build1 (TRUTH_NOT_EXPR, TREE_TYPE (lse.expr), lse.expr);
2652   gfc_add_modify_expr (&body1, tmpexpr, tmp1);
2653
2654  if (lss == gfc_ss_terminator)
2655     {
2656       gfc_add_block_to_block (&body, &body1);
2657     }
2658   else
2659     {
2660       /* Increment count.  */
2661       tmp1 = fold (build2 (PLUS_EXPR, gfc_array_index_type, count,
2662                           gfc_index_one_node));
2663       gfc_add_modify_expr (&body1, count, tmp1);
2664
2665       /* Generate the copying loops.  */
2666       gfc_trans_scalarizing_loops (&loop, &body1);
2667
2668       gfc_add_block_to_block (&body, &loop.pre);
2669       gfc_add_block_to_block (&body, &loop.post);
2670
2671       gfc_cleanup_loop (&loop);
2672       /* TODO: Reuse lss and rss when copying temp->lhs.  Need to be careful
2673          as tree nodes in SS may not be valid in different scope.  */
2674     }
2675
2676   tmp1 = gfc_finish_block (&body);
2677   /* If the WHERE construct is inside FORALL, fill the full temporary.  */
2678   if (nested_forall_info != NULL)
2679     tmp1 = gfc_trans_nested_forall_loop (nested_forall_info, tmp1, 1, 1);
2680
2681
2682   gfc_add_expr_to_block (block, tmp1);
2683
2684   *mask = tmp;
2685   *nmask = ntmp;
2686
2687   return tmp1;
2688 }
2689
2690
2691 /* Translate an assignment statement in a WHERE statement or construct
2692    statement. The MASK expression is used to control which elements
2693    of EXPR1 shall be assigned.  */
2694
2695 static tree
2696 gfc_trans_where_assign (gfc_expr *expr1, gfc_expr *expr2, tree mask,
2697                         tree count1, tree count2)
2698 {
2699   gfc_se lse;
2700   gfc_se rse;
2701   gfc_ss *lss;
2702   gfc_ss *lss_section;
2703   gfc_ss *rss;
2704
2705   gfc_loopinfo loop;
2706   tree tmp;
2707   stmtblock_t block;
2708   stmtblock_t body;
2709   tree index, maskexpr, tmp1;
2710
2711 #if 0
2712   /* TODO: handle this special case.
2713      Special case a single function returning an array.  */
2714   if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
2715     {
2716       tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
2717       if (tmp)
2718         return tmp;
2719     }
2720 #endif
2721
2722  /* Assignment of the form lhs = rhs.  */
2723   gfc_start_block (&block);
2724
2725   gfc_init_se (&lse, NULL);
2726   gfc_init_se (&rse, NULL);
2727
2728   /* Walk the lhs.  */
2729   lss = gfc_walk_expr (expr1);
2730   rss = NULL;
2731
2732   /* In each where-assign-stmt, the mask-expr and the variable being
2733      defined shall be arrays of the same shape.  */
2734   gcc_assert (lss != gfc_ss_terminator);
2735
2736   /* The assignment needs scalarization.  */
2737   lss_section = lss;
2738
2739   /* Find a non-scalar SS from the lhs.  */
2740   while (lss_section != gfc_ss_terminator
2741          && lss_section->type != GFC_SS_SECTION)
2742     lss_section = lss_section->next;
2743
2744   gcc_assert (lss_section != gfc_ss_terminator);
2745
2746   /* Initialize the scalarizer.  */
2747   gfc_init_loopinfo (&loop);
2748
2749   /* Walk the rhs.  */
2750   rss = gfc_walk_expr (expr2);
2751   if (rss == gfc_ss_terminator)
2752    {
2753      /* The rhs is scalar.  Add a ss for the expression.  */
2754      rss = gfc_get_ss ();
2755      rss->next = gfc_ss_terminator;
2756      rss->type = GFC_SS_SCALAR;
2757      rss->expr = expr2;
2758     }
2759
2760   /* Associate the SS with the loop.  */
2761   gfc_add_ss_to_loop (&loop, lss);
2762   gfc_add_ss_to_loop (&loop, rss);
2763
2764   /* Calculate the bounds of the scalarization.  */
2765   gfc_conv_ss_startstride (&loop);
2766
2767   /* Resolve any data dependencies in the statement.  */
2768   gfc_conv_resolve_dependencies (&loop, lss_section, rss);
2769
2770   /* Setup the scalarizing loops.  */
2771   gfc_conv_loop_setup (&loop);
2772
2773   /* Setup the gfc_se structures.  */
2774   gfc_copy_loopinfo_to_se (&lse, &loop);
2775   gfc_copy_loopinfo_to_se (&rse, &loop);
2776
2777   rse.ss = rss;
2778   gfc_mark_ss_chain_used (rss, 1);
2779   if (loop.temp_ss == NULL)
2780     {
2781       lse.ss = lss;
2782       gfc_mark_ss_chain_used (lss, 1);
2783     }
2784   else
2785     {
2786       lse.ss = loop.temp_ss;
2787       gfc_mark_ss_chain_used (lss, 3);
2788       gfc_mark_ss_chain_used (loop.temp_ss, 3);
2789     }
2790
2791   /* Start the scalarized loop body.  */
2792   gfc_start_scalarized_body (&loop, &body);
2793
2794   /* Translate the expression.  */
2795   gfc_conv_expr (&rse, expr2);
2796   if (lss != gfc_ss_terminator && loop.temp_ss != NULL)
2797     {
2798       gfc_conv_tmp_array_ref (&lse);
2799       gfc_advance_se_ss_chain (&lse);
2800     }
2801   else
2802     gfc_conv_expr (&lse, expr1);
2803
2804   /* Form the mask expression according to the mask tree list.  */
2805   index = count1;
2806   tmp = mask;
2807   if (tmp != NULL)
2808     maskexpr = gfc_build_array_ref (tmp, index);
2809   else
2810     maskexpr = NULL;
2811
2812   tmp = TREE_CHAIN (tmp);
2813   while (tmp)
2814     {
2815       tmp1 = gfc_build_array_ref (tmp, index);
2816       maskexpr = build2 (TRUTH_AND_EXPR, TREE_TYPE (tmp1), maskexpr, tmp1);
2817       tmp = TREE_CHAIN (tmp);
2818     }
2819   /* Use the scalar assignment as is.  */
2820   tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
2821   tmp = build3_v (COND_EXPR, maskexpr, tmp, build_empty_stmt ());
2822
2823   gfc_add_expr_to_block (&body, tmp);
2824
2825   if (lss == gfc_ss_terminator)
2826     {
2827       /* Increment count1.  */
2828       tmp = fold (build2 (PLUS_EXPR, gfc_array_index_type,
2829                           count1, gfc_index_one_node));
2830       gfc_add_modify_expr (&body, count1, tmp);
2831
2832       /* Use the scalar assignment as is.  */
2833       gfc_add_block_to_block (&block, &body);
2834     }
2835   else
2836     {
2837       gcc_assert (lse.ss == gfc_ss_terminator
2838                   && rse.ss == gfc_ss_terminator);
2839
2840       if (loop.temp_ss != NULL)
2841         {
2842           /* Increment count1 before finish the main body of a scalarized
2843              expression.  */
2844           tmp = fold (build2 (PLUS_EXPR, gfc_array_index_type,
2845                               count1, gfc_index_one_node));
2846           gfc_add_modify_expr (&body, count1, tmp);
2847           gfc_trans_scalarized_loop_boundary (&loop, &body);
2848
2849           /* We need to copy the temporary to the actual lhs.  */
2850           gfc_init_se (&lse, NULL);
2851           gfc_init_se (&rse, NULL);
2852           gfc_copy_loopinfo_to_se (&lse, &loop);
2853           gfc_copy_loopinfo_to_se (&rse, &loop);
2854
2855           rse.ss = loop.temp_ss;
2856           lse.ss = lss;
2857
2858           gfc_conv_tmp_array_ref (&rse);
2859           gfc_advance_se_ss_chain (&rse);
2860           gfc_conv_expr (&lse, expr1);
2861
2862           gcc_assert (lse.ss == gfc_ss_terminator
2863                       && rse.ss == gfc_ss_terminator);
2864
2865           /* Form the mask expression according to the mask tree list.  */
2866           index = count2;
2867           tmp = mask;
2868           if (tmp != NULL)
2869             maskexpr = gfc_build_array_ref (tmp, index);
2870           else
2871             maskexpr = NULL;
2872
2873           tmp = TREE_CHAIN (tmp);
2874           while (tmp)
2875             {
2876               tmp1 = gfc_build_array_ref (tmp, index);
2877               maskexpr = build2 (TRUTH_AND_EXPR, TREE_TYPE (tmp1),
2878                                  maskexpr, tmp1);
2879               tmp = TREE_CHAIN (tmp);
2880             }
2881           /* Use the scalar assignment as is.  */
2882           tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
2883           tmp = build3_v (COND_EXPR, maskexpr, tmp, build_empty_stmt ());
2884           gfc_add_expr_to_block (&body, tmp);
2885
2886           /* Increment count2.  */
2887           tmp = fold (build2 (PLUS_EXPR, gfc_array_index_type,
2888                               count2, gfc_index_one_node));
2889           gfc_add_modify_expr (&body, count2, tmp);
2890         }
2891       else
2892         {
2893           /* Increment count1.  */
2894           tmp = fold (build2 (PLUS_EXPR, gfc_array_index_type,
2895                               count1, gfc_index_one_node));
2896           gfc_add_modify_expr (&body, count1, tmp);
2897         }
2898
2899       /* Generate the copying loops.  */
2900       gfc_trans_scalarizing_loops (&loop, &body);
2901
2902       /* Wrap the whole thing up.  */
2903       gfc_add_block_to_block (&block, &loop.pre);
2904       gfc_add_block_to_block (&block, &loop.post);
2905       gfc_cleanup_loop (&loop);
2906     }
2907
2908   return gfc_finish_block (&block);
2909 }
2910
2911
2912 /* Translate the WHERE construct or statement.
2913    This fuction can be called iteratively to translate the nested WHERE
2914    construct or statement.
2915    MASK is the control mask, and PMASK is the pending control mask.
2916    TEMP records the temporary address which must be freed later.  */
2917
2918 static void
2919 gfc_trans_where_2 (gfc_code * code, tree mask, tree pmask,
2920                    forall_info * nested_forall_info, stmtblock_t * block,
2921                    temporary_list ** temp)
2922 {
2923   gfc_expr *expr1;
2924   gfc_expr *expr2;
2925   gfc_code *cblock;
2926   gfc_code *cnext;
2927   tree tmp, tmp1, tmp2;
2928   tree count1, count2;
2929   tree mask_copy;
2930   int need_temp;
2931
2932   /* the WHERE statement or the WHERE construct statement.  */
2933   cblock = code->block;
2934   while (cblock)
2935     {
2936       /* Has mask-expr.  */
2937       if (cblock->expr)
2938         {
2939           /* Ensure that the WHERE mask be evaluated only once.  */
2940           tmp2 = gfc_evaluate_where_mask (cblock->expr, nested_forall_info,
2941                                           &tmp, &tmp1, temp, block);
2942
2943           /* Set the control mask and the pending control mask.  */
2944           /* It's a where-stmt.  */
2945           if (mask == NULL)
2946             {
2947               mask = tmp;
2948               pmask = tmp1;
2949             }
2950           /* It's a nested where-stmt.  */
2951           else if (mask && pmask == NULL)
2952             {
2953               tree tmp2;
2954               /* Use the TREE_CHAIN to list the masks.  */
2955               tmp2 = copy_list (mask);
2956               pmask = chainon (mask, tmp1);
2957               mask = chainon (tmp2, tmp);
2958             }
2959           /* It's a masked-elsewhere-stmt.  */
2960           else if (mask && cblock->expr)
2961             {
2962               tree tmp2;
2963               tmp2 = copy_list (pmask);
2964
2965               mask = pmask;
2966               tmp2 = chainon (tmp2, tmp);
2967               pmask = chainon (mask, tmp1);
2968               mask = tmp2;
2969             }
2970         }
2971       /* It's a elsewhere-stmt. No mask-expr is present.  */
2972       else
2973         mask = pmask;
2974
2975       /* Get the assignment statement of a WHERE statement, or the first
2976          statement in where-body-construct of a WHERE construct.  */
2977       cnext = cblock->next;
2978       while (cnext)
2979         {
2980           switch (cnext->op)
2981             {
2982             /* WHERE assignment statement.  */
2983             case EXEC_ASSIGN:
2984               expr1 = cnext->expr;
2985               expr2 = cnext->expr2;
2986               if (nested_forall_info != NULL)
2987                 {
2988                   int nvar;
2989                   gfc_expr **varexpr;
2990
2991                   nvar = nested_forall_info->nvar;
2992                   varexpr = (gfc_expr **)
2993                             gfc_getmem (nvar * sizeof (gfc_expr *));
2994                   need_temp = gfc_check_dependency (expr1, expr2, varexpr,
2995                                                     nvar);
2996                   if (need_temp)
2997                     gfc_trans_assign_need_temp (expr1, expr2, mask,
2998                                                 nested_forall_info, block);
2999                   else
3000                     {
3001                       /* Variables to control maskexpr.  */
3002                       count1 = gfc_create_var (gfc_array_index_type, "count1");
3003                       count2 = gfc_create_var (gfc_array_index_type, "count2");
3004                       gfc_add_modify_expr (block, count1, gfc_index_zero_node);
3005                       gfc_add_modify_expr (block, count2, gfc_index_zero_node);
3006
3007                       tmp = gfc_trans_where_assign (expr1, expr2, mask, count1,
3008                                                     count2);
3009                       tmp = gfc_trans_nested_forall_loop (nested_forall_info,
3010                                                           tmp, 1, 1);
3011                       gfc_add_expr_to_block (block, tmp);
3012                     }
3013                 }
3014               else
3015                 {
3016                   /* Variables to control maskexpr.  */
3017                   count1 = gfc_create_var (gfc_array_index_type, "count1");
3018                   count2 = gfc_create_var (gfc_array_index_type, "count2");
3019                   gfc_add_modify_expr (block, count1, gfc_index_zero_node);
3020                   gfc_add_modify_expr (block, count2, gfc_index_zero_node);
3021
3022                   tmp = gfc_trans_where_assign (expr1, expr2, mask, count1,
3023                                                 count2);
3024                   gfc_add_expr_to_block (block, tmp);
3025
3026                 }
3027               break;
3028
3029             /* WHERE or WHERE construct is part of a where-body-construct.  */
3030             case EXEC_WHERE:
3031               /* Ensure that MASK is not modified by next gfc_trans_where_2.  */
3032               mask_copy = copy_list (mask);
3033               gfc_trans_where_2 (cnext, mask_copy, NULL, nested_forall_info,
3034                                  block, temp);
3035               break;
3036
3037             default:
3038               gcc_unreachable ();
3039             }
3040
3041          /* The next statement within the same where-body-construct.  */
3042          cnext = cnext->next;
3043        }
3044     /* The next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt.  */
3045     cblock = cblock->block;
3046   }
3047 }
3048
3049
3050 /* As the WHERE or WHERE construct statement can be nested, we call
3051    gfc_trans_where_2 to do the translation, and pass the initial
3052    NULL values for both the control mask and the pending control mask.  */
3053
3054 tree
3055 gfc_trans_where (gfc_code * code)
3056 {
3057   stmtblock_t block;
3058   temporary_list *temp, *p;
3059   tree args;
3060   tree tmp;
3061
3062   gfc_start_block (&block);
3063   temp = NULL;
3064
3065   gfc_trans_where_2 (code, NULL, NULL, NULL, &block, &temp);
3066
3067   /* Add calls to free temporaries which were dynamically allocated.  */
3068   while (temp)
3069     {
3070       args = gfc_chainon_list (NULL_TREE, temp->temporary);
3071       tmp = gfc_build_function_call (gfor_fndecl_internal_free, args);
3072       gfc_add_expr_to_block (&block, tmp);
3073
3074       p = temp;
3075       temp = temp->next;
3076       gfc_free (p);
3077     }
3078   return gfc_finish_block (&block);
3079 }
3080
3081
3082 /* CYCLE a DO loop. The label decl has already been created by
3083    gfc_trans_do(), it's in TREE_PURPOSE (backend_decl) of the gfc_code
3084    node at the head of the loop. We must mark the label as used.  */
3085
3086 tree
3087 gfc_trans_cycle (gfc_code * code)
3088 {
3089   tree cycle_label;
3090
3091   cycle_label = TREE_PURPOSE (code->ext.whichloop->backend_decl);
3092   TREE_USED (cycle_label) = 1;
3093   return build1_v (GOTO_EXPR, cycle_label);
3094 }
3095
3096
3097 /* EXIT a DO loop. Similar to CYCLE, but now the label is in
3098    TREE_VALUE (backend_decl) of the gfc_code node at the head of the
3099    loop.  */
3100
3101 tree
3102 gfc_trans_exit (gfc_code * code)
3103 {
3104   tree exit_label;
3105
3106   exit_label = TREE_VALUE (code->ext.whichloop->backend_decl);
3107   TREE_USED (exit_label) = 1;
3108   return build1_v (GOTO_EXPR, exit_label);
3109 }
3110
3111
3112 /* Translate the ALLOCATE statement.  */
3113
3114 tree
3115 gfc_trans_allocate (gfc_code * code)
3116 {
3117   gfc_alloc *al;
3118   gfc_expr *expr;
3119   gfc_se se;
3120   tree tmp;
3121   tree parm;
3122   gfc_ref *ref;
3123   tree stat;
3124   tree pstat;
3125   tree error_label;
3126   stmtblock_t block;
3127
3128   if (!code->ext.alloc_list)
3129     return NULL_TREE;
3130
3131   gfc_start_block (&block);
3132
3133   if (code->expr)
3134     {
3135       tree gfc_int4_type_node = gfc_get_int_type (4);
3136
3137       stat = gfc_create_var (gfc_int4_type_node, "stat");
3138       pstat = gfc_build_addr_expr (NULL, stat);
3139
3140       error_label = gfc_build_label_decl (NULL_TREE);
3141       TREE_USED (error_label) = 1;
3142     }
3143   else
3144     {
3145       pstat = integer_zero_node;
3146       stat = error_label = NULL_TREE;
3147     }
3148
3149
3150   for (al = code->ext.alloc_list; al != NULL; al = al->next)
3151     {
3152       expr = al->expr;
3153
3154       gfc_init_se (&se, NULL);
3155       gfc_start_block (&se.pre);
3156
3157       se.want_pointer = 1;
3158       se.descriptor_only = 1;
3159       gfc_conv_expr (&se, expr);
3160
3161       ref = expr->ref;
3162
3163       /* Find the last reference in the chain.  */
3164       while (ref && ref->next != NULL)
3165         {
3166           gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT);
3167           ref = ref->next;
3168         }
3169
3170       if (ref != NULL && ref->type == REF_ARRAY)
3171         {
3172           /* An array.  */
3173           gfc_array_allocate (&se, ref, pstat);
3174         }
3175       else
3176         {
3177           /* A scalar or derived type.  */
3178           tree val;
3179
3180           val = gfc_create_var (ppvoid_type_node, "ptr");
3181           tmp = gfc_build_addr_expr (ppvoid_type_node, se.expr);
3182           gfc_add_modify_expr (&se.pre, val, tmp);
3183
3184           tmp = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (se.expr)));
3185           parm = gfc_chainon_list (NULL_TREE, val);
3186           parm = gfc_chainon_list (parm, tmp);
3187           parm = gfc_chainon_list (parm, pstat);
3188           tmp = gfc_build_function_call (gfor_fndecl_allocate, parm);
3189           gfc_add_expr_to_block (&se.pre, tmp);
3190
3191           if (code->expr)
3192             {
3193               tmp = build1_v (GOTO_EXPR, error_label);
3194               parm =
3195                 build2 (NE_EXPR, boolean_type_node, stat, integer_zero_node);
3196               tmp = build3_v (COND_EXPR, parm, tmp, build_empty_stmt ());
3197               gfc_add_expr_to_block (&se.pre, tmp);
3198             }
3199         }
3200
3201       tmp = gfc_finish_block (&se.pre);
3202       gfc_add_expr_to_block (&block, tmp);
3203     }
3204
3205   /* Assign the value to the status variable.  */
3206   if (code->expr)
3207     {
3208       tmp = build1_v (LABEL_EXPR, error_label);
3209       gfc_add_expr_to_block (&block, tmp);
3210
3211       gfc_init_se (&se, NULL);
3212       gfc_conv_expr_lhs (&se, code->expr);
3213       tmp = convert (TREE_TYPE (se.expr), stat);
3214       gfc_add_modify_expr (&block, se.expr, tmp);
3215     }
3216
3217   return gfc_finish_block (&block);
3218 }
3219
3220
3221 tree
3222 gfc_trans_deallocate (gfc_code * code)
3223 {
3224   gfc_se se;
3225   gfc_alloc *al;
3226   gfc_expr *expr;
3227   tree var;
3228   tree tmp;
3229   tree type;
3230   stmtblock_t block;
3231
3232   gfc_start_block (&block);
3233
3234   for (al = code->ext.alloc_list; al != NULL; al = al->next)
3235     {
3236       expr = al->expr;
3237       gcc_assert (expr->expr_type == EXPR_VARIABLE);
3238
3239       gfc_init_se (&se, NULL);
3240       gfc_start_block (&se.pre);
3241
3242       se.want_pointer = 1;
3243       se.descriptor_only = 1;
3244       gfc_conv_expr (&se, expr);
3245
3246       if (expr->symtree->n.sym->attr.dimension)
3247         {
3248           tmp = gfc_array_deallocate (se.expr);
3249           gfc_add_expr_to_block (&se.pre, tmp);
3250         }
3251       else
3252         {
3253           type = build_pointer_type (TREE_TYPE (se.expr));
3254           var = gfc_create_var (type, "ptr");
3255           tmp = gfc_build_addr_expr (type, se.expr);
3256           gfc_add_modify_expr (&se.pre, var, tmp);
3257
3258           tmp = gfc_chainon_list (NULL_TREE, var);
3259           tmp = gfc_chainon_list (tmp, integer_zero_node);
3260           tmp = gfc_build_function_call (gfor_fndecl_deallocate, tmp);
3261           gfc_add_expr_to_block (&se.pre, tmp);
3262         }
3263       tmp = gfc_finish_block (&se.pre);
3264       gfc_add_expr_to_block (&block, tmp);
3265     }
3266
3267   return gfc_finish_block (&block);
3268 }
3269