gcc/fortran/trans-stmt.c

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