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