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 an 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 #ifdef USE_MAPPED_LOCATION
 386       line = LOCATION_LINE (where->lb->location);
 387 #else
 388       line = where->lb->linenum;
 389 #endif
 390       asprintf (&message, "At line %d of file %s",  line,
 391                 where->lb->file->filename);
 392     }
 393   else
 394     asprintf (&message, "In file '%s', around line %d",
 395               gfc_source_file, input_line + 1);
 396
 397   arg = gfc_build_addr_expr (pchar_type_node, gfc_build_cstring_const(message));
 398   gfc_free(message);
 399
 400   asprintf (&message, "%s", _(msgid));
 401   arg2 = gfc_build_addr_expr (pchar_type_node, gfc_build_cstring_const(message));
 402   gfc_free(message);
 403
 404   /* Build the argument array.  */
 405   argarray = (tree *) alloca (sizeof (tree) * (nargs + 2));
 406   argarray[0] = arg;
 407   argarray[1] = arg2;
 408   va_start (ap, msgid);
 409   for (i = 0; i < nargs; i++)
 410     argarray[2+i] = va_arg (ap, tree);
 411   va_end (ap);
 412
 413   /* Build the function call to runtime_error_at; because of the variable
 414      number of arguments, we can't use build_call_expr directly.  */
 415   fntype = TREE_TYPE (gfor_fndecl_runtime_error_at);
 416   tmp = fold_builtin_call_array (TREE_TYPE (fntype),
 417                                  fold_build1 (ADDR_EXPR,
 418                                               build_pointer_type (fntype),
 419                                               gfor_fndecl_runtime_error_at),
 420                                  nargs + 2, argarray);
 421   gfc_add_expr_to_block (&block, tmp);
 422
 423   body = gfc_finish_block (&block);
 424
 425   if (integer_onep (cond))
 426     {
 427       gfc_add_expr_to_block (pblock, body);
 428     }
 429   else
 430     {
 431       /* Tell the compiler that this isn't likely.  */
 432       cond = fold_convert (long_integer_type_node, cond);
 433       tmp = build_int_cst (long_integer_type_node, 0);
 434       cond = build_call_expr (built_in_decls[BUILT_IN_EXPECT], 2, cond, tmp);
 435       cond = fold_convert (boolean_type_node, cond);
 436
 437       tmp = build3_v (COND_EXPR, cond, body, build_empty_stmt ());
 438       gfc_add_expr_to_block (pblock, tmp);
 439     }
 440 }
 441
 442
 443 /* Call malloc to allocate size bytes of memory, with special conditions:
 444       + if size < 0, generate a runtime error,
 445       + if size == 0, return a NULL pointer,
 446       + if malloc returns NULL, issue a runtime error.  */
 447 tree
 448 gfc_call_malloc (stmtblock_t * block, tree type, tree size)
 449 {
 450   tree tmp, msg, negative, zero, malloc_result, null_result, res;
 451   stmtblock_t block2;
 452
 453   size = gfc_evaluate_now (size, block);
 454
 455   if (TREE_TYPE (size) != TREE_TYPE (size_type_node))
 456     size = fold_convert (size_type_node, size);
 457
 458   /* Create a variable to hold the result.  */
 459   res = gfc_create_var (pvoid_type_node, NULL);
 460
 461   /* size < 0 ?  */
 462   negative = fold_build2 (LT_EXPR, boolean_type_node, size,
 463                           build_int_cst (size_type_node, 0));
 464   msg = gfc_build_addr_expr (pchar_type_node, gfc_build_cstring_const
 465       ("Attempt to allocate a negative amount of memory."));
 466   tmp = fold_build3 (COND_EXPR, void_type_node, negative,
 467                      build_call_expr (gfor_fndecl_runtime_error, 1, msg),
 468                      build_empty_stmt ());
 469   gfc_add_expr_to_block (block, tmp);
 470
 471   /* Call malloc and check the result.  */
 472   gfc_start_block (&block2);
 473   gfc_add_modify_expr (&block2, res,
 474                        build_call_expr (built_in_decls[BUILT_IN_MALLOC], 1,
 475                        size));
 476   null_result = fold_build2 (EQ_EXPR, boolean_type_node, res,
 477                              build_int_cst (pvoid_type_node, 0));
 478   msg = gfc_build_addr_expr (pchar_type_node, gfc_build_cstring_const
 479       ("Memory allocation failed"));
 480   tmp = fold_build3 (COND_EXPR, void_type_node, null_result,
 481                      build_call_expr (gfor_fndecl_os_error, 1, msg),
 482                      build_empty_stmt ());
 483   gfc_add_expr_to_block (&block2, tmp);
 484   malloc_result = gfc_finish_block (&block2);
 485
 486   /* size == 0  */
 487   zero = fold_build2 (EQ_EXPR, boolean_type_node, size,
 488                       build_int_cst (size_type_node, 0));
 489   tmp = fold_build2 (MODIFY_EXPR, pvoid_type_node, res,
 490                      build_int_cst (pvoid_type_node, 0));
 491   tmp = fold_build3 (COND_EXPR, void_type_node, zero, tmp, malloc_result);
 492   gfc_add_expr_to_block (block, tmp);
 493
 494   if (type != NULL)
 495     res = fold_convert (type, res);
 496   return res;
 497 }
 498
 499 /* Allocate memory, using an optional status argument.
 500
 501    This function follows the following pseudo-code:
 502
 503     void *
 504     allocate (size_t size, integer_type* stat)
 505     {
 506       void *newmem;
 507
 508       if (stat)
 509         *stat = 0;
 510
 511       // The only time this can happen is the size wraps around.
 512       if (size < 0)
 513       {
 514         if (stat)
 515         {
 516           *stat = LIBERROR_ALLOCATION;
 517           newmem = NULL;
 518         }
 519         else
 520           runtime_error ("Attempt to allocate negative amount of memory. "
 521                          "Possible integer overflow");
 522       }
 523       else
 524       {
 525         newmem = malloc (MAX (size, 1));
 526         if (newmem == NULL)
 527         {
 528           if (stat)
 529             *stat = LIBERROR_ALLOCATION;
 530           else
 531             runtime_error ("Out of memory");
 532         }
 533       }
 534
 535       return newmem;
 536     }  */
 537 tree
 538 gfc_allocate_with_status (stmtblock_t * block, tree size, tree status)
 539 {
 540   stmtblock_t alloc_block;
 541   tree res, tmp, error, msg, cond;
 542   tree status_type = status ? TREE_TYPE (TREE_TYPE (status)) : NULL_TREE;
 543
 544   /* Evaluate size only once, and make sure it has the right type.  */
 545   size = gfc_evaluate_now (size, block);
 546   if (TREE_TYPE (size) != TREE_TYPE (size_type_node))
 547     size = fold_convert (size_type_node, size);
 548
 549   /* Create a variable to hold the result.  */
 550   res = gfc_create_var (pvoid_type_node, NULL);
 551
 552   /* Set the optional status variable to zero.  */
 553   if (status != NULL_TREE && !integer_zerop (status))
 554     {
 555       tmp = fold_build2 (MODIFY_EXPR, status_type,
 556                          fold_build1 (INDIRECT_REF, status_type, status),
 557                          build_int_cst (status_type, 0));
 558       tmp = fold_build3 (COND_EXPR, void_type_node,
 559                          fold_build2 (NE_EXPR, boolean_type_node,
 560                                       status, build_int_cst (status_type, 0)),
 561                          tmp, build_empty_stmt ());
 562       gfc_add_expr_to_block (block, tmp);
 563     }
 564
 565   /* Generate the block of code handling (size < 0).  */
 566   msg = gfc_build_addr_expr (pchar_type_node, gfc_build_cstring_const
 567                         ("Attempt to allocate negative amount of memory. "
 568                          "Possible integer overflow"));
 569   error = build_call_expr (gfor_fndecl_runtime_error, 1, msg);
 570
 571   if (status != NULL_TREE && !integer_zerop (status))
 572     {
 573       /* Set the status variable if it's present.  */
 574       stmtblock_t set_status_block;
 575
 576       gfc_start_block (&set_status_block);
 577       gfc_add_modify_expr (&set_status_block,
 578                            fold_build1 (INDIRECT_REF, status_type, status),
 579                            build_int_cst (status_type, LIBERROR_ALLOCATION));
 580       gfc_add_modify_expr (&set_status_block, res,
 581                            build_int_cst (pvoid_type_node, 0));
 582
 583       tmp = fold_build2 (EQ_EXPR, boolean_type_node, status,
 584                          build_int_cst (status_type, 0));
 585       error = fold_build3 (COND_EXPR, void_type_node, tmp, error,
 586                            gfc_finish_block (&set_status_block));
 587     }
 588
 589   /* The allocation itself.  */
 590   gfc_start_block (&alloc_block);
 591   gfc_add_modify_expr (&alloc_block, res,
 592                        build_call_expr (built_in_decls[BUILT_IN_MALLOC], 1,
 593                                         fold_build2 (MAX_EXPR, size_type_node,
 594                                                      size,
 595                                                      build_int_cst (size_type_node, 1))));
 596
 597   msg = gfc_build_addr_expr (pchar_type_node,
 598                              gfc_build_cstring_const ("Out of memory"));
 599   tmp = build_call_expr (gfor_fndecl_os_error, 1, msg);
 600
 601   if (status != NULL_TREE && !integer_zerop (status))
 602     {
 603       /* Set the status variable if it's present.  */
 604       tree tmp2;
 605
 606       cond = fold_build2 (EQ_EXPR, boolean_type_node, status,
 607                           build_int_cst (status_type, 0));
 608       tmp2 = fold_build2 (MODIFY_EXPR, status_type,
 609                           fold_build1 (INDIRECT_REF, status_type, status),
 610                           build_int_cst (status_type, LIBERROR_ALLOCATION));
 611       tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp,
 612                          tmp2);
 613     }
 614
 615   tmp = fold_build3 (COND_EXPR, void_type_node,
 616                      fold_build2 (EQ_EXPR, boolean_type_node, res,
 617                                   build_int_cst (pvoid_type_node, 0)),
 618                      tmp, build_empty_stmt ());
 619   gfc_add_expr_to_block (&alloc_block, tmp);
 620
 621   cond = fold_build2 (LT_EXPR, boolean_type_node, size,
 622                       build_int_cst (TREE_TYPE (size), 0));
 623   tmp = fold_build3 (COND_EXPR, void_type_node, cond, error,
 624                      gfc_finish_block (&alloc_block));
 625   gfc_add_expr_to_block (block, tmp);
 626
 627   return res;
 628 }
 629
 630
 631 /* Generate code for an ALLOCATE statement when the argument is an
 632    allocatable array.  If the array is currently allocated, it is an
 633    error to allocate it again.
 634
 635    This function follows the following pseudo-code:
 636
 637     void *
 638     allocate_array (void *mem, size_t size, integer_type *stat)
 639     {
 640       if (mem == NULL)
 641         return allocate (size, stat);
 642       else
 643       {
 644         if (stat)
 645         {
 646           free (mem);
 647           mem = allocate (size, stat);
 648           *stat = LIBERROR_ALLOCATION;
 649           return mem;
 650         }
 651         else
 652           runtime_error ("Attempting to allocate already allocated array");
 653     }  */
 654 tree
 655 gfc_allocate_array_with_status (stmtblock_t * block, tree mem, tree size,
 656                                 tree status)
 657 {
 658   stmtblock_t alloc_block;
 659   tree res, tmp, null_mem, alloc, error, msg;
 660   tree type = TREE_TYPE (mem);
 661
 662   if (TREE_TYPE (size) != TREE_TYPE (size_type_node))
 663     size = fold_convert (size_type_node, size);
 664
 665   /* Create a variable to hold the result.  */
 666   res = gfc_create_var (pvoid_type_node, NULL);
 667   null_mem = fold_build2 (EQ_EXPR, boolean_type_node, mem,
 668                           build_int_cst (type, 0));
 669
 670   /* If mem is NULL, we call gfc_allocate_with_status.  */
 671   gfc_start_block (&alloc_block);
 672   tmp = gfc_allocate_with_status (&alloc_block, size, status);
 673   gfc_add_modify_expr (&alloc_block, res, fold_convert (type, tmp));
 674   alloc = gfc_finish_block (&alloc_block);
 675
 676   /* Otherwise, we issue a runtime error or set the status variable.  */
 677   msg = gfc_build_addr_expr (pchar_type_node, gfc_build_cstring_const
 678                         ("Attempting to allocate already allocated array"));
 679   error = build_call_expr (gfor_fndecl_runtime_error, 1, msg);
 680
 681   if (status != NULL_TREE && !integer_zerop (status))
 682     {
 683       tree status_type = TREE_TYPE (TREE_TYPE (status));
 684       stmtblock_t set_status_block;
 685
 686       gfc_start_block (&set_status_block);
 687       tmp = build_call_expr (built_in_decls[BUILT_IN_FREE], 1,
 688                              fold_convert (pvoid_type_node, mem));
 689       gfc_add_expr_to_block (&set_status_block, tmp);
 690
 691       tmp = gfc_allocate_with_status (&set_status_block, size, status);
 692       gfc_add_modify_expr (&set_status_block, res, fold_convert (type, tmp));
 693
 694       gfc_add_modify_expr (&set_status_block,
 695                            fold_build1 (INDIRECT_REF, status_type, status),
 696                            build_int_cst (status_type, LIBERROR_ALLOCATION));
 697
 698       tmp = fold_build2 (EQ_EXPR, boolean_type_node, status,
 699                          build_int_cst (status_type, 0));
 700       error = fold_build3 (COND_EXPR, void_type_node, tmp, error,
 701                            gfc_finish_block (&set_status_block));
 702     }
 703
 704   tmp = fold_build3 (COND_EXPR, void_type_node, null_mem, alloc, error);
 705   gfc_add_expr_to_block (block, tmp);
 706
 707   return res;
 708 }
 709
 710
 711 /* Free a given variable, if it's not NULL.  */
 712 tree
 713 gfc_call_free (tree var)
 714 {
 715   stmtblock_t block;
 716   tree tmp, cond, call;
 717
 718   if (TREE_TYPE (var) != TREE_TYPE (pvoid_type_node))
 719     var = fold_convert (pvoid_type_node, var);
 720
 721   gfc_start_block (&block);
 722   var = gfc_evaluate_now (var, &block);
 723   cond = fold_build2 (NE_EXPR, boolean_type_node, var,
 724                       build_int_cst (pvoid_type_node, 0));
 725   call = build_call_expr (built_in_decls[BUILT_IN_FREE], 1, var);
 726   tmp = fold_build3 (COND_EXPR, void_type_node, cond, call,
 727                      build_empty_stmt ());
 728   gfc_add_expr_to_block (&block, tmp);
 729
 730   return gfc_finish_block (&block);
 731 }
 732
 733
 734
 735 /* User-deallocate; we emit the code directly from the front-end, and the
 736    logic is the same as the previous library function:
 737
 738     void
 739     deallocate (void *pointer, GFC_INTEGER_4 * stat)
 740     {
 741       if (!pointer)
 742         {
 743           if (stat)
 744             *stat = 1;
 745           else
 746             runtime_error ("Attempt to DEALLOCATE unallocated memory.");
 747         }
 748       else
 749         {
 750           free (pointer);
 751           if (stat)
 752             *stat = 0;
 753         }
 754     }
 755
 756    In this front-end version, status doesn't have to be GFC_INTEGER_4.
 757    Moreover, if CAN_FAIL is true, then we will not emit a runtime error,
 758    even when no status variable is passed to us (this is used for
 759    unconditional deallocation generated by the front-end at end of
 760    each procedure).  */
 761 tree
 762 gfc_deallocate_with_status (tree pointer, tree status, bool can_fail)
 763 {
 764   stmtblock_t null, non_null;
 765   tree cond, tmp, error, msg;
 766
 767   cond = fold_build2 (EQ_EXPR, boolean_type_node, pointer,
 768                       build_int_cst (TREE_TYPE (pointer), 0));
 769
 770   /* When POINTER is NULL, we set STATUS to 1 if it's present, otherwise
 771      we emit a runtime error.  */
 772   gfc_start_block (&null);
 773   if (!can_fail)
 774     {
 775       msg = gfc_build_addr_expr (pchar_type_node, gfc_build_cstring_const
 776                         ("Attempt to DEALLOCATE unallocated memory."));
 777       error = build_call_expr (gfor_fndecl_runtime_error, 1, msg);
 778     }
 779   else
 780     error = build_empty_stmt ();
 781
 782   if (status != NULL_TREE && !integer_zerop (status))
 783     {
 784       tree status_type = TREE_TYPE (TREE_TYPE (status));
 785       tree cond2;
 786
 787       cond2 = fold_build2 (NE_EXPR, boolean_type_node, status,
 788                            build_int_cst (TREE_TYPE (status), 0));
 789       tmp = fold_build2 (MODIFY_EXPR, status_type,
 790                          fold_build1 (INDIRECT_REF, status_type, status),
 791                          build_int_cst (status_type, 1));
 792       error = fold_build3 (COND_EXPR, void_type_node, cond2, tmp, error);
 793     }
 794
 795   gfc_add_expr_to_block (&null, error);
 796
 797   /* When POINTER is not NULL, we free it.  */
 798   gfc_start_block (&non_null);
 799   tmp = build_call_expr (built_in_decls[BUILT_IN_FREE], 1,
 800                          fold_convert (pvoid_type_node, pointer));
 801   gfc_add_expr_to_block (&non_null, tmp);
 802
 803   if (status != NULL_TREE && !integer_zerop (status))
 804     {
 805       /* We set STATUS to zero if it is present.  */
 806       tree status_type = TREE_TYPE (TREE_TYPE (status));
 807       tree cond2;
 808
 809       cond2 = fold_build2 (NE_EXPR, boolean_type_node, status,
 810                            build_int_cst (TREE_TYPE (status), 0));
 811       tmp = fold_build2 (MODIFY_EXPR, status_type,
 812                          fold_build1 (INDIRECT_REF, status_type, status),
 813                          build_int_cst (status_type, 0));
 814       tmp = fold_build3 (COND_EXPR, void_type_node, cond2, tmp,
 815                          build_empty_stmt ());
 816       gfc_add_expr_to_block (&non_null, tmp);
 817     }
 818
 819   return fold_build3 (COND_EXPR, void_type_node, cond,
 820                       gfc_finish_block (&null), gfc_finish_block (&non_null));
 821 }
 822
 823
 824 /* Reallocate MEM so it has SIZE bytes of data.  This behaves like the
 825    following pseudo-code:
 826
 827 void *
 828 internal_realloc (void *mem, size_t size)
 829 {
 830   if (size < 0)
 831     runtime_error ("Attempt to allocate a negative amount of memory.");
 832   res = realloc (mem, size);
 833   if (!res && size != 0)
 834     _gfortran_os_error ("Out of memory");
 835
 836   if (size == 0)
 837     return NULL;
 838
 839   return res;
 840 }  */
 841 tree
 842 gfc_call_realloc (stmtblock_t * block, tree mem, tree size)
 843 {
 844   tree msg, res, negative, nonzero, zero, null_result, tmp;
 845   tree type = TREE_TYPE (mem);
 846
 847   size = gfc_evaluate_now (size, block);
 848
 849   if (TREE_TYPE (size) != TREE_TYPE (size_type_node))
 850     size = fold_convert (size_type_node, size);
 851
 852   /* Create a variable to hold the result.  */
 853   res = gfc_create_var (type, NULL);
 854
 855   /* size < 0 ?  */
 856   negative = fold_build2 (LT_EXPR, boolean_type_node, size,
 857                           build_int_cst (size_type_node, 0));
 858   msg = gfc_build_addr_expr (pchar_type_node, gfc_build_cstring_const
 859       ("Attempt to allocate a negative amount of memory."));
 860   tmp = fold_build3 (COND_EXPR, void_type_node, negative,
 861                      build_call_expr (gfor_fndecl_runtime_error, 1, msg),
 862                      build_empty_stmt ());
 863   gfc_add_expr_to_block (block, tmp);
 864
 865   /* Call realloc and check the result.  */
 866   tmp = build_call_expr (built_in_decls[BUILT_IN_REALLOC], 2,
 867                          fold_convert (pvoid_type_node, mem), size);
 868   gfc_add_modify_expr (block, res, fold_convert (type, tmp));
 869   null_result = fold_build2 (EQ_EXPR, boolean_type_node, res,
 870                              build_int_cst (pvoid_type_node, 0));
 871   nonzero = fold_build2 (NE_EXPR, boolean_type_node, size,
 872                          build_int_cst (size_type_node, 0));
 873   null_result = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, null_result,
 874                              nonzero);
 875   msg = gfc_build_addr_expr (pchar_type_node,
 876                              gfc_build_cstring_const ("Out of memory"));
 877   tmp = fold_build3 (COND_EXPR, void_type_node, null_result,
 878                      build_call_expr (gfor_fndecl_os_error, 1, msg),
 879                      build_empty_stmt ());
 880   gfc_add_expr_to_block (block, tmp);
 881
 882   /* if (size == 0) then the result is NULL.  */
 883   tmp = fold_build2 (MODIFY_EXPR, type, res, build_int_cst (type, 0));
 884   zero = fold_build1 (TRUTH_NOT_EXPR, boolean_type_node, nonzero);
 885   tmp = fold_build3 (COND_EXPR, void_type_node, zero, tmp,
 886                      build_empty_stmt ());
 887   gfc_add_expr_to_block (block, tmp);
 888
 889   return res;
 890 }
 891
 892 /* Add a statement to a block.  */
 893
 894 void
 895 gfc_add_expr_to_block (stmtblock_t * block, tree expr)
 896 {
 897   gcc_assert (block);
 898
 899   if (expr == NULL_TREE || IS_EMPTY_STMT (expr))
 900     return;
 901
 902   if (block->head)
 903     {
 904       if (TREE_CODE (block->head) != STATEMENT_LIST)
 905         {
 906           tree tmp;
 907
 908           tmp = block->head;
 909           block->head = NULL_TREE;
 910           append_to_statement_list (tmp, &block->head);
 911         }
 912       append_to_statement_list (expr, &block->head);
 913     }
 914   else
 915     /* Don't bother creating a list if we only have a single statement.  */
 916     block->head = expr;
 917 }
 918
 919
 920 /* Add a block the end of a block.  */
 921
 922 void
 923 gfc_add_block_to_block (stmtblock_t * block, stmtblock_t * append)
 924 {
 925   gcc_assert (append);
 926   gcc_assert (!append->has_scope);
 927
 928   gfc_add_expr_to_block (block, append->head);
 929   append->head = NULL_TREE;
 930 }
 931
 932
 933 /* Get the current locus.  The structure may not be complete, and should
 934    only be used with gfc_set_backend_locus.  */
 935
 936 void
 937 gfc_get_backend_locus (locus * loc)
 938 {
 939   loc->lb = gfc_getmem (sizeof (gfc_linebuf));
 940 #ifdef USE_MAPPED_LOCATION
 941   loc->lb->location = input_location;
 942 #else
 943   loc->lb->linenum = input_line;
 944 #endif
 945   loc->lb->file = gfc_current_backend_file;
 946 }
 947
 948
 949 /* Set the current locus.  */
 950
 951 void
 952 gfc_set_backend_locus (locus * loc)
 953 {
 954   gfc_current_backend_file = loc->lb->file;
 955 #ifdef USE_MAPPED_LOCATION
 956   input_location = loc->lb->location;
 957 #else
 958   input_line = loc->lb->linenum;
 959   input_filename = loc->lb->file->filename;
 960 #endif
 961 }
 962
 963
 964 /* Translate an executable statement.  */
 965
 966 tree
 967 gfc_trans_code (gfc_code * code)
 968 {
 969   stmtblock_t block;
 970   tree res;
 971
 972   if (!code)
 973     return build_empty_stmt ();
 974
 975   gfc_start_block (&block);
 976
 977   /* Translate statements one by one to GIMPLE trees until we reach
 978      the end of this gfc_code branch.  */
 979   for (; code; code = code->next)
 980     {
 981       if (code->here != 0)
 982         {
 983           res = gfc_trans_label_here (code);
 984           gfc_add_expr_to_block (&block, res);
 985         }
 986
 987       switch (code->op)
 988         {
 989         case EXEC_NOP:
 990           res = NULL_TREE;
 991           break;
 992
 993         case EXEC_ASSIGN:
 994           res = gfc_trans_assign (code);
 995           break;
 996
 997         case EXEC_LABEL_ASSIGN:
 998           res = gfc_trans_label_assign (code);
 999           break;
1000
1001         case EXEC_POINTER_ASSIGN:
1002           res = gfc_trans_pointer_assign (code);
1003           break;
1004
1005         case EXEC_INIT_ASSIGN:
1006           res = gfc_trans_init_assign (code);
1007           break;
1008
1009         case EXEC_CONTINUE:
1010           res = NULL_TREE;
1011           break;
1012
1013         case EXEC_CYCLE:
1014           res = gfc_trans_cycle (code);
1015           break;
1016
1017         case EXEC_EXIT:
1018           res = gfc_trans_exit (code);
1019           break;
1020
1021         case EXEC_GOTO:
1022           res = gfc_trans_goto (code);
1023           break;
1024
1025         case EXEC_ENTRY:
1026           res = gfc_trans_entry (code);
1027           break;
1028
1029         case EXEC_PAUSE:
1030           res = gfc_trans_pause (code);
1031           break;
1032
1033         case EXEC_STOP:
1034           res = gfc_trans_stop (code);
1035           break;
1036
1037         case EXEC_CALL:
1038           res = gfc_trans_call (code, false);
1039           break;
1040
1041         case EXEC_ASSIGN_CALL:
1042           res = gfc_trans_call (code, true);
1043           break;
1044
1045         case EXEC_RETURN:
1046           res = gfc_trans_return (code);
1047           break;
1048
1049         case EXEC_IF:
1050           res = gfc_trans_if (code);
1051           break;
1052
1053         case EXEC_ARITHMETIC_IF:
1054           res = gfc_trans_arithmetic_if (code);
1055           break;
1056
1057         case EXEC_DO:
1058           res = gfc_trans_do (code);
1059           break;
1060
1061         case EXEC_DO_WHILE:
1062           res = gfc_trans_do_while (code);
1063           break;
1064
1065         case EXEC_SELECT:
1066           res = gfc_trans_select (code);
1067           break;
1068
1069         case EXEC_FLUSH:
1070           res = gfc_trans_flush (code);
1071           break;
1072
1073         case EXEC_FORALL:
1074           res = gfc_trans_forall (code);
1075           break;
1076
1077         case EXEC_WHERE:
1078           res = gfc_trans_where (code);
1079           break;
1080
1081         case EXEC_ALLOCATE:
1082           res = gfc_trans_allocate (code);
1083           break;
1084
1085         case EXEC_DEALLOCATE:
1086           res = gfc_trans_deallocate (code);
1087           break;
1088
1089         case EXEC_OPEN:
1090           res = gfc_trans_open (code);
1091           break;
1092
1093         case EXEC_CLOSE:
1094           res = gfc_trans_close (code);
1095           break;
1096
1097         case EXEC_READ:
1098           res = gfc_trans_read (code);
1099           break;
1100
1101         case EXEC_WRITE:
1102           res = gfc_trans_write (code);
1103           break;
1104
1105         case EXEC_IOLENGTH:
1106           res = gfc_trans_iolength (code);
1107           break;
1108
1109         case EXEC_BACKSPACE:
1110           res = gfc_trans_backspace (code);
1111           break;
1112
1113         case EXEC_ENDFILE:
1114           res = gfc_trans_endfile (code);
1115           break;
1116
1117         case EXEC_INQUIRE:
1118           res = gfc_trans_inquire (code);
1119           break;
1120
1121         case EXEC_REWIND:
1122           res = gfc_trans_rewind (code);
1123           break;
1124
1125         case EXEC_TRANSFER:
1126           res = gfc_trans_transfer (code);
1127           break;
1128
1129         case EXEC_DT_END:
1130           res = gfc_trans_dt_end (code);
1131           break;
1132
1133         case EXEC_OMP_ATOMIC:
1134         case EXEC_OMP_BARRIER:
1135         case EXEC_OMP_CRITICAL:
1136         case EXEC_OMP_DO:
1137         case EXEC_OMP_FLUSH:
1138         case EXEC_OMP_MASTER:
1139         case EXEC_OMP_ORDERED:
1140         case EXEC_OMP_PARALLEL:
1141         case EXEC_OMP_PARALLEL_DO:
1142         case EXEC_OMP_PARALLEL_SECTIONS:
1143         case EXEC_OMP_PARALLEL_WORKSHARE:
1144         case EXEC_OMP_SECTIONS:
1145         case EXEC_OMP_SINGLE:
1146         case EXEC_OMP_WORKSHARE:
1147           res = gfc_trans_omp_directive (code);
1148           break;
1149
1150         default:
1151           internal_error ("gfc_trans_code(): Bad statement code");
1152         }
1153
1154       gfc_set_backend_locus (&code->loc);
1155
1156       if (res != NULL_TREE && ! IS_EMPTY_STMT (res))
1157         {
1158           if (TREE_CODE (res) == STATEMENT_LIST)
1159             annotate_all_with_locus (&res, input_location);
1160           else
1161             SET_EXPR_LOCATION (res, input_location);
1162
1163           /* Add the new statement to the block.  */
1164           gfc_add_expr_to_block (&block, res);
1165         }
1166     }
1167
1168   /* Return the finished block.  */
1169   return gfc_finish_block (&block);
1170 }
1171
1172
1173 /* This function is called after a complete program unit has been parsed
1174    and resolved.  */
1175
1176 void
1177 gfc_generate_code (gfc_namespace * ns)
1178 {
1179   if (ns->is_block_data)
1180     {
1181       gfc_generate_block_data (ns);
1182       return;
1183     }
1184
1185   gfc_generate_function_code (ns);
1186 }
1187
1188
1189 /* This function is called after a complete module has been parsed
1190    and resolved.  */
1191
1192 void
1193 gfc_generate_module_code (gfc_namespace * ns)
1194 {
1195   gfc_namespace *n;
1196
1197   gfc_generate_module_vars (ns);
1198
1199   /* We need to generate all module function prototypes first, to allow
1200      sibling calls.  */
1201   for (n = ns->contained; n; n = n->sibling)
1202     {
1203       if (!n->proc_name)
1204         continue;
1205
1206       gfc_create_function_decl (n);
1207     }
1208
1209   for (n = ns->contained; n; n = n->sibling)
1210     {
1211       if (!n->proc_name)
1212         continue;
1213
1214       gfc_generate_function_code (n);
1215     }
1216 }
1217