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