gcc/fortran/trans.c

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