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