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