gcc/fortran/trans.c

   1 /* Code translation -- generate GCC trees from gfc_code.
   2    Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
   3    Free Software Foundation, Inc.
   4    Contributed by Paul Brook
   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 3, 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 COPYING3.  If not see
  20 <http://www.gnu.org/licenses/>.  */
  21
  22 #include "config.h"
  23 #include "system.h"
  24 #include "coretypes.h"
  25 #include "tree.h"
  26 #include "gimple.h"     /* For create_tmp_var_raw.  */
  27 #include "tree-iterator.h"
  28 #include "diagnostic-core.h"  /* For internal_error.  */
  29 #include "defaults.h"
  30 #include "flags.h"
  31 #include "gfortran.h"
  32 #include "trans.h"
  33 #include "trans-stmt.h"
  34 #include "trans-array.h"
  35 #include "trans-types.h"
  36 #include "trans-const.h"
  37
  38 /* Naming convention for backend interface code:
  39
  40    gfc_trans_*  translate gfc_code into STMT trees.
  41
  42    gfc_conv_*   expression conversion
  43
  44    gfc_get_*    get a backend tree representation of a decl or type  */
  45
  46 static gfc_file *gfc_current_backend_file;
  47
  48 const char gfc_msg_fault[] = N_("Array reference out of bounds");
  49 const char gfc_msg_wrong_return[] = N_("Incorrect function return value");
  50
  51
  52 /* Advance along TREE_CHAIN n times.  */
  53
  54 tree
  55 gfc_advance_chain (tree t, int n)
  56 {
  57   for (; n > 0; n--)
  58     {
  59       gcc_assert (t != NULL_TREE);
  60       t = DECL_CHAIN (t);
  61     }
  62   return t;
  63 }
  64
  65
  66 /* Wrap a node in a TREE_LIST node and add it to the end of a list.  */
  67
  68 tree
  69 gfc_chainon_list (tree list, tree add)
  70 {
  71   tree l;
  72
  73   l = tree_cons (NULL_TREE, add, NULL_TREE);
  74
  75   return chainon (list, l);
  76 }
  77
  78
  79 /* Strip off a legitimate source ending from the input
  80    string NAME of length LEN.  */
  81
  82 static inline void
  83 remove_suffix (char *name, int len)
  84 {
  85   int i;
  86
  87   for (i = 2; i < 8 && len > i; i++)
  88     {
  89       if (name[len - i] == '.')
  90         {
  91           name[len - i] = '\0';
  92           break;
  93         }
  94     }
  95 }
  96
  97
  98 /* Creates a variable declaration with a given TYPE.  */
  99
 100 tree
 101 gfc_create_var_np (tree type, const char *prefix)
 102 {
 103   tree t;
 104
 105   t = create_tmp_var_raw (type, prefix);
 106
 107   /* No warnings for anonymous variables.  */
 108   if (prefix == NULL)
 109     TREE_NO_WARNING (t) = 1;
 110
 111   return t;
 112 }
 113
 114
 115 /* Like above, but also adds it to the current scope.  */
 116
 117 tree
 118 gfc_create_var (tree type, const char *prefix)
 119 {
 120   tree tmp;
 121
 122   tmp = gfc_create_var_np (type, prefix);
 123
 124   pushdecl (tmp);
 125
 126   return tmp;
 127 }
 128
 129
 130 /* If the expression is not constant, evaluate it now.  We assign the
 131    result of the expression to an artificially created variable VAR, and
 132    return a pointer to the VAR_DECL node for this variable.  */
 133
 134 tree
 135 gfc_evaluate_now_loc (location_t loc, tree expr, stmtblock_t * pblock)
 136 {
 137   tree var;
 138
 139   if (CONSTANT_CLASS_P (expr))
 140     return expr;
 141
 142   var = gfc_create_var (TREE_TYPE (expr), NULL);
 143   gfc_add_modify_loc (loc, pblock, var, expr);
 144
 145   return var;
 146 }
 147
 148
 149 tree
 150 gfc_evaluate_now (tree expr, stmtblock_t * pblock)
 151 {
 152   return gfc_evaluate_now_loc (input_location, expr, pblock);
 153 }
 154
 155
 156 /* Build a MODIFY_EXPR node and add it to a given statement block PBLOCK.
 157    A MODIFY_EXPR is an assignment:
 158    LHS <- RHS.  */
 159
 160 void
 161 gfc_add_modify_loc (location_t loc, stmtblock_t * pblock, tree lhs, tree rhs)
 162 {
 163   tree tmp;
 164
 165 #ifdef ENABLE_CHECKING
 166   tree t1, t2;
 167   t1 = TREE_TYPE (rhs);
 168   t2 = TREE_TYPE (lhs);
 169   /* Make sure that the types of the rhs and the lhs are the same
 170      for scalar assignments.  We should probably have something
 171      similar for aggregates, but right now removing that check just
 172      breaks everything.  */
 173   gcc_assert (t1 == t2
 174               || AGGREGATE_TYPE_P (TREE_TYPE (lhs)));
 175 #endif
 176
 177   tmp = fold_build2_loc (loc, MODIFY_EXPR, void_type_node, lhs,
 178                          rhs);
 179   gfc_add_expr_to_block (pblock, tmp);
 180 }
 181
 182
 183 void
 184 gfc_add_modify (stmtblock_t * pblock, tree lhs, tree rhs)
 185 {
 186   gfc_add_modify_loc (input_location, pblock, lhs, rhs);
 187 }
 188
 189
 190 /* Create a new scope/binding level and initialize a block.  Care must be
 191    taken when translating expressions as any temporaries will be placed in
 192    the innermost scope.  */
 193
 194 void
 195 gfc_start_block (stmtblock_t * block)
 196 {
 197   /* Start a new binding level.  */
 198   pushlevel (0);
 199   block->has_scope = 1;
 200
 201   /* The block is empty.  */
 202   block->head = NULL_TREE;
 203 }
 204
 205
 206 /* Initialize a block without creating a new scope.  */
 207
 208 void
 209 gfc_init_block (stmtblock_t * block)
 210 {
 211   block->head = NULL_TREE;
 212   block->has_scope = 0;
 213 }
 214
 215
 216 /* Sometimes we create a scope but it turns out that we don't actually
 217    need it.  This function merges the scope of BLOCK with its parent.
 218    Only variable decls will be merged, you still need to add the code.  */
 219
 220 void
 221 gfc_merge_block_scope (stmtblock_t * block)
 222 {
 223   tree decl;
 224   tree next;
 225
 226   gcc_assert (block->has_scope);
 227   block->has_scope = 0;
 228
 229   /* Remember the decls in this scope.  */
 230   decl = getdecls ();
 231   poplevel (0, 0, 0);
 232
 233   /* Add them to the parent scope.  */
 234   while (decl != NULL_TREE)
 235     {
 236       next = DECL_CHAIN (decl);
 237       DECL_CHAIN (decl) = NULL_TREE;
 238
 239       pushdecl (decl);
 240       decl = next;
 241     }
 242 }
 243
 244
 245 /* Finish a scope containing a block of statements.  */
 246
 247 tree
 248 gfc_finish_block (stmtblock_t * stmtblock)
 249 {
 250   tree decl;
 251   tree expr;
 252   tree block;
 253
 254   expr = stmtblock->head;
 255   if (!expr)
 256     expr = build_empty_stmt (input_location);
 257
 258   stmtblock->head = NULL_TREE;
 259
 260   if (stmtblock->has_scope)
 261     {
 262       decl = getdecls ();
 263
 264       if (decl)
 265         {
 266           block = poplevel (1, 0, 0);
 267           expr = build3_v (BIND_EXPR, decl, expr, block);
 268         }
 269       else
 270         poplevel (0, 0, 0);
 271     }
 272
 273   return expr;
 274 }
 275
 276
 277 /* Build an ADDR_EXPR and cast the result to TYPE.  If TYPE is NULL, the
 278    natural type is used.  */
 279
 280 tree
 281 gfc_build_addr_expr (tree type, tree t)
 282 {
 283   tree base_type = TREE_TYPE (t);
 284   tree natural_type;
 285
 286   if (type && POINTER_TYPE_P (type)
 287       && TREE_CODE (base_type) == ARRAY_TYPE
 288       && TYPE_MAIN_VARIANT (TREE_TYPE (type))
 289          == TYPE_MAIN_VARIANT (TREE_TYPE (base_type)))
 290     {
 291       tree min_val = size_zero_node;
 292       tree type_domain = TYPE_DOMAIN (base_type);
 293       if (type_domain && TYPE_MIN_VALUE (type_domain))
 294         min_val = TYPE_MIN_VALUE (type_domain);
 295       t = fold (build4_loc (input_location, ARRAY_REF, TREE_TYPE (type),
 296                             t, min_val, NULL_TREE, NULL_TREE));
 297       natural_type = type;
 298     }
 299   else
 300     natural_type = build_pointer_type (base_type);
 301
 302   if (TREE_CODE (t) == INDIRECT_REF)
 303     {
 304       if (!type)
 305         type = natural_type;
 306       t = TREE_OPERAND (t, 0);
 307       natural_type = TREE_TYPE (t);
 308     }
 309   else
 310     {
 311       tree base = get_base_address (t);
 312       if (base && DECL_P (base))
 313         TREE_ADDRESSABLE (base) = 1;
 314       t = fold_build1_loc (input_location, ADDR_EXPR, natural_type, t);
 315     }
 316
 317   if (type && natural_type != type)
 318     t = convert (type, t);
 319
 320   return t;
 321 }
 322
 323
 324 /* Build an ARRAY_REF with its natural type.  */
 325
 326 tree
 327 gfc_build_array_ref (tree base, tree offset, tree decl)
 328 {
 329   tree type = TREE_TYPE (base);
 330   tree tmp;
 331
 332   gcc_assert (TREE_CODE (type) == ARRAY_TYPE);
 333   type = TREE_TYPE (type);
 334
 335   if (DECL_P (base))
 336     TREE_ADDRESSABLE (base) = 1;
 337
 338   /* Strip NON_LVALUE_EXPR nodes.  */
 339   STRIP_TYPE_NOPS (offset);
 340
 341   /* If the array reference is to a pointer, whose target contains a
 342      subreference, use the span that is stored with the backend decl
 343      and reference the element with pointer arithmetic.  */
 344   if (decl && (TREE_CODE (decl) == FIELD_DECL
 345                  || TREE_CODE (decl) == VAR_DECL
 346                  || TREE_CODE (decl) == PARM_DECL)
 347         && GFC_DECL_SUBREF_ARRAY_P (decl)
 348         && !integer_zerop (GFC_DECL_SPAN(decl)))
 349     {
 350       offset = fold_build2_loc (input_location, MULT_EXPR,
 351                                 gfc_array_index_type,
 352                                 offset, GFC_DECL_SPAN(decl));
 353       tmp = gfc_build_addr_expr (pvoid_type_node, base);
 354       tmp = fold_build2_loc (input_location, POINTER_PLUS_EXPR,
 355                              pvoid_type_node, tmp,
 356                              fold_convert (sizetype, offset));
 357       tmp = fold_convert (build_pointer_type (type), tmp);
 358       if (!TYPE_STRING_FLAG (type))
 359         tmp = build_fold_indirect_ref_loc (input_location, tmp);
 360       return tmp;
 361     }
 362   else
 363     /* Otherwise use a straightforward array reference.  */
 364     return build4_loc (input_location, ARRAY_REF, type, base, offset,
 365                        NULL_TREE, NULL_TREE);
 366 }
 367
 368
 369 /* Generate a call to print a runtime error possibly including multiple
 370    arguments and a locus.  */
 371
 372 static tree
 373 trans_runtime_error_vararg (bool error, locus* where, const char* msgid,
 374                             va_list ap)
 375 {
 376   stmtblock_t block;
 377   tree tmp;
 378   tree arg, arg2;
 379   tree *argarray;
 380   tree fntype;
 381   char *message;
 382   const char *p;
 383   int line, nargs, i;
 384   location_t loc;
 385
 386   /* Compute the number of extra arguments from the format string.  */
 387   for (p = msgid, nargs = 0; *p; p++)
 388     if (*p == '%')
 389       {
 390         p++;
 391         if (*p != '%')
 392           nargs++;
 393       }
 394
 395   /* The code to generate the error.  */
 396   gfc_start_block (&block);
 397
 398   if (where)
 399     {
 400       line = LOCATION_LINE (where->lb->location);
 401       asprintf (&message, "At line %d of file %s",  line,
 402                 where->lb->file->filename);
 403     }
 404   else
 405     asprintf (&message, "In file '%s', around line %d",
 406               gfc_source_file, input_line + 1);
 407
 408   arg = gfc_build_addr_expr (pchar_type_node,
 409                              gfc_build_localized_cstring_const (message));
 410   gfc_free(message);
 411
 412   asprintf (&message, "%s", _(msgid));
 413   arg2 = gfc_build_addr_expr (pchar_type_node,
 414                               gfc_build_localized_cstring_const (message));
 415   gfc_free(message);
 416
 417   /* Build the argument array.  */
 418   argarray = XALLOCAVEC (tree, nargs + 2);
 419   argarray[0] = arg;
 420   argarray[1] = arg2;
 421   for (i = 0; i < nargs; i++)
 422     argarray[2 + i] = va_arg (ap, tree);
 423
 424   /* Build the function call to runtime_(warning,error)_at; because of the
 425      variable number of arguments, we can't use build_call_expr_loc dinput_location,
 426      irectly.  */
 427   if (error)
 428     fntype = TREE_TYPE (gfor_fndecl_runtime_error_at);
 429   else
 430     fntype = TREE_TYPE (gfor_fndecl_runtime_warning_at);
 431
 432   loc = where ? where->lb->location : input_location;
 433   tmp = fold_builtin_call_array (loc, TREE_TYPE (fntype),
 434                                  fold_build1_loc (loc, ADDR_EXPR,
 435                                              build_pointer_type (fntype),
 436                                              error
 437                                              ? gfor_fndecl_runtime_error_at
 438                                              : gfor_fndecl_runtime_warning_at),
 439                                  nargs + 2, argarray);
 440   gfc_add_expr_to_block (&block, tmp);
 441
 442   return gfc_finish_block (&block);
 443 }
 444
 445
 446 tree
 447 gfc_trans_runtime_error (bool error, locus* where, const char* msgid, ...)
 448 {
 449   va_list ap;
 450   tree result;
 451
 452   va_start (ap, msgid);
 453   result = trans_runtime_error_vararg (error, where, msgid, ap);
 454   va_end (ap);
 455   return result;
 456 }
 457
 458
 459 /* Generate a runtime error if COND is true.  */
 460
 461 void
 462 gfc_trans_runtime_check (bool error, bool once, tree cond, stmtblock_t * pblock,
 463                          locus * where, const char * msgid, ...)
 464 {
 465   va_list ap;
 466   stmtblock_t block;
 467   tree body;
 468   tree tmp;
 469   tree tmpvar = NULL;
 470
 471   if (integer_zerop (cond))
 472     return;
 473
 474   if (once)
 475     {
 476        tmpvar = gfc_create_var (boolean_type_node, "print_warning");
 477        TREE_STATIC (tmpvar) = 1;
 478        DECL_INITIAL (tmpvar) = boolean_true_node;
 479        gfc_add_expr_to_block (pblock, tmpvar);
 480     }
 481
 482   gfc_start_block (&block);
 483
 484   /* The code to generate the error.  */
 485   va_start (ap, msgid);
 486   gfc_add_expr_to_block (&block,
 487                          trans_runtime_error_vararg (error, where,
 488                                                      msgid, ap));
 489
 490   if (once)
 491     gfc_add_modify (&block, tmpvar, boolean_false_node);
 492
 493   body = gfc_finish_block (&block);
 494
 495   if (integer_onep (cond))
 496     {
 497       gfc_add_expr_to_block (pblock, body);
 498     }
 499   else
 500     {
 501       /* Tell the compiler that this isn't likely.  */
 502       if (once)
 503         cond = fold_build2_loc (where->lb->location, TRUTH_AND_EXPR,
 504                                 long_integer_type_node, tmpvar, cond);
 505       else
 506         cond = fold_convert (long_integer_type_node, cond);
 507
 508       tmp = build_int_cst (long_integer_type_node, 0);
 509       cond = build_call_expr_loc (where->lb->location,
 510                               built_in_decls[BUILT_IN_EXPECT], 2, cond, tmp);
 511       cond = fold_convert (boolean_type_node, cond);
 512
 513       tmp = fold_build3_loc (where->lb->location, COND_EXPR, void_type_node,
 514                              cond, body,
 515                              build_empty_stmt (where->lb->location));
 516       gfc_add_expr_to_block (pblock, tmp);
 517     }
 518 }
 519
 520
 521 /* Call malloc to allocate size bytes of memory, with special conditions:
 522       + if size <= 0, return a malloced area of size 1,
 523       + if malloc returns NULL, issue a runtime error.  */
 524 tree
 525 gfc_call_malloc (stmtblock_t * block, tree type, tree size)
 526 {
 527   tree tmp, msg, malloc_result, null_result, res;
 528   stmtblock_t block2;
 529
 530   size = gfc_evaluate_now (size, block);
 531
 532   if (TREE_TYPE (size) != TREE_TYPE (size_type_node))
 533     size = fold_convert (size_type_node, size);
 534
 535   /* Create a variable to hold the result.  */
 536   res = gfc_create_var (prvoid_type_node, NULL);
 537
 538   /* Call malloc.  */
 539   gfc_start_block (&block2);
 540
 541   size = fold_build2_loc (input_location, MAX_EXPR, size_type_node, size,
 542                           build_int_cst (size_type_node, 1));
 543
 544   gfc_add_modify (&block2, res,
 545                   fold_convert (prvoid_type_node,
 546                                 build_call_expr_loc (input_location,
 547                                    built_in_decls[BUILT_IN_MALLOC], 1, size)));
 548
 549   /* Optionally check whether malloc was successful.  */
 550   if (gfc_option.rtcheck & GFC_RTCHECK_MEM)
 551     {
 552       null_result = fold_build2_loc (input_location, EQ_EXPR,
 553                                      boolean_type_node, res,
 554                                      build_int_cst (pvoid_type_node, 0));
 555       msg = gfc_build_addr_expr (pchar_type_node,
 556               gfc_build_localized_cstring_const ("Memory allocation failed"));
 557       tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
 558                              null_result,
 559               build_call_expr_loc (input_location,
 560                                    gfor_fndecl_os_error, 1, msg),
 561                                    build_empty_stmt (input_location));
 562       gfc_add_expr_to_block (&block2, tmp);
 563     }
 564
 565   malloc_result = gfc_finish_block (&block2);
 566
 567   gfc_add_expr_to_block (block, malloc_result);
 568
 569   if (type != NULL)
 570     res = fold_convert (type, res);
 571   return res;
 572 }
 573
 574
 575 /* Allocate memory, using an optional status argument.
 576
 577    This function follows the following pseudo-code:
 578
 579     void *
 580     allocate (size_t size, integer_type* stat)
 581     {
 582       void *newmem;
 583
 584       if (stat)
 585         *stat = 0;
 586
 587       // The only time this can happen is the size wraps around.
 588       if (size < 0)
 589       {
 590         if (stat)
 591         {
 592           *stat = LIBERROR_ALLOCATION;
 593           newmem = NULL;
 594         }
 595         else
 596           runtime_error ("Attempt to allocate negative amount of memory. "
 597                          "Possible integer overflow");
 598       }
 599       else
 600       {
 601         newmem = malloc (MAX (size, 1));
 602         if (newmem == NULL)
 603         {
 604           if (stat)
 605             *stat = LIBERROR_ALLOCATION;
 606           else
 607             runtime_error ("Out of memory");
 608         }
 609       }
 610
 611       return newmem;
 612     }  */
 613 tree
 614 gfc_allocate_with_status (stmtblock_t * block, tree size, tree status)
 615 {
 616   stmtblock_t alloc_block;
 617   tree res, tmp, error, msg, cond;
 618   tree status_type = status ? TREE_TYPE (TREE_TYPE (status)) : NULL_TREE;
 619
 620   /* Evaluate size only once, and make sure it has the right type.  */
 621   size = gfc_evaluate_now (size, block);
 622   if (TREE_TYPE (size) != TREE_TYPE (size_type_node))
 623     size = fold_convert (size_type_node, size);
 624
 625   /* Create a variable to hold the result.  */
 626   res = gfc_create_var (prvoid_type_node, NULL);
 627
 628   /* Set the optional status variable to zero.  */
 629   if (status != NULL_TREE && !integer_zerop (status))
 630     {
 631       tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
 632                              fold_build1_loc (input_location, INDIRECT_REF,
 633                                               status_type, status),
 634                              build_int_cst (status_type, 0));
 635       tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
 636                              fold_build2_loc (input_location, NE_EXPR,
 637                                         boolean_type_node, status,
 638                                         build_int_cst (TREE_TYPE (status), 0)),
 639                              tmp, build_empty_stmt (input_location));
 640       gfc_add_expr_to_block (block, tmp);
 641     }
 642
 643   /* Generate the block of code handling (size < 0).  */
 644   msg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const
 645                         ("Attempt to allocate negative amount of memory. "
 646                          "Possible integer overflow"));
 647   error = build_call_expr_loc (input_location,
 648                            gfor_fndecl_runtime_error, 1, msg);
 649
 650   if (status != NULL_TREE && !integer_zerop (status))
 651     {
 652       /* Set the status variable if it's present.  */
 653       stmtblock_t set_status_block;
 654
 655       gfc_start_block (&set_status_block);
 656       gfc_add_modify (&set_status_block,
 657                       fold_build1_loc (input_location, INDIRECT_REF,
 658                                        status_type, status),
 659                            build_int_cst (status_type, LIBERROR_ALLOCATION));
 660       gfc_add_modify (&set_status_block, res,
 661                            build_int_cst (prvoid_type_node, 0));
 662
 663       tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
 664                              status, build_int_cst (TREE_TYPE (status), 0));
 665       error = fold_build3_loc (input_location, COND_EXPR, void_type_node, tmp,
 666                                error, gfc_finish_block (&set_status_block));
 667     }
 668
 669   /* The allocation itself.  */
 670   gfc_start_block (&alloc_block);
 671   gfc_add_modify (&alloc_block, res,
 672                   fold_convert (prvoid_type_node,
 673                                 build_call_expr_loc (input_location,
 674                                    built_in_decls[BUILT_IN_MALLOC], 1,
 675                                         fold_build2_loc (input_location,
 676                                             MAX_EXPR, size_type_node, size,
 677                                             build_int_cst (size_type_node,
 678                                                            1)))));
 679
 680   msg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const
 681                                                 ("Out of memory"));
 682   tmp = build_call_expr_loc (input_location,
 683                          gfor_fndecl_os_error, 1, msg);
 684
 685   if (status != NULL_TREE && !integer_zerop (status))
 686     {
 687       /* Set the status variable if it's present.  */
 688       tree tmp2;
 689
 690       cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
 691                               status, build_int_cst (TREE_TYPE (status), 0));
 692       tmp2 = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
 693                               fold_build1_loc (input_location, INDIRECT_REF,
 694                                                status_type, status),
 695                               build_int_cst (status_type, LIBERROR_ALLOCATION));
 696       tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
 697                              tmp, tmp2);
 698     }
 699
 700   tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
 701                          fold_build2_loc (input_location, EQ_EXPR,
 702                                           boolean_type_node, res,
 703                                           build_int_cst (prvoid_type_node, 0)),
 704                          tmp, build_empty_stmt (input_location));
 705   gfc_add_expr_to_block (&alloc_block, tmp);
 706
 707   cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, size,
 708                           build_int_cst (TREE_TYPE (size), 0));
 709   tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, error,
 710                          gfc_finish_block (&alloc_block));
 711   gfc_add_expr_to_block (block, tmp);
 712
 713   return res;
 714 }
 715
 716
 717 /* Generate code for an ALLOCATE statement when the argument is an
 718    allocatable array.  If the array is currently allocated, it is an
 719    error to allocate it again.
 720
 721    This function follows the following pseudo-code:
 722
 723     void *
 724     allocate_array (void *mem, size_t size, integer_type *stat)
 725     {
 726       if (mem == NULL)
 727         return allocate (size, stat);
 728       else
 729       {
 730         if (stat)
 731         {
 732           free (mem);
 733           mem = allocate (size, stat);
 734           *stat = LIBERROR_ALLOCATION;
 735           return mem;
 736         }
 737         else
 738           runtime_error ("Attempting to allocate already allocated variable");
 739       }
 740     }
 741
 742     expr must be set to the original expression being allocated for its locus
 743     and variable name in case a runtime error has to be printed.  */
 744 tree
 745 gfc_allocate_array_with_status (stmtblock_t * block, tree mem, tree size,
 746                                 tree status, gfc_expr* expr)
 747 {
 748   stmtblock_t alloc_block;
 749   tree res, tmp, null_mem, alloc, error;
 750   tree type = TREE_TYPE (mem);
 751
 752   if (TREE_TYPE (size) != TREE_TYPE (size_type_node))
 753     size = fold_convert (size_type_node, size);
 754
 755   /* Create a variable to hold the result.  */
 756   res = gfc_create_var (type, NULL);
 757   null_mem = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, mem,
 758                               build_int_cst (type, 0));
 759
 760   /* If mem is NULL, we call gfc_allocate_with_status.  */
 761   gfc_start_block (&alloc_block);
 762   tmp = gfc_allocate_with_status (&alloc_block, size, status);
 763   gfc_add_modify (&alloc_block, res, fold_convert (type, tmp));
 764   alloc = gfc_finish_block (&alloc_block);
 765
 766   /* Otherwise, we issue a runtime error or set the status variable.  */
 767   if (expr)
 768     {
 769       tree varname;
 770
 771       gcc_assert (expr->expr_type == EXPR_VARIABLE && expr->symtree);
 772       varname = gfc_build_cstring_const (expr->symtree->name);
 773       varname = gfc_build_addr_expr (pchar_type_node, varname);
 774
 775       error = gfc_trans_runtime_error (true, &expr->where,
 776                                        "Attempting to allocate already"
 777                                        " allocated variable '%s'",
 778                                        varname);
 779     }
 780   else
 781     error = gfc_trans_runtime_error (true, NULL,
 782                                      "Attempting to allocate already allocated"
 783                                      " variable");
 784
 785   if (status != NULL_TREE && !integer_zerop (status))
 786     {
 787       tree status_type = TREE_TYPE (TREE_TYPE (status));
 788       stmtblock_t set_status_block;
 789
 790       gfc_start_block (&set_status_block);
 791       tmp = build_call_expr_loc (input_location,
 792                              built_in_decls[BUILT_IN_FREE], 1,
 793                              fold_convert (pvoid_type_node, mem));
 794       gfc_add_expr_to_block (&set_status_block, tmp);
 795
 796       tmp = gfc_allocate_with_status (&set_status_block, size, status);
 797       gfc_add_modify (&set_status_block, res, fold_convert (type, tmp));
 798
 799       gfc_add_modify (&set_status_block,
 800                            fold_build1_loc (input_location, INDIRECT_REF,
 801                                             status_type, status),
 802                            build_int_cst (status_type, LIBERROR_ALLOCATION));
 803
 804       tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
 805                              status, build_int_cst (status_type, 0));
 806       error = fold_build3_loc (input_location, COND_EXPR, void_type_node, tmp,
 807                                error, gfc_finish_block (&set_status_block));
 808     }
 809
 810   tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, null_mem,
 811                          alloc, error);
 812   gfc_add_expr_to_block (block, tmp);
 813
 814   return res;
 815 }
 816
 817
 818 /* Free a given variable, if it's not NULL.  */
 819 tree
 820 gfc_call_free (tree var)
 821 {
 822   stmtblock_t block;
 823   tree tmp, cond, call;
 824
 825   if (TREE_TYPE (var) != TREE_TYPE (pvoid_type_node))
 826     var = fold_convert (pvoid_type_node, var);
 827
 828   gfc_start_block (&block);
 829   var = gfc_evaluate_now (var, &block);
 830   cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, var,
 831                           build_int_cst (pvoid_type_node, 0));
 832   call = build_call_expr_loc (input_location,
 833                               built_in_decls[BUILT_IN_FREE], 1, var);
 834   tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, call,
 835                          build_empty_stmt (input_location));
 836   gfc_add_expr_to_block (&block, tmp);
 837
 838   return gfc_finish_block (&block);
 839 }
 840
 841
 842
 843 /* User-deallocate; we emit the code directly from the front-end, and the
 844    logic is the same as the previous library function:
 845
 846     void
 847     deallocate (void *pointer, GFC_INTEGER_4 * stat)
 848     {
 849       if (!pointer)
 850         {
 851           if (stat)
 852             *stat = 1;
 853           else
 854             runtime_error ("Attempt to DEALLOCATE unallocated memory.");
 855         }
 856       else
 857         {
 858           free (pointer);
 859           if (stat)
 860             *stat = 0;
 861         }
 862     }
 863
 864    In this front-end version, status doesn't have to be GFC_INTEGER_4.
 865    Moreover, if CAN_FAIL is true, then we will not emit a runtime error,
 866    even when no status variable is passed to us (this is used for
 867    unconditional deallocation generated by the front-end at end of
 868    each procedure).
 869
 870    If a runtime-message is possible, `expr' must point to the original
 871    expression being deallocated for its locus and variable name.  */
 872 tree
 873 gfc_deallocate_with_status (tree pointer, tree status, bool can_fail,
 874                             gfc_expr* expr)
 875 {
 876   stmtblock_t null, non_null;
 877   tree cond, tmp, error;
 878
 879   cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, pointer,
 880                           build_int_cst (TREE_TYPE (pointer), 0));
 881
 882   /* When POINTER is NULL, we set STATUS to 1 if it's present, otherwise
 883      we emit a runtime error.  */
 884   gfc_start_block (&null);
 885   if (!can_fail)
 886     {
 887       tree varname;
 888
 889       gcc_assert (expr && expr->expr_type == EXPR_VARIABLE && expr->symtree);
 890
 891       varname = gfc_build_cstring_const (expr->symtree->name);
 892       varname = gfc_build_addr_expr (pchar_type_node, varname);
 893
 894       error = gfc_trans_runtime_error (true, &expr->where,
 895                                        "Attempt to DEALLOCATE unallocated '%s'",
 896                                        varname);
 897     }
 898   else
 899     error = build_empty_stmt (input_location);
 900
 901   if (status != NULL_TREE && !integer_zerop (status))
 902     {
 903       tree status_type = TREE_TYPE (TREE_TYPE (status));
 904       tree cond2;
 905
 906       cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
 907                                status, build_int_cst (TREE_TYPE (status), 0));
 908       tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
 909                              fold_build1_loc (input_location, INDIRECT_REF,
 910                                               status_type, status),
 911                              build_int_cst (status_type, 1));
 912       error = fold_build3_loc (input_location, COND_EXPR, void_type_node,
 913                                cond2, tmp, error);
 914     }
 915
 916   gfc_add_expr_to_block (&null, error);
 917
 918   /* When POINTER is not NULL, we free it.  */
 919   gfc_start_block (&non_null);
 920   tmp = build_call_expr_loc (input_location,
 921                          built_in_decls[BUILT_IN_FREE], 1,
 922                          fold_convert (pvoid_type_node, pointer));
 923   gfc_add_expr_to_block (&non_null, tmp);
 924
 925   if (status != NULL_TREE && !integer_zerop (status))
 926     {
 927       /* We set STATUS to zero if it is present.  */
 928       tree status_type = TREE_TYPE (TREE_TYPE (status));
 929       tree cond2;
 930
 931       cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
 932                                status, build_int_cst (TREE_TYPE (status), 0));
 933       tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
 934                              fold_build1_loc (input_location, INDIRECT_REF,
 935                                               status_type, status),
 936                              build_int_cst (status_type, 0));
 937       tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond2,
 938                              tmp, build_empty_stmt (input_location));
 939       gfc_add_expr_to_block (&non_null, tmp);
 940     }
 941
 942   return fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
 943                           gfc_finish_block (&null),
 944                           gfc_finish_block (&non_null));
 945 }
 946
 947
 948 /* Generate code for deallocation of allocatable scalars (variables or
 949    components). Before the object itself is freed, any allocatable
 950    subcomponents are being deallocated.  */
 951
 952 tree
 953 gfc_deallocate_scalar_with_status (tree pointer, tree status, bool can_fail,
 954                                    gfc_expr* expr, gfc_typespec ts)
 955 {
 956   stmtblock_t null, non_null;
 957   tree cond, tmp, error;
 958
 959   cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, pointer,
 960                           build_int_cst (TREE_TYPE (pointer), 0));
 961
 962   /* When POINTER is NULL, we set STATUS to 1 if it's present, otherwise
 963      we emit a runtime error.  */
 964   gfc_start_block (&null);
 965   if (!can_fail)
 966     {
 967       tree varname;
 968
 969       gcc_assert (expr && expr->expr_type == EXPR_VARIABLE && expr->symtree);
 970
 971       varname = gfc_build_cstring_const (expr->symtree->name);
 972       varname = gfc_build_addr_expr (pchar_type_node, varname);
 973
 974       error = gfc_trans_runtime_error (true, &expr->where,
 975                                        "Attempt to DEALLOCATE unallocated '%s'",
 976                                        varname);
 977     }
 978   else
 979     error = build_empty_stmt (input_location);
 980
 981   if (status != NULL_TREE && !integer_zerop (status))
 982     {
 983       tree status_type = TREE_TYPE (TREE_TYPE (status));
 984       tree cond2;
 985
 986       cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
 987                                status, build_int_cst (TREE_TYPE (status), 0));
 988       tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
 989                              fold_build1_loc (input_location, INDIRECT_REF,
 990                                               status_type, status),
 991                              build_int_cst (status_type, 1));
 992       error = fold_build3_loc (input_location, COND_EXPR, void_type_node,
 993                                cond2, tmp, error);
 994     }
 995
 996   gfc_add_expr_to_block (&null, error);
 997
 998   /* When POINTER is not NULL, we free it.  */
 999   gfc_start_block (&non_null);
