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