gcc/fortran/trans-stmt.c

   1 /* Statement translation -- generate GCC trees from gfc_code.
   2    Copyright (C) 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
   3    Contributed by Paul Brook <paul@nowt.org>
   4    and Steven Bosscher <s.bosscher@student.tudelft.nl>
   5
   6 This file is part of GCC.
   7
   8 GCC is free software; you can redistribute it and/or modify it under
   9 the terms of the GNU General Public License as published by the Free
  10 Software Foundation; either version 2, or (at your option) any later
  11 version.
  12
  13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
  14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
  15 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  16 for more details.
  17
  18 You should have received a copy of the GNU General Public License
  19 along with GCC; see the file COPYING.  If not, write to the Free
  20 Software Foundation, 59 Temple Place - Suite 330, Boston, MA
  21 02111-1307, USA.  */
  22
  23
  24 #include "config.h"
  25 #include "system.h"
  26 #include "coretypes.h"
  27 #include "tree.h"
  28 #include "tree-gimple.h"
  29 #include "ggc.h"
  30 #include "toplev.h"
  31 #include "real.h"
  32 #include "gfortran.h"
  33 #include "trans.h"
  34 #include "trans-stmt.h"
  35 #include "trans-types.h"
  36 #include "trans-array.h"
  37 #include "trans-const.h"
  38 #include "arith.h"
  39
  40 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       /* Allocate the mask temporary.  */
