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