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