1000
1001   /* Free allocatable components.  */
1002   if (ts.type == BT_DERIVED && ts.u.derived->attr.alloc_comp)
1003     {
1004       tmp = build_fold_indirect_ref_loc (input_location, pointer);
1005       tmp = gfc_deallocate_alloc_comp (ts.u.derived, tmp, 0);
1006       gfc_add_expr_to_block (&non_null, tmp);
1007     }
1008   else if (ts.type == BT_CLASS
1009            && ts.u.derived->components->ts.u.derived->attr.alloc_comp)
1010     {
1011       tmp = build_fold_indirect_ref_loc (input_location, pointer);
1012       tmp = gfc_deallocate_alloc_comp (ts.u.derived->components->ts.u.derived,
1013                                        tmp, 0);
1014       gfc_add_expr_to_block (&non_null, tmp);
1015     }
1016
1017   tmp = build_call_expr_loc (input_location,
1018                          built_in_decls[BUILT_IN_FREE], 1,
1019                          fold_convert (pvoid_type_node, pointer));
1020   gfc_add_expr_to_block (&non_null, tmp);
1021
1022   if (status != NULL_TREE && !integer_zerop (status))
1023     {
1024       /* We set STATUS to zero if it is present.  */
1025       tree status_type = TREE_TYPE (TREE_TYPE (status));
1026       tree cond2;
1027
1028       cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
1029                                status, build_int_cst (TREE_TYPE (status), 0));
1030       tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
1031                              fold_build1_loc (input_location, INDIRECT_REF,
1032                                               status_type, status),
1033                              build_int_cst (status_type, 0));
1034       tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond2,
1035                              tmp, build_empty_stmt (input_location));
1036       gfc_add_expr_to_block (&non_null, tmp);
1037     }
1038
1039   return fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
1040                           gfc_finish_block (&null),
1041                           gfc_finish_block (&non_null));
1042 }
1043
1044
1045 /* Reallocate MEM so it has SIZE bytes of data.  This behaves like the
1046    following pseudo-code:
1047
1048 void *
1049 internal_realloc (void *mem, size_t size)
1050 {
1051   if (size < 0)
1052     runtime_error ("Attempt to allocate a negative amount of memory.");
1053   res = realloc (mem, size);
1054   if (!res && size != 0)
1055     _gfortran_os_error ("Out of memory");
1056
1057   if (size == 0)
1058     return NULL;
1059
1060   return res;
1061 }  */
1062 tree
1063 gfc_call_realloc (stmtblock_t * block, tree mem, tree size)
1064 {
1065   tree msg, res, negative, nonzero, zero, null_result, tmp;
1066   tree type = TREE_TYPE (mem);
1067
1068   size = gfc_evaluate_now (size, block);
1069
1070   if (TREE_TYPE (size) != TREE_TYPE (size_type_node))
1071     size = fold_convert (size_type_node, size);
1072
1073   /* Create a variable to hold the result.  */
1074   res = gfc_create_var (type, NULL);
1075
1076   /* size < 0 ?  */
1077   negative = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, size,
1078                               build_int_cst (size_type_node, 0));
1079   msg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const
1080       ("Attempt to allocate a negative amount of memory."));
1081   tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, negative,
1082                          build_call_expr_loc (input_location,
1083                                             gfor_fndecl_runtime_error, 1, msg),
1084                          build_empty_stmt (input_location));
1085   gfc_add_expr_to_block (block, tmp);
1086
1087   /* Call realloc and check the result.  */
1088   tmp = build_call_expr_loc (input_location,
1089                          built_in_decls[BUILT_IN_REALLOC], 2,
1090                          fold_convert (pvoid_type_node, mem), size);
1091   gfc_add_modify (block, res, fold_convert (type, tmp));
1092   null_result = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
1093                                  res, build_int_cst (pvoid_type_node, 0));
1094   nonzero = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, size,
1095                              build_int_cst (size_type_node, 0));
1096   null_result = fold_build2_loc (input_location, TRUTH_AND_EXPR, boolean_type_node,
1097                                  null_result, nonzero);
1098   msg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const
1099                                                 ("Out of memory"));
1100   tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
1101                          null_result,
1102                          build_call_expr_loc (input_location,
1103                                               gfor_fndecl_os_error, 1, msg),
1104                          build_empty_stmt (input_location));
1105   gfc_add_expr_to_block (block, tmp);
1106
1107   /* if (size == 0) then the result is NULL.  */
1108   tmp = fold_build2_loc (input_location, MODIFY_EXPR, type, res,
1109                          build_int_cst (type, 0));
1110   zero = fold_build1_loc (input_location, TRUTH_NOT_EXPR, boolean_type_node,
1111                           nonzero);
1112   tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, zero, tmp,
1113                          build_empty_stmt (input_location));
1114   gfc_add_expr_to_block (block, tmp);
1115
1116   return res;
1117 }
1118
1119
1120 /* Add an expression to another one, either at the front or the back.  */
1121
1122 static void
1123 add_expr_to_chain (tree* chain, tree expr, bool front)
1124 {
1125   if (expr == NULL_TREE || IS_EMPTY_STMT (expr))
1126     return;
1127
1128   if (*chain)
1129     {
1130       if (TREE_CODE (*chain) != STATEMENT_LIST)
1131         {
1132           tree tmp;
1133
1134           tmp = *chain;
1135           *chain = NULL_TREE;
1136           append_to_statement_list (tmp, chain);
1137         }
1138
1139       if (front)
1140         {
1141           tree_stmt_iterator i;
1142
1143           i = tsi_start (*chain);
1144           tsi_link_before (&i, expr, TSI_CONTINUE_LINKING);
1145         }
1146       else
1147         append_to_statement_list (expr, chain);
1148     }
1149   else
1150     *chain = expr;
1151 }
1152
1153 /* Add a statement to a block.  */
1154
1155 void
1156 gfc_add_expr_to_block (stmtblock_t * block, tree expr)
1157 {
1158   gcc_assert (block);
1159   add_expr_to_chain (&block->head, expr, false);
1160 }
1161
1162
1163 /* Add a block the end of a block.  */
1164
1165 void
1166 gfc_add_block_to_block (stmtblock_t * block, stmtblock_t * append)
1167 {
1168   gcc_assert (append);
1169   gcc_assert (!append->has_scope);
1170
1171   gfc_add_expr_to_block (block, append->head);
1172   append->head = NULL_TREE;
1173 }
1174
1175
1176 /* Save the current locus.  The structure may not be complete, and should
1177    only be used with gfc_restore_backend_locus.  */
1178
1179 void
1180 gfc_save_backend_locus (locus * loc)
1181 {
1182   loc->lb = XCNEW (gfc_linebuf);
1183   loc->lb->location = input_location;
1184   loc->lb->file = gfc_current_backend_file;
1185 }
1186
1187
1188 /* Set the current locus.  */
1189
1190 void
1191 gfc_set_backend_locus (locus * loc)
1192 {
1193   gfc_current_backend_file = loc->lb->file;
1194   input_location = loc->lb->location;
1195 }
1196
1197
1198 /* Restore the saved locus. Only used in conjonction with
1199    gfc_save_backend_locus, to free the memory when we are done.  */
1200
1201 void
1202 gfc_restore_backend_locus (locus * loc)
1203 {
1204   gfc_set_backend_locus (loc);
1205   gfc_free (loc->lb);
1206 }
1207
1208
1209 /* Translate an executable statement. The tree cond is used by gfc_trans_do.
1210    This static function is wrapped by gfc_trans_code_cond and
1211    gfc_trans_code.  */
1212
1213 static tree
1214 trans_code (gfc_code * code, tree cond)
1215 {
1216   stmtblock_t block;
1217   tree res;
1218
1219   if (!code)
1220     return build_empty_stmt (input_location);
1221
1222   gfc_start_block (&block);
1223
1224   /* Translate statements one by one into GENERIC trees until we reach
1225      the end of this gfc_code branch.  */
1226   for (; code; code = code->next)
1227     {
1228       if (code->here != 0)
1229         {
1230           res = gfc_trans_label_here (code);
1231           gfc_add_expr_to_block (&block, res);
1232         }
1233
1234       gfc_set_backend_locus (&code->loc);
1235
1236       switch (code->op)
1237         {
1238         case EXEC_NOP:
1239         case EXEC_END_BLOCK:
1240         case EXEC_END_PROCEDURE:
1241           res = NULL_TREE;
1242           break;
1243
1244         case EXEC_ASSIGN:
1245           if (code->expr1->ts.type == BT_CLASS)
1246             res = gfc_trans_class_assign (code->expr1, code->expr2, code->op);
1247           else
1248             res = gfc_trans_assign (code);
1249           break;
1250
1251         case EXEC_LABEL_ASSIGN:
1252           res = gfc_trans_label_assign (code);
1253           break;
1254
1255         case EXEC_POINTER_ASSIGN:
1256           if (code->expr1->ts.type == BT_CLASS)
1257             res = gfc_trans_class_assign (code->expr1, code->expr2, code->op);
1258           else
1259             res = gfc_trans_pointer_assign (code);
1260           break;
1261
1262         case EXEC_INIT_ASSIGN:
1263           if (code->expr1->ts.type == BT_CLASS)
1264             res = gfc_trans_class_init_assign (code);
1265           else
1266             res = gfc_trans_init_assign (code);
1267           break;
1268
1269         case EXEC_CONTINUE:
1270           res = NULL_TREE;
1271           break;
1272
1273         case EXEC_CRITICAL:
1274           res = gfc_trans_critical (code);
1275           break;
1276
1277         case EXEC_CYCLE:
1278           res = gfc_trans_cycle (code);
1279           break;
1280
1281         case EXEC_EXIT:
1282           res = gfc_trans_exit (code);
1283           break;
1284
1285         case EXEC_GOTO:
1286           res = gfc_trans_goto (code);
1287           break;
1288
1289         case EXEC_ENTRY:
1290           res = gfc_trans_entry (code);
1291           break;
1292
1293         case EXEC_PAUSE:
1294           res = gfc_trans_pause (code);
1295           break;
1296
1297         case EXEC_STOP:
1298         case EXEC_ERROR_STOP:
1299           res = gfc_trans_stop (code, code->op == EXEC_ERROR_STOP);
1300           break;
1301
1302         case EXEC_CALL:
1303           /* For MVBITS we've got the special exception that we need a
1304              dependency check, too.  */
1305           {
1306             bool is_mvbits = false;
1307             if (code->resolved_isym
1308                 && code->resolved_isym->id == GFC_ISYM_MVBITS)
1309               is_mvbits = true;
1310             if (code->resolved_isym
1311                 && code->resolved_isym->id == GFC_ISYM_MOVE_ALLOC)
1312               res = gfc_conv_intrinsic_move_alloc (code);
1313             else
1314               res = gfc_trans_call (code, is_mvbits, NULL_TREE,
1315                                     NULL_TREE, false);
1316           }
1317           break;
1318
1319         case EXEC_CALL_PPC:
1320           res = gfc_trans_call (code, false, NULL_TREE,
1321                                 NULL_TREE, false);
1322           break;
1323
1324         case EXEC_ASSIGN_CALL:
1325           res = gfc_trans_call (code, true, NULL_TREE,
1326                                 NULL_TREE, false);
1327           break;
1328
1329         case EXEC_RETURN:
1330           res = gfc_trans_return (code);
1331           break;
1332
1333         case EXEC_IF:
1334           res = gfc_trans_if (code);
1335           break;
1336
1337         case EXEC_ARITHMETIC_IF:
1338           res = gfc_trans_arithmetic_if (code);
1339           break;
1340
1341         case EXEC_BLOCK:
1342           res = gfc_trans_block_construct (code);
1343           break;
1344
1345         case EXEC_DO:
1346           res = gfc_trans_do (code, cond);
1347           break;
1348
1349         case EXEC_DO_WHILE:
1350           res = gfc_trans_do_while (code);
1351           break;
1352
1353         case EXEC_SELECT:
1354           res = gfc_trans_select (code);
1355           break;
1356
1357         case EXEC_SELECT_TYPE:
1358           /* Do nothing. SELECT TYPE statements should be transformed into
1359           an ordinary SELECT CASE at resolution stage.
1360           TODO: Add an error message here once this is done.  */
1361           res = NULL_TREE;
1362           break;
1363
1364         case EXEC_FLUSH:
1365           res = gfc_trans_flush (code);
1366           break;
1367
1368         case EXEC_SYNC_ALL:
1369         case EXEC_SYNC_IMAGES:
1370         case EXEC_SYNC_MEMORY:
1371           res = gfc_trans_sync (code, code->op);
1372           break;
1373
1374         case EXEC_FORALL:
1375           res = gfc_trans_forall (code);
1376           break;
1377
1378         case EXEC_WHERE:
1379           res = gfc_trans_where (code);
1380           break;
1381
1382         case EXEC_ALLOCATE:
1383           res = gfc_trans_allocate (code);
1384           break;
1385
1386         case EXEC_DEALLOCATE:
1387           res = gfc_trans_deallocate (code);
1388           break;
1389
1390         case EXEC_OPEN:
1391           res = gfc_trans_open (code);
1392           break;
1393
1394         case EXEC_CLOSE:
1395           res = gfc_trans_close (code);
1396           break;
1397
1398         case EXEC_READ:
1399           res = gfc_trans_read (code);
1400           break;
1401
1402         case EXEC_WRITE:
1403           res = gfc_trans_write (code);
1404           break;
1405
1406         case EXEC_IOLENGTH:
1407           res = gfc_trans_iolength (code);
1408           break;
1409
1410         case EXEC_BACKSPACE:
1411           res = gfc_trans_backspace (code);
1412           break;
1413
1414         case EXEC_ENDFILE:
1415           res = gfc_trans_endfile (code);
1416           break;
1417
1418         case EXEC_INQUIRE:
1419           res = gfc_trans_inquire (code);
1420           break;
1421
1422         case EXEC_WAIT:
1423           res = gfc_trans_wait (code);
1424           break;
1425
1426         case EXEC_REWIND:
1427           res = gfc_trans_rewind (code);
1428           break;
1429
1430         case EXEC_TRANSFER:
1431           res = gfc_trans_transfer (code);
1432           break;
1433
1434         case EXEC_DT_END:
1435           res = gfc_trans_dt_end (code);
1436           break;
1437
1438         case EXEC_OMP_ATOMIC:
1439         case EXEC_OMP_BARRIER:
1440         case EXEC_OMP_CRITICAL:
1441         case EXEC_OMP_DO:
1442         case EXEC_OMP_FLUSH:
1443         case EXEC_OMP_MASTER:
1444         case EXEC_OMP_ORDERED:
1445         case EXEC_OMP_PARALLEL:
1446         case EXEC_OMP_PARALLEL_DO:
1447         case EXEC_OMP_PARALLEL_SECTIONS:
1448         case EXEC_OMP_PARALLEL_WORKSHARE:
1449         case EXEC_OMP_SECTIONS:
1450         case EXEC_OMP_SINGLE:
1451         case EXEC_OMP_TASK:
1452         case EXEC_OMP_TASKWAIT:
1453         case EXEC_OMP_WORKSHARE:
1454           res = gfc_trans_omp_directive (code);
1455           break;
1456
1457         default:
1458           internal_error ("gfc_trans_code(): Bad statement code");
1459         }
1460
1461       gfc_set_backend_locus (&code->loc);
1462
1463       if (res != NULL_TREE && ! IS_EMPTY_STMT (res))
1464         {
1465           if (TREE_CODE (res) != STATEMENT_LIST)
1466             SET_EXPR_LOCATION (res, input_location);
1467
1468           /* Add the new statement to the block.  */
1469           gfc_add_expr_to_block (&block, res);
1470         }
1471     }
1472
1473   /* Return the finished block.  */
1474   return gfc_finish_block (&block);
1475 }
1476
1477
1478 /* Translate an executable statement with condition, cond.  The condition is
1479    used by gfc_trans_do to test for IO result conditions inside implied
1480    DO loops of READ and WRITE statements.  See build_dt in trans-io.c.  */
1481
1482 tree
1483 gfc_trans_code_cond (gfc_code * code, tree cond)
1484 {
1485   return trans_code (code, cond);
1486 }
1487
1488 /* Translate an executable statement without condition.  */
1489
1490 tree
1491 gfc_trans_code (gfc_code * code)
1492 {
1493   return trans_code (code, NULL_TREE);
1494 }
1495
1496
1497 /* This function is called after a complete program unit has been parsed
1498    and resolved.  */
1499
1500 void
1501 gfc_generate_code (gfc_namespace * ns)
1502 {
1503   ompws_flags = 0;
1504   if (ns->is_block_data)
1505     {
1506       gfc_generate_block_data (ns);
1507       return;
1508     }
1509
1510   gfc_generate_function_code (ns);
1511 }
1512
1513
1514 /* This function is called after a complete module has been parsed
1515    and resolved.  */
1516
1517 void
1518 gfc_generate_module_code (gfc_namespace * ns)
1519 {
1520   gfc_namespace *n;
1521   struct module_htab_entry *entry;
1522
1523   gcc_assert (ns->proc_name->backend_decl == NULL);
1524   ns->proc_name->backend_decl
1525     = build_decl (ns->proc_name->declared_at.lb->location,
1526                   NAMESPACE_DECL, get_identifier (ns->proc_name->name),
1527                   void_type_node);
1528   entry = gfc_find_module (ns->proc_name->name);
1529   if (entry->namespace_decl)
1530     /* Buggy sourcecode, using a module before defining it?  */
1531     htab_empty (entry->decls);
1532   entry->namespace_decl = ns->proc_name->backend_decl;
1533
1534   gfc_generate_module_vars (ns);
1535
1536   /* We need to generate all module function prototypes first, to allow
1537      sibling calls.  */
1538   for (n = ns->contained; n; n = n->sibling)
1539     {
1540       gfc_entry_list *el;
1541
1542       if (!n->proc_name)
1543         continue;
1544
1545       gfc_create_function_decl (n, false);
1546       DECL_CONTEXT (n->proc_name->backend_decl) = ns->proc_name->backend_decl;
1547       gfc_module_add_decl (entry, n->proc_name->backend_decl);
1548       for (el = ns->entries; el; el = el->next)
1549         {
1550           DECL_CONTEXT (el->sym->backend_decl) = ns->proc_name->backend_decl;
1551           gfc_module_add_decl (entry, el->sym->backend_decl);
1552         }
1553     }
1554
1555   for (n = ns->contained; n; n = n->sibling)
1556     {
1557       if (!n->proc_name)
1558         continue;
1559
1560       gfc_generate_function_code (n);
1561     }
1562 }
1563
1564
1565 /* Initialize an init/cleanup block with existing code.  */
1566
1567 void
1568 gfc_start_wrapped_block (gfc_wrapped_block* block, tree code)
1569 {
1570   gcc_assert (block);
1571
1572   block->init = NULL_TREE;
1573   block->code = code;
1574   block->cleanup = NULL_TREE;
1575 }
1576
1577
1578 /* Add a new pair of initializers/clean-up code.  */
1579
1580 void
1581 gfc_add_init_cleanup (gfc_wrapped_block* block, tree init, tree cleanup)
1582 {
1583   gcc_assert (block);
1584
1585   /* The new pair of init/cleanup should be "wrapped around" the existing
1586      block of code, thus the initialization is added to the front and the
1587      cleanup to the back.  */
1588   add_expr_to_chain (&block->init, init, true);
1589   add_expr_to_chain (&block->cleanup, cleanup, false);
1590 }
1591
1592
1593 /* Finish up a wrapped block by building a corresponding try-finally expr.  */
1594
1595 tree
1596 gfc_finish_wrapped_block (gfc_wrapped_block* block)
1597 {
1598   tree result;
1599
1600   gcc_assert (block);
1601
1602   /* Build the final expression.  For this, just add init and body together,
1603      and put clean-up with that into a TRY_FINALLY_EXPR.  */
1604   result = block->init;
1605   add_expr_to_chain (&result, block->code, false);
1606   if (block->cleanup)
1607     result = build2_loc (input_location, TRY_FINALLY_EXPR, void_type_node,
1608                          result, block->cleanup);
1609
1610   /* Clear the block.  */
1611   block->init = NULL_TREE;
1612   block->code = NULL_TREE;
1613   block->cleanup = NULL_TREE;
1614
1615   return result;
1616 }