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