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