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