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