2415       bytesize = fold_build2 (MULT_EXPR, gfc_array_index_type, size,
2416                               TYPE_SIZE_UNIT (boolean_type_node));
2417
2418       mask = gfc_do_allocate (bytesize, size, &pmask, &block, boolean_type_node);
2419
2420       maskindex = gfc_create_var_np (gfc_array_index_type, "mi");
2421       /* Record them in the info structure.  */
2422       info->pmask = pmask;
2423       info->mask = mask;
2424       info->maskindex = maskindex;
2425
2426       gfc_add_modify_expr (&block, maskindex, gfc_index_zero_node);
2427
2428       /* Start of mask assignment loop body.  */
2429       gfc_start_block (&body);
2430
2431       /* Evaluate the mask expression.  */
2432       gfc_init_se (&se, NULL);
2433       gfc_conv_expr_val (&se, code->expr);
2434       gfc_add_block_to_block (&body, &se.pre);
2435
2436       /* Store the mask.  */
2437       se.expr = convert (boolean_type_node, se.expr);
2438
2439       if (pmask)
2440         tmp = gfc_build_indirect_ref (mask);
2441       else
2442         tmp = mask;
2443       tmp = gfc_build_array_ref (tmp, maskindex);
2444       gfc_add_modify_expr (&body, tmp, se.expr);
2445
2446       /* Advance to the next mask element.  */
2447       tmp = build2 (PLUS_EXPR, gfc_array_index_type,
2448                    maskindex, gfc_index_one_node);
2449       gfc_add_modify_expr (&body, maskindex, tmp);
2450
2451       /* Generate the loops.  */
2452       tmp = gfc_finish_block (&body);
2453       tmp = gfc_trans_nested_forall_loop (info, tmp, 0, 0);
2454       gfc_add_expr_to_block (&block, tmp);
2455     }
2456   else
2457     {
2458       /* No mask was specified.  */
2459       maskindex = NULL_TREE;
2460       mask = pmask = NULL_TREE;
2461     }
2462
2463   c = code->block->next;
2464
2465   /* TODO: loop merging in FORALL statements.  */
2466   /* Now that we've got a copy of the mask, generate the assignment loops.  */
2467   while (c)
2468     {
2469       switch (c->op)
2470         {
2471         case EXEC_ASSIGN:
2472           /* A scalar or array assignment.  */
2473           need_temp = gfc_check_dependency (c->expr, c->expr2, varexpr, nvar);
2474           /* Temporaries due to array assignment data dependencies introduce
2475              no end of problems.  */
2476           if (need_temp)
2477             gfc_trans_assign_need_temp (c->expr, c->expr2, NULL,
2478                                         nested_forall_info, &block);
2479           else
2480             {
2481               /* Use the normal assignment copying routines.  */
2482               assign = gfc_trans_assignment (c->expr, c->expr2);
2483
2484               /* Reset the mask index.  */
2485               if (mask)
2486                 gfc_add_modify_expr (&block, maskindex, gfc_index_zero_node);
2487
2488               /* Generate body and loops.  */
2489               tmp = gfc_trans_nested_forall_loop (nested_forall_info, assign, 1, 1);
2490               gfc_add_expr_to_block (&block, tmp);
2491             }
2492
2493           break;
2494
2495         case EXEC_WHERE:
2496
2497           /* Translate WHERE or WHERE construct nested in FORALL.  */
2498           temp = NULL;
2499           gfc_trans_where_2 (c, NULL, NULL, nested_forall_info, &block, &temp);
2500
2501           while (temp)
2502             {
2503               tree args;
2504               temporary_list *p;
2505
2506               /* Free the temporary.  */
2507               args = gfc_chainon_list (NULL_TREE, temp->temporary);
2508               tmp = gfc_build_function_call (gfor_fndecl_internal_free, args);
2509               gfc_add_expr_to_block (&block, tmp);
2510
2511               p = temp;
2512               temp = temp->next;
2513               gfc_free (p);
2514             }
2515
2516           break;
2517
2518         /* Pointer assignment inside FORALL.  */
2519         case EXEC_POINTER_ASSIGN:
2520           need_temp = gfc_check_dependency (c->expr, c->expr2, varexpr, nvar);
2521           if (need_temp)
2522             gfc_trans_pointer_assign_need_temp (c->expr, c->expr2,
2523                                                 nested_forall_info, &block);
2524           else
2525             {
2526               /* Use the normal assignment copying routines.  */
2527               assign = gfc_trans_pointer_assignment (c->expr, c->expr2);
2528
2529               /* Reset the mask index.  */
2530               if (mask)
2531                 gfc_add_modify_expr (&block, maskindex, gfc_index_zero_node);
2532
2533               /* Generate body and loops.  */
2534               tmp = gfc_trans_nested_forall_loop (nested_forall_info, assign,
2535                                                   1, 1);
2536               gfc_add_expr_to_block (&block, tmp);
2537             }
2538           break;
2539
2540         case EXEC_FORALL:
2541           tmp = gfc_trans_forall_1 (c, nested_forall_info);
2542           gfc_add_expr_to_block (&block, tmp);
2543           break;
2544
2545         default:
2546           gcc_unreachable ();
2547         }
2548
2549       c = c->next;
2550     }
2551
2552   /* Restore the original index variables.  */
2553   for (fa = code->ext.forall_iterator, n = 0; fa; fa = fa->next, n++)
2554     gfc_restore_sym (fa->var->symtree->n.sym, &saved_vars[n]);
2555
2556   /* Free the space for var, start, end, step, varexpr.  */
2557   gfc_free (var);
2558   gfc_free (start);
2559   gfc_free (end);
2560   gfc_free (step);
2561   gfc_free (varexpr);
2562   gfc_free (saved_vars);
2563
2564   if (pmask)
2565     {
2566       /* Free the temporary for the mask.  */
2567       tmp = gfc_chainon_list (NULL_TREE, pmask);
2568       tmp = gfc_build_function_call (gfor_fndecl_internal_free, tmp);
2569       gfc_add_expr_to_block (&block, tmp);
2570     }
2571   if (maskindex)
2572     pushdecl (maskindex);
2573
2574   return gfc_finish_block (&block);
2575 }
2576
2577
2578 /* Translate the FORALL statement or construct.  */
2579
2580 tree gfc_trans_forall (gfc_code * code)
2581 {
2582   return gfc_trans_forall_1 (code, NULL);
2583 }
2584
2585
2586 /* Evaluate the WHERE mask expression, copy its value to a temporary.
2587    If the WHERE construct is nested in FORALL, compute the overall temporary
2588    needed by the WHERE mask expression multiplied by the iterator number of
2589    the nested forall.
2590    ME is the WHERE mask expression.
2591    MASK is the temporary which value is mask's value.
2592    NMASK is another temporary which value is !mask.
2593    TEMP records the temporary's address allocated in this function in order to
2594    free them outside this function.
2595    MASK, NMASK and TEMP are all OUT arguments.  */
2596
2597 static tree
2598 gfc_evaluate_where_mask (gfc_expr * me, forall_info * nested_forall_info,
2599                          tree * mask, tree * nmask, temporary_list ** temp,
2600                          stmtblock_t * block)
2601 {
2602   tree tmp, tmp1;
2603   gfc_ss *lss, *rss;
2604   gfc_loopinfo loop;
2605   tree ptemp1, ntmp, ptemp2;
2606   tree inner_size, size;
2607   stmtblock_t body, body1, inner_size_body;
2608   gfc_se lse, rse;
2609   tree count;
2610   tree tmpexpr;
2611
2612   gfc_init_loopinfo (&loop);
2613
2614   /* Calculate the size of temporary needed by the mask-expr.  */
2615   gfc_init_block (&inner_size_body);
2616   inner_size = compute_inner_temp_size (me, me, &inner_size_body, &lss, &rss);
2617
2618   /* Calculate the total size of temporary needed.  */
2619   size = compute_overall_iter_number (nested_forall_info, inner_size,
2620                                       &inner_size_body, block);
2621
2622   /* Allocate temporary for where mask.  */
2623   tmp = allocate_temp_for_forall_nest_1 (boolean_type_node, size, block,
2624                                          &ptemp1);
2625   /* Record the temporary address in order to free it later.  */
2626   if (ptemp1)
2627     {
2628       temporary_list *tempo;
2629       tempo = (temporary_list *) gfc_getmem (sizeof (temporary_list));
2630       tempo->temporary = ptemp1;
2631       tempo->next = *temp;
2632       *temp = tempo;
2633     }
2634
2635   /* Allocate temporary for !mask.  */
2636   ntmp = allocate_temp_for_forall_nest_1 (boolean_type_node, size, block,
2637                                           &ptemp2);
2638   /* Record the temporary  in order to free it later.  */
2639   if (ptemp2)
2640     {
2641       temporary_list *tempo;
2642       tempo = (temporary_list *) gfc_getmem (sizeof (temporary_list));
2643       tempo->temporary = ptemp2;
2644       tempo->next = *temp;
2645       *temp = tempo;
2646     }
2647
2648   /* Variable to index the temporary.  */
2649   count = gfc_create_var (gfc_array_index_type, "count");
2650   /* Initialize count.  */
2651   gfc_add_modify_expr (block, count, gfc_index_zero_node);
2652
2653   gfc_start_block (&body);
2654
2655   gfc_init_se (&rse, NULL);
2656   gfc_init_se (&lse, NULL);
2657
2658   if (lss == gfc_ss_terminator)
2659     {
2660       gfc_init_block (&body1);
2661     }
2662   else
2663     {
2664       /* Initialize the loop.  */
2665       gfc_init_loopinfo (&loop);
2666
2667       /* We may need LSS to determine the shape of the expression.  */
2668       gfc_add_ss_to_loop (&loop, lss);
2669       gfc_add_ss_to_loop (&loop, rss);
2670
2671       gfc_conv_ss_startstride (&loop);
2672       gfc_conv_loop_setup (&loop);
2673
2674       gfc_mark_ss_chain_used (rss, 1);
2675       /* Start the loop body.  */
2676       gfc_start_scalarized_body (&loop, &body1);
2677
2678       /* Translate the expression.  */
2679       gfc_copy_loopinfo_to_se (&rse, &loop);
2680       rse.ss = rss;
2681       gfc_conv_expr (&rse, me);
2682     }
2683   /* Form the expression of the temporary.  */
2684   lse.expr = gfc_build_array_ref (tmp, count);
2685   tmpexpr = gfc_build_array_ref (ntmp, count);
2686
2687   /* Use the scalar assignment to fill temporary TMP.  */
2688   tmp1 = gfc_trans_scalar_assign (&lse, &rse, me->ts.type);
2689   gfc_add_expr_to_block (&body1, tmp1);
2690
2691   /* Fill temporary NTMP.  */
2692   tmp1 = build1 (TRUTH_NOT_EXPR, TREE_TYPE (lse.expr), lse.expr);
2693   gfc_add_modify_expr (&body1, tmpexpr, tmp1);
2694
2695  if (lss == gfc_ss_terminator)
2696     {
2697       gfc_add_block_to_block (&body, &body1);
2698     }
2699   else
2700     {
2701       /* Increment count.  */
2702       tmp1 = fold_build2 (PLUS_EXPR, gfc_array_index_type, count,
2703                           gfc_index_one_node);
2704       gfc_add_modify_expr (&body1, count, tmp1);
2705
2706       /* Generate the copying loops.  */
2707       gfc_trans_scalarizing_loops (&loop, &body1);
2708
2709       gfc_add_block_to_block (&body, &loop.pre);
2710       gfc_add_block_to_block (&body, &loop.post);
2711
2712       gfc_cleanup_loop (&loop);
2713       /* TODO: Reuse lss and rss when copying temp->lhs.  Need to be careful
2714          as tree nodes in SS may not be valid in different scope.  */
2715     }
2716
2717   tmp1 = gfc_finish_block (&body);
2718   /* If the WHERE construct is inside FORALL, fill the full temporary.  */
2719   if (nested_forall_info != NULL)
2720     {
2721       forall_info *forall_tmp;
2722       tree maskindex;
2723
2724       /* Initialize the maskindexes.  */
2725       forall_tmp = nested_forall_info;
2726       while (forall_tmp != NULL)
2727         {
2728           maskindex = forall_tmp->maskindex;
2729           if (forall_tmp->mask)
2730             gfc_add_modify_expr (block, maskindex, gfc_index_zero_node);
2731           forall_tmp = forall_tmp->next_nest;
2732         }
2733
2734       tmp1 = gfc_trans_nested_forall_loop (nested_forall_info, tmp1, 1, 1);
2735     }
2736
2737   gfc_add_expr_to_block (block, tmp1);
2738
2739   *mask = tmp;
2740   *nmask = ntmp;
2741
2742   return tmp1;
2743 }
2744
2745
2746 /* Translate an assignment statement in a WHERE statement or construct
2747    statement. The MASK expression is used to control which elements
2748    of EXPR1 shall be assigned.  */
2749
2750 static tree
2751 gfc_trans_where_assign (gfc_expr *expr1, gfc_expr *expr2, tree mask,
2752                         tree count1, tree count2)
2753 {
2754   gfc_se lse;
2755   gfc_se rse;
2756   gfc_ss *lss;
2757   gfc_ss *lss_section;
2758   gfc_ss *rss;
2759
2760   gfc_loopinfo loop;
2761   tree tmp;
2762   stmtblock_t block;
2763   stmtblock_t body;
2764   tree index, maskexpr, tmp1;
2765
2766 #if 0
2767   /* TODO: handle this special case.
2768      Special case a single function returning an array.  */
2769   if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
2770     {
2771       tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
2772       if (tmp)
2773         return tmp;
2774     }
2775 #endif
2776
2777  /* Assignment of the form lhs = rhs.  */
2778   gfc_start_block (&block);
2779
2780   gfc_init_se (&lse, NULL);
2781   gfc_init_se (&rse, NULL);
2782
2783   /* Walk the lhs.  */
2784   lss = gfc_walk_expr (expr1);
2785   rss = NULL;
2786
2787   /* In each where-assign-stmt, the mask-expr and the variable being
2788      defined shall be arrays of the same shape.  */
2789   gcc_assert (lss != gfc_ss_terminator);
2790
2791   /* The assignment needs scalarization.  */
2792   lss_section = lss;
2793
2794   /* Find a non-scalar SS from the lhs.  */
2795   while (lss_section != gfc_ss_terminator
2796          && lss_section->type != GFC_SS_SECTION)
2797     lss_section = lss_section->next;
2798
2799   gcc_assert (lss_section != gfc_ss_terminator);
2800
2801   /* Initialize the scalarizer.  */
2802   gfc_init_loopinfo (&loop);
2803
2804   /* Walk the rhs.  */
2805   rss = gfc_walk_expr (expr2);
2806   if (rss == gfc_ss_terminator)
2807    {
2808      /* The rhs is scalar.  Add a ss for the expression.  */
2809      rss = gfc_get_ss ();
2810      rss->next = gfc_ss_terminator;
2811      rss->type = GFC_SS_SCALAR;
2812      rss->expr = expr2;
2813     }
2814
2815   /* Associate the SS with the loop.  */
2816   gfc_add_ss_to_loop (&loop, lss);
2817   gfc_add_ss_to_loop (&loop, rss);
2818
2819   /* Calculate the bounds of the scalarization.  */
2820   gfc_conv_ss_startstride (&loop);
2821
2822   /* Resolve any data dependencies in the statement.  */
2823   gfc_conv_resolve_dependencies (&loop, lss_section, rss);
2824
2825   /* Setup the scalarizing loops.  */
2826   gfc_conv_loop_setup (&loop);
2827
2828   /* Setup the gfc_se structures.  */
2829   gfc_copy_loopinfo_to_se (&lse, &loop);
2830   gfc_copy_loopinfo_to_se (&rse, &loop);
2831
2832   rse.ss = rss;
2833   gfc_mark_ss_chain_used (rss, 1);
2834   if (loop.temp_ss == NULL)
2835     {
2836       lse.ss = lss;
2837       gfc_mark_ss_chain_used (lss, 1);
2838     }
2839   else
2840     {
2841       lse.ss = loop.temp_ss;
2842       gfc_mark_ss_chain_used (lss, 3);
2843       gfc_mark_ss_chain_used (loop.temp_ss, 3);
2844     }
2845
2846   /* Start the scalarized loop body.  */
2847   gfc_start_scalarized_body (&loop, &body);
2848
2849   /* Translate the expression.  */
2850   gfc_conv_expr (&rse, expr2);
2851   if (lss != gfc_ss_terminator && loop.temp_ss != NULL)
2852     {
2853       gfc_conv_tmp_array_ref (&lse);
2854       gfc_advance_se_ss_chain (&lse);
2855     }
2856   else
2857     gfc_conv_expr (&lse, expr1);
2858
2859   /* Form the mask expression according to the mask tree list.  */
2860   index = count1;
2861   tmp = mask;
2862   if (tmp != NULL)
2863     maskexpr = gfc_build_array_ref (tmp, index);
2864   else
2865     maskexpr = NULL;
2866
2867   tmp = TREE_CHAIN (tmp);
2868   while (tmp)
2869     {
2870       tmp1 = gfc_build_array_ref (tmp, index);
2871       maskexpr = build2 (TRUTH_AND_EXPR, TREE_TYPE (tmp1), maskexpr, tmp1);
2872       tmp = TREE_CHAIN (tmp);
2873     }
2874   /* Use the scalar assignment as is.  */
2875   tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
2876   tmp = build3_v (COND_EXPR, maskexpr, tmp, build_empty_stmt ());
2877
2878   gfc_add_expr_to_block (&body, tmp);
2879
2880   if (lss == gfc_ss_terminator)
2881     {
2882       /* Increment count1.  */
2883       tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2884                          count1, gfc_index_one_node);
2885       gfc_add_modify_expr (&body, count1, tmp);
2886
2887       /* Use the scalar assignment as is.  */
2888       gfc_add_block_to_block (&block, &body);
2889     }
2890   else
2891     {
2892       gcc_assert (lse.ss == gfc_ss_terminator
2893                   && rse.ss == gfc_ss_terminator);
2894
2895       if (loop.temp_ss != NULL)
2896         {
2897           /* Increment count1 before finish the main body of a scalarized
2898              expression.  */
2899           tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2900                              count1, gfc_index_one_node);
2901           gfc_add_modify_expr (&body, count1, tmp);
2902           gfc_trans_scalarized_loop_boundary (&loop, &body);
2903
2904           /* We need to copy the temporary to the actual lhs.  */
2905           gfc_init_se (&lse, NULL);
2906           gfc_init_se (&rse, NULL);
2907           gfc_copy_loopinfo_to_se (&lse, &loop);
2908           gfc_copy_loopinfo_to_se (&rse, &loop);
2909
2910           rse.ss = loop.temp_ss;
2911           lse.ss = lss;
2912
2913           gfc_conv_tmp_array_ref (&rse);
2914           gfc_advance_se_ss_chain (&rse);
2915           gfc_conv_expr (&lse, expr1);
2916
2917           gcc_assert (lse.ss == gfc_ss_terminator
2918                       && rse.ss == gfc_ss_terminator);
2919
2920           /* Form the mask expression according to the mask tree list.  */
2921           index = count2;
2922           tmp = mask;
2923           if (tmp != NULL)
2924             maskexpr = gfc_build_array_ref (tmp, index);
2925           else
2926             maskexpr = NULL;
2927
2928           tmp = TREE_CHAIN (tmp);
2929           while (tmp)
2930             {
2931               tmp1 = gfc_build_array_ref (tmp, index);
2932               maskexpr = build2 (TRUTH_AND_EXPR, TREE_TYPE (tmp1),
2933                                  maskexpr, tmp1);
2934               tmp = TREE_CHAIN (tmp);
2935             }
2936           /* Use the scalar assignment as is.  */
2937           tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
2938           tmp = build3_v (COND_EXPR, maskexpr, tmp, build_empty_stmt ());
2939           gfc_add_expr_to_block (&body, tmp);
2940
2941           /* Increment count2.  */
2942           tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2943                              count2, gfc_index_one_node);
2944           gfc_add_modify_expr (&body, count2, tmp);
2945         }
2946       else
2947         {
2948           /* Increment count1.  */
2949           tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2950                              count1, gfc_index_one_node);
2951           gfc_add_modify_expr (&body, count1, tmp);
2952         }
2953
2954       /* Generate the copying loops.  */
2955       gfc_trans_scalarizing_loops (&loop, &body);
2956
2957       /* Wrap the whole thing up.  */
2958       gfc_add_block_to_block (&block, &loop.pre);
2959       gfc_add_block_to_block (&block, &loop.post);
2960       gfc_cleanup_loop (&loop);
2961     }
2962
2963   return gfc_finish_block (&block);
2964 }
2965
2966
2967 /* Translate the WHERE construct or statement.
2968    This function can be called iteratively to translate the nested WHERE
2969    construct or statement.
2970    MASK is the control mask, and PMASK is the pending control mask.
2971    TEMP records the temporary address which must be freed later.  */
2972
2973 static void
2974 gfc_trans_where_2 (gfc_code * code, tree mask, tree pmask,
2975                    forall_info * nested_forall_info, stmtblock_t * block,
2976                    temporary_list ** temp)
2977 {
2978   gfc_expr *expr1;
2979   gfc_expr *expr2;
2980   gfc_code *cblock;
2981   gfc_code *cnext;
2982   tree tmp, tmp1, tmp2;
2983   tree count1, count2;
2984   tree mask_copy;
2985   int need_temp;
2986
2987   /* the WHERE statement or the WHERE construct statement.  */
2988   cblock = code->block;
2989   while (cblock)
2990     {
2991       /* Has mask-expr.  */
2992       if (cblock->expr)
2993         {
2994           /* Ensure that the WHERE mask be evaluated only once.  */
2995           tmp2 = gfc_evaluate_where_mask (cblock->expr, nested_forall_info,
2996                                           &tmp, &tmp1, temp, block);
2997
2998           /* Set the control mask and the pending control mask.  */
2999           /* It's a where-stmt.  */
3000           if (mask == NULL)
3001             {
3002               mask = tmp;
3003               pmask = tmp1;
3004             }
3005           /* It's a nested where-stmt.  */
3006           else if (mask && pmask == NULL)
3007             {
3008               tree tmp2;
3009               /* Use the TREE_CHAIN to list the masks.  */
3010               tmp2 = copy_list (mask);
3011               pmask = chainon (mask, tmp1);
3012               mask = chainon (tmp2, tmp);
3013             }
3014           /* It's a masked-elsewhere-stmt.  */
3015           else if (mask && cblock->expr)
3016             {
3017               tree tmp2;
3018               tmp2 = copy_list (pmask);
3019
3020               mask = pmask;
3021               tmp2 = chainon (tmp2, tmp);
3022               pmask = chainon (mask, tmp1);
3023               mask = tmp2;
3024             }
3025         }
3026       /* It's a elsewhere-stmt. No mask-expr is present.  */
3027       else
3028         mask = pmask;
3029
3030       /* Get the assignment statement of a WHERE statement, or the first
3031          statement in where-body-construct of a WHERE construct.  */
3032       cnext = cblock->next;
3033       while (cnext)
3034         {
3035           switch (cnext->op)
3036             {
3037             /* WHERE assignment statement.  */
3038             case EXEC_ASSIGN:
3039               expr1 = cnext->expr;
3040               expr2 = cnext->expr2;
3041               if (nested_forall_info != NULL)
3042                 {
3043                   int nvar;
3044                   gfc_expr **varexpr;
3045
3046                   nvar = nested_forall_info->nvar;
3047                   varexpr = (gfc_expr **)
3048                             gfc_getmem (nvar * sizeof (gfc_expr *));
3049                   need_temp = gfc_check_dependency (expr1, expr2, varexpr,
3050                                                     nvar);
3051                   if (need_temp)
3052                     gfc_trans_assign_need_temp (expr1, expr2, mask,
3053                                                 nested_forall_info, block);
3054                   else
3055                     {
3056                       forall_info *forall_tmp;
3057                       tree maskindex;
3058
3059                       /* Variables to control maskexpr.  */
3060                       count1 = gfc_create_var (gfc_array_index_type, "count1");
3061                       count2 = gfc_create_var (gfc_array_index_type, "count2");
3062                       gfc_add_modify_expr (block, count1, gfc_index_zero_node);
3063                       gfc_add_modify_expr (block, count2, gfc_index_zero_node);
3064
3065                       tmp = gfc_trans_where_assign (expr1, expr2, mask, count1,
3066                                                     count2);
3067
3068                       /* Initialize the maskindexes.  */
3069                       forall_tmp = nested_forall_info;
3070                       while (forall_tmp != NULL)
3071                         {
3072                           maskindex = forall_tmp->maskindex;
3073                           if (forall_tmp->mask)
3074                             gfc_add_modify_expr (block, maskindex,
3075                                                  gfc_index_zero_node);
3076                           forall_tmp = forall_tmp->next_nest;
3077                         }
3078
3079                       tmp = gfc_trans_nested_forall_loop (nested_forall_info,
3080                                                           tmp, 1, 1);
3081                       gfc_add_expr_to_block (block, tmp);
3082                     }
3083                 }
3084               else
3085                 {
3086                   /* Variables to control maskexpr.  */
3087                   count1 = gfc_create_var (gfc_array_index_type, "count1");
3088                   count2 = gfc_create_var (gfc_array_index_type, "count2");
3089                   gfc_add_modify_expr (block, count1, gfc_index_zero_node);
3090                   gfc_add_modify_expr (block, count2, gfc_index_zero_node);
3091
3092                   tmp = gfc_trans_where_assign (expr1, expr2, mask, count1,
3093                                                 count2);
3094                   gfc_add_expr_to_block (block, tmp);
3095
3096                 }
3097               break;
3098
3099             /* WHERE or WHERE construct is part of a where-body-construct.  */
3100             case EXEC_WHERE:
3101               /* Ensure that MASK is not modified by next gfc_trans_where_2.  */
3102               mask_copy = copy_list (mask);
3103               gfc_trans_where_2 (cnext, mask_copy, NULL, nested_forall_info,
3104                                  block, temp);
3105               break;
3106
3107             default:
3108               gcc_unreachable ();
3109             }
3110
3111          /* The next statement within the same where-body-construct.  */
3112          cnext = cnext->next;
3113        }
3114     /* The next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt.  */
3115     cblock = cblock->block;
3116   }
3117 }
3118
3119
3120 /* As the WHERE or WHERE construct statement can be nested, we call
3121    gfc_trans_where_2 to do the translation, and pass the initial
3122    NULL values for both the control mask and the pending control mask.  */
3123
3124 tree
3125 gfc_trans_where (gfc_code * code)
3126 {
3127   stmtblock_t block;
3128   temporary_list *temp, *p;
3129   tree args;
3130   tree tmp;
3131
3132   gfc_start_block (&block);
3133   temp = NULL;
3134
3135   gfc_trans_where_2 (code, NULL, NULL, NULL, &block, &temp);
3136
3137   /* Add calls to free temporaries which were dynamically allocated.  */
3138   while (temp)
3139     {
3140       args = gfc_chainon_list (NULL_TREE, temp->temporary);
3141       tmp = gfc_build_function_call (gfor_fndecl_internal_free, args);
3142       gfc_add_expr_to_block (&block, tmp);
3143
3144       p = temp;
3145       temp = temp->next;
3146       gfc_free (p);
3147     }
3148   return gfc_finish_block (&block);
3149 }
3150
3151
3152 /* CYCLE a DO loop. The label decl has already been created by
3153    gfc_trans_do(), it's in TREE_PURPOSE (backend_decl) of the gfc_code
3154    node at the head of the loop. We must mark the label as used.  */
3155
3156 tree
3157 gfc_trans_cycle (gfc_code * code)
3158 {
3159   tree cycle_label;
3160
3161   cycle_label = TREE_PURPOSE (code->ext.whichloop->backend_decl);
3162   TREE_USED (cycle_label) = 1;
3163   return build1_v (GOTO_EXPR, cycle_label);
3164 }
3165
3166
3167 /* EXIT a DO loop. Similar to CYCLE, but now the label is in
3168    TREE_VALUE (backend_decl) of the gfc_code node at the head of the
3169    loop.  */
3170
3171 tree
3172 gfc_trans_exit (gfc_code * code)
3173 {
3174   tree exit_label;
3175
3176   exit_label = TREE_VALUE (code->ext.whichloop->backend_decl);
3177   TREE_USED (exit_label) = 1;
3178   return build1_v (GOTO_EXPR, exit_label);
3179 }
3180
3181
3182 /* Translate the ALLOCATE statement.  */
3183
3184 tree
3185 gfc_trans_allocate (gfc_code * code)
3186 {
3187   gfc_alloc *al;
3188   gfc_expr *expr;
3189   gfc_se se;
3190   tree tmp;
3191   tree parm;
3192   gfc_ref *ref;
3193   tree stat;
3194   tree pstat;
3195   tree error_label;
3196   stmtblock_t block;
3197
3198   if (!code->ext.alloc_list)
3199     return NULL_TREE;
3200
3201   gfc_start_block (&block);
3202
3203   if (code->expr)
3204     {
3205       tree gfc_int4_type_node = gfc_get_int_type (4);
3206
3207       stat = gfc_create_var (gfc_int4_type_node, "stat");
3208       pstat = gfc_build_addr_expr (NULL, stat);
3209
3210       error_label = gfc_build_label_decl (NULL_TREE);
3211       TREE_USED (error_label) = 1;
3212     }
3213   else
3214     {
3215       pstat = integer_zero_node;
3216       stat = error_label = NULL_TREE;
3217     }
3218
3219
3220   for (al = code->ext.alloc_list; al != NULL; al = al->next)
3221     {
3222       expr = al->expr;
3223
3224       gfc_init_se (&se, NULL);
3225       gfc_start_block (&se.pre);
3226
3227       se.want_pointer = 1;
3228       se.descriptor_only = 1;
3229       gfc_conv_expr (&se, expr);
3230
3231       ref = expr->ref;
3232
3233       /* Find the last reference in the chain.  */
3234       while (ref && ref->next != NULL)
3235         {
3236           gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT);
3237           ref = ref->next;
3238         }
3239
3240       if (ref != NULL && ref->type == REF_ARRAY)
3241         {
3242           /* An array.  */
3243           gfc_array_allocate (&se, ref, pstat);
3244         }
3245       else
3246         {
3247           /* A scalar or derived type.  */
3248           tree val;
3249
3250           val = gfc_create_var (ppvoid_type_node, "ptr");
3251           tmp = gfc_build_addr_expr (ppvoid_type_node, se.expr);
3252           gfc_add_modify_expr (&se.pre, val, tmp);
3253
3254           tmp = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (se.expr)));
3255           parm = gfc_chainon_list (NULL_TREE, val);
3256           parm = gfc_chainon_list (parm, tmp);
3257           parm = gfc_chainon_list (parm, pstat);
3258           tmp = gfc_build_function_call (gfor_fndecl_allocate, parm);
3259           gfc_add_expr_to_block (&se.pre, tmp);
3260
3261           if (code->expr)
3262             {
3263               tmp = build1_v (GOTO_EXPR, error_label);
3264               parm =
3265                 build2 (NE_EXPR, boolean_type_node, stat, integer_zero_node);
3266               tmp = build3_v (COND_EXPR, parm, tmp, build_empty_stmt ());
3267               gfc_add_expr_to_block (&se.pre, tmp);
3268             }
3269         }
3270
3271       tmp = gfc_finish_block (&se.pre);
3272       gfc_add_expr_to_block (&block, tmp);
3273     }
3274
3275   /* Assign the value to the status variable.  */
3276   if (code->expr)
3277     {
3278       tmp = build1_v (LABEL_EXPR, error_label);
3279       gfc_add_expr_to_block (&block, tmp);
3280
3281       gfc_init_se (&se, NULL);
3282       gfc_conv_expr_lhs (&se, code->expr);
3283       tmp = convert (TREE_TYPE (se.expr), stat);
3284       gfc_add_modify_expr (&block, se.expr, tmp);
3285     }
3286
3287   return gfc_finish_block (&block);
3288 }
3289
3290
3291 /* Translate a DEALLOCATE statement.
3292    There are two cases within the for loop:
3293    (1) deallocate(a1, a2, a3) is translated into the following sequence
3294        _gfortran_deallocate(a1, 0B)
3295        _gfortran_deallocate(a2, 0B)
3296        _gfortran_deallocate(a3, 0B)
3297        where the STAT= variable is passed a NULL pointer.
3298    (2) deallocate(a1, a2, a3, stat=i) is translated into the following
3299        astat = 0
3300        _gfortran_deallocate(a1, &stat)
3301        astat = astat + stat
3302        _gfortran_deallocate(a2, &stat)
3303        astat = astat + stat
3304        _gfortran_deallocate(a3, &stat)
3305        astat = astat + stat
3306     In case (1), we simply return at the end of the for loop.  In case (2)
3307     we set STAT= astat.  */
3308 tree
3309 gfc_trans_deallocate (gfc_code * code)
3310 {
3311   gfc_se se;
3312   gfc_alloc *al;
3313   gfc_expr *expr;
3314   tree apstat, astat, parm, pstat, stat, tmp, type, var;
3315   stmtblock_t block;
3316
3317   gfc_start_block (&block);
3318
3319   /* Set up the optional STAT= */
3320   if (code->expr)
3321     {
3322       tree gfc_int4_type_node = gfc_get_int_type (4);
3323
3324       /* Variable used with the library call.  */
3325       stat = gfc_create_var (gfc_int4_type_node, "stat");
3326       pstat = gfc_build_addr_expr (NULL, stat);
3327
3328       /* Running total of possible deallocation failures.  */
3329       astat = gfc_create_var (gfc_int4_type_node, "astat");
3330       apstat = gfc_build_addr_expr (NULL, astat);
3331
3332       /* Initialize astat to 0.  */
3333       gfc_add_modify_expr (&block, astat, build_int_cst (TREE_TYPE (astat), 0));
3334     }
3335   else
3336     {
3337       pstat = apstat = null_pointer_node;
3338       stat = astat = NULL_TREE;
3339     }
3340
3341   for (al = code->ext.alloc_list; al != NULL; al = al->next)
3342     {
3343       expr = al->expr;
3344       gcc_assert (expr->expr_type == EXPR_VARIABLE);
3345
3346       gfc_init_se (&se, NULL);
3347       gfc_start_block (&se.pre);
3348
3349       se.want_pointer = 1;
3350       se.descriptor_only = 1;
3351       gfc_conv_expr (&se, expr);
3352
3353       if (expr->symtree->n.sym->attr.dimension)
3354         tmp = gfc_array_deallocate (se.expr, pstat);
3355       else
3356         {
3357           type = build_pointer_type (TREE_TYPE (se.expr));
3358           var = gfc_create_var (type, "ptr");
3359           tmp = gfc_build_addr_expr (type, se.expr);
3360           gfc_add_modify_expr (&se.pre, var, tmp);
3361
3362           parm = gfc_chainon_list (NULL_TREE, var);
3363           parm = gfc_chainon_list (parm, pstat);
3364           tmp = gfc_build_function_call (gfor_fndecl_deallocate, parm);
3365         }
3366
3367       gfc_add_expr_to_block (&se.pre, tmp);
3368
3369       /* Keep track of the number of failed deallocations by adding stat
3370          of the last deallocation to the running total.  */
3371       if (code->expr)
3372         {
3373           apstat = build2 (PLUS_EXPR, TREE_TYPE (stat), astat, stat);
3374           gfc_add_modify_expr (&se.pre, astat, apstat);
3375         }
3376
3377       tmp = gfc_finish_block (&se.pre);
3378       gfc_add_expr_to_block (&block, tmp);
3379
3380     }
3381
3382   /* Assign the value to the status variable.  */
3383   if (code->expr)
3384     {
3385       gfc_init_se (&se, NULL);
3386       gfc_conv_expr_lhs (&se, code->expr);
3387       tmp = convert (TREE_TYPE (se.expr), astat);
3388       gfc_add_modify_expr (&block, se.expr, tmp);
3389     }
3390
3391   return gfc_finish_block (&block);
3392 }
3393