gcc/fortran/trans.c

   1 /* Code translation -- generate GCC trees from gfc_code.
   2    Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 Free
   3    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"
  27 #include "tree-iterator.h"
  28 #include "ggc.h"
  29 #include "toplev.h"
  30 #include "defaults.h"
  31 #include "real.h"
  32 #include "flags.h"
  33 #include "gfortran.h"
  34 #include "trans.h"
  35 #include "trans-stmt.h"
  36 #include "trans-array.h"
  37 #include "trans-types.h"
  38 #include "trans-const.h"
  39
  40 /* Naming convention for backend interface code:
  41
  42    gfc_trans_*  translate gfc_code into STMT trees.
  43
  44    gfc_conv_*   expression conversion
  45
  46    gfc_get_*    get a backend tree representation of a decl or type  */
  47
  48 static gfc_file *gfc_current_backend_file;
  49
  50 const char gfc_msg_bounds[] = N_("Array bound mismatch");
  51 const char gfc_msg_fault[] = N_("Array reference out of bounds");
  52 const char gfc_msg_wrong_return[] = N_("Incorrect function return value");
  53
  54
  55 /* Advance along TREE_CHAIN n times.  */
  56
  57 tree
  58 gfc_advance_chain (tree t, int n)
  59 {
  60   for (; n > 0; n--)
  61     {
  62       gcc_assert (t != NULL_TREE);
  63       t = TREE_CHAIN (t);
  64     }
  65   return t;
  66 }
  67
  68
  69 /* Wrap a node in a TREE_LIST node and add it to the end of a list.  */
  70
  71 tree
  72 gfc_chainon_list (tree list, tree add)
  73 {
  74   tree l;
  75
  76   l = tree_cons (NULL_TREE, add, NULL_TREE);
  77
  78   return chainon (list, l);
  79 }
  80
  81
  82 /* Strip off a legitimate source ending from the input
  83    string NAME of length LEN.  */
  84
  85 static inline void
  86 remove_suffix (char *name, int len)
  87 {
  88   int i;
  89
  90   for (i = 2; i < 8 && len > i; i++)
  91     {
  92       if (name[len - i] == '.')
  93         {
  94           name[len - i] = '\0';
  95           break;
  96         }
  97     }
  98 }
  99
 100
 101 /* Creates a variable declaration with a given TYPE.  */
 102
 103 tree
 104 gfc_create_var_np (tree type, const char *prefix)
 105 {
 106   tree t;
 107
 108   t = create_tmp_var_raw (type, prefix);
 109
 110   /* No warnings for anonymous variables.  */
 111   if (prefix == NULL)
 112     TREE_NO_WARNING (t) = 1;
 113
 114   return t;
 115 }
 116
 117
 118 /* Like above, but also adds it to the current scope.  */
 119
 120 tree
 121 gfc_create_var (tree type, const char *prefix)
 122 {
 123   tree tmp;
 124
 125   tmp = gfc_create_var_np (type, prefix);
 126
 127   pushdecl (tmp);
 128
 129   return tmp;
 130 }
 131
 132
 133 /* If the expression is not constant, evaluate it now.  We assign the
 134    result of the expression to an artificially created variable VAR, and
 135    return a pointer to the VAR_DECL node for this variable.  */
 136
 137 tree
 138 gfc_evaluate_now (tree expr, stmtblock_t * pblock)
 139 {
 140   tree var;
 141
 142   if (CONSTANT_CLASS_P (expr))
 143     return expr;
 144
 145   var = gfc_create_var (TREE_TYPE (expr), NULL);
 146   gfc_add_modify (pblock, var, expr);
 147
 148   return var;
 149 }
 150
 151
 152 /* Build a MODIFY_EXPR node and add it to a given statement block PBLOCK.
 153    A MODIFY_EXPR is an assignment:
 154    LHS <- RHS.  */
 155
 156 void
 157 gfc_add_modify (stmtblock_t * pblock, tree lhs, tree rhs)
 158 {
 159   tree tmp;
 160
 161 #ifdef ENABLE_CHECKING
 162   tree t1, t2;
 163   t1 = TREE_TYPE (rhs);
 164   t2 = TREE_TYPE (lhs);
 165   /* ??? This is actually backwards, we should test the "base" type
 166      from which the nontarget_type was copied, but we don't have this
 167      backlink.  This will do for now, it's for checking anyway.  */
 168   if (TYPE_LANG_SPECIFIC (t1))
 169     t1 = TYPE_LANG_SPECIFIC (t1)->nontarget_type;
 170   if (TYPE_LANG_SPECIFIC (t2))
 171     t2 = TYPE_LANG_SPECIFIC (t2)->nontarget_type;
 172   /* Make sure that the types of the rhs and the lhs are the same
 173      for scalar assignments.  We should probably have something
 174      similar for aggregates, but right now removing that check just
 175      breaks everything.  */
 176   gcc_assert (t1 == t2
 177               || AGGREGATE_TYPE_P (TREE_TYPE (lhs)));
 178 #endif
 179
 180   tmp = fold_build2 (MODIFY_EXPR, void_type_node, lhs, rhs);
 181   gfc_add_expr_to_block (pblock, tmp);
 182 }
 183
 184
 185 /* Create a new scope/binding level and initialize a block.  Care must be
 186    taken when translating expressions as any temporaries will be placed in
 187    the innermost scope.  */
 188
 189 void
 190 gfc_start_block (stmtblock_t * block)
 191 {
 192   /* Start a new binding level.  */
 193   pushlevel (0);
 194   block->has_scope = 1;
 195
 196   /* The block is empty.  */
 197   block->head = NULL_TREE;
 198 }
 199
 200
 201 /* Initialize a block without creating a new scope.  */
 202
 203 void
 204 gfc_init_block (stmtblock_t * block)
 205 {
 206   block->head = NULL_TREE;
 207   block->has_scope = 0;
 208 }
 209
 210
 211 /* Sometimes we create a scope but it turns out that we don't actually
 212    need it.  This function merges the scope of BLOCK with its parent.
 213    Only variable decls will be merged, you still need to add the code.  */
 214
 215 void
 216 gfc_merge_block_scope (stmtblock_t * block)
 217 {
 218   tree decl;
 219   tree next;
 220
 221   gcc_assert (block->has_scope);
 222   block->has_scope = 0;
 223
 224   /* Remember the decls in this scope.  */
 225   decl = getdecls ();
 226   poplevel (0, 0, 0);
 227
 228   /* Add them to the parent scope.  */
 229   while (decl != NULL_TREE)
 230     {
 231       next = TREE_CHAIN (decl);
 232       TREE_CHAIN (decl) = NULL_TREE;
 233
 234       pushdecl (decl);
 235       decl = next;
 236     }
 237 }
 238
 239
 240 /* Finish a scope containing a block of statements.  */
 241
 242 tree
 243 gfc_finish_block (stmtblock_t * stmtblock)
 244 {
 245   tree decl;
 246   tree expr;
 247   tree block;
 248
 249   expr = stmtblock->head;
 250   if (!expr)
 251     expr = build_empty_stmt (input_location);
 252
 253   stmtblock->head = NULL_TREE;
 254
 255   if (stmtblock->has_scope)
 256     {
 257       decl = getdecls ();
 258
 259       if (decl)
 260         {
 261           block = poplevel (1, 0, 0);
 262           expr = build3_v (BIND_EXPR, decl, expr, block);
 263         }
 264       else
 265         poplevel (0, 0, 0);
 266     }
 267
 268   return expr;
 269 }
 270
 271
 272 /* Build an ADDR_EXPR and cast the result to TYPE.  If TYPE is NULL, the
 273    natural type is used.  */
 274
 275 tree
 276 gfc_build_addr_expr (tree type, tree t)
 277 {
 278   tree base_type = TREE_TYPE (t);
 279   tree natural_type;
 280
 281   if (type && POINTER_TYPE_P (type)
 282       && TREE_CODE (base_type) == ARRAY_TYPE
 283       && TYPE_MAIN_VARIANT (TREE_TYPE (type))
 284          == TYPE_MAIN_VARIANT (TREE_TYPE (base_type)))
 285     {
 286       tree min_val = size_zero_node;
 287       tree type_domain = TYPE_DOMAIN (base_type);
 288       if (type_domain && TYPE_MIN_VALUE (type_domain))
 289         min_val = TYPE_MIN_VALUE (type_domain);
 290       t = fold (build4 (ARRAY_REF, TREE_TYPE (type),
 291                         t, min_val, NULL_TREE, NULL_TREE));
 292       natural_type = type;
 293     }
 294   else
 295     natural_type = build_pointer_type (base_type);
 296
 297   if (TREE_CODE (t) == INDIRECT_REF)
 298     {
 299       if (!type)
 300         type = natural_type;
 301       t = TREE_OPERAND (t, 0);
 302       natural_type = TREE_TYPE (t);
 303     }
 304   else
 305     {
 306       tree base = get_base_address (t);
 307       if (base && DECL_P (base))
 308         TREE_ADDRESSABLE (base) = 1;
 309       t = fold_build1 (ADDR_EXPR, natural_type, t);
 310     }
 311
 312   if (type && natural_type != type)
 313     t = convert (type, t);
 314
 315   return t;
 316 }
 317
 318
 319 /* Build an ARRAY_REF with its natural type.  */
 320
 321 tree
 322 gfc_build_array_ref (tree base, tree offset, tree decl)
 323 {
 324   tree type = TREE_TYPE (base);
 325   tree tmp;
 326
 327   gcc_assert (TREE_CODE (type) == ARRAY_TYPE);
 328   type = TREE_TYPE (type);
 329
 330   if (DECL_P (base))
 331     TREE_ADDRESSABLE (base) = 1;
 332
 333   /* Strip NON_LVALUE_EXPR nodes.  */
 334   STRIP_TYPE_NOPS (offset);
 335
 336   /* If the array reference is to a pointer, whose target contains a
 337      subreference, use the span that is stored with the backend decl
 338      and reference the element with pointer arithmetic.  */
 339   if (decl && (TREE_CODE (decl) == FIELD_DECL
 340                  || TREE_CODE (decl) == VAR_DECL
 341                  || TREE_CODE (decl) == PARM_DECL)
 342         && GFC_DECL_SUBREF_ARRAY_P (decl)
 343         && !integer_zerop (GFC_DECL_SPAN(decl)))
 344     {
 345       offset = fold_build2 (MULT_EXPR, gfc_array_index_type,
 346                             offset, GFC_DECL_SPAN(decl));
 347       tmp = gfc_build_addr_expr (pvoid_type_node, base);
 348       tmp = fold_build2 (POINTER_PLUS_EXPR, pvoid_type_node,
 349                          tmp, fold_convert (sizetype, offset));
 350       tmp = fold_convert (build_pointer_type (type), tmp);
 351       if (!TYPE_STRING_FLAG (type))
 352         tmp = build_fold_indirect_ref_loc (input_location, tmp);
 353       return tmp;
 354     }
 355   else
 356     /* Otherwise use a straightforward array reference.  */
 357     return build4 (ARRAY_REF, type, base, offset, NULL_TREE, NULL_TREE);
 358 }
 359
 360
 361 /* Generate a call to print a runtime error possibly including multiple
 362    arguments and a locus.  */
 363
 364 tree
 365 gfc_trans_runtime_error (bool error, locus* where, const char* msgid, ...)
 366 {
 367   va_list ap;
 368
 369   va_start (ap, msgid);
 370   return gfc_trans_runtime_error_vararg (error, where, msgid, ap);
 371 }
 372
 373 tree
 374 gfc_trans_runtime_error_vararg (bool error, locus* where, const char* msgid,
 375                                 va_list ap)
 376 {
 377   stmtblock_t block;
 378   tree tmp;
 379   tree arg, arg2;
 380   tree *argarray;
 381   tree fntype;
 382   char *message;
 383   const char *p;
 384   int line, nargs, i;
 385
 386   /* Compute the number of extra arguments from the format string.  */
 387   for (p = msgid, nargs = 0; *p; p++)
 388     if (*p == '%')
 389       {
 390         p++;
 391         if (*p != '%')
 392           nargs++;
 393       }
 394
 395   /* The code to generate the error.  */
 396   gfc_start_block (&block);
 397
 398   if (where)
 399     {
 400       line = LOCATION_LINE (where->lb->location);
 401       asprintf (&message, "At line %d of file %s",  line,
 402                 where->lb->file->filename);
 403     }
 404   else
 405     asprintf (&message, "In file '%s', around line %d",
 406               gfc_source_file, input_line + 1);
 407
 408   arg = gfc_build_addr_expr (pchar_type_node,
 409                              gfc_build_localized_cstring_const (message));
 410   gfc_free(message);
 411
 412   asprintf (&message, "%s", _(msgid));
 413   arg2 = gfc_build_addr_expr (pchar_type_node,
 414                               gfc_build_localized_cstring_const (message));
 415   gfc_free(message);
 416
 417   /* Build the argument array.  */
 418   argarray = (tree *) alloca (sizeof (tree) * (nargs + 2));
 419   argarray[0] = arg;
 420   argarray[1] = arg2;
 421   for (i = 0; i < nargs; i++)
 422     argarray[2 + i] = va_arg (ap, tree);
 423   va_end (ap);
 424
 425   /* Build the function call to runtime_(warning,error)_at; because of the
 426      variable number of arguments, we can't use build_call_expr_loc dinput_location,
 427      irectly.  */
 428   if (error)
 429     fntype = TREE_TYPE (gfor_fndecl_runtime_error_at);
 430   else
 431     fntype = TREE_TYPE (gfor_fndecl_runtime_warning_at);
 432
 433   tmp = fold_builtin_call_array (input_location, TREE_TYPE (fntype),
 434                                  fold_build1 (ADDR_EXPR,
 435                                               build_pointer_type (fntype),
 436                                               error
 437                                               ? gfor_fndecl_runtime_error_at
 438                                               : gfor_fndecl_runtime_warning_at),
 439                                  nargs + 2, argarray);
 440   gfc_add_expr_to_block (&block, tmp);
 441
 442   return gfc_finish_block (&block);
 443 }
 444
 445
 446 /* Generate a runtime error if COND is true.  */
 447
 448 void
 449 gfc_trans_runtime_check (bool error, bool once, tree cond, stmtblock_t * pblock,
 450                          locus * where, const char * msgid, ...)
 451 {
 452   va_list ap;
 453   stmtblock_t block;
 454   tree body;
 455   tree tmp;
 456   tree tmpvar = NULL;
 457
 458   if (integer_zerop (cond))
 459     return;
 460
 461   if (once)
 462     {
 463        tmpvar = gfc_create_var (boolean_type_node, "print_warning");
 464        TREE_STATIC (tmpvar) = 1;
 465        DECL_INITIAL (tmpvar) = boolean_true_node;
 466        gfc_add_expr_to_block (pblock, tmpvar);
 467     }
 468
 469   gfc_start_block (&block);
 470
 471   /* The code to generate the error.  */
 472   va_start (ap, msgid);
 473   gfc_add_expr_to_block (&block,
 474                          gfc_trans_runtime_error_vararg (error, where,
 475                                                          msgid, ap));
 476
 477   if (once)
 478     gfc_add_modify (&block, tmpvar, boolean_false_node);
 479
 480   body = gfc_finish_block (&block);
 481
 482   if (integer_onep (cond))
 483     {
 484       gfc_add_expr_to_block (pblock, body);
 485     }
 486   else
 487     {
 488       /* Tell the compiler that this isn't likely.  */
 489       if (once)
 490         cond = fold_build2 (TRUTH_AND_EXPR, long_integer_type_node, tmpvar,
 491                             cond);
 492       else
 493         cond = fold_convert (long_integer_type_node, cond);
 494
 495       tmp = build_int_cst (long_integer_type_node, 0);
 496       cond = build_call_expr_loc (input_location,
 497                               built_in_decls[BUILT_IN_EXPECT], 2, cond, tmp);
 498       cond = fold_convert (boolean_type_node, cond);
 499
 500       tmp = build3_v (COND_EXPR, cond, body, build_empty_stmt (input_location));
 501       gfc_add_expr_to_block (pblock, tmp);
 502     }
 503 }
 504
 505
 506 /* Call malloc to allocate size bytes of memory, with special conditions:
 507       + if size < 0, generate a runtime error,
 508       + if size == 0, return a malloced area of size 1,
 509       + if malloc returns NULL, issue a runtime error.  */
 510 tree
 511 gfc_call_malloc (stmtblock_t * block, tree type, tree size)
 512 {
 513   tree tmp, msg, negative, malloc_result, null_result, res;
 514   stmtblock_t block2;
 515
 516   size = gfc_evaluate_now (size, block);
 517
 518   if (TREE_TYPE (size) != TREE_TYPE (size_type_node))
 519     size = fold_convert (size_type_node, size);
 520
 521   /* Create a variable to hold the result.  */
 522   res = gfc_create_var (prvoid_type_node, NULL);
 523
 524   /* size < 0 ?  */
 525   negative = fold_build2 (LT_EXPR, boolean_type_node, size,
 526                           build_int_cst (size_type_node, 0));
 527   msg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const
 528       ("Attempt to allocate a negative amount of memory."));
 529   tmp = fold_build3 (COND_EXPR, void_type_node, negative,
 530                      build_call_expr_loc (input_location,
 531                                       gfor_fndecl_runtime_error, 1, msg),
 532                      build_empty_stmt (input_location));
 533   gfc_add_expr_to_block (block, tmp);
 534
 535   /* Call malloc and check the result.  */
 536   gfc_start_block (&block2);
 537
 538   size = fold_build2 (MAX_EXPR, size_type_node, size,
 539                       build_int_cst (size_type_node, 1));
 540
 541   gfc_add_modify (&block2, res,
 542                   fold_convert (prvoid_type_node,
 543                                 build_call_expr_loc (input_location,
 544                                    built_in_decls[BUILT_IN_MALLOC], 1, size)));
 545   null_result = fold_build2 (EQ_EXPR, boolean_type_node, res,
 546                              build_int_cst (pvoid_type_node, 0));
 547   msg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const
 548       ("Memory allocation failed"));
 549   tmp = fold_build3 (COND_EXPR, void_type_node, null_result,
 550                      build_call_expr_loc (input_location,
 551                                       gfor_fndecl_os_error, 1, msg),
 552                      build_empty_stmt (input_location));
 553   gfc_add_expr_to_block (&block2, tmp);
 554   malloc_result = gfc_finish_block (&block2);
 555
 556   gfc_add_expr_to_block (block, malloc_result);
 557
 558   if (type != NULL)
 559     res = fold_convert (type, res);
 560   return res;
 561 }
 562
 563 /* Allocate memory, using an optional status argument.
 564
 565    This function follows the following pseudo-code:
 566
 567     void *
 568     allocate (size_t size, integer_type* stat)
 569     {
 570       void *newmem;
 571
 572       if (stat)
 573         *stat = 0;
 574
 575       // The only time this can happen is the size wraps around.
 576       if (size < 0)
 577       {
 578         if (stat)
 579         {
 580           *stat = LIBERROR_ALLOCATION;
 581           newmem = NULL;
 582         }
 583         else
 584           runtime_error ("Attempt to allocate negative amount of memory. "
 585                          "Possible integer overflow");
 586       }
 587       else
 588       {
 589         newmem = malloc (MAX (size, 1));
 590         if (newmem == NULL)
 591         {
 592           if (stat)
 593             *stat = LIBERROR_ALLOCATION;
 594           else
 595             runtime_error ("Out of memory");
 596         }
 597       }
 598
 599       return newmem;
 600     }  */
 601 tree
 602 gfc_allocate_with_status (stmtblock_t * block, tree size, tree status)
 603 {
 604   stmtblock_t alloc_block;
 605   tree res, tmp, error, msg, cond;
 606   tree status_type = status ? TREE_TYPE (TREE_TYPE (status)) : NULL_TREE;
 607
 608   /* Evaluate size only once, and make sure it has the right type.  */
 609   size = gfc_evaluate_now (size, block);
 610   if (TREE_TYPE (size) != TREE_TYPE (size_type_node))
 611     size = fold_convert (size_type_node, size);
 612
 613   /* Create a variable to hold the result.  */
 614   res = gfc_create_var (prvoid_type_node, NULL);
 615
 616   /* Set the optional status variable to zero.  */
 617   if (status != NULL_TREE && !integer_zerop (status))
 618     {
 619       tmp = fold_build2 (MODIFY_EXPR, status_type,
 620                          fold_build1 (INDIRECT_REF, status_type, status),
 621                          build_int_cst (status_type, 0));
 622       tmp = fold_build3 (COND_EXPR, void_type_node,
 623                          fold_build2 (NE_EXPR, boolean_type_node, status,
 624                                       build_int_cst (TREE_TYPE (status), 0)),
 625                          tmp, build_empty_stmt (input_location));
 626       gfc_add_expr_to_block (block, tmp);
 627     }
 628
 629   /* Generate the block of code handling (size < 0).  */
 630   msg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const
 631                         ("Attempt to allocate negative amount of memory. "
 632                          "Possible integer overflow"));
 633   error = build_call_expr_loc (input_location,
 634                            gfor_fndecl_runtime_error, 1, msg);
 635
 636   if (status != NULL_TREE && !integer_zerop (status))
 637     {
 638       /* Set the status variable if it's present.  */
 639       stmtblock_t set_status_block;
 640
 641       gfc_start_block (&set_status_block);
 642       gfc_add_modify (&set_status_block,
 643                       fold_build1 (INDIRECT_REF, status_type, status),
 644                            build_int_cst (status_type, LIBERROR_ALLOCATION));
 645       gfc_add_modify (&set_status_block, res,
 646                            build_int_cst (prvoid_type_node, 0));
 647
 648       tmp = fold_build2 (EQ_EXPR, boolean_type_node, status,
 649                          build_int_cst (TREE_TYPE (status), 0));
 650       error = fold_build3 (COND_EXPR, void_type_node, tmp, error,
 651                            gfc_finish_block (&set_status_block));
 652     }
 653
 654   /* The allocation itself.  */
 655   gfc_start_block (&alloc_block);
 656   gfc_add_modify (&alloc_block, res,
 657                   fold_convert (prvoid_type_node,
 658                                 build_call_expr_loc (input_location,
 659                                    built_in_decls[BUILT_IN_MALLOC], 1,
 660                                         fold_build2 (MAX_EXPR, size_type_node,
 661                                                      size,
 662                                                      build_int_cst (size_type_node, 1)))));
 663
 664   msg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const
 665                                                 ("Out of memory"));
 666   tmp = build_call_expr_loc (input_location,
 667                          gfor_fndecl_os_error, 1, msg);
 668
 669   if (status != NULL_TREE && !integer_zerop (status))
 670     {
 671       /* Set the status variable if it's present.  */
 672       tree tmp2;
 673
 674       cond = fold_build2 (EQ_EXPR, boolean_type_node, status,
 675                           build_int_cst (TREE_TYPE (status), 0));
 676       tmp2 = fold_build2 (MODIFY_EXPR, status_type,
 677                           fold_build1 (INDIRECT_REF, status_type, status),
 678                           build_int_cst (status_type, LIBERROR_ALLOCATION));
 679       tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp,
 680                          tmp2);
 681     }
 682
 683   tmp = fold_build3 (COND_EXPR, void_type_node,
 684                      fold_build2 (EQ_EXPR, boolean_type_node, res,
 685                                   build_int_cst (prvoid_type_node, 0)),
 686                      tmp, build_empty_stmt (input_location));
 687   gfc_add_expr_to_block (&alloc_block, tmp);
 688
 689   cond = fold_build2 (LT_EXPR, boolean_type_node, size,
 690                       build_int_cst (TREE_TYPE (size), 0));
 691   tmp = fold_build3 (COND_EXPR, void_type_node, cond, error,
 692                      gfc_finish_block (&alloc_block));
 693   gfc_add_expr_to_block (block, tmp);
 694
 695   return res;
 696 }
 697
 698
 699 /* Generate code for an ALLOCATE statement when the argument is an
 700    allocatable array.  If the array is currently allocated, it is an
 701    error to allocate it again.
 702
 703    This function follows the following pseudo-code:
 704
 705     void *
 706     allocate_array (void *mem, size_t size, integer_type *stat)
 707     {
 708       if (mem == NULL)
 709         return allocate (size, stat);
 710       else
 711       {
 712         if (stat)
 713         {
 714           free (mem);
 715           mem = allocate (size, stat);
 716           *stat = LIBERROR_ALLOCATION;
 717           return mem;
 718         }
 719         else
 720           runtime_error ("Attempting to allocate already allocated array");
 721     }
 722
 723     expr must be set to the original expression being allocated for its locus
 724     and variable name in case a runtime error has to be printed.  */
 725 tree
 726 gfc_allocate_array_with_status (stmtblock_t * block, tree mem, tree size,
 727                                 tree status, gfc_expr* expr)
 728 {
 729   stmtblock_t alloc_block;
 730   tree res, tmp, null_mem, alloc, error;
 731   tree type = TREE_TYPE (mem);
 732
 733   if (TREE_TYPE (size) != TREE_TYPE (size_type_node))
 734     size = fold_convert (size_type_node, size);
 735
 736   /* Create a variable to hold the result.  */
 737   res = gfc_create_var (type, NULL);
 738   null_mem = fold_build2 (EQ_EXPR, boolean_type_node, mem,
 739                           build_int_cst (type, 0));
 740
 741   /* If mem is NULL, we call gfc_allocate_with_status.  */
 742   gfc_start_block (&alloc_block);
 743   tmp = gfc_allocate_with_status (&alloc_block, size, status);
 744   gfc_add_modify (&alloc_block, res, fold_convert (type, tmp));
 745   alloc = gfc_finish_block (&alloc_block);
 746
 747   /* Otherwise, we issue a runtime error or set the status variable.  */
 748   if (expr)
 749     {
 750       tree varname;
 751
 752       gcc_assert (expr->expr_type == EXPR_VARIABLE && expr->symtree);
 753       varname = gfc_build_cstring_const (expr->symtree->name);
 754       varname = gfc_build_addr_expr (pchar_type_node, varname);
 755
 756       error = gfc_trans_runtime_error (true, &expr->where,
 757                                        "Attempting to allocate already"
 758                                        " allocated array '%s'",
 759                                        varname);
 760     }
 761   else
 762     error = gfc_trans_runtime_error (true, NULL,
 763                                      "Attempting to allocate already allocated"
 764                                      "array");
 765
 766   if (status != NULL_TREE && !integer_zerop (status))
 767     {
 768       tree status_type = TREE_TYPE (TREE_TYPE (status));
 769       stmtblock_t set_status_block;
 770
 771       gfc_start_block (&set_status_block);
 772       tmp = build_call_expr_loc (input_location,
 773                              built_in_decls[BUILT_IN_FREE], 1,
 774                              fold_convert (pvoid_type_node, mem));
 775       gfc_add_expr_to_block (&set_status_block, tmp);
 776
 777       tmp = gfc_allocate_with_status (&set_status_block, size, status);
 778       gfc_add_modify (&set_status_block, res, fold_convert (type, tmp));
 779
 780       gfc_add_modify (&set_status_block,
 781                            fold_build1 (INDIRECT_REF, status_type, status),
 782                            build_int_cst (status_type, LIBERROR_ALLOCATION));
 783
 784       tmp = fold_build2 (EQ_EXPR, boolean_type_node, status,
 785                          build_int_cst (status_type, 0));
 786       error = fold_build3 (COND_EXPR, void_type_node, tmp, error,
 787                            gfc_finish_block (&set_status_block));
 788     }
 789
 790   tmp = fold_build3 (COND_EXPR, void_type_node, null_mem, alloc, error);
 791   gfc_add_expr_to_block (block, tmp);
 792
 793   return res;
 794 }
 795
 796
 797 /* Free a given variable, if it's not NULL.  */
 798 tree
 799 gfc_call_free (tree var)
 800 {
 801   stmtblock_t block;
 802   tree tmp, cond, call;
 803
 804   if (TREE_TYPE (var) != TREE_TYPE (pvoid_type_node))
 805     var = fold_convert (pvoid_type_node, var);
 806
 807   gfc_start_block (&block);
 808   var = gfc_evaluate_now (var, &block);
 809   cond = fold_build2 (NE_EXPR, boolean_type_node, var,
 810                       build_int_cst (pvoid_type_node, 0));
 811   call = build_call_expr_loc (input_location,
 812                           built_in_decls[BUILT_IN_FREE], 1, var);
 813   tmp = fold_build3 (COND_EXPR, void_type_node, cond, call,
 814                      build_empty_stmt (input_location));
 815   gfc_add_expr_to_block (&block, tmp);
 816
 817   return gfc_finish_block (&block);
 818 }
 819
 820
 821
 822 /* User-deallocate; we emit the code directly from the front-end, and the
 823    logic is the same as the previous library function:
 824
 825     void
 826     deallocate (void *pointer, GFC_INTEGER_4 * stat)
 827     {
 828       if (!pointer)
 829         {
 830           if (stat)
 831             *stat = 1;
 832           else
 833             runtime_error ("Attempt to DEALLOCATE unallocated memory.");
 834         }
 835       else
 836         {
 837           free (pointer);
 838           if (stat)
 839             *stat = 0;
 840         }
 841     }
 842
 843    In this front-end version, status doesn't have to be GFC_INTEGER_4.
 844    Moreover, if CAN_FAIL is true, then we will not emit a runtime error,
 845    even when no status variable is passed to us (this is used for
 846    unconditional deallocation generated by the front-end at end of
 847    each procedure).
 848
 849    If a runtime-message is possible, `expr' must point to the original
 850    expression being deallocated for its locus and variable name.  */
 851 tree
 852 gfc_deallocate_with_status (tree pointer, tree status, bool can_fail,
 853                             gfc_expr* expr)
 854 {
 855   stmtblock_t null, non_null;
 856   tree cond, tmp, error;
 857
 858   cond = fold_build2 (EQ_EXPR, boolean_type_node, pointer,
 859                       build_int_cst (TREE_TYPE (pointer), 0));
 860
 861   /* When POINTER is NULL, we set STATUS to 1 if it's present, otherwise
 862      we emit a runtime error.  */
 863   gfc_start_block (&null);
 864   if (!can_fail)
 865     {
 866       tree varname;
 867
 868       gcc_assert (expr && expr->expr_type == EXPR_VARIABLE && expr->symtree);
 869
 870       varname = gfc_build_cstring_const (expr->symtree->name);
 871       varname = gfc_build_addr_expr (pchar_type_node, varname);
 872
 873       error = gfc_trans_runtime_error (true, &expr->where,
 874                                        "Attempt to DEALLOCATE unallocated '%s'",
 875                                        varname);
 876     }
 877   else
 878     error = build_empty_stmt (input_location);
 879
 880   if (status != NULL_TREE && !integer_zerop (status))
 881     {
 882       tree status_type = TREE_TYPE (TREE_TYPE (status));
 883       tree cond2;
 884
 885       cond2 = fold_build2 (NE_EXPR, boolean_type_node, status,
 886                            build_int_cst (TREE_TYPE (status), 0));
 887       tmp = fold_build2 (MODIFY_EXPR, status_type,
 888                          fold_build1 (INDIRECT_REF, status_type, status),
 889                          build_int_cst (status_type, 1));
 890       error = fold_build3 (COND_EXPR, void_type_node, cond2, tmp, error);
 891     }
 892
 893   gfc_add_expr_to_block (&null, error);
 894
 895   /* When POINTER is not NULL, we free it.  */
 896   gfc_start_block (&non_null);
 897   tmp = build_call_expr_loc (input_location,
 898                          built_in_decls[BUILT_IN_FREE], 1,
 899                          fold_convert (pvoid_type_node, pointer));
 900   gfc_add_expr_to_block (&non_null, tmp);
 901
 902   if (status != NULL_TREE && !integer_zerop (status))
 903     {
 904       /* We set STATUS to zero if it is present.  */
 905       tree status_type = TREE_TYPE (TREE_TYPE (status));
 906       tree cond2;
 907
 908       cond2 = fold_build2 (NE_EXPR, boolean_type_node, status,
 909                            build_int_cst (TREE_TYPE (status), 0));
 910       tmp = fold_build2 (MODIFY_EXPR, status_type,
 911                          fold_build1 (INDIRECT_REF, status_type, status),
 912                          build_int_cst (status_type, 0));
 913       tmp = fold_build3 (COND_EXPR, void_type_node, cond2, tmp,
 914                          build_empty_stmt (input_location));
 915       gfc_add_expr_to_block (&non_null, tmp);
 916     }
 917
 918   return fold_build3 (COND_EXPR, void_type_node, cond,
 919                       gfc_finish_block (&null), gfc_finish_block (&non_null));
 920 }
 921
 922
 923 /* Reallocate MEM so it has SIZE bytes of data.  This behaves like the
 924    following pseudo-code:
 925
 926 void *
 927 internal_realloc (void *mem, size_t size)
 928 {
 929   if (size < 0)
 930     runtime_error ("Attempt to allocate a negative amount of memory.");
 931   res = realloc (mem, size);
 932   if (!res && size != 0)
 933     _gfortran_os_error ("Out of memory");
 934
 935   if (size == 0)
 936     return NULL;
 937
 938   return res;
 939 }  */
 940 tree
 941 gfc_call_realloc (stmtblock_t * block, tree mem, tree size)
 942 {
 943   tree msg, res, negative, nonzero, zero, null_result, tmp;
 944   tree type = TREE_TYPE (mem);
 945
 946   size = gfc_evaluate_now (size, block);
 947
 948   if (TREE_TYPE (size) != TREE_TYPE (size_type_node))
 949     size = fold_convert (size_type_node, size);
 950
 951   /* Create a variable to hold the result.  */
 952   res = gfc_create_var (type, NULL);
 953
 954   /* size < 0 ?  */
 955   negative = fold_build2 (LT_EXPR, boolean_type_node, size,
 956                           build_int_cst (size_type_node, 0));
 957   msg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const
 958       ("Attempt to allocate a negative amount of memory."));
 959   tmp = fold_build3 (COND_EXPR, void_type_node, negative,
 960                      build_call_expr_loc (input_location,
 961                                       gfor_fndecl_runtime_error, 1, msg),
 962                      build_empty_stmt (input_location));
 963   gfc_add_expr_to_block (block, tmp);
 964
 965   /* Call realloc and check the result.  */
 966   tmp = build_call_expr_loc (input_location,
 967                          built_in_decls[BUILT_IN_REALLOC], 2,
 968                          fold_convert (pvoid_type_node, mem), size);
 969   gfc_add_modify (block, res, fold_convert (type, tmp));
 970   null_result = fold_build2 (EQ_EXPR, boolean_type_node, res,
 971                              build_int_cst (pvoid_type_node, 0));
 972   nonzero = fold_build2 (NE_EXPR, boolean_type_node, size,
 973                          build_int_cst (size_type_node, 0));
 974   null_result = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, null_result,
 975                              nonzero);
 976   msg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const
 977                                                 ("Out of memory"));
 978   tmp = fold_build3 (COND_EXPR, void_type_node, null_result,
 979                      build_call_expr_loc (input_location,
 980                                       gfor_fndecl_os_error, 1, msg),
 981                      build_empty_stmt (input_location));
 982   gfc_add_expr_to_block (block, tmp);
 983
 984   /* if (size == 0) then the result is NULL.  */
 985   tmp = fold_build2 (MODIFY_EXPR, type, res, build_int_cst (type, 0));
 986   zero = fold_build1 (TRUTH_NOT_EXPR, boolean_type_node, nonzero);
 987   tmp = fold_build3 (COND_EXPR, void_type_node, zero, tmp,
 988                      build_empty_stmt (input_location));
 989   gfc_add_expr_to_block (block, tmp);
 990
 991   return res;
 992 }
 993
 994 /* Add a statement to a block.  */
 995
 996 void
 997 gfc_add_expr_to_block (stmtblock_t * block, tree expr)
 998 {
 999   gcc_assert (block);
1000
1001   if (expr == NULL_TREE || IS_EMPTY_STMT (expr))
1002     return;
1003
1004   if (block->head)
1005     {
1006       if (TREE_CODE (block->head) != STATEMENT_LIST)
1007         {
1008           tree tmp;
1009
1010           tmp = block->head;
1011           block->head = NULL_TREE;
1012           append_to_statement_list (tmp, &block->head);
1013         }
1014       append_to_statement_list (expr, &block->head);
1015     }
1016   else
1017     /* Don't bother creating a list if we only have a single statement.  */
1018     block->head = expr;
1019 }
1020
1021
1022 /* Add a block the end of a block.  */
1023
1024 void
1025 gfc_add_block_to_block (stmtblock_t * block, stmtblock_t * append)
1026 {
1027   gcc_assert (append);
1028   gcc_assert (!append->has_scope);
1029
1030   gfc_add_expr_to_block (block, append->head);
1031   append->head = NULL_TREE;
1032 }
1033
1034
1035 /* Get the current locus.  The structure may not be complete, and should
1036    only be used with gfc_set_backend_locus.  */
1037
1038 void
1039 gfc_get_backend_locus (locus * loc)
1040 {
1041   loc->lb = XCNEW (gfc_linebuf);
1042   loc->lb->location = input_location;
1043   loc->lb->file = gfc_current_backend_file;
1044 }
1045
1046
1047 /* Set the current locus.  */
1048
1049 void
1050 gfc_set_backend_locus (locus * loc)
1051 {
1052   gfc_current_backend_file = loc->lb->file;
1053   input_location = loc->lb->location;
1054 }
1055
1056
1057 /* Translate an executable statement.  */
1058
1059 tree
1060 gfc_trans_code (gfc_code * code)
1061 {
1062   stmtblock_t block;
1063   tree res;
1064
1065   if (!code)
1066     return build_empty_stmt (input_location);
1067
1068   gfc_start_block (&block);
1069
1070   /* Translate statements one by one into GENERIC trees until we reach
1071      the end of this gfc_code branch.  */
1072   for (; code; code = code->next)
1073     {
1074       if (code->here != 0)
1075         {
1076           res = gfc_trans_label_here (code);
1077           gfc_add_expr_to_block (&block, res);
1078         }
1079
1080       switch (code->op)
1081         {
1082         case EXEC_NOP:
1083         case EXEC_END_BLOCK:
1084         case EXEC_END_PROCEDURE:
1085           res = NULL_TREE;
1086           break;
1087
1088         case EXEC_ASSIGN:
1089           res = gfc_trans_assign (code);
1090           break;
1091
1092         case EXEC_LABEL_ASSIGN:
1093           res = gfc_trans_label_assign (code);
1094           break;
1095
1096         case EXEC_POINTER_ASSIGN:
1097           res = gfc_trans_pointer_assign (code);
1098           break;
1099
1100         case EXEC_INIT_ASSIGN:
1101           res = gfc_trans_init_assign (code);
1102           break;
1103
1104         case EXEC_CONTINUE:
1105           res = NULL_TREE;
1106           break;
1107
1108         case EXEC_CYCLE:
1109           res = gfc_trans_cycle (code);
1110           break;
1111
1112         case EXEC_EXIT:
1113           res = gfc_trans_exit (code);
1114           break;
1115
1116         case EXEC_GOTO:
1117           res = gfc_trans_goto (code);
1118           break;
1119
1120         case EXEC_ENTRY:
1121           res = gfc_trans_entry (code);
1122           break;
1123
1124         case EXEC_PAUSE:
1125           res = gfc_trans_pause (code);
1126           break;
1127
1128         case EXEC_STOP:
1129           res = gfc_trans_stop (code);
1130           break;
1131
1132         case EXEC_CALL:
1133           /* For MVBITS we've got the special exception that we need a
1134              dependency check, too.  */
1135           {
1136             bool is_mvbits = false;
1137             if (code->resolved_isym
1138                 && code->resolved_isym->id == GFC_ISYM_MVBITS)
1139               is_mvbits = true;
1140             res = gfc_trans_call (code, is_mvbits, NULL_TREE,
1141                                   NULL_TREE, false);
1142           }
1143           break;
1144
1145         case EXEC_CALL_PPC:
1146           res = gfc_trans_call (code, false, NULL_TREE,
1147                                 NULL_TREE, false);
1148           break;
1149
1150         case EXEC_ASSIGN_CALL:
1151           res = gfc_trans_call (code, true, NULL_TREE,
1152                                 NULL_TREE, false);
1153           break;
1154
1155         case EXEC_RETURN:
1156           res = gfc_trans_return (code);
1157           break;
1158
1159         case EXEC_IF:
1160           res = gfc_trans_if (code);
1161           break;
1162
1163         case EXEC_ARITHMETIC_IF:
1164           res = gfc_trans_arithmetic_if (code);
1165           break;
1166
1167         case EXEC_DO:
1168           res = gfc_trans_do (code);
1169           break;
1170
1171         case EXEC_DO_WHILE:
1172           res = gfc_trans_do_while (code);
1173           break;
1174
1175         case EXEC_SELECT:
1176           res = gfc_trans_select (code);
1177           break;
1178
1179         case EXEC_FLUSH:
1180           res = gfc_trans_flush (code);
1181           break;
1182
1183         case EXEC_FORALL:
1184           res = gfc_trans_forall (code);
1185           break;
1186
1187         case EXEC_WHERE:
1188           res = gfc_trans_where (code);
1189           break;
1190
1191         case EXEC_ALLOCATE:
1192           res = gfc_trans_allocate (code);
1193           break;
1194
1195         case EXEC_DEALLOCATE:
1196           res = gfc_trans_deallocate (code);
1197           break;
1198
1199         case EXEC_OPEN:
1200           res = gfc_trans_open (code);
1201           break;
1202
1203         case EXEC_CLOSE:
1204           res = gfc_trans_close (code);
1205           break;
1206
1207         case EXEC_READ:
1208           res = gfc_trans_read (code);
1209           break;
1210
1211         case EXEC_WRITE:
1212           res = gfc_trans_write (code);
1213           break;
1214
1215         case EXEC_IOLENGTH:
1216           res = gfc_trans_iolength (code);
1217           break;
1218
1219         case EXEC_BACKSPACE:
1220           res = gfc_trans_backspace (code);
1221           break;
1222
1223         case EXEC_ENDFILE:
1224           res = gfc_trans_endfile (code);
1225           break;
1226
1227         case EXEC_INQUIRE:
1228           res = gfc_trans_inquire (code);
1229           break;
1230
1231         case EXEC_WAIT:
1232           res = gfc_trans_wait (code);
1233           break;
1234
1235         case EXEC_REWIND:
1236           res = gfc_trans_rewind (code);
1237           break;
1238
1239         case EXEC_TRANSFER:
1240           res = gfc_trans_transfer (code);
1241           break;
1242
1243         case EXEC_DT_END:
1244           res = gfc_trans_dt_end (code);
1245           break;
1246
1247         case EXEC_OMP_ATOMIC:
1248         case EXEC_OMP_BARRIER:
1249         case EXEC_OMP_CRITICAL:
1250         case EXEC_OMP_DO:
1251         case EXEC_OMP_FLUSH:
1252         case EXEC_OMP_MASTER:
1253         case EXEC_OMP_ORDERED:
1254         case EXEC_OMP_PARALLEL:
1255         case EXEC_OMP_PARALLEL_DO:
1256         case EXEC_OMP_PARALLEL_SECTIONS:
1257         case EXEC_OMP_PARALLEL_WORKSHARE:
1258         case EXEC_OMP_SECTIONS:
1259         case EXEC_OMP_SINGLE:
1260         case EXEC_OMP_TASK:
1261         case EXEC_OMP_TASKWAIT:
1262         case EXEC_OMP_WORKSHARE:
1263           res = gfc_trans_omp_directive (code);
1264           break;
1265
1266         default:
1267           internal_error ("gfc_trans_code(): Bad statement code");
1268         }
1269
1270       gfc_set_backend_locus (&code->loc);
1271
1272       if (res != NULL_TREE && ! IS_EMPTY_STMT (res))
1273         {
1274           if (TREE_CODE (res) == STATEMENT_LIST)
1275             tree_annotate_all_with_location (&res, input_location);
1276           else
1277             SET_EXPR_LOCATION (res, input_location);
1278
1279           /* Add the new statement to the block.  */
1280           gfc_add_expr_to_block (&block, res);
1281         }
1282     }
1283
1284   /* Return the finished block.  */
1285   return gfc_finish_block (&block);
1286 }
1287
1288
1289 /* This function is called after a complete program unit has been parsed
1290    and resolved.  */
1291
1292 void
1293 gfc_generate_code (gfc_namespace * ns)
1294 {
1295   ompws_flags = 0;
1296   if (ns->is_block_data)
1297     {
1298       gfc_generate_block_data (ns);
1299       return;
1300     }
1301
1302   gfc_generate_function_code (ns);
1303 }
1304
1305
1306 /* This function is called after a complete module has been parsed
1307    and resolved.  */
1308
1309 void
1310 gfc_generate_module_code (gfc_namespace * ns)
1311 {
1312   gfc_namespace *n;
1313   struct module_htab_entry *entry;
1314
1315   gcc_assert (ns->proc_name->backend_decl == NULL);
1316   ns->proc_name->backend_decl
1317     = build_decl (ns->proc_name->declared_at.lb->location,
1318                   NAMESPACE_DECL, get_identifier (ns->proc_name->name),
1319                   void_type_node);
1320   entry = gfc_find_module (ns->proc_name->name);
1321   if (entry->namespace_decl)
1322     /* Buggy sourcecode, using a module before defining it?  */
1323     htab_empty (entry->decls);
1324   entry->namespace_decl = ns->proc_name->backend_decl;
1325
1326   gfc_generate_module_vars (ns);
1327
1328   /* We need to generate all module function prototypes first, to allow
1329      sibling calls.  */
1330   for (n = ns->contained; n; n = n->sibling)
1331     {
1332       gfc_entry_list *el;
1333
1334       if (!n->proc_name)
1335         continue;
1336
1337       gfc_create_function_decl (n);
1338       gcc_assert (DECL_CONTEXT (n->proc_name->backend_decl) == NULL_TREE);
1339       DECL_CONTEXT (n->proc_name->backend_decl) = ns->proc_name->backend_decl;
1340       gfc_module_add_decl (entry, n->proc_name->backend_decl);
1341       for (el = ns->entries; el; el = el->next)
1342         {
1343           gcc_assert (DECL_CONTEXT (el->sym->backend_decl) == NULL_TREE);
1344           DECL_CONTEXT (el->sym->backend_decl) = ns->proc_name->backend_decl;
1345           gfc_module_add_decl (entry, el->sym->backend_decl);
1346         }
1347     }
1348
1349   for (n = ns->contained; n; n = n->sibling)
1350     {
1351       if (!n->proc_name)
1352         continue;
1353
1354       gfc_generate_function_code (n);
1355     }
1356 }
1357