gcc/fortran/trans.c

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