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