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