gcc/fortran/trans.c

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