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       newmem = malloc (MAX (size, 1));
 588       if (newmem == NULL)
 589       {
 590         if (stat)
 591           *stat = LIBERROR_ALLOCATION;
 592         else
 593           runtime_error ("Allocation would exceed memory limit");
 594       }
 595       return newmem;
 596     }  */
 597 tree
 598 gfc_allocate_with_status (stmtblock_t * block, tree size, tree status)
 599 {
 600   stmtblock_t alloc_block;
 601   tree res, tmp, msg, cond;
 602   tree status_type = status ? TREE_TYPE (TREE_TYPE (status)) : NULL_TREE;
 603
 604   /* Evaluate size only once, and make sure it has the right type.  */
 605   size = gfc_evaluate_now (size, block);
 606   if (TREE_TYPE (size) != TREE_TYPE (size_type_node))
 607     size = fold_convert (size_type_node, size);
 608
 609   /* Create a variable to hold the result.  */
 610   res = gfc_create_var (prvoid_type_node, NULL);
 611
 612   /* Set the optional status variable to zero.  */
 613   if (status != NULL_TREE && !integer_zerop (status))
 614     {
 615       tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
 616                              fold_build1_loc (input_location, INDIRECT_REF,
 617                                               status_type, status),
 618                              build_int_cst (status_type, 0));
 619       tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
 620                              fold_build2_loc (input_location, NE_EXPR,
 621                                         boolean_type_node, status,
 622                                         build_int_cst (TREE_TYPE (status), 0)),
 623                              tmp, build_empty_stmt (input_location));
 624       gfc_add_expr_to_block (block, tmp);
 625     }
 626
 627   /* The allocation itself.  */
 628   gfc_start_block (&alloc_block);
 629   gfc_add_modify (&alloc_block, res,
 630                   fold_convert (prvoid_type_node,
 631                                 build_call_expr_loc (input_location,
 632                                    built_in_decls[BUILT_IN_MALLOC], 1,
 633                                         fold_build2_loc (input_location,
 634                                             MAX_EXPR, size_type_node, size,
 635                                             build_int_cst (size_type_node,
 636                                                            1)))));
 637
 638   msg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const
 639                              ("Allocation would exceed memory limit"));
 640   tmp = build_call_expr_loc (input_location,
 641                          gfor_fndecl_os_error, 1, msg);
 642
 643   if (status != NULL_TREE && !integer_zerop (status))
 644     {
 645       /* Set the status variable if it's present.  */
 646       tree tmp2;
 647
 648       cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
 649                               status, build_int_cst (TREE_TYPE (status), 0));
 650       tmp2 = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
 651                               fold_build1_loc (input_location, INDIRECT_REF,
 652                                                status_type, status),
 653                               build_int_cst (status_type, LIBERROR_ALLOCATION));
 654       tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
 655                              tmp, tmp2);
 656     }
 657
 658   tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
 659                          fold_build2_loc (input_location, EQ_EXPR,
 660                                           boolean_type_node, res,
 661                                           build_int_cst (prvoid_type_node, 0)),
 662                          tmp, build_empty_stmt (input_location));
 663   gfc_add_expr_to_block (&alloc_block, tmp);
 664   gfc_add_expr_to_block (block, gfc_finish_block (&alloc_block));
 665
 666   return res;
 667 }
 668
 669
 670 /* Generate code for an ALLOCATE statement when the argument is an
 671    allocatable array.  If the array is currently allocated, it is an
 672    error to allocate it again.
 673
 674    This function follows the following pseudo-code:
 675
 676     void *
 677     allocate_array (void *mem, size_t size, integer_type *stat)
 678     {
 679       if (mem == NULL)
 680         return allocate (size, stat);
 681       else
 682       {
 683         if (stat)
 684         {
 685           free (mem);
 686           mem = allocate (size, stat);
 687           *stat = LIBERROR_ALLOCATION;
 688           return mem;
 689         }
 690         else
 691           runtime_error ("Attempting to allocate already allocated variable");
 692       }
 693     }
 694
 695     expr must be set to the original expression being allocated for its locus
 696     and variable name in case a runtime error has to be printed.  */
 697 tree
 698 gfc_allocate_array_with_status (stmtblock_t * block, tree mem, tree size,
 699                                 tree status, gfc_expr* expr)
 700 {
 701   stmtblock_t alloc_block;
 702   tree res, tmp, null_mem, alloc, error;
 703   tree type = TREE_TYPE (mem);
 704
 705   if (TREE_TYPE (size) != TREE_TYPE (size_type_node))
 706     size = fold_convert (size_type_node, size);
 707
 708   /* Create a variable to hold the result.  */
 709   res = gfc_create_var (type, NULL);
 710   null_mem = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, mem,
 711                               build_int_cst (type, 0));
 712
 713   /* If mem is NULL, we call gfc_allocate_with_status.  */
 714   gfc_start_block (&alloc_block);
 715   tmp = gfc_allocate_with_status (&alloc_block, size, status);
 716   gfc_add_modify (&alloc_block, res, fold_convert (type, tmp));
 717   alloc = gfc_finish_block (&alloc_block);
 718
 719   /* Otherwise, we issue a runtime error or set the status variable.  */
 720   if (expr)
 721     {
 722       tree varname;
 723
 724       gcc_assert (expr->expr_type == EXPR_VARIABLE && expr->symtree);
 725       varname = gfc_build_cstring_const (expr->symtree->name);
 726       varname = gfc_build_addr_expr (pchar_type_node, varname);
 727
 728       error = gfc_trans_runtime_error (true, &expr->where,
 729                                        "Attempting to allocate already"
 730                                        " allocated variable '%s'",
 731                                        varname);
 732     }
 733   else
 734     error = gfc_trans_runtime_error (true, NULL,
 735                                      "Attempting to allocate already allocated"
 736                                      " variable");
 737
 738   if (status != NULL_TREE && !integer_zerop (status))
 739     {
 740       tree status_type = TREE_TYPE (TREE_TYPE (status));
 741       stmtblock_t set_status_block;
 742
 743       gfc_start_block (&set_status_block);
 744       tmp = build_call_expr_loc (input_location,
 745                              built_in_decls[BUILT_IN_FREE], 1,
 746                              fold_convert (pvoid_type_node, mem));
 747       gfc_add_expr_to_block (&set_status_block, tmp);
 748
 749       tmp = gfc_allocate_with_status (&set_status_block, size, status);
 750       gfc_add_modify (&set_status_block, res, fold_convert (type, tmp));
 751
 752       gfc_add_modify (&set_status_block,
 753                            fold_build1_loc (input_location, INDIRECT_REF,
 754                                             status_type, status),
 755                            build_int_cst (status_type, LIBERROR_ALLOCATION));
 756
 757       tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
 758                              status, build_int_cst (status_type, 0));
 759       error = fold_build3_loc (input_location, COND_EXPR, void_type_node, tmp,
 760                                error, gfc_finish_block (&set_status_block));
 761     }
 762
 763   tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, null_mem,
 764                          alloc, error);
 765   gfc_add_expr_to_block (block, tmp);
 766
 767   return res;
 768 }
 769
 770
 771 /* Free a given variable, if it's not NULL.  */
 772 tree
 773 gfc_call_free (tree var)
 774 {
 775   stmtblock_t block;
 776   tree tmp, cond, call;
 777
 778   if (TREE_TYPE (var) != TREE_TYPE (pvoid_type_node))
 779     var = fold_convert (pvoid_type_node, var);
 780
 781   gfc_start_block (&block);
 782   var = gfc_evaluate_now (var, &block);
 783   cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, var,
 784                           build_int_cst (pvoid_type_node, 0));
 785   call = build_call_expr_loc (input_location,
 786                               built_in_decls[BUILT_IN_FREE], 1, var);
 787   tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, call,
 788                          build_empty_stmt (input_location));
 789   gfc_add_expr_to_block (&block, tmp);
 790
 791   return gfc_finish_block (&block);
 792 }
 793
 794
 795
 796 /* User-deallocate; we emit the code directly from the front-end, and the
 797    logic is the same as the previous library function:
 798
 799     void
 800     deallocate (void *pointer, GFC_INTEGER_4 * stat)
 801     {
 802       if (!pointer)
 803         {
 804           if (stat)
 805             *stat = 1;
 806           else
 807             runtime_error ("Attempt to DEALLOCATE unallocated memory.");
 808         }
 809       else
 810         {
 811           free (pointer);
 812           if (stat)
 813             *stat = 0;
 814         }
 815     }
 816
 817    In this front-end version, status doesn't have to be GFC_INTEGER_4.
 818    Moreover, if CAN_FAIL is true, then we will not emit a runtime error,
 819    even when no status variable is passed to us (this is used for
 820    unconditional deallocation generated by the front-end at end of
 821    each procedure).
 822
 823    If a runtime-message is possible, `expr' must point to the original
 824    expression being deallocated for its locus and variable name.  */
 825 tree
 826 gfc_deallocate_with_status (tree pointer, tree status, bool can_fail,
 827                             gfc_expr* expr)
 828 {
 829   stmtblock_t null, non_null;
 830   tree cond, tmp, error;
 831
 832   cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, pointer,
 833                           build_int_cst (TREE_TYPE (pointer), 0));
 834
 835   /* When POINTER is NULL, we set STATUS to 1 if it's present, otherwise
 836      we emit a runtime error.  */
 837   gfc_start_block (&null);
 838   if (!can_fail)
 839     {
 840       tree varname;
 841
 842       gcc_assert (expr && expr->expr_type == EXPR_VARIABLE && expr->symtree);
 843
 844       varname = gfc_build_cstring_const (expr->symtree->name);
 845       varname = gfc_build_addr_expr (pchar_type_node, varname);
 846
 847       error = gfc_trans_runtime_error (true, &expr->where,
 848                                        "Attempt to DEALLOCATE unallocated '%s'",
 849                                        varname);
 850     }
 851   else
 852     error = build_empty_stmt (input_location);
 853
 854   if (status != NULL_TREE && !integer_zerop (status))
 855     {
 856       tree status_type = TREE_TYPE (TREE_TYPE (status));
 857       tree cond2;
 858
 859       cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
 860                                status, build_int_cst (TREE_TYPE (status), 0));
 861       tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
 862                              fold_build1_loc (input_location, INDIRECT_REF,
 863                                               status_type, status),
 864                              build_int_cst (status_type, 1));
 865       error = fold_build3_loc (input_location, COND_EXPR, void_type_node,
 866                                cond2, tmp, error);
 867     }
 868
 869   gfc_add_expr_to_block (&null, error);
 870
 871   /* When POINTER is not NULL, we free it.  */
 872   gfc_start_block (&non_null);
 873   tmp = build_call_expr_loc (input_location,
 874                          built_in_decls[BUILT_IN_FREE], 1,
 875                          fold_convert (pvoid_type_node, pointer));
 876   gfc_add_expr_to_block (&non_null, tmp);
 877
 878   if (status != NULL_TREE && !integer_zerop (status))
 879     {
 880       /* We set STATUS to zero if it is present.  */
 881       tree status_type = TREE_TYPE (TREE_TYPE (status));
 882       tree cond2;
 883
 884       cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
 885                                status, build_int_cst (TREE_TYPE (status), 0));
 886       tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
 887                              fold_build1_loc (input_location, INDIRECT_REF,
 888                                               status_type, status),
 889                              build_int_cst (status_type, 0));
 890       tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond2,
 891                              tmp, build_empty_stmt (input_location));
 892       gfc_add_expr_to_block (&non_null, tmp);
 893     }
 894
 895   return fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
 896                           gfc_finish_block (&null),
 897                           gfc_finish_block (&non_null));
 898 }
 899
 900
 901 /* Generate code for deallocation of allocatable scalars (variables or
 902    components). Before the object itself is freed, any allocatable
 903    subcomponents are being deallocated.  */
 904
 905 tree
 906 gfc_deallocate_scalar_with_status (tree pointer, tree status, bool can_fail,
 907                                    gfc_expr* expr, gfc_typespec ts)
 908 {
 909   stmtblock_t null, non_null;
 910   tree cond, tmp, error;
 911
 912   cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, pointer,
 913                           build_int_cst (TREE_TYPE (pointer), 0));
 914
 915   /* When POINTER is NULL, we set STATUS to 1 if it's present, otherwise
 916      we emit a runtime error.  */
 917   gfc_start_block (&null);
 918   if (!can_fail)
 919     {
 920       tree varname;
 921
 922       gcc_assert (expr && expr->expr_type == EXPR_VARIABLE && expr->symtree);
 923
 924       varname = gfc_build_cstring_const (expr->symtree->name);
 925       varname = gfc_build_addr_expr (pchar_type_node, varname);
 926
 927       error = gfc_trans_runtime_error (true, &expr->where,
 928                                        "Attempt to DEALLOCATE unallocated '%s'",
 929                                        varname);
 930     }
 931   else
 932     error = build_empty_stmt (input_location);
 933
 934   if (status != NULL_TREE && !integer_zerop (status))
 935     {
 936       tree status_type = TREE_TYPE (TREE_TYPE (status));
 937       tree cond2;
 938
 939       cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
 940                                status, build_int_cst (TREE_TYPE (status), 0));
 941       tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
 942                              fold_build1_loc (input_location, INDIRECT_REF,
 943                                               status_type, status),
 944                              build_int_cst (status_type, 1));
 945       error = fold_build3_loc (input_location, COND_EXPR, void_type_node,
 946                                cond2, tmp, error);
 947     }
 948
 949   gfc_add_expr_to_block (&null, error);
 950
 951   /* When POINTER is not NULL, we free it.  */
 952   gfc_start_block (&non_null);
 953
 954   /* Free allocatable components.  */
 955   if (ts.type == BT_DERIVED && ts.u.derived->attr.alloc_comp)
 956     {
 957       tmp = build_fold_indirect_ref_loc (input_location, pointer);
 958       tmp = gfc_deallocate_alloc_comp (ts.u.derived, tmp, 0);
 959       gfc_add_expr_to_block (&non_null, tmp);
 960     }
 961   else if (ts.type == BT_CLASS
 962            && ts.u.derived->components->ts.u.derived->attr.alloc_comp)
 963     {
 964       tmp = build_fold_indirect_ref_loc (input_location, pointer);
 965       tmp = gfc_deallocate_alloc_comp (ts.u.derived->components->ts.u.derived,
 966                                        tmp, 0);
 967       gfc_add_expr_to_block (&non_null, tmp);
 968     }
 969
 970   tmp = build_call_expr_loc (input_location,
 971                          built_in_decls[BUILT_IN_FREE], 1,
 972                          fold_convert (pvoid_type_node, pointer));
 973   gfc_add_expr_to_block (&non_null, tmp);
 974
 975   if (status != NULL_TREE && !integer_zerop (status))
 976     {
 977       /* We set STATUS to zero if it is present.  */
 978       tree status_type = TREE_TYPE (TREE_TYPE (status));
 979       tree cond2;
 980
 981       cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
 982                                status, build_int_cst (TREE_TYPE (status), 0));
 983       tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
 984                              fold_build1_loc (input_location, INDIRECT_REF,
 985                                               status_type, status),
 986                              build_int_cst (status_type, 0));
 987       tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond2,
 988                              tmp, build_empty_stmt (input_location));
 989       gfc_add_expr_to_block (&non_null, tmp);
 990     }
 991
 992   return fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
 993                           gfc_finish_block (&null),
 994                           gfc_finish_block (&non_null));
 995 }
 996
 997
 998 /* Reallocate MEM so it has SIZE bytes of data.  This behaves like the
 999    following pseudo-code:
1000
1001 void *
1002 internal_realloc (void *mem, size_t size)
1003 {
1004   res = realloc (mem, size);
1005   if (!res && size != 0)
1006     _gfortran_os_error ("Allocation would exceed memory limit");
1007
1008   if (size == 0)
1009     return NULL;
1010
1011   return res;
1012 }  */
1013 tree
1014 gfc_call_realloc (stmtblock_t * block, tree mem, tree size)
1015 {
1016   tree msg, res, nonzero, zero, null_result, tmp;
1017   tree type = TREE_TYPE (mem);
1018
1019   size = gfc_evaluate_now (size, block);
1020
1021   if (TREE_TYPE (size) != TREE_TYPE (size_type_node))
1022     size = fold_convert (size_type_node, size);
1023
1024   /* Create a variable to hold the result.  */
1025   res = gfc_create_var (type, NULL);
1026
1027   /* Call realloc and check the result.  */
1028   tmp = build_call_expr_loc (input_location,
1029                          built_in_decls[BUILT_IN_REALLOC], 2,
1030                          fold_convert (pvoid_type_node, mem), size);
1031   gfc_add_modify (block, res, fold_convert (type, tmp));
1032   null_result = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
1033                                  res, build_int_cst (pvoid_type_node, 0));
1034   nonzero = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, size,
1035                              build_int_cst (size_type_node, 0));
1036   null_result = fold_build2_loc (input_location, TRUTH_AND_EXPR, boolean_type_node,
1037                                  null_result, nonzero);
1038   msg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const
1039                              ("Allocation would exceed memory limit"));
1040   tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
1041                          null_result,
1042                          build_call_expr_loc (input_location,
1043                                               gfor_fndecl_os_error, 1, msg),
1044                          build_empty_stmt (input_location));
1045   gfc_add_expr_to_block (block, tmp);
1046
1047   /* if (size == 0) then the result is NULL.  */
1048   tmp = fold_build2_loc (input_location, MODIFY_EXPR, type, res,
1049                          build_int_cst (type, 0));
1050   zero = fold_build1_loc (input_location, TRUTH_NOT_EXPR, boolean_type_node,
1051                           nonzero);
1052   tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, zero, tmp,
1053                          build_empty_stmt (input_location));
1054   gfc_add_expr_to_block (block, tmp);
1055
1056   return res;
1057 }
1058
1059
1060 /* Add an expression to another one, either at the front or the back.  */
1061
1062 static void
1063 add_expr_to_chain (tree* chain, tree expr, bool front)
1064 {
1065   if (expr == NULL_TREE || IS_EMPTY_STMT (expr))
1066     return;
1067
1068   if (*chain)
1069     {
1070       if (TREE_CODE (*chain) != STATEMENT_LIST)
1071         {
1072           tree tmp;
1073
1074           tmp = *chain;
1075           *chain = NULL_TREE;
1076           append_to_statement_list (tmp, chain);
1077         }
1078
1079       if (front)
1080         {
1081           tree_stmt_iterator i;
1082
1083           i = tsi_start (*chain);
1084           tsi_link_before (&i, expr, TSI_CONTINUE_LINKING);
1085         }
1086       else
1087         append_to_statement_list (expr, chain);
1088     }
1089   else
1090     *chain = expr;
1091 }
1092
1093 /* Add a statement to a block.  */
1094
1095 void
1096 gfc_add_expr_to_block (stmtblock_t * block, tree expr)
1097 {
1098   gcc_assert (block);
1099   add_expr_to_chain (&block->head, expr, false);
1100 }
1101
1102
1103 /* Add a block the end of a block.  */
1104
1105 void
1106 gfc_add_block_to_block (stmtblock_t * block, stmtblock_t * append)
1107 {
1108   gcc_assert (append);
1109   gcc_assert (!append->has_scope);
1110
1111   gfc_add_expr_to_block (block, append->head);
1112   append->head = NULL_TREE;
1113 }
1114
1115
1116 /* Save the current locus.  The structure may not be complete, and should
1117    only be used with gfc_restore_backend_locus.  */
1118
1119 void
1120 gfc_save_backend_locus (locus * loc)
1121 {
1122   loc->lb = XCNEW (gfc_linebuf);
1123   loc->lb->location = input_location;
1124   loc->lb->file = gfc_current_backend_file;
1125 }
1126
1127
1128 /* Set the current locus.  */
1129
1130 void
1131 gfc_set_backend_locus (locus * loc)
1132 {
1133   gfc_current_backend_file = loc->lb->file;
1134   input_location = loc->lb->location;
1135 }
1136
1137
1138 /* Restore the saved locus. Only used in conjonction with
1139    gfc_save_backend_locus, to free the memory when we are done.  */
1140
1141 void
1142 gfc_restore_backend_locus (locus * loc)
1143 {
1144   gfc_set_backend_locus (loc);
1145   gfc_free (loc->lb);
1146 }
1147
1148
1149 /* Translate an executable statement. The tree cond is used by gfc_trans_do.
1150    This static function is wrapped by gfc_trans_code_cond and
1151    gfc_trans_code.  */
1152
1153 static tree
1154 trans_code (gfc_code * code, tree cond)
1155 {
1156   stmtblock_t block;
1157   tree res;
1158
1159   if (!code)
1160     return build_empty_stmt (input_location);
1161
1162   gfc_start_block (&block);
1163
1164   /* Translate statements one by one into GENERIC trees until we reach
1165      the end of this gfc_code branch.  */
1166   for (; code; code = code->next)
1167     {
1168       if (code->here != 0)
1169         {
1170           res = gfc_trans_label_here (code);
1171           gfc_add_expr_to_block (&block, res);
1172         }
1173
1174       gfc_set_backend_locus (&code->loc);
1175
1176       switch (code->op)
1177         {
1178         case EXEC_NOP:
1179         case EXEC_END_BLOCK:
1180         case EXEC_END_PROCEDURE:
1181           res = NULL_TREE;
1182           break;
1183
1184         case EXEC_ASSIGN:
1185           if (code->expr1->ts.type == BT_CLASS)
1186             res = gfc_trans_class_assign (code->expr1, code->expr2, code->op);
1187           else
1188             res = gfc_trans_assign (code);
1189           break;
1190
1191         case EXEC_LABEL_ASSIGN:
1192           res = gfc_trans_label_assign (code);
1193           break;
1194
1195         case EXEC_POINTER_ASSIGN:
1196           if (code->expr1->ts.type == BT_CLASS)
1197             res = gfc_trans_class_assign (code->expr1, code->expr2, code->op);
1198           else
1199             res = gfc_trans_pointer_assign (code);
1200           break;
1201
1202         case EXEC_INIT_ASSIGN:
1203           if (code->expr1->ts.type == BT_CLASS)
1204             res = gfc_trans_class_init_assign (code);
1205           else
1206             res = gfc_trans_init_assign (code);
1207           break;
1208
1209         case EXEC_CONTINUE:
1210           res = NULL_TREE;
1211           break;
1212
1213         case EXEC_CRITICAL:
1214           res = gfc_trans_critical (code);
1215           break;
1216
1217         case EXEC_CYCLE:
1218           res = gfc_trans_cycle (code);
1219           break;
1220
1221         case EXEC_EXIT:
1222           res = gfc_trans_exit (code);
1223           break;
1224
1225         case EXEC_GOTO:
1226           res = gfc_trans_goto (code);
1227           break;
1228
1229         case EXEC_ENTRY:
1230           res = gfc_trans_entry (code);
1231           break;
1232
1233         case EXEC_PAUSE:
1234           res = gfc_trans_pause (code);
1235           break;
1236
1237         case EXEC_STOP:
1238         case EXEC_ERROR_STOP:
1239           res = gfc_trans_stop (code, code->op == EXEC_ERROR_STOP);
1240           break;
1241
1242         case EXEC_CALL:
1243           /* For MVBITS we've got the special exception that we need a
1244              dependency check, too.  */
1245           {
1246             bool is_mvbits = false;
1247             if (code->resolved_isym
1248                 && code->resolved_isym->id == GFC_ISYM_MVBITS)
1249               is_mvbits = true;
1250             if (code->resolved_isym
1251                 && code->resolved_isym->id == GFC_ISYM_MOVE_ALLOC)
1252               res = gfc_conv_intrinsic_move_alloc (code);
1253             else
1254               res = gfc_trans_call (code, is_mvbits, NULL_TREE,
1255                                     NULL_TREE, false);
1256           }
1257           break;
1258
1259         case EXEC_CALL_PPC:
1260           res = gfc_trans_call (code, false, NULL_TREE,
1261                                 NULL_TREE, false);
1262           break;
1263
1264         case EXEC_ASSIGN_CALL:
1265           res = gfc_trans_call (code, true, NULL_TREE,
1266                                 NULL_TREE, false);
1267           break;
1268
1269         case EXEC_RETURN:
1270           res = gfc_trans_return (code);
1271           break;
1272
1273         case EXEC_IF:
1274           res = gfc_trans_if (code);
1275           break;
1276
1277         case EXEC_ARITHMETIC_IF:
1278           res = gfc_trans_arithmetic_if (code);
1279           break;
1280
1281         case EXEC_BLOCK:
1282           res = gfc_trans_block_construct (code);
1283           break;
1284
1285         case EXEC_DO:
1286           res = gfc_trans_do (code, cond);
1287           break;
1288
1289         case EXEC_DO_WHILE:
1290           res = gfc_trans_do_while (code);
1291           break;
1292
1293         case EXEC_SELECT:
1294           res = gfc_trans_select (code);
1295           break;
1296
1297         case EXEC_SELECT_TYPE:
1298           /* Do nothing. SELECT TYPE statements should be transformed into
1299           an ordinary SELECT CASE at resolution stage.
1300           TODO: Add an error message here once this is done.  */
1301           res = NULL_TREE;
1302           break;
1303
1304         case EXEC_FLUSH:
1305           res = gfc_trans_flush (code);
1306           break;
1307
1308         case EXEC_SYNC_ALL:
1309         case EXEC_SYNC_IMAGES:
1310         case EXEC_SYNC_MEMORY:
1311           res = gfc_trans_sync (code, code->op);
1312           break;
1313
1314         case EXEC_FORALL:
1315           res = gfc_trans_forall (code);
1316           break;
1317
1318         case EXEC_WHERE:
1319           res = gfc_trans_where (code);
1320           break;
1321
1322         case EXEC_ALLOCATE:
1323           res = gfc_trans_allocate (code);
1324           break;
1325
1326         case EXEC_DEALLOCATE:
1327           res = gfc_trans_deallocate (code);
1328           break;
1329
1330         case EXEC_OPEN:
1331           res = gfc_trans_open (code);
1332           break;
1333
1334         case EXEC_CLOSE:
1335           res = gfc_trans_close (code);
1336           break;
1337
1338         case EXEC_READ:
1339           res = gfc_trans_read (code);
1340           break;
1341
1342         case EXEC_WRITE:
1343           res = gfc_trans_write (code);
1344           break;
1345
1346         case EXEC_IOLENGTH:
1347           res = gfc_trans_iolength (code);
1348           break;
1349
1350         case EXEC_BACKSPACE:
1351           res = gfc_trans_backspace (code);
1352           break;
1353
1354         case EXEC_ENDFILE:
1355           res = gfc_trans_endfile (code);
1356           break;
1357
1358         case EXEC_INQUIRE:
1359           res = gfc_trans_inquire (code);
1360           break;
1361
1362         case EXEC_WAIT:
1363           res = gfc_trans_wait (code);
1364           break;
1365
1366         case EXEC_REWIND:
1367           res = gfc_trans_rewind (code);
1368           break;
1369
1370         case EXEC_TRANSFER:
1371           res = gfc_trans_transfer (code);
1372           break;
1373
1374         case EXEC_DT_END:
1375           res = gfc_trans_dt_end (code);
1376           break;
1377
1378         case EXEC_OMP_ATOMIC:
1379         case EXEC_OMP_BARRIER:
1380         case EXEC_OMP_CRITICAL:
1381         case EXEC_OMP_DO:
1382         case EXEC_OMP_FLUSH:
1383         case EXEC_OMP_MASTER:
1384         case EXEC_OMP_ORDERED:
1385         case EXEC_OMP_PARALLEL:
1386         case EXEC_OMP_PARALLEL_DO:
1387         case EXEC_OMP_PARALLEL_SECTIONS:
1388         case EXEC_OMP_PARALLEL_WORKSHARE:
1389         case EXEC_OMP_SECTIONS:
1390         case EXEC_OMP_SINGLE:
1391         case EXEC_OMP_TASK:
1392         case EXEC_OMP_TASKWAIT:
1393         case EXEC_OMP_WORKSHARE:
1394           res = gfc_trans_omp_directive (code);
1395           break;
1396
1397         default:
1398           internal_error ("gfc_trans_code(): Bad statement code");
1399         }
1400
1401       gfc_set_backend_locus (&code->loc);
1402
1403       if (res != NULL_TREE && ! IS_EMPTY_STMT (res))
1404         {
1405           if (TREE_CODE (res) != STATEMENT_LIST)
1406             SET_EXPR_LOCATION (res, input_location);
1407
1408           /* Add the new statement to the block.  */
1409           gfc_add_expr_to_block (&block, res);
1410         }
1411     }
1412
1413   /* Return the finished block.  */
1414   return gfc_finish_block (&block);
1415 }
1416
1417
1418 /* Translate an executable statement with condition, cond.  The condition is
1419    used by gfc_trans_do to test for IO result conditions inside implied
1420    DO loops of READ and WRITE statements.  See build_dt in trans-io.c.  */
1421
1422 tree
1423 gfc_trans_code_cond (gfc_code * code, tree cond)
1424 {
1425   return trans_code (code, cond);
1426 }
1427
1428 /* Translate an executable statement without condition.  */
1429
1430 tree
1431 gfc_trans_code (gfc_code * code)
1432 {
1433   return trans_code (code, NULL_TREE);
1434 }
1435
1436
1437 /* This function is called after a complete program unit has been parsed
1438    and resolved.  */
1439
1440 void
1441 gfc_generate_code (gfc_namespace * ns)
1442 {
1443   ompws_flags = 0;
1444   if (ns->is_block_data)
1445     {
1446       gfc_generate_block_data (ns);
1447       return;
1448     }
1449
1450   gfc_generate_function_code (ns);
1451 }
1452
1453
1454 /* This function is called after a complete module has been parsed
1455    and resolved.  */
1456
1457 void
1458 gfc_generate_module_code (gfc_namespace * ns)
1459 {
1460   gfc_namespace *n;
1461   struct module_htab_entry *entry;
1462
1463   gcc_assert (ns->proc_name->backend_decl == NULL);
1464   ns->proc_name->backend_decl
1465     = build_decl (ns->proc_name->declared_at.lb->location,
1466                   NAMESPACE_DECL, get_identifier (ns->proc_name->name),
1467                   void_type_node);
1468   entry = gfc_find_module (ns->proc_name->name);
1469   if (entry->namespace_decl)
1470     /* Buggy sourcecode, using a module before defining it?  */
1471     htab_empty (entry->decls);
1472   entry->namespace_decl = ns->proc_name->backend_decl;
1473
1474   gfc_generate_module_vars (ns);
1475
1476   /* We need to generate all module function prototypes first, to allow
1477      sibling calls.  */
1478   for (n = ns->contained; n; n = n->sibling)
1479     {
1480       gfc_entry_list *el;
1481
1482       if (!n->proc_name)
1483         continue;
1484
1485       gfc_create_function_decl (n, false);
1486       DECL_CONTEXT (n->proc_name->backend_decl) = ns->proc_name->backend_decl;
1487       gfc_module_add_decl (entry, n->proc_name->backend_decl);
1488       for (el = ns->entries; el; el = el->next)
1489         {
1490           DECL_CONTEXT (el->sym->backend_decl) = ns->proc_name->backend_decl;
1491           gfc_module_add_decl (entry, el->sym->backend_decl);
1492         }
1493     }
1494
1495   for (n = ns->contained; n; n = n->sibling)
1496     {
1497       if (!n->proc_name)
1498         continue;
1499
1500       gfc_generate_function_code (n);
1501     }
1502 }
1503
1504
1505 /* Initialize an init/cleanup block with existing code.  */
1506
1507 void
1508 gfc_start_wrapped_block (gfc_wrapped_block* block, tree code)
1509 {
1510   gcc_assert (block);
1511
1512   block->init = NULL_TREE;
1513   block->code = code;
1514   block->cleanup = NULL_TREE;
1515 }
1516
1517
1518 /* Add a new pair of initializers/clean-up code.  */
1519
1520 void
1521 gfc_add_init_cleanup (gfc_wrapped_block* block, tree init, tree cleanup)
1522 {
1523   gcc_assert (block);
1524
1525   /* The new pair of init/cleanup should be "wrapped around" the existing
1526      block of code, thus the initialization is added to the front and the
1527      cleanup to the back.  */
1528   add_expr_to_chain (&block->init, init, true);
1529   add_expr_to_chain (&block->cleanup, cleanup, false);
1530 }
1531
1532
1533 /* Finish up a wrapped block by building a corresponding try-finally expr.  */
1534
1535 tree
1536 gfc_finish_wrapped_block (gfc_wrapped_block* block)
1537 {
1538   tree result;
1539
1540   gcc_assert (block);
1541
1542   /* Build the final expression.  For this, just add init and body together,
1543      and put clean-up with that into a TRY_FINALLY_EXPR.  */
1544   result = block->init;
1545   add_expr_to_chain (&result, block->code, false);
1546   if (block->cleanup)
1547     result = build2_loc (input_location, TRY_FINALLY_EXPR, void_type_node,
1548                          result, block->cleanup);
1549
1550   /* Clear the block.  */
1551   block->init = NULL_TREE;
1552   block->code = NULL_TREE;
1553   block->cleanup = NULL_TREE;
1554
1555   return result;
1556 }