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