gcc/fortran/trans.c

   1 /* Code translation -- generate GCC trees from gfc_code.
   2    Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
   3    Free Software Foundation, Inc.
   4    Contributed by Paul Brook
   5
   6 This file is part of GCC.
   7
   8 GCC is free software; you can redistribute it and/or modify it under
   9 the terms of the GNU General Public License as published by the Free
  10 Software Foundation; either version 3, or (at your option) any later
  11 version.
  12
  13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
  14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
  15 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  16 for more details.
  17
  18 You should have received a copy of the GNU General Public License
  19 along with GCC; see the file COPYING3.  If not see
  20 <http://www.gnu.org/licenses/>.  */
  21
  22 #include "config.h"
  23 #include "system.h"
  24 #include "coretypes.h"
  25 #include "tree.h"
  26 #include "gimple.h"     /* For create_tmp_var_raw.  */
  27 #include "tree-iterator.h"
  28 #include "toplev.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 = TREE_CHAIN (t);
  61     }
  62   return t;
  63 }
  64
  65
  66 /* Wrap a node in a TREE_LIST node and add it to the end of a list.  */
  67
  68 tree
  69 gfc_chainon_list (tree list, tree add)
  70 {
  71   tree l;
  72
  73   l = tree_cons (NULL_TREE, add, NULL_TREE);
  74
  75   return chainon (list, l);
  76 }
  77
  78
  79 /* Strip off a legitimate source ending from the input
  80    string NAME of length LEN.  */
  81
  82 static inline void
  83 remove_suffix (char *name, int len)
  84 {
  85   int i;
  86
  87   for (i = 2; i < 8 && len > i; i++)
  88     {
  89       if (name[len - i] == '.')
  90         {
  91           name[len - i] = '\0';
  92           break;
  93         }
  94     }
  95 }
  96
  97
  98 /* Creates a variable declaration with a given TYPE.  */
  99
 100 tree
 101 gfc_create_var_np (tree type, const char *prefix)
 102 {
 103   tree t;
 104
 105   t = create_tmp_var_raw (type, prefix);
 106
 107   /* No warnings for anonymous variables.  */
 108   if (prefix == NULL)
 109     TREE_NO_WARNING (t) = 1;
 110
 111   return t;
 112 }
 113
 114
 115 /* Like above, but also adds it to the current scope.  */
 116
 117 tree
 118 gfc_create_var (tree type, const char *prefix)
 119 {
 120   tree tmp;
 121
 122   tmp = gfc_create_var_np (type, prefix);
 123
 124   pushdecl (tmp);
 125
 126   return tmp;
 127 }
 128
 129
 130 /* If the expression is not constant, evaluate it now.  We assign the
 131    result of the expression to an artificially created variable VAR, and
 132    return a pointer to the VAR_DECL node for this variable.  */
 133
 134 tree
 135 gfc_evaluate_now (tree expr, stmtblock_t * pblock)
 136 {
 137   tree var;
 138
 139   if (CONSTANT_CLASS_P (expr))
 140     return expr;
 141
 142   var = gfc_create_var (TREE_TYPE (expr), NULL);
 143   gfc_add_modify (pblock, var, expr);
 144
 145   return var;
 146 }
 147
 148
 149 /* Build a MODIFY_EXPR node and add it to a given statement block PBLOCK.
 150    A MODIFY_EXPR is an assignment:
 151    LHS <- RHS.  */
 152
 153 void
 154 gfc_add_modify (stmtblock_t * pblock, tree lhs, tree rhs)
 155 {
 156   tree tmp;
 157
 158 #ifdef ENABLE_CHECKING
 159   tree t1, t2;
 160   t1 = TREE_TYPE (rhs);
 161   t2 = TREE_TYPE (lhs);
 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 (t1 == t2
 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 (input_location);
 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_loc (input_location, 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_loc dinput_location,
 417      irectly.  */
 418   if (error)
 419     fntype = TREE_TYPE (gfor_fndecl_runtime_error_at);
 420   else
 421     fntype = TREE_TYPE (gfor_fndecl_runtime_warning_at);
 422
 423   tmp = fold_builtin_call_array (input_location, TREE_TYPE (fntype),
 424                                  fold_build1 (ADDR_EXPR,
 425                                               build_pointer_type (fntype),
 426                                               error
 427                                               ? gfor_fndecl_runtime_error_at
 428                                               : gfor_fndecl_runtime_warning_at),
 429                                  nargs + 2, argarray);
 430   gfc_add_expr_to_block (&block, tmp);
 431
 432   return gfc_finish_block (&block);
 433 }
 434
 435
 436 /* Generate a runtime error if COND is true.  */
 437
 438 void
 439 gfc_trans_runtime_check (bool error, bool once, tree cond, stmtblock_t * pblock,
 440                          locus * where, const char * msgid, ...)
 441 {
 442   va_list ap;
 443   stmtblock_t block;
 444   tree body;
 445   tree tmp;
 446   tree tmpvar = NULL;
 447
 448   if (integer_zerop (cond))
 449     return;
 450
 451   if (once)
 452     {
 453        tmpvar = gfc_create_var (boolean_type_node, "print_warning");
 454        TREE_STATIC (tmpvar) = 1;
 455        DECL_INITIAL (tmpvar) = boolean_true_node;
 456        gfc_add_expr_to_block (pblock, tmpvar);
 457     }
 458
 459   gfc_start_block (&block);
 460
 461   /* The code to generate the error.  */
 462   va_start (ap, msgid);
 463   gfc_add_expr_to_block (&block,
 464                          gfc_trans_runtime_error_vararg (error, where,
 465                                                          msgid, ap));
 466
 467   if (once)
 468     gfc_add_modify (&block, tmpvar, boolean_false_node);
 469
 470   body = gfc_finish_block (&block);
 471
 472   if (integer_onep (cond))
 473     {
 474       gfc_add_expr_to_block (pblock, body);
 475     }
 476   else
 477     {
 478       /* Tell the compiler that this isn't likely.  */
 479       if (once)
 480         cond = fold_build2 (TRUTH_AND_EXPR, long_integer_type_node, tmpvar,
 481                             cond);
 482       else
 483         cond = fold_convert (long_integer_type_node, cond);
 484
 485       tmp = build_int_cst (long_integer_type_node, 0);
 486       cond = build_call_expr_loc (input_location,
 487                               built_in_decls[BUILT_IN_EXPECT], 2, cond, tmp);
 488       cond = fold_convert (boolean_type_node, cond);
 489
 490       tmp = build3_v (COND_EXPR, cond, body, build_empty_stmt (input_location));
 491       gfc_add_expr_to_block (pblock, tmp);
 492     }
 493 }
 494
 495
 496 /* Call malloc to allocate size bytes of memory, with special conditions:
 497       + if size <= 0, return a malloced area of size 1,
 498       + if malloc returns NULL, issue a runtime error.  */
 499 tree
 500 gfc_call_malloc (stmtblock_t * block, tree type, tree size)
 501 {
 502   tree tmp, msg, malloc_result, null_result, res;
 503   stmtblock_t block2;
 504
 505   size = gfc_evaluate_now (size, block);
 506
 507   if (TREE_TYPE (size) != TREE_TYPE (size_type_node))
 508     size = fold_convert (size_type_node, size);
 509
 510   /* Create a variable to hold the result.  */
 511   res = gfc_create_var (prvoid_type_node, NULL);
 512
 513   /* Call malloc.  */
 514   gfc_start_block (&block2);
 515
 516   size = fold_build2 (MAX_EXPR, size_type_node, size,
 517                       build_int_cst (size_type_node, 1));
 518
 519   gfc_add_modify (&block2, res,
 520                   fold_convert (prvoid_type_node,
 521                                 build_call_expr_loc (input_location,
 522                                    built_in_decls[BUILT_IN_MALLOC], 1, size)));
 523
 524   /* Optionally check whether malloc was successful.  */
 525   if (gfc_option.rtcheck & GFC_RTCHECK_MEM)
 526     {
 527       null_result = fold_build2 (EQ_EXPR, boolean_type_node, res,
 528                                  build_int_cst (pvoid_type_node, 0));
 529       msg = gfc_build_addr_expr (pchar_type_node,
 530               gfc_build_localized_cstring_const ("Memory allocation failed"));
 531       tmp = fold_build3 (COND_EXPR, void_type_node, null_result,
 532               build_call_expr_loc (input_location,
 533                                    gfor_fndecl_os_error, 1, msg),
 534                                    build_empty_stmt (input_location));
 535       gfc_add_expr_to_block (&block2, tmp);
 536     }
 537
 538   malloc_result = gfc_finish_block (&block2);
 539
 540   gfc_add_expr_to_block (block, malloc_result);
 541
 542   if (type != NULL)
 543     res = fold_convert (type, res);
 544   return res;
 545 }
 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 (prvoid_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 (input_location));
 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_loc (input_location,
 619                            gfor_fndecl_runtime_error, 1, msg);
 620
 621   if (status != NULL_TREE && !integer_zerop (status))
 622     {
 623       /* Set the status variable if it's present.  */
 624       stmtblock_t set_status_block;
 625
 626       gfc_start_block (&set_status_block);
 627       gfc_add_modify (&set_status_block,
 628                       fold_build1 (INDIRECT_REF, status_type, status),
 629                            build_int_cst (status_type, LIBERROR_ALLOCATION));
 630       gfc_add_modify (&set_status_block, res,
 631                            build_int_cst (prvoid_type_node, 0));
 632
 633       tmp = fold_build2 (EQ_EXPR, boolean_type_node, status,
 634                          build_int_cst (TREE_TYPE (status), 0));
 635       error = fold_build3 (COND_EXPR, void_type_node, tmp, error,
 636                            gfc_finish_block (&set_status_block));
 637     }
 638
 639   /* The allocation itself.  */
 640   gfc_start_block (&alloc_block);
 641   gfc_add_modify (&alloc_block, res,
 642                   fold_convert (prvoid_type_node,
 643                                 build_call_expr_loc (input_location,
 644                                    built_in_decls[BUILT_IN_MALLOC], 1,
 645                                         fold_build2 (MAX_EXPR, size_type_node,
 646                                                      size,
 647                                                      build_int_cst (size_type_node, 1)))));
 648
 649   msg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const
 650                                                 ("Out of memory"));
 651   tmp = build_call_expr_loc (input_location,
 652                          gfor_fndecl_os_error, 1, msg);
 653
 654   if (status != NULL_TREE && !integer_zerop (status))
 655     {
 656       /* Set the status variable if it's present.  */
 657       tree tmp2;
 658
 659       cond = fold_build2 (EQ_EXPR, boolean_type_node, status,
 660                           build_int_cst (TREE_TYPE (status), 0));
 661       tmp2 = fold_build2 (MODIFY_EXPR, status_type,
 662                           fold_build1 (INDIRECT_REF, status_type, status),
 663                           build_int_cst (status_type, LIBERROR_ALLOCATION));
 664       tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp,
 665                          tmp2);
 666     }
 667
 668   tmp = fold_build3 (COND_EXPR, void_type_node,
 669                      fold_build2 (EQ_EXPR, boolean_type_node, res,
 670                                   build_int_cst (prvoid_type_node, 0)),
 671                      tmp, build_empty_stmt (input_location));
 672   gfc_add_expr_to_block (&alloc_block, tmp);
 673
 674   cond = fold_build2 (LT_EXPR, boolean_type_node, size,
 675                       build_int_cst (TREE_TYPE (size), 0));
 676   tmp = fold_build3 (COND_EXPR, void_type_node, cond, error,
 677                      gfc_finish_block (&alloc_block));
 678   gfc_add_expr_to_block (block, tmp);
 679
 680   return res;
 681 }
 682
 683
 684 /* Generate code for an ALLOCATE statement when the argument is an
 685    allocatable array.  If the array is currently allocated, it is an
 686    error to allocate it again.
 687
 688    This function follows the following pseudo-code:
 689
 690     void *
 691     allocate_array (void *mem, size_t size, integer_type *stat)
 692     {
 693       if (mem == NULL)
 694         return allocate (size, stat);
 695       else
 696       {
 697         if (stat)
 698         {
 699           free (mem);
 700           mem = allocate (size, stat);
 701           *stat = LIBERROR_ALLOCATION;
 702           return mem;
 703         }
 704         else
 705           runtime_error ("Attempting to allocate already allocated variable");
 706       }
 707     }
 708
 709     expr must be set to the original expression being allocated for its locus
 710     and variable name in case a runtime error has to be printed.  */
 711 tree
 712 gfc_allocate_array_with_status (stmtblock_t * block, tree mem, tree size,
 713                                 tree status, gfc_expr* expr)
 714 {
 715   stmtblock_t alloc_block;
 716   tree res, tmp, null_mem, alloc, error;
 717   tree type = TREE_TYPE (mem);
 718
 719   if (TREE_TYPE (size) != TREE_TYPE (size_type_node))
 720     size = fold_convert (size_type_node, size);
 721
 722   /* Create a variable to hold the result.  */
 723   res = gfc_create_var (type, NULL);
 724   null_mem = fold_build2 (EQ_EXPR, boolean_type_node, mem,
 725                           build_int_cst (type, 0));
 726
 727   /* If mem is NULL, we call gfc_allocate_with_status.  */
 728   gfc_start_block (&alloc_block);
 729   tmp = gfc_allocate_with_status (&alloc_block, size, status);
 730   gfc_add_modify (&alloc_block, res, fold_convert (type, tmp));
 731   alloc = gfc_finish_block (&alloc_block);
 732
 733   /* Otherwise, we issue a runtime error or set the status variable.  */
 734   if (expr)
 735     {
 736       tree varname;
 737
 738       gcc_assert (expr->expr_type == EXPR_VARIABLE && expr->symtree);
 739       varname = gfc_build_cstring_const (expr->symtree->name);
 740       varname = gfc_build_addr_expr (pchar_type_node, varname);
 741
 742       error = gfc_trans_runtime_error (true, &expr->where,
 743                                        "Attempting to allocate already"
 744                                        " allocated variable '%s'",
 745                                        varname);
 746     }
 747   else
 748     error = gfc_trans_runtime_error (true, NULL,
 749                                      "Attempting to allocate already allocated"
 750                                      "variable");
 751
 752   if (status != NULL_TREE && !integer_zerop (status))
 753     {
 754       tree status_type = TREE_TYPE (TREE_TYPE (status));
 755       stmtblock_t set_status_block;
 756
 757       gfc_start_block (&set_status_block);
 758       tmp = build_call_expr_loc (input_location,
 759                              built_in_decls[BUILT_IN_FREE], 1,
 760                              fold_convert (pvoid_type_node, mem));
 761       gfc_add_expr_to_block (&set_status_block, tmp);
 762
 763       tmp = gfc_allocate_with_status (&set_status_block, size, status);
 764       gfc_add_modify (&set_status_block, res, fold_convert (type, tmp));
 765
 766       gfc_add_modify (&set_status_block,
 767                            fold_build1 (INDIRECT_REF, status_type, status),
 768                            build_int_cst (status_type, LIBERROR_ALLOCATION));
 769
 770       tmp = fold_build2 (EQ_EXPR, boolean_type_node, status,
 771                          build_int_cst (status_type, 0));
 772       error = fold_build3 (COND_EXPR, void_type_node, tmp, error,
 773                            gfc_finish_block (&set_status_block));
 774     }
 775
 776   tmp = fold_build3 (COND_EXPR, void_type_node, null_mem, alloc, error);
 777   gfc_add_expr_to_block (block, tmp);
 778
 779   return res;
 780 }
 781
 782
 783 /* Free a given variable, if it's not NULL.  */
 784 tree
 785 gfc_call_free (tree var)
 786 {
 787   stmtblock_t block;
 788   tree tmp, cond, call;
 789
 790   if (TREE_TYPE (var) != TREE_TYPE (pvoid_type_node))
 791     var = fold_convert (pvoid_type_node, var);
 792
 793   gfc_start_block (&block);
 794   var = gfc_evaluate_now (var, &block);
 795   cond = fold_build2 (NE_EXPR, boolean_type_node, var,
 796                       build_int_cst (pvoid_type_node, 0));
 797   call = build_call_expr_loc (input_location,
 798                           built_in_decls[BUILT_IN_FREE], 1, var);
 799   tmp = fold_build3 (COND_EXPR, void_type_node, cond, call,
 800                      build_empty_stmt (input_location));
 801   gfc_add_expr_to_block (&block, tmp);
 802
 803   return gfc_finish_block (&block);
 804 }
 805
 806
 807
 808 /* User-deallocate; we emit the code directly from the front-end, and the
 809    logic is the same as the previous library function:
 810
 811     void
 812     deallocate (void *pointer, GFC_INTEGER_4 * stat)
 813     {
 814       if (!pointer)
 815         {
 816           if (stat)
 817             *stat = 1;
 818           else
 819             runtime_error ("Attempt to DEALLOCATE unallocated memory.");
 820         }
 821       else
 822         {
 823           free (pointer);
 824           if (stat)
 825             *stat = 0;
 826         }
 827     }
 828
 829    In this front-end version, status doesn't have to be GFC_INTEGER_4.
 830    Moreover, if CAN_FAIL is true, then we will not emit a runtime error,
 831    even when no status variable is passed to us (this is used for
 832    unconditional deallocation generated by the front-end at end of
 833    each procedure).
 834
 835    If a runtime-message is possible, `expr' must point to the original
 836    expression being deallocated for its locus and variable name.  */
 837 tree
 838 gfc_deallocate_with_status (tree pointer, tree status, bool can_fail,
 839                             gfc_expr* expr)
 840 {
 841   stmtblock_t null, non_null;
 842   tree cond, tmp, error;
 843
 844   cond = fold_build2 (EQ_EXPR, boolean_type_node, pointer,
 845                       build_int_cst (TREE_TYPE (pointer), 0));
 846
 847   /* When POINTER is NULL, we set STATUS to 1 if it's present, otherwise
 848      we emit a runtime error.  */
 849   gfc_start_block (&null);
 850   if (!can_fail)
 851     {
 852       tree varname;
 853
 854       gcc_assert (expr && expr->expr_type == EXPR_VARIABLE && expr->symtree);
 855
 856       varname = gfc_build_cstring_const (expr->symtree->name);
 857       varname = gfc_build_addr_expr (pchar_type_node, varname);
 858
 859       error = gfc_trans_runtime_error (true, &expr->where,
 860                                        "Attempt to DEALLOCATE unallocated '%s'",
 861                                        varname);
 862     }
 863   else
 864     error = build_empty_stmt (input_location);
 865
 866   if (status != NULL_TREE && !integer_zerop (status))
 867     {
 868       tree status_type = TREE_TYPE (TREE_TYPE (status));
 869       tree cond2;
 870
 871       cond2 = fold_build2 (NE_EXPR, boolean_type_node, status,
 872                            build_int_cst (TREE_TYPE (status), 0));
 873       tmp = fold_build2 (MODIFY_EXPR, status_type,
 874                          fold_build1 (INDIRECT_REF, status_type, status),
 875                          build_int_cst (status_type, 1));
 876       error = fold_build3 (COND_EXPR, void_type_node, cond2, tmp, error);
 877     }
 878
 879   gfc_add_expr_to_block (&null, error);
 880
 881   /* When POINTER is not NULL, we free it.  */
 882   gfc_start_block (&non_null);
 883   tmp = build_call_expr_loc (input_location,
 884                          built_in_decls[BUILT_IN_FREE], 1,
 885                          fold_convert (pvoid_type_node, pointer));
 886   gfc_add_expr_to_block (&non_null, tmp);
 887
 888   if (status != NULL_TREE && !integer_zerop (status))
 889     {
 890       /* We set STATUS to zero if it is present.  */
 891       tree status_type = TREE_TYPE (TREE_TYPE (status));
 892       tree cond2;
 893
 894       cond2 = fold_build2 (NE_EXPR, boolean_type_node, status,
 895                            build_int_cst (TREE_TYPE (status), 0));
 896       tmp = fold_build2 (MODIFY_EXPR, status_type,
 897                          fold_build1 (INDIRECT_REF, status_type, status),
 898                          build_int_cst (status_type, 0));
 899       tmp = fold_build3 (COND_EXPR, void_type_node, cond2, tmp,
 900                          build_empty_stmt (input_location));
 901       gfc_add_expr_to_block (&non_null, tmp);
 902     }
 903
 904   return fold_build3 (COND_EXPR, void_type_node, cond,
 905                       gfc_finish_block (&null), gfc_finish_block (&non_null));
 906 }
 907
 908
 909 /* Reallocate MEM so it has SIZE bytes of data.  This behaves like the
 910    following pseudo-code:
 911
 912 void *
 913 internal_realloc (void *mem, size_t size)
 914 {
 915   if (size < 0)
 916     runtime_error ("Attempt to allocate a negative amount of memory.");
 917   res = realloc (mem, size);
 918   if (!res && size != 0)
 919     _gfortran_os_error ("Out of memory");
 920
 921   if (size == 0)
 922     return NULL;
 923
 924   return res;
 925 }  */
 926 tree
 927 gfc_call_realloc (stmtblock_t * block, tree mem, tree size)
 928 {
 929   tree msg, res, negative, nonzero, zero, null_result, tmp;
 930   tree type = TREE_TYPE (mem);
 931
 932   size = gfc_evaluate_now (size, block);
 933
 934   if (TREE_TYPE (size) != TREE_TYPE (size_type_node))
 935     size = fold_convert (size_type_node, size);
 936
 937   /* Create a variable to hold the result.  */
 938   res = gfc_create_var (type, NULL);
 939
 940   /* size < 0 ?  */
 941   negative = fold_build2 (LT_EXPR, boolean_type_node, size,
 942                           build_int_cst (size_type_node, 0));
 943   msg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const
 944       ("Attempt to allocate a negative amount of memory."));
 945   tmp = fold_build3 (COND_EXPR, void_type_node, negative,
 946                      build_call_expr_loc (input_location,
 947                                       gfor_fndecl_runtime_error, 1, msg),
 948                      build_empty_stmt (input_location));
 949   gfc_add_expr_to_block (block, tmp);
 950
 951   /* Call realloc and check the result.  */
 952   tmp = build_call_expr_loc (input_location,
 953                          built_in_decls[BUILT_IN_REALLOC], 2,
 954                          fold_convert (pvoid_type_node, mem), size);
 955   gfc_add_modify (block, res, fold_convert (type, tmp));
 956   null_result = fold_build2 (EQ_EXPR, boolean_type_node, res,
 957                              build_int_cst (pvoid_type_node, 0));
 958   nonzero = fold_build2 (NE_EXPR, boolean_type_node, size,
 959                          build_int_cst (size_type_node, 0));
 960   null_result = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, null_result,
 961                              nonzero);
 962   msg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const
 963                                                 ("Out of memory"));
 964   tmp = fold_build3 (COND_EXPR, void_type_node, null_result,
 965                      build_call_expr_loc (input_location,
 966                                       gfor_fndecl_os_error, 1, msg),
 967                      build_empty_stmt (input_location));
 968   gfc_add_expr_to_block (block, tmp);
 969
 970   /* if (size == 0) then the result is NULL.  */
 971   tmp = fold_build2 (MODIFY_EXPR, type, res, build_int_cst (type, 0));
 972   zero = fold_build1 (TRUTH_NOT_EXPR, boolean_type_node, nonzero);
 973   tmp = fold_build3 (COND_EXPR, void_type_node, zero, tmp,
 974                      build_empty_stmt (input_location));
 975   gfc_add_expr_to_block (block, tmp);
 976
 977   return res;
 978 }
 979
 980 /* Add a statement to a block.  */
 981
 982 void
 983 gfc_add_expr_to_block (stmtblock_t * block, tree expr)
 984 {
 985   gcc_assert (block);
 986
 987   if (expr == NULL_TREE || IS_EMPTY_STMT (expr))
 988     return;
 989
 990   if (block->head)
 991     {
 992       if (TREE_CODE (block->head) != STATEMENT_LIST)
 993         {
 994           tree tmp;
 995
 996           tmp = block->head;
 997           block->head = NULL_TREE;
 998           append_to_statement_list (tmp, &block->head);
 999         }
1000       append_to_statement_list (expr, &block->head);
1001     }
1002   else
1003     /* Don't bother creating a list if we only have a single statement.  */
1004     block->head = expr;
1005 }
1006
1007
1008 /* Add a block the end of a block.  */
1009
1010 void
1011 gfc_add_block_to_block (stmtblock_t * block, stmtblock_t * append)
1012 {
1013   gcc_assert (append);
1014   gcc_assert (!append->has_scope);
1015
1016   gfc_add_expr_to_block (block, append->head);
1017   append->head = NULL_TREE;
1018 }
1019
1020
1021 /* Get the current locus.  The structure may not be complete, and should
1022    only be used with gfc_set_backend_locus.  */
1023
1024 void
1025 gfc_get_backend_locus (locus * loc)
1026 {
1027   loc->lb = XCNEW (gfc_linebuf);
1028   loc->lb->location = input_location;
1029   loc->lb->file = gfc_current_backend_file;
1030 }
1031
1032
1033 /* Set the current locus.  */
1034
1035 void
1036 gfc_set_backend_locus (locus * loc)
1037 {
1038   gfc_current_backend_file = loc->lb->file;
1039   input_location = loc->lb->location;
1040 }
1041
1042
1043 /* Translate an executable statement. The tree cond is used by gfc_trans_do.
1044    This static function is wrapped by gfc_trans_code_cond and
1045    gfc_trans_code.  */
1046
1047 static tree
1048 trans_code (gfc_code * code, tree cond)
1049 {
1050   stmtblock_t block;
1051   tree res;
1052
1053   if (!code)
1054     return build_empty_stmt (input_location);
1055
1056   gfc_start_block (&block);
1057
1058   /* Translate statements one by one into GENERIC trees until we reach
1059      the end of this gfc_code branch.  */
1060   for (; code; code = code->next)
1061     {
1062       if (code->here != 0)
1063         {
1064           res = gfc_trans_label_here (code);
1065           gfc_add_expr_to_block (&block, res);
1066         }
1067
1068       gfc_set_backend_locus (&code->loc);
1069
1070       switch (code->op)
1071         {
1072         case EXEC_NOP:
1073         case EXEC_END_BLOCK:
1074         case EXEC_END_PROCEDURE:
1075           res = NULL_TREE;
1076           break;
1077
1078         case EXEC_ASSIGN:
1079           if (code->expr1->ts.type == BT_CLASS)
1080             res = gfc_trans_class_assign (code);
1081           else
1082             res = gfc_trans_assign (code);
1083           break;
1084
1085         case EXEC_LABEL_ASSIGN:
1086           res = gfc_trans_label_assign (code);
1087           break;
1088
1089         case EXEC_POINTER_ASSIGN:
1090           if (code->expr1->ts.type == BT_CLASS)
1091             res = gfc_trans_class_assign (code);
1092           else
1093             res = gfc_trans_pointer_assign (code);
1094           break;
1095
1096         case EXEC_INIT_ASSIGN:
1097           if (code->expr1->ts.type == BT_CLASS)
1098             res = gfc_trans_class_assign (code);
1099           else
1100             res = gfc_trans_init_assign (code);
1101           break;
1102
1103         case EXEC_CONTINUE:
1104           res = NULL_TREE;
1105           break;
1106
1107         case EXEC_CRITICAL:
1108           res = gfc_trans_critical (code);
1109           break;
1110
1111         case EXEC_CYCLE:
1112           res = gfc_trans_cycle (code);
1113           break;
1114
1115         case EXEC_EXIT:
1116           res = gfc_trans_exit (code);
1117           break;
1118
1119         case EXEC_GOTO:
1120           res = gfc_trans_goto (code);
1121           break;
1122
1123         case EXEC_ENTRY:
1124           res = gfc_trans_entry (code);
1125           break;
1126
1127         case EXEC_PAUSE:
1128           res = gfc_trans_pause (code);
1129           break;
1130
1131         case EXEC_STOP:
1132         case EXEC_ERROR_STOP:
1133           res = gfc_trans_stop (code, code->op == EXEC_ERROR_STOP);
1134           break;
1135
1136         case EXEC_CALL:
1137           /* For MVBITS we've got the special exception that we need a
1138              dependency check, too.  */
1139           {
1140             bool is_mvbits = false;
1141             if (code->resolved_isym
1142                 && code->resolved_isym->id == GFC_ISYM_MVBITS)
1143               is_mvbits = true;
1144             res = gfc_trans_call (code, is_mvbits, NULL_TREE,
1145                                   NULL_TREE, false);
1146           }
1147           break;
1148
1149         case EXEC_CALL_PPC:
1150           res = gfc_trans_call (code, false, NULL_TREE,
1151                                 NULL_TREE, false);
1152           break;
1153
1154         case EXEC_ASSIGN_CALL:
1155           res = gfc_trans_call (code, true, NULL_TREE,
1156                                 NULL_TREE, false);
1157           break;
1158
1159         case EXEC_RETURN:
1160           res = gfc_trans_return (code);
1161           break;
1162
1163         case EXEC_IF:
1164           res = gfc_trans_if (code);
1165           break;
1166
1167         case EXEC_ARITHMETIC_IF:
1168           res = gfc_trans_arithmetic_if (code);
1169           break;
1170
1171         case EXEC_BLOCK:
1172           res = gfc_trans_block_construct (code);
1173           break;
1174
1175         case EXEC_DO:
1176           res = gfc_trans_do (code, cond);
1177           break;
1178
1179         case EXEC_DO_WHILE:
1180           res = gfc_trans_do_while (code);
1181           break;
1182
1183         case EXEC_SELECT:
1184           res = gfc_trans_select (code);
1185           break;
1186
1187         case EXEC_SELECT_TYPE:
1188           /* Do nothing. SELECT TYPE statements should be transformed into
1189           an ordinary SELECT CASE at resolution stage.
1190           TODO: Add an error message here once this is done.  */
1191           res = NULL_TREE;
1192           break;
1193
1194         case EXEC_FLUSH:
1195           res = gfc_trans_flush (code);
1196           break;
1197
1198         case EXEC_SYNC_ALL:
1199         case EXEC_SYNC_IMAGES:
1200         case EXEC_SYNC_MEMORY:
1201           res = gfc_trans_sync (code, code->op);
1202           break;
1203
1204         case EXEC_FORALL:
1205           res = gfc_trans_forall (code);
1206           break;
1207
1208         case EXEC_WHERE:
1209           res = gfc_trans_where (code);
1210           break;
1211
1212         case EXEC_ALLOCATE:
1213           res = gfc_trans_allocate (code);
1214           break;
1215
1216         case EXEC_DEALLOCATE:
1217           res = gfc_trans_deallocate (code);
1218           break;
1219
1220         case EXEC_OPEN:
1221           res = gfc_trans_open (code);
1222           break;
1223
1224         case EXEC_CLOSE:
1225           res = gfc_trans_close (code);
1226           break;
1227
1228         case EXEC_READ:
1229           res = gfc_trans_read (code);
1230           break;
1231
1232         case EXEC_WRITE:
1233           res = gfc_trans_write (code);
1234           break;
1235
1236         case EXEC_IOLENGTH:
1237           res = gfc_trans_iolength (code);
1238           break;
1239
1240         case EXEC_BACKSPACE:
1241           res = gfc_trans_backspace (code);
1242           break;
1243
1244         case EXEC_ENDFILE:
1245           res = gfc_trans_endfile (code);
1246           break;
1247
1248         case EXEC_INQUIRE:
1249           res = gfc_trans_inquire (code);
1250           break;
1251
1252         case EXEC_WAIT:
1253           res = gfc_trans_wait (code);
1254           break;
1255
1256         case EXEC_REWIND:
1257           res = gfc_trans_rewind (code);
1258           break;
1259
1260         case EXEC_TRANSFER:
1261           res = gfc_trans_transfer (code);
1262           break;
1263
1264         case EXEC_DT_END:
1265           res = gfc_trans_dt_end (code);
1266           break;
1267
1268         case EXEC_OMP_ATOMIC:
1269         case EXEC_OMP_BARRIER:
1270         case EXEC_OMP_CRITICAL:
1271         case EXEC_OMP_DO:
1272         case EXEC_OMP_FLUSH:
1273         case EXEC_OMP_MASTER:
1274         case EXEC_OMP_ORDERED:
1275         case EXEC_OMP_PARALLEL:
1276         case EXEC_OMP_PARALLEL_DO:
1277         case EXEC_OMP_PARALLEL_SECTIONS:
1278         case EXEC_OMP_PARALLEL_WORKSHARE:
1279         case EXEC_OMP_SECTIONS:
1280         case EXEC_OMP_SINGLE:
1281         case EXEC_OMP_TASK:
1282         case EXEC_OMP_TASKWAIT:
1283         case EXEC_OMP_WORKSHARE:
1284           res = gfc_trans_omp_directive (code);
1285           break;
1286
1287         default:
1288           internal_error ("gfc_trans_code(): Bad statement code");
1289         }
1290
1291       gfc_set_backend_locus (&code->loc);
1292
1293       if (res != NULL_TREE && ! IS_EMPTY_STMT (res))
1294         {
1295           if (TREE_CODE (res) != STATEMENT_LIST)
1296             SET_EXPR_LOCATION (res, input_location);
1297
1298           /* Add the new statement to the block.  */
1299           gfc_add_expr_to_block (&block, res);
1300         }
1301     }
1302
1303   /* Return the finished block.  */
1304   return gfc_finish_block (&block);
1305 }
1306
1307
1308 /* Translate an executable statement with condition, cond.  The condition is
1309    used by gfc_trans_do to test for IO result conditions inside implied
1310    DO loops of READ and WRITE statements.  See build_dt in trans-io.c.  */
1311
1312 tree
1313 gfc_trans_code_cond (gfc_code * code, tree cond)
1314 {
1315   return trans_code (code, cond);
1316 }
1317
1318 /* Translate an executable statement without condition.  */
1319
1320 tree
1321 gfc_trans_code (gfc_code * code)
1322 {
1323   return trans_code (code, NULL_TREE);
1324 }
1325
1326
1327 /* This function is called after a complete program unit has been parsed
1328    and resolved.  */
1329
1330 void
1331 gfc_generate_code (gfc_namespace * ns)
1332 {
1333   ompws_flags = 0;
1334   if (ns->is_block_data)
1335     {
1336       gfc_generate_block_data (ns);
1337       return;
1338     }
1339
1340   gfc_generate_function_code (ns);
1341 }
1342
1343
1344 /* This function is called after a complete module has been parsed
1345    and resolved.  */
1346
1347 void
1348 gfc_generate_module_code (gfc_namespace * ns)
1349 {
1350   gfc_namespace *n;
1351   struct module_htab_entry *entry;
1352
1353   gcc_assert (ns->proc_name->backend_decl == NULL);
1354   ns->proc_name->backend_decl
1355     = build_decl (ns->proc_name->declared_at.lb->location,
1356                   NAMESPACE_DECL, get_identifier (ns->proc_name->name),
1357                   void_type_node);
1358   entry = gfc_find_module (ns->proc_name->name);
1359   if (entry->namespace_decl)
1360     /* Buggy sourcecode, using a module before defining it?  */
1361     htab_empty (entry->decls);
1362   entry->namespace_decl = ns->proc_name->backend_decl;
1363
1364   gfc_generate_module_vars (ns);
1365
1366   /* We need to generate all module function prototypes first, to allow
1367      sibling calls.  */
1368   for (n = ns->contained; n; n = n->sibling)
1369     {
1370       gfc_entry_list *el;
1371
1372       if (!n->proc_name)
1373         continue;
1374
1375       gfc_create_function_decl (n);
1376       gcc_assert (DECL_CONTEXT (n->proc_name->backend_decl) == NULL_TREE);
1377       DECL_CONTEXT (n->proc_name->backend_decl) = ns->proc_name->backend_decl;
1378       gfc_module_add_decl (entry, n->proc_name->backend_decl);
1379       for (el = ns->entries; el; el = el->next)
1380         {
1381           gcc_assert (DECL_CONTEXT (el->sym->backend_decl) == NULL_TREE);
1382           DECL_CONTEXT (el->sym->backend_decl) = ns->proc_name->backend_decl;
1383           gfc_module_add_decl (entry, el->sym->backend_decl);
1384         }
1385     }
1386
1387   for (n = ns->contained; n; n = n->sibling)
1388     {
1389       if (!n->proc_name)
1390         continue;
1391
1392       gfc_generate_function_code (n);
1393     }
1394 }
1395