gcc/fortran/trans-stmt.c

   1 /* Statement translation -- generate GCC trees from gfc_code.
   2    Copyright (C) 2002, 2003, 2004 Free Software Foundation, Inc.
   3    Contributed by Paul Brook <paul@nowt.org>
   4    and Steven Bosscher <s.bosscher@student.tudelft.nl>
   5
   6 This file is part of GCC.
   7
   8 GCC is free software; you can redistribute it and/or modify it under
   9 the terms of the GNU General Public License as published by the Free
  10 Software Foundation; either version 2, or (at your option) any later
  11 version.
  12
  13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
  14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
  15 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  16 for more details.
  17
  18 You should have received a copy of the GNU General Public License
  19 along with GCC; see the file COPYING.  If not, write to the Free
  20 Software Foundation, 59 Temple Place - Suite 330, Boston, MA
  21 02111-1307, USA.  */
  22
  23
  24 #include "config.h"
  25 #include "system.h"
  26 #include "coretypes.h"
  27 #include "tree.h"
  28 #include "tree-gimple.h"
  29 #include <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   gfc_saved_var *saved_vars;
2125   iter_info *this_forall, *iter_tmp;
2126   forall_info *info, *forall_tmp;
2127   temporary_list *temp;
2128
2129   gfc_start_block (&block);
2130
2131   n = 0;
2132   /* Count the FORALL index number.  */
2133   for (fa = code->ext.forall_iterator; fa; fa = fa->next)
2134     n++;
2135   nvar = n;
2136
2137   /* Allocate the space for var, start, end, step, varexpr.  */
2138   var = (tree *) gfc_getmem (nvar * sizeof (tree));
2139   start = (tree *) gfc_getmem (nvar * sizeof (tree));
2140   end = (tree *) gfc_getmem (nvar * sizeof (tree));
2141   step = (tree *) gfc_getmem (nvar * sizeof (tree));
2142   varexpr = (gfc_expr **) gfc_getmem (nvar * sizeof (gfc_expr *));
2143   saved_vars = (gfc_saved_var *) gfc_getmem (nvar * sizeof (gfc_saved_var));
2144
2145   /* Allocate the space for info.  */
2146   info = (forall_info *) gfc_getmem (sizeof (forall_info));
2147   n = 0;
2148   for (fa = code->ext.forall_iterator; fa; fa = fa->next)
2149     {
2150       gfc_symbol *sym = fa->var->symtree->n.sym;
2151
2152       /* allocate space for this_forall.  */
2153       this_forall = (iter_info *) gfc_getmem (sizeof (iter_info));
2154
2155       /* Create a temporary variable for the FORALL index.  */
2156       tmp = gfc_typenode_for_spec (&sym->ts);
2157       var[n] = gfc_create_var (tmp, sym->name);
2158       gfc_shadow_sym (sym, var[n], &saved_vars[n]);
2159
2160       /* Record it in this_forall.  */
2161       this_forall->var = var[n];
2162
2163       /* Replace the index symbol's backend_decl with the temporary decl.  */
2164       sym->backend_decl = var[n];
2165
2166       /* Work out the start, end and stride for the loop.  */
2167       gfc_init_se (&se, NULL);
2168       gfc_conv_expr_val (&se, fa->start);
2169       /* Record it in this_forall.  */
2170       this_forall->start = se.expr;
2171       gfc_add_block_to_block (&block, &se.pre);
2172       start[n] = se.expr;
2173
2174       gfc_init_se (&se, NULL);
2175       gfc_conv_expr_val (&se, fa->end);
2176       /* Record it in this_forall.  */
2177       this_forall->end = se.expr;
2178       gfc_make_safe_expr (&se);
2179       gfc_add_block_to_block (&block, &se.pre);
2180       end[n] = se.expr;
2181
2182       gfc_init_se (&se, NULL);
2183       gfc_conv_expr_val (&se, fa->stride);
2184       /* Record it in this_forall.  */
2185       this_forall->step = se.expr;
2186       gfc_make_safe_expr (&se);
2187       gfc_add_block_to_block (&block, &se.pre);
2188       step[n] = se.expr;
2189
2190       /* Set the NEXT field of this_forall to NULL.  */
2191       this_forall->next = NULL;
2192       /* Link this_forall to the info construct.  */
2193       if (info->this_loop == NULL)
2194         info->this_loop = this_forall;
2195       else
2196         {
2197           iter_tmp = info->this_loop;
2198           while (iter_tmp->next != NULL)
2199             iter_tmp = iter_tmp->next;
2200           iter_tmp->next = this_forall;
2201         }
2202
2203       n++;
2204     }
2205   nvar = n;
2206
2207   /* Work out the number of elements in the mask array.  */
2208   tmpvar = NULL_TREE;
2209   lenvar = NULL_TREE;
2210   size = integer_one_node;
2211   sizevar = NULL_TREE;
2212
2213   for (n = 0; n < nvar; n++)
2214     {
2215       if (lenvar && TREE_TYPE (lenvar) != TREE_TYPE (start[n]))
2216         lenvar = NULL_TREE;
2217
2218       /* size = (end + step - start) / step.  */
2219       tmp = fold (build (MINUS_EXPR, TREE_TYPE (start[n]), step[n], start[n]));
2220       tmp = fold (build (PLUS_EXPR, TREE_TYPE (end[n]), end[n], tmp));
2221
2222       tmp = fold (build (FLOOR_DIV_EXPR, TREE_TYPE (tmp), tmp, step[n]));
2223       tmp = convert (gfc_array_index_type, tmp);
2224
2225       size = fold (build (MULT_EXPR, gfc_array_index_type, size, tmp));
2226     }
2227
2228   /* Record the nvar and size of current forall level.  */
2229   info->nvar = nvar;
2230   info->size = size;
2231
2232   /* Link the current forall level to nested_forall_info.  */
2233   forall_tmp = nested_forall_info;
2234   if (forall_tmp == NULL)
2235     nested_forall_info = info;
2236   else
2237     {
2238       while (forall_tmp->next_nest != NULL)
2239         forall_tmp = forall_tmp->next_nest;
2240       info->outer = forall_tmp;
2241       forall_tmp->next_nest = info;
2242     }
2243
2244   /* Copy the mask into a temporary variable if required.
2245      For now we assume a mask temporary is needed. */
2246   if (code->expr)
2247     {
2248       /* Allocate the mask temporary.  */
2249       bytesize = fold (build (MULT_EXPR, gfc_array_index_type, size,
2250                               TYPE_SIZE_UNIT (boolean_type_node)));
2251
2252       mask = gfc_do_allocate (bytesize, size, &pmask, &block, boolean_type_node);
2253
2254       maskindex = gfc_create_var_np (gfc_array_index_type, "mi");
2255       /* Record them in the info structure.  */
2256       info->pmask = pmask;
2257       info->mask = mask;
2258       info->maskindex = maskindex;
2259
2260       gfc_add_modify_expr (&block, maskindex, integer_zero_node);
2261
2262       /* Start of mask assignment loop body.  */
2263       gfc_start_block (&body);
2264
2265       /* Evaluate the mask expression.  */
2266       gfc_init_se (&se, NULL);
2267       gfc_conv_expr_val (&se, code->expr);
2268       gfc_add_block_to_block (&body, &se.pre);
2269
2270       /* Store the mask.  */
2271       se.expr = convert (boolean_type_node, se.expr);
2272
2273       if (pmask)
2274         tmp = gfc_build_indirect_ref (mask);
2275       else
2276         tmp = mask;
2277       tmp = gfc_build_array_ref (tmp, maskindex);
2278       gfc_add_modify_expr (&body, tmp, se.expr);
2279
2280       /* Advance to the next mask element.  */
2281       tmp = build (PLUS_EXPR, gfc_array_index_type, maskindex,
2282                    integer_one_node);
2283       gfc_add_modify_expr (&body, maskindex, tmp);
2284
2285       /* Generate the loops.  */
2286       tmp = gfc_finish_block (&body);
2287       tmp = gfc_trans_nested_forall_loop (info, tmp, 0, 0);
2288       gfc_add_expr_to_block (&block, tmp);
2289     }
2290   else
2291     {
2292       /* No mask was specified.  */
2293       maskindex = NULL_TREE;
2294       mask = pmask = NULL_TREE;
2295     }
2296
2297   c = code->block->next;
2298
2299   /* TODO: loop merging in FORALL statements.  */
2300   /* Now that we've got a copy of the mask, generate the assignment loops.  */
2301   while (c)
2302     {
2303       switch (c->op)
2304         {
2305         case EXEC_ASSIGN:
2306           /* A scalar or array assingment.  */
2307           need_temp = gfc_check_dependency (c->expr, c->expr2, varexpr, nvar);
2308           /* Teporaries due to array assignment data dependencies introduce
2309              no end of problems.  */
2310           if (need_temp)
2311             gfc_trans_assign_need_temp (c->expr, c->expr2, NULL,
2312                                         nested_forall_info, &block);
2313           else
2314             {
2315               /* Use the normal assignment copying routines.  */
2316               assign = gfc_trans_assignment (c->expr, c->expr2);
2317
2318               /* Reset the mask index.  */
2319               if (mask)
2320                 gfc_add_modify_expr (&block, maskindex, integer_zero_node);
2321
2322               /* Generate body and loops.  */
2323               tmp = gfc_trans_nested_forall_loop (nested_forall_info, assign, 1, 1);
2324               gfc_add_expr_to_block (&block, tmp);
2325             }
2326
2327           break;
2328
2329         case EXEC_WHERE:
2330
2331           /* Translate WHERE or WHERE construct nested in FORALL.  */
2332           temp = NULL;
2333           gfc_trans_where_2 (c, NULL, NULL, nested_forall_info, &block, &temp);
2334
2335           while (temp)
2336             {
2337               tree args;
2338               temporary_list *p;
2339
2340               /* Free the temporary.  */
2341               args = gfc_chainon_list (NULL_TREE, temp->temporary);
2342               tmp = gfc_build_function_call (gfor_fndecl_internal_free, args);
2343               gfc_add_expr_to_block (&block, tmp);
2344
2345               p = temp;
2346               temp = temp->next;
2347               gfc_free (p);
2348             }
2349
2350           break;
2351
2352         /* Pointer assignment inside FORALL.  */
2353         case EXEC_POINTER_ASSIGN:
2354           need_temp = gfc_check_dependency (c->expr, c->expr2, varexpr, nvar);
2355           if (need_temp)
2356             gfc_trans_pointer_assign_need_temp (c->expr, c->expr2,
2357                                                 nested_forall_info, &block);
2358           else
2359             {
2360               /* Use the normal assignment copying routines.  */
2361               assign = gfc_trans_pointer_assignment (c->expr, c->expr2);
2362
2363               /* Reset the mask index.  */
2364               if (mask)
2365                 gfc_add_modify_expr (&block, maskindex, integer_zero_node);
2366
2367               /* Generate body and loops.  */
2368               tmp = gfc_trans_nested_forall_loop (nested_forall_info, assign,
2369                                                   1, 1);
2370               gfc_add_expr_to_block (&block, tmp);
2371             }
2372           break;
2373
2374         case EXEC_FORALL:
2375           tmp = gfc_trans_forall_1 (c, nested_forall_info);
2376           gfc_add_expr_to_block (&block, tmp);
2377           break;
2378
2379         default:
2380           abort ();
2381           break;
2382         }
2383
2384       c = c->next;
2385     }
2386
2387   /* Restore the original index variables.  */
2388   for (fa = code->ext.forall_iterator, n = 0; fa; fa = fa->next, n++)
2389     gfc_restore_sym (fa->var->symtree->n.sym, &saved_vars[n]);
2390
2391   /* Free the space for var, start, end, step, varexpr.  */
2392   gfc_free (var);
2393   gfc_free (start);
2394   gfc_free (end);
2395   gfc_free (step);
2396   gfc_free (varexpr);
2397   gfc_free (saved_vars);
2398
2399   if (pmask)
2400     {
2401       /* Free the temporary for the mask.  */
2402       tmp = gfc_chainon_list (NULL_TREE, pmask);
2403       tmp = gfc_build_function_call (gfor_fndecl_internal_free, tmp);
2404       gfc_add_expr_to_block (&block, tmp);
2405     }
2406   if (maskindex)
2407     pushdecl (maskindex);
2408
2409   return gfc_finish_block (&block);
2410 }
2411
2412
2413 /* Translate the FORALL statement or construct.  */
2414
2415 tree gfc_trans_forall (gfc_code * code)
2416 {
2417   return gfc_trans_forall_1 (code, NULL);
2418 }
2419
2420
2421 /* Evaluate the WHERE mask expression, copy its value to a temporary.
2422    If the WHERE construct is nested in FORALL, compute the overall temporary
2423    needed by the WHERE mask expression multiplied by the iterator number of
2424    the nested forall.
2425    ME is the WHERE mask expression.
2426    MASK is the temporary which value is mask's value.
2427    NMASK is another temporary which value is !mask.
2428    TEMP records the temporary's address allocated in this function in order to
2429    free them outside this function.
2430    MASK, NMASK and TEMP are all OUT arguments.  */
2431
2432 static tree
2433 gfc_evaluate_where_mask (gfc_expr * me, forall_info * nested_forall_info,
2434                          tree * mask, tree * nmask, temporary_list ** temp,
2435                          stmtblock_t * block)
2436 {
2437   tree tmp, tmp1;
2438   gfc_ss *lss, *rss;
2439   gfc_loopinfo loop;
2440   tree ptemp1, ntmp, ptemp2;
2441   tree inner_size;
2442   stmtblock_t body, body1;
2443   gfc_se lse, rse;
2444   tree count;
2445   tree tmpexpr;
2446
2447   gfc_init_loopinfo (&loop);
2448
2449   /* Calculate the size of temporary needed by the mask-expr.  */
2450   inner_size = compute_inner_temp_size (me, me, block, &lss, &rss);
2451
2452   /* Allocate temporary for where mask.  */
2453   tmp = allocate_temp_for_forall_nest (nested_forall_info, boolean_type_node,
2454                                        inner_size, block, &ptemp1);
2455   /* Record the temporary address in order to free it later.  */
2456   if (ptemp1)
2457     {
2458       temporary_list *tempo;
2459       tempo = (temporary_list *) gfc_getmem (sizeof (temporary_list));
2460       tempo->temporary = ptemp1;
2461       tempo->next = *temp;
2462       *temp = tempo;
2463     }
2464
2465   /* Allocate temporary for !mask.  */
2466   ntmp = allocate_temp_for_forall_nest (nested_forall_info, boolean_type_node,
2467                                         inner_size, block, &ptemp2);
2468   /* Record the temporary  in order to free it later.  */
2469   if (ptemp2)
2470     {
2471       temporary_list *tempo;
2472       tempo = (temporary_list *) gfc_getmem (sizeof (temporary_list));
2473       tempo->temporary = ptemp2;
2474       tempo->next = *temp;
2475       *temp = tempo;
2476     }
2477
2478   /* Variable to index the temporary.  */
2479   count = gfc_create_var (gfc_array_index_type, "count");
2480   /* Initilize count.  */
2481   gfc_add_modify_expr (block, count, integer_zero_node);
2482
2483   gfc_start_block (&body);
2484
2485   gfc_init_se (&rse, NULL);
2486   gfc_init_se (&lse, NULL);
2487
2488   if (lss == gfc_ss_terminator)
2489     {
2490       gfc_init_block (&body1);
2491     }
2492   else
2493     {
2494       /* Initiliaze the loop.  */
2495       gfc_init_loopinfo (&loop);
2496
2497       /* We may need LSS to determine the shape of the expression.  */
2498       gfc_add_ss_to_loop (&loop, lss);
2499       gfc_add_ss_to_loop (&loop, rss);
2500
2501       gfc_conv_ss_startstride (&loop);
2502       gfc_conv_loop_setup (&loop);
2503
2504       gfc_mark_ss_chain_used (rss, 1);
2505       /* Start the loop body.  */
2506       gfc_start_scalarized_body (&loop, &body1);
2507
2508       /* Translate the expression.  */
2509       gfc_copy_loopinfo_to_se (&rse, &loop);
2510       rse.ss = rss;
2511       gfc_conv_expr (&rse, me);
2512     }
2513   /* Form the expression of the temporary.  */
2514   lse.expr = gfc_build_array_ref (tmp, count);
2515   tmpexpr = gfc_build_array_ref (ntmp, count);
2516
2517   /* Use the scalar assignment to fill temporary TMP.  */
2518   tmp1 = gfc_trans_scalar_assign (&lse, &rse, me->ts.type);
2519   gfc_add_expr_to_block (&body1, tmp1);
2520
2521   /* Fill temporary NTMP.  */
2522   tmp1 = build1 (TRUTH_NOT_EXPR, TREE_TYPE (lse.expr), lse.expr);
2523   gfc_add_modify_expr (&body1, tmpexpr, tmp1);
2524
2525  if (lss == gfc_ss_terminator)
2526     {
2527       gfc_add_block_to_block (&body, &body1);
2528     }
2529   else
2530     {
2531       /* Increment count.  */
2532       tmp1 = fold (build (PLUS_EXPR, gfc_array_index_type, count,
2533                           integer_one_node));
2534       gfc_add_modify_expr (&body1, count, tmp1);
2535
2536       /* Generate the copying loops.  */
2537       gfc_trans_scalarizing_loops (&loop, &body1);
2538
2539       gfc_add_block_to_block (&body, &loop.pre);
2540       gfc_add_block_to_block (&body, &loop.post);
2541
2542       gfc_cleanup_loop (&loop);
2543       /* TODO: Reuse lss and rss when copying temp->lhs.  Need to be careful
2544          as tree nodes in SS may not be valid in different scope.  */
2545     }
2546
2547   tmp1 = gfc_finish_block (&body);
2548   /* If the WHERE construct is inside FORALL, fill the full temporary.  */
2549   if (nested_forall_info != NULL)
2550     tmp1 = gfc_trans_nested_forall_loop (nested_forall_info, tmp1, 1, 1);
2551
2552
2553   gfc_add_expr_to_block (block, tmp1);
2554
2555   *mask = tmp;
2556   *nmask = ntmp;
2557
2558   return tmp1;
2559 }
2560
2561
2562 /* Translate an assignment statement in a WHERE statement or construct
2563    statement. The MASK expression is used to control which elements
2564    of EXPR1 shall be assigned.  */
2565
2566 static tree
2567 gfc_trans_where_assign (gfc_expr *expr1, gfc_expr *expr2, tree mask,
2568                         tree count1, tree count2)
2569 {
2570   gfc_se lse;
2571   gfc_se rse;
2572   gfc_ss *lss;
2573   gfc_ss *lss_section;
2574   gfc_ss *rss;
2575
2576   gfc_loopinfo loop;
2577   tree tmp;
2578   stmtblock_t block;
2579   stmtblock_t body;
2580   tree index, maskexpr, tmp1;
2581
2582 #if 0
2583   /* TODO: handle this special case.
2584      Special case a single function returning an array.  */
2585   if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
2586     {
2587       tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
2588       if (tmp)
2589         return tmp;
2590     }
2591 #endif
2592
2593  /* Assignment of the form lhs = rhs.  */
2594   gfc_start_block (&block);
2595
2596   gfc_init_se (&lse, NULL);
2597   gfc_init_se (&rse, NULL);
2598
2599   /* Walk the lhs.  */
2600   lss = gfc_walk_expr (expr1);
2601   rss = NULL;
2602
2603   /* In each where-assign-stmt, the mask-expr and the variable being
2604      defined shall be arrays of the same shape.  */
2605   assert (lss != gfc_ss_terminator);
2606
2607   /* The assignment needs scalarization.  */
2608   lss_section = lss;
2609
2610   /* Find a non-scalar SS from the lhs.  */
2611   while (lss_section != gfc_ss_terminator
2612          && lss_section->type != GFC_SS_SECTION)
2613     lss_section = lss_section->next;
2614
2615   assert (lss_section != gfc_ss_terminator);
2616
2617   /* Initialize the scalarizer.  */
2618   gfc_init_loopinfo (&loop);
2619
2620   /* Walk the rhs.  */
2621   rss = gfc_walk_expr (expr2);
2622   if (rss == gfc_ss_terminator)
2623    {
2624      /* The rhs is scalar.  Add a ss for the expression.  */
2625      rss = gfc_get_ss ();
2626      rss->next = gfc_ss_terminator;
2627      rss->type = GFC_SS_SCALAR;
2628      rss->expr = expr2;
2629     }
2630
2631   /* Associate the SS with the loop.  */
2632   gfc_add_ss_to_loop (&loop, lss);
2633   gfc_add_ss_to_loop (&loop, rss);
2634
2635   /* Calculate the bounds of the scalarization.  */
2636   gfc_conv_ss_startstride (&loop);
2637
2638   /* Resolve any data dependencies in the statement.  */
2639   gfc_conv_resolve_dependencies (&loop, lss_section, rss);
2640
2641   /* Setup the scalarizing loops.  */
2642   gfc_conv_loop_setup (&loop);
2643
2644   /* Setup the gfc_se structures.  */
2645   gfc_copy_loopinfo_to_se (&lse, &loop);
2646   gfc_copy_loopinfo_to_se (&rse, &loop);
2647
2648   rse.ss = rss;
2649   gfc_mark_ss_chain_used (rss, 1);
2650   if (loop.temp_ss == NULL)
2651     {
2652       lse.ss = lss;
2653       gfc_mark_ss_chain_used (lss, 1);
2654     }
2655   else
2656     {
2657       lse.ss = loop.temp_ss;
2658       gfc_mark_ss_chain_used (lss, 3);
2659       gfc_mark_ss_chain_used (loop.temp_ss, 3);
2660     }
2661
2662   /* Start the scalarized loop body.  */
2663   gfc_start_scalarized_body (&loop, &body);
2664
2665   /* Translate the expression.  */
2666   gfc_conv_expr (&rse, expr2);
2667   if (lss != gfc_ss_terminator && loop.temp_ss != NULL)
2668     {
2669       gfc_conv_tmp_array_ref (&lse);
2670       gfc_advance_se_ss_chain (&lse);
2671     }
2672   else
2673     gfc_conv_expr (&lse, expr1);
2674
2675   /* Form the mask expression according to the mask tree list.  */
2676   index = count1;
2677   tmp = mask;
2678   if (tmp != NULL)
2679     maskexpr = gfc_build_array_ref (tmp, index);
2680   else
2681     maskexpr = NULL;
2682
2683   tmp = TREE_CHAIN (tmp);
2684   while (tmp)
2685     {
2686       tmp1 = gfc_build_array_ref (tmp, index);
2687       maskexpr = build (TRUTH_AND_EXPR, TREE_TYPE (tmp1), maskexpr, tmp1);
2688       tmp = TREE_CHAIN (tmp);
2689     }
2690   /* Use the scalar assignment as is.  */
2691   tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
2692   tmp = build_v (COND_EXPR, maskexpr, tmp, build_empty_stmt ());
2693
2694   gfc_add_expr_to_block (&body, tmp);
2695
2696   if (lss == gfc_ss_terminator)
2697     {
2698       /* Increment count1.  */
2699       tmp = fold (build (PLUS_EXPR, TREE_TYPE (count1), count1,
2700                          integer_one_node));
2701       gfc_add_modify_expr (&body, count1, tmp);
2702
2703       /* Use the scalar assignment as is.  */
2704       gfc_add_block_to_block (&block, &body);
2705     }
2706   else
2707     {
2708       if (lse.ss != gfc_ss_terminator)
2709         abort ();
2710       if (rse.ss != gfc_ss_terminator)
2711         abort ();
2712
2713       if (loop.temp_ss != NULL)
2714         {
2715           /* Increment count1 before finish the main body of a scalarized
2716              expression.  */
2717           tmp = fold (build (PLUS_EXPR, TREE_TYPE (count1), count1,
2718                              integer_one_node));
2719           gfc_add_modify_expr (&body, count1, tmp);
2720           gfc_trans_scalarized_loop_boundary (&loop, &body);
2721
2722           /* We need to copy the temporary to the actual lhs.  */
2723           gfc_init_se (&lse, NULL);
2724           gfc_init_se (&rse, NULL);
2725           gfc_copy_loopinfo_to_se (&lse, &loop);
2726           gfc_copy_loopinfo_to_se (&rse, &loop);
2727
2728           rse.ss = loop.temp_ss;
2729           lse.ss = lss;
2730
2731           gfc_conv_tmp_array_ref (&rse);
2732           gfc_advance_se_ss_chain (&rse);
2733           gfc_conv_expr (&lse, expr1);
2734
2735           if (lse.ss != gfc_ss_terminator)
2736             abort ();
2737
2738           if (rse.ss != gfc_ss_terminator)
2739             abort ();
2740
2741           /* Form the mask expression according to the mask tree list.  */
2742           index = count2;
2743           tmp = mask;
2744           if (tmp != NULL)
2745             maskexpr = gfc_build_array_ref (tmp, index);
2746           else
2747             maskexpr = NULL;
2748
2749           tmp = TREE_CHAIN (tmp);
2750           while (tmp)
2751             {
2752               tmp1 = gfc_build_array_ref (tmp, index);
2753               maskexpr = build (TRUTH_AND_EXPR, TREE_TYPE (tmp1), maskexpr,
2754                                 tmp1);
2755               tmp = TREE_CHAIN (tmp);
2756             }
2757           /* Use the scalar assignment as is.  */
2758           tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
2759           tmp = build_v (COND_EXPR, maskexpr, tmp, build_empty_stmt ());
2760           gfc_add_expr_to_block (&body, tmp);
2761           /* Increment count2.  */
2762           tmp = fold (build (PLUS_EXPR, TREE_TYPE (count2), count2,
2763                              integer_one_node));
2764           gfc_add_modify_expr (&body, count2, tmp);
2765         }
2766       else
2767         {
2768           /* Increment count1.  */
2769           tmp = fold (build (PLUS_EXPR, TREE_TYPE (count1), count1,
2770                              integer_one_node));
2771           gfc_add_modify_expr (&body, count1, tmp);
2772         }
2773
2774       /* Generate the copying loops.  */
2775       gfc_trans_scalarizing_loops (&loop, &body);
2776
2777       /* Wrap the whole thing up.  */
2778       gfc_add_block_to_block (&block, &loop.pre);
2779       gfc_add_block_to_block (&block, &loop.post);
2780       gfc_cleanup_loop (&loop);
2781     }
2782
2783   return gfc_finish_block (&block);
2784 }
2785
2786
2787 /* Translate the WHERE construct or statement.
2788    This fuction can be called iteratelly to translate the nested WHERE
2789    construct or statement.
2790    MASK is the control mask, and PMASK is the pending control mask.
2791    TEMP records the temporary address which must be freed later.  */
2792
2793 static void
2794 gfc_trans_where_2 (gfc_code * code, tree mask, tree pmask,
2795                    forall_info * nested_forall_info, stmtblock_t * block,
2796                    temporary_list ** temp)
2797 {
2798   gfc_expr *expr1;
2799   gfc_expr *expr2;
2800   gfc_code *cblock;
2801   gfc_code *cnext;
2802   tree tmp, tmp1, tmp2;
2803   tree count1, count2;
2804   tree mask_copy;
2805   int need_temp;
2806
2807   /* the WHERE statement or the WHERE construct statement.  */
2808   cblock = code->block;
2809   while (cblock)
2810     {
2811       /* Has mask-expr.  */
2812       if (cblock->expr)
2813         {
2814           /* Ensure that the WHERE mask be evaluated only once.  */
2815           tmp2 = gfc_evaluate_where_mask (cblock->expr, nested_forall_info,
2816                                           &tmp, &tmp1, temp, block);
2817
2818           /* Set the control mask and the pending control mask.  */
2819           /* It's a where-stmt.  */
2820           if (mask == NULL)
2821             {
2822               mask = tmp;
2823               pmask = tmp1;
2824             }
2825           /* It's a nested where-stmt.  */
2826           else if (mask && pmask == NULL)
2827             {
2828               tree tmp2;
2829               /* Use the TREE_CHAIN to list the masks.  */
2830               tmp2 = copy_list (mask);
2831               pmask = chainon (mask, tmp1);
2832               mask = chainon (tmp2, tmp);
2833             }
2834           /* It's a masked-elsewhere-stmt.  */
2835           else if (mask && cblock->expr)
2836             {
2837               tree tmp2;
2838               tmp2 = copy_list (pmask);
2839
2840               mask = pmask;
2841               tmp2 = chainon (tmp2, tmp);
2842               pmask = chainon (mask, tmp1);
2843               mask = tmp2;
2844             }
2845         }
2846       /* It's a elsewhere-stmt. No mask-expr is present.  */
2847       else
2848         mask = pmask;
2849
2850       /* Get the assignment statement of a WHERE statement, or the first
2851          statement in where-body-construct of a WHERE construct.  */
2852       cnext = cblock->next;
2853       while (cnext)
2854         {
2855           switch (cnext->op)
2856             {
2857             /* WHERE assignment statement.  */
2858             case EXEC_ASSIGN:
2859               expr1 = cnext->expr;
2860               expr2 = cnext->expr2;
2861               if (nested_forall_info != NULL)
2862                 {
2863                   int nvar;
2864                   gfc_expr **varexpr;
2865
2866                   nvar = nested_forall_info->nvar;
2867                   varexpr = (gfc_expr **)
2868                             gfc_getmem (nvar * sizeof (gfc_expr *));
2869                   need_temp = gfc_check_dependency (expr1, expr2, varexpr,
2870                                                     nvar);
2871                   if (need_temp)
2872                     gfc_trans_assign_need_temp (expr1, expr2, mask,
2873                                                 nested_forall_info, block);
2874                   else
2875                     {
2876                       /* Variables to control maskexpr.  */
2877                       count1 = gfc_create_var (gfc_array_index_type, "count1");
2878                       count2 = gfc_create_var (gfc_array_index_type, "count2");
2879                       gfc_add_modify_expr (block, count1, integer_zero_node);
2880                       gfc_add_modify_expr (block, count2, integer_zero_node);
2881
2882                       tmp = gfc_trans_where_assign (expr1, expr2, mask, count1,
2883                                                     count2);
2884                       tmp = gfc_trans_nested_forall_loop (nested_forall_info,
2885                                                           tmp, 1, 1);
2886                       gfc_add_expr_to_block (block, tmp);
2887                     }
2888                 }
2889               else
2890                 {
2891                   /* Variables to control maskexpr.  */
2892                   count1 = gfc_create_var (gfc_array_index_type, "count1");
2893                   count2 = gfc_create_var (gfc_array_index_type, "count2");
2894                   gfc_add_modify_expr (block, count1, integer_zero_node);
2895                   gfc_add_modify_expr (block, count2, integer_zero_node);
2896
2897                   tmp = gfc_trans_where_assign (expr1, expr2, mask, count1,
2898                                                 count2);
2899                   gfc_add_expr_to_block (block, tmp);
2900
2901                 }
2902               break;
2903
2904             /* WHERE or WHERE construct is part of a where-body-construct.  */
2905             case EXEC_WHERE:
2906               /* Ensure that MASK is not modified by next gfc_trans_where_2.  */
2907               mask_copy = copy_list (mask);
2908               gfc_trans_where_2 (cnext, mask_copy, NULL, nested_forall_info,
2909                                  block, temp);
2910               break;
2911
2912             default:
2913               abort ();
2914             }
2915
2916          /* The next statement within the same where-body-construct.  */
2917          cnext = cnext->next;
2918        }
2919     /* The next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt.  */
2920     cblock = cblock->block;
2921   }
2922 }
2923
2924
2925 /* As the WHERE or WHERE construct statement can be nested, we call
2926    gfc_trans_where_2 to do the translation, and pass the initial
2927    NULL values for both the control mask and the pending control mask. */
2928
2929 tree
2930 gfc_trans_where (gfc_code * code)
2931 {
2932   stmtblock_t block;
2933   temporary_list *temp, *p;
2934   tree args;
2935   tree tmp;
2936
2937   gfc_start_block (&block);
2938   temp = NULL;
2939
2940   gfc_trans_where_2 (code, NULL, NULL, NULL, &block, &temp);
2941
2942   /* Add calls to free temporaries which were dynamically allocated.  */
2943   while (temp)
2944     {
2945       args = gfc_chainon_list (NULL_TREE, temp->temporary);
2946       tmp = gfc_build_function_call (gfor_fndecl_internal_free, args);
2947       gfc_add_expr_to_block (&block, tmp);
2948
2949       p = temp;
2950       temp = temp->next;
2951       gfc_free (p);
2952     }
2953   return gfc_finish_block (&block);
2954 }
2955
2956
2957 /* CYCLE a DO loop. The label decl has already been created by
2958    gfc_trans_do(), it's in TREE_PURPOSE (backend_decl) of the gfc_code
2959    node at the head of the loop. We must mark the label as used.  */
2960
2961 tree
2962 gfc_trans_cycle (gfc_code * code)
2963 {
2964   tree cycle_label;
2965
2966   cycle_label = TREE_PURPOSE (code->ext.whichloop->backend_decl);
2967   TREE_USED (cycle_label) = 1;
2968   return build1_v (GOTO_EXPR, cycle_label);
2969 }
2970
2971
2972 /* EXIT a DO loop. Similair to CYCLE, but now the label is in
2973    TREE_VALUE (backend_decl) of the gfc_code node at the head of the
2974    loop.  */
2975
2976 tree
2977 gfc_trans_exit (gfc_code * code)
2978 {
2979   tree exit_label;
2980
2981   exit_label = TREE_VALUE (code->ext.whichloop->backend_decl);
2982   TREE_USED (exit_label) = 1;
2983   return build1_v (GOTO_EXPR, exit_label);
2984 }
2985
2986
2987 /* Translate the ALLOCATE statement.  */
2988
2989 tree
2990 gfc_trans_allocate (gfc_code * code)
2991 {
2992   gfc_alloc *al;
2993   gfc_expr *expr;
2994   gfc_se se;
2995   tree tmp;
2996   tree parm;
2997   gfc_ref *ref;
2998   tree stat;
2999   tree pstat;
3000   tree error_label;
3001   stmtblock_t block;
3002
3003   if (!code->ext.alloc_list)
3004     return NULL_TREE;
3005
3006   gfc_start_block (&block);
3007
3008   if (code->expr)
3009     {
3010       stat = gfc_create_var (gfc_int4_type_node, "stat");
3011       pstat = gfc_build_addr_expr (NULL, stat);
3012
3013       error_label = gfc_build_label_decl (NULL_TREE);
3014       TREE_USED (error_label) = 1;
3015     }
3016   else
3017     {
3018       pstat = integer_zero_node;
3019       stat = error_label = NULL_TREE;
3020     }
3021
3022
3023   for (al = code->ext.alloc_list; al != NULL; al = al->next)
3024     {
3025       expr = al->expr;
3026
3027       gfc_init_se (&se, NULL);
3028       gfc_start_block (&se.pre);
3029
3030       se.want_pointer = 1;
3031       se.descriptor_only = 1;
3032       gfc_conv_expr (&se, expr);
3033
3034       ref = expr->ref;
3035
3036       /* Find the last reference in the chain.  */
3037       while (ref && ref->next != NULL)
3038         {
3039           assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT);
3040           ref = ref->next;
3041         }
3042
3043       if (ref != NULL && ref->type == REF_ARRAY)
3044         {
3045           /* An array.  */
3046           gfc_array_allocate (&se, ref, pstat);
3047         }
3048       else
3049         {
3050           /* A scalar or derived type.  */
3051           tree val;
3052
3053           val = gfc_create_var (ppvoid_type_node, "ptr");
3054           tmp = gfc_build_addr_expr (ppvoid_type_node, se.expr);
3055           gfc_add_modify_expr (&se.pre, val, tmp);
3056
3057           tmp = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (se.expr)));
3058           parm = gfc_chainon_list (NULL_TREE, val);
3059           parm = gfc_chainon_list (parm, tmp);
3060           parm = gfc_chainon_list (parm, pstat);
3061           tmp = gfc_build_function_call (gfor_fndecl_allocate, parm);
3062           gfc_add_expr_to_block (&se.pre, tmp);
3063
3064           if (code->expr)
3065             {
3066               tmp = build1_v (GOTO_EXPR, error_label);
3067               parm =
3068                 build (NE_EXPR, boolean_type_node, stat, integer_zero_node);
3069               tmp = build_v (COND_EXPR, parm, tmp, build_empty_stmt ());
3070               gfc_add_expr_to_block (&se.pre, tmp);
3071             }
3072         }
3073
3074       tmp = gfc_finish_block (&se.pre);
3075       gfc_add_expr_to_block (&block, tmp);
3076     }
3077
3078   /* Assign the value to the status variable.  */
3079   if (code->expr)
3080     {
3081       tmp = build1_v (LABEL_EXPR, error_label);
3082       gfc_add_expr_to_block (&block, tmp);
3083
3084       gfc_init_se (&se, NULL);
3085       gfc_conv_expr_lhs (&se, code->expr);
3086       tmp = convert (TREE_TYPE (se.expr), stat);
3087       gfc_add_modify_expr (&block, se.expr, tmp);
3088     }
3089
3090   return gfc_finish_block (&block);
3091 }
3092
3093
3094 tree
3095 gfc_trans_deallocate (gfc_code * code)
3096 {
3097   gfc_se se;
3098   gfc_alloc *al;
3099   gfc_expr *expr;
3100   tree var;
3101   tree tmp;
3102   tree type;
3103   stmtblock_t block;
3104
3105   gfc_start_block (&block);
3106
3107   for (al = code->ext.alloc_list; al != NULL; al = al->next)
3108     {
3109       expr = al->expr;
3110       assert (expr->expr_type == EXPR_VARIABLE);
3111
3112       gfc_init_se (&se, NULL);
3113       gfc_start_block (&se.pre);
3114
3115       se.want_pointer = 1;
3116       se.descriptor_only = 1;
3117       gfc_conv_expr (&se, expr);
3118
3119       if (expr->symtree->n.sym->attr.dimension)
3120         {
3121           tmp = gfc_array_deallocate (se.expr);
3122           gfc_add_expr_to_block (&se.pre, tmp);
3123         }
3124       else
3125         {
3126           type = build_pointer_type (TREE_TYPE (se.expr));
3127           var = gfc_create_var (type, "ptr");
3128           tmp = gfc_build_addr_expr (type, se.expr);
3129           gfc_add_modify_expr (&se.pre, var, tmp);
3130
3131           tmp = gfc_chainon_list (NULL_TREE, var);
3132           tmp = gfc_chainon_list (tmp, integer_zero_node);
3133           tmp = gfc_build_function_call (gfor_fndecl_deallocate, tmp);
3134           gfc_add_expr_to_block (&se.pre, tmp);
3135         }
3136       tmp = gfc_finish_block (&se.pre);
3137       gfc_add_expr_to_block (&block, tmp);
3138     }
3139
3140   return gfc_finish_block (&block);
3141 }
3142