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 /* Save the current locus.  The structure may not be complete, and should
1059    only be used with gfc_restore_backend_locus.  */
1060
1061 void
1062 gfc_save_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 /* Restore the saved locus. Only used in conjonction with
1081    gfc_save_backend_locus, to free the memory when we are done.  */
1082
1083 void
1084 gfc_restore_backend_locus (locus * loc)
1085 {
1086   gfc_set_backend_locus (loc);
1087   gfc_free (loc->lb);
1088 }
1089
1090
1091 /* Translate an executable statement. The tree cond is used by gfc_trans_do.
1092    This static function is wrapped by gfc_trans_code_cond and
1093    gfc_trans_code.  */
1094
1095 static tree
1096 trans_code (gfc_code * code, tree cond)
1097 {
1098   stmtblock_t block;
1099   tree res;
1100
1101   if (!code)
1102     return build_empty_stmt (input_location);
1103
1104   gfc_start_block (&block);
1105
1106   /* Translate statements one by one into GENERIC trees until we reach
1107      the end of this gfc_code branch.  */
1108   for (; code; code = code->next)
1109     {
1110       if (code->here != 0)
1111         {
1112           res = gfc_trans_label_here (code);
1113           gfc_add_expr_to_block (&block, res);
1114         }
1115
1116       gfc_set_backend_locus (&code->loc);
1117
1118       switch (code->op)
1119         {
1120         case EXEC_NOP:
1121         case EXEC_END_BLOCK:
1122         case EXEC_END_PROCEDURE:
1123           res = NULL_TREE;
1124           break;
1125
1126         case EXEC_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_assign (code);
1131           break;
1132
1133         case EXEC_LABEL_ASSIGN:
1134           res = gfc_trans_label_assign (code);
1135           break;
1136
1137         case EXEC_POINTER_ASSIGN:
1138           if (code->expr1->ts.type == BT_CLASS)
1139             res = gfc_trans_class_assign (code->expr1, code->expr2, code->op);
1140           else
1141             res = gfc_trans_pointer_assign (code);
1142           break;
1143
1144         case EXEC_INIT_ASSIGN:
1145           if (code->expr1->ts.type == BT_CLASS)
1146             res = gfc_trans_class_init_assign (code);
1147           else
1148             res = gfc_trans_init_assign (code);
1149           break;
1150
1151         case EXEC_CONTINUE:
1152           res = NULL_TREE;
1153           break;
1154
1155         case EXEC_CRITICAL:
1156           res = gfc_trans_critical (code);
1157           break;
1158
1159         case EXEC_CYCLE:
1160           res = gfc_trans_cycle (code);
1161           break;
1162
1163         case EXEC_EXIT:
1164           res = gfc_trans_exit (code);
1165           break;
1166
1167         case EXEC_GOTO:
1168           res = gfc_trans_goto (code);
1169           break;
1170
1171         case EXEC_ENTRY:
1172           res = gfc_trans_entry (code);
1173           break;
1174
1175         case EXEC_PAUSE:
1176           res = gfc_trans_pause (code);
1177           break;
1178
1179         case EXEC_STOP:
1180         case EXEC_ERROR_STOP:
1181           res = gfc_trans_stop (code, code->op == EXEC_ERROR_STOP);
1182           break;
1183
1184         case EXEC_CALL:
1185           /* For MVBITS we've got the special exception that we need a
1186              dependency check, too.  */
1187           {
1188             bool is_mvbits = false;
1189             if (code->resolved_isym
1190                 && code->resolved_isym->id == GFC_ISYM_MVBITS)
1191               is_mvbits = true;
1192             if (code->resolved_isym
1193                 && code->resolved_isym->id == GFC_ISYM_MOVE_ALLOC)
1194               res = gfc_conv_intrinsic_move_alloc (code);
1195             else
1196               res = gfc_trans_call (code, is_mvbits, NULL_TREE,
1197                                     NULL_TREE, false);
1198           }
1199           break;
1200
1201         case EXEC_CALL_PPC:
1202           res = gfc_trans_call (code, false, NULL_TREE,
1203                                 NULL_TREE, false);
1204           break;
1205
1206         case EXEC_ASSIGN_CALL:
1207           res = gfc_trans_call (code, true, NULL_TREE,
1208                                 NULL_TREE, false);
1209           break;
1210
1211         case EXEC_RETURN:
1212           res = gfc_trans_return (code);
1213           break;
1214
1215         case EXEC_IF:
1216           res = gfc_trans_if (code);
1217           break;
1218
1219         case EXEC_ARITHMETIC_IF:
1220           res = gfc_trans_arithmetic_if (code);
1221           break;
1222
1223         case EXEC_BLOCK:
1224           res = gfc_trans_block_construct (code);
1225           break;
1226
1227         case EXEC_DO:
1228           res = gfc_trans_do (code, cond);
1229           break;
1230
1231         case EXEC_DO_WHILE:
1232           res = gfc_trans_do_while (code);
1233           break;
1234
1235         case EXEC_SELECT:
1236           res = gfc_trans_select (code);
1237           break;
1238
1239         case EXEC_SELECT_TYPE:
1240           /* Do nothing. SELECT TYPE statements should be transformed into
1241           an ordinary SELECT CASE at resolution stage.
1242           TODO: Add an error message here once this is done.  */
1243           res = NULL_TREE;
1244           break;
1245
1246         case EXEC_FLUSH:
1247           res = gfc_trans_flush (code);
1248           break;
1249
1250         case EXEC_SYNC_ALL:
1251         case EXEC_SYNC_IMAGES:
1252         case EXEC_SYNC_MEMORY:
1253           res = gfc_trans_sync (code, code->op);
1254           break;
1255
1256         case EXEC_FORALL:
1257           res = gfc_trans_forall (code);
1258           break;
1259
1260         case EXEC_WHERE:
1261           res = gfc_trans_where (code);
1262           break;
1263
1264         case EXEC_ALLOCATE:
1265           res = gfc_trans_allocate (code);
1266           break;
1267
1268         case EXEC_DEALLOCATE:
1269           res = gfc_trans_deallocate (code);
1270           break;
1271
1272         case EXEC_OPEN:
1273           res = gfc_trans_open (code);
1274           break;
1275
1276         case EXEC_CLOSE:
1277           res = gfc_trans_close (code);
1278           break;
1279
1280         case EXEC_READ:
1281           res = gfc_trans_read (code);
1282           break;
1283
1284         case EXEC_WRITE:
1285           res = gfc_trans_write (code);
1286           break;
1287
1288         case EXEC_IOLENGTH:
1289           res = gfc_trans_iolength (code);
1290           break;
1291
1292         case EXEC_BACKSPACE:
1293           res = gfc_trans_backspace (code);
1294           break;
1295
1296         case EXEC_ENDFILE:
1297           res = gfc_trans_endfile (code);
1298           break;
1299
1300         case EXEC_INQUIRE:
1301           res = gfc_trans_inquire (code);
1302           break;
1303
1304         case EXEC_WAIT:
1305           res = gfc_trans_wait (code);
1306           break;
1307
1308         case EXEC_REWIND:
1309           res = gfc_trans_rewind (code);
1310           break;
1311
1312         case EXEC_TRANSFER:
1313           res = gfc_trans_transfer (code);
1314           break;
1315
1316         case EXEC_DT_END:
1317           res = gfc_trans_dt_end (code);
1318           break;
1319
1320         case EXEC_OMP_ATOMIC:
1321         case EXEC_OMP_BARRIER:
1322         case EXEC_OMP_CRITICAL:
1323         case EXEC_OMP_DO:
1324         case EXEC_OMP_FLUSH:
1325         case EXEC_OMP_MASTER:
1326         case EXEC_OMP_ORDERED:
1327         case EXEC_OMP_PARALLEL:
1328         case EXEC_OMP_PARALLEL_DO:
1329         case EXEC_OMP_PARALLEL_SECTIONS:
1330         case EXEC_OMP_PARALLEL_WORKSHARE:
1331         case EXEC_OMP_SECTIONS:
1332         case EXEC_OMP_SINGLE:
1333         case EXEC_OMP_TASK:
1334         case EXEC_OMP_TASKWAIT:
1335         case EXEC_OMP_WORKSHARE:
1336           res = gfc_trans_omp_directive (code);
1337           break;
1338
1339         default:
1340           internal_error ("gfc_trans_code(): Bad statement code");
1341         }
1342
1343       gfc_set_backend_locus (&code->loc);
1344
1345       if (res != NULL_TREE && ! IS_EMPTY_STMT (res))
1346         {
1347           if (TREE_CODE (res) != STATEMENT_LIST)
1348             SET_EXPR_LOCATION (res, input_location);
1349
1350           /* Add the new statement to the block.  */
1351           gfc_add_expr_to_block (&block, res);
1352         }
1353     }
1354
1355   /* Return the finished block.  */
1356   return gfc_finish_block (&block);
1357 }
1358
1359
1360 /* Translate an executable statement with condition, cond.  The condition is
1361    used by gfc_trans_do to test for IO result conditions inside implied
1362    DO loops of READ and WRITE statements.  See build_dt in trans-io.c.  */
1363
1364 tree
1365 gfc_trans_code_cond (gfc_code * code, tree cond)
1366 {
1367   return trans_code (code, cond);
1368 }
1369
1370 /* Translate an executable statement without condition.  */
1371
1372 tree
1373 gfc_trans_code (gfc_code * code)
1374 {
1375   return trans_code (code, NULL_TREE);
1376 }
1377
1378
1379 /* This function is called after a complete program unit has been parsed
1380    and resolved.  */
1381
1382 void
1383 gfc_generate_code (gfc_namespace * ns)
1384 {
1385   ompws_flags = 0;
1386   if (ns->is_block_data)
1387     {
1388       gfc_generate_block_data (ns);
1389       return;
1390     }
1391
1392   gfc_generate_function_code (ns);
1393 }
1394
1395
1396 /* This function is called after a complete module has been parsed
1397    and resolved.  */
1398
1399 void
1400 gfc_generate_module_code (gfc_namespace * ns)
1401 {
1402   gfc_namespace *n;
1403   struct module_htab_entry *entry;
1404
1405   gcc_assert (ns->proc_name->backend_decl == NULL);
1406   ns->proc_name->backend_decl
1407     = build_decl (ns->proc_name->declared_at.lb->location,
1408                   NAMESPACE_DECL, get_identifier (ns->proc_name->name),
1409                   void_type_node);
1410   entry = gfc_find_module (ns->proc_name->name);
1411   if (entry->namespace_decl)
1412     /* Buggy sourcecode, using a module before defining it?  */
1413     htab_empty (entry->decls);
1414   entry->namespace_decl = ns->proc_name->backend_decl;
1415
1416   gfc_generate_module_vars (ns);
1417
1418   /* We need to generate all module function prototypes first, to allow
1419      sibling calls.  */
1420   for (n = ns->contained; n; n = n->sibling)
1421     {
1422       gfc_entry_list *el;
1423
1424       if (!n->proc_name)
1425         continue;
1426
1427       gfc_create_function_decl (n, false);
1428       DECL_CONTEXT (n->proc_name->backend_decl) = ns->proc_name->backend_decl;
1429       gfc_module_add_decl (entry, n->proc_name->backend_decl);
1430       for (el = ns->entries; el; el = el->next)
1431         {
1432           DECL_CONTEXT (el->sym->backend_decl) = ns->proc_name->backend_decl;
1433           gfc_module_add_decl (entry, el->sym->backend_decl);
1434         }
1435     }
1436
1437   for (n = ns->contained; n; n = n->sibling)
1438     {
1439       if (!n->proc_name)
1440         continue;
1441
1442       gfc_generate_function_code (n);
1443     }
1444 }
1445
1446
1447 /* Initialize an init/cleanup block with existing code.  */
1448
1449 void
1450 gfc_start_wrapped_block (gfc_wrapped_block* block, tree code)
1451 {
1452   gcc_assert (block);
1453
1454   block->init = NULL_TREE;
1455   block->code = code;
1456   block->cleanup = NULL_TREE;
1457 }
1458
1459
1460 /* Add a new pair of initializers/clean-up code.  */
1461
1462 void
1463 gfc_add_init_cleanup (gfc_wrapped_block* block, tree init, tree cleanup)
1464 {
1465   gcc_assert (block);
1466
1467   /* The new pair of init/cleanup should be "wrapped around" the existing
1468      block of code, thus the initialization is added to the front and the
1469      cleanup to the back.  */
1470   add_expr_to_chain (&block->init, init, true);
1471   add_expr_to_chain (&block->cleanup, cleanup, false);
1472 }
1473
1474
1475 /* Finish up a wrapped block by building a corresponding try-finally expr.  */
1476
1477 tree
1478 gfc_finish_wrapped_block (gfc_wrapped_block* block)
1479 {
1480   tree result;
1481
1482   gcc_assert (block);
1483
1484   /* Build the final expression.  For this, just add init and body together,
1485      and put clean-up with that into a TRY_FINALLY_EXPR.  */
1486   result = block->init;
1487   add_expr_to_chain (&result, block->code, false);
1488   if (block->cleanup)
1489     result = build2_loc (input_location, TRY_FINALLY_EXPR, void_type_node,
1490                          result, block->cleanup);
1491
1492   /* Clear the block.  */
1493   block->init = NULL_TREE;
1494   block->code = NULL_TREE;
1495   block->cleanup = NULL_TREE;
1496
1497   return result;
1498 }