gcc/fortran/trans-stmt.c

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