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