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