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