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