gcc/fortran/trans-decl.c

   1 /* Backend function setup
   2    Copyright (C) 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
   3    Contributed by Paul Brook
   4
   5 This file is part of GCC.
   6
   7 GCC is free software; you can redistribute it and/or modify it under
   8 the terms of the GNU General Public License as published by the Free
   9 Software Foundation; either version 2, or (at your option) any later
  10 version.
  11
  12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
  13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
  14 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  15 for more details.
  16
  17 You should have received a copy of the GNU General Public License
  18 along with GCC; see the file COPYING.  If not, write to the Free
  19 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
  20 02110-1301, USA.  */
  21
  22 /* trans-decl.c -- Handling of backend function and variable decls, etc */
  23
  24 #include "config.h"
  25 #include "system.h"
  26 #include "coretypes.h"
  27 #include "tree.h"
  28 #include "tree-dump.h"
  29 #include "tree-gimple.h"
  30 #include "ggc.h"
  31 #include "toplev.h"
  32 #include "tm.h"
  33 #include "target.h"
  34 #include "function.h"
  35 #include "flags.h"
  36 #include "cgraph.h"
  37 #include "gfortran.h"
  38 #include "trans.h"
  39 #include "trans-types.h"
  40 #include "trans-array.h"
  41 #include "trans-const.h"
  42 /* Only for gfc_trans_code.  Shouldn't need to include this.  */
  43 #include "trans-stmt.h"
  44
  45 #define MAX_LABEL_VALUE 99999
  46
  47
  48 /* Holds the result of the function if no result variable specified.  */
  49
  50 static GTY(()) tree current_fake_result_decl;
  51
  52 static GTY(()) tree current_function_return_label;
  53
  54
  55 /* Holds the variable DECLs for the current function.  */
  56
  57 static GTY(()) tree saved_function_decls = NULL_TREE;
  58 static GTY(()) tree saved_parent_function_decls = NULL_TREE;
  59
  60
  61 /* The namespace of the module we're currently generating.  Only used while
  62    outputting decls for module variables.  Do not rely on this being set.  */
  63
  64 static gfc_namespace *module_namespace;
  65
  66
  67 /* List of static constructor functions.  */
  68
  69 tree gfc_static_ctors;
  70
  71
  72 /* Function declarations for builtin library functions.  */
  73
  74 tree gfor_fndecl_internal_malloc;
  75 tree gfor_fndecl_internal_malloc64;
  76 tree gfor_fndecl_internal_realloc;
  77 tree gfor_fndecl_internal_realloc64;
  78 tree gfor_fndecl_internal_free;
  79 tree gfor_fndecl_allocate;
  80 tree gfor_fndecl_allocate64;
  81 tree gfor_fndecl_deallocate;
  82 tree gfor_fndecl_pause_numeric;
  83 tree gfor_fndecl_pause_string;
  84 tree gfor_fndecl_stop_numeric;
  85 tree gfor_fndecl_stop_string;
  86 tree gfor_fndecl_select_string;
  87 tree gfor_fndecl_runtime_error;
  88 tree gfor_fndecl_set_fpe;
  89 tree gfor_fndecl_set_std;
  90 tree gfor_fndecl_in_pack;
  91 tree gfor_fndecl_in_unpack;
  92 tree gfor_fndecl_associated;
  93
  94
  95 /* Math functions.  Many other math functions are handled in
  96    trans-intrinsic.c.  */
  97
  98 gfc_powdecl_list gfor_fndecl_math_powi[4][3];
  99 tree gfor_fndecl_math_cpowf;
 100 tree gfor_fndecl_math_cpow;
 101 tree gfor_fndecl_math_cpowl10;
 102 tree gfor_fndecl_math_cpowl16;
 103 tree gfor_fndecl_math_ishftc4;
 104 tree gfor_fndecl_math_ishftc8;
 105 tree gfor_fndecl_math_ishftc16;
 106 tree gfor_fndecl_math_exponent4;
 107 tree gfor_fndecl_math_exponent8;
 108 tree gfor_fndecl_math_exponent10;
 109 tree gfor_fndecl_math_exponent16;
 110
 111
 112 /* String functions.  */
 113
 114 tree gfor_fndecl_copy_string;
 115 tree gfor_fndecl_compare_string;
 116 tree gfor_fndecl_concat_string;
 117 tree gfor_fndecl_string_len_trim;
 118 tree gfor_fndecl_string_index;
 119 tree gfor_fndecl_string_scan;
 120 tree gfor_fndecl_string_verify;
 121 tree gfor_fndecl_string_trim;
 122 tree gfor_fndecl_string_repeat;
 123 tree gfor_fndecl_adjustl;
 124 tree gfor_fndecl_adjustr;
 125
 126
 127 /* Other misc. runtime library functions.  */
 128
 129 tree gfor_fndecl_size0;
 130 tree gfor_fndecl_size1;
 131 tree gfor_fndecl_iargc;
 132
 133 /* Intrinsic functions implemented in FORTRAN.  */
 134 tree gfor_fndecl_si_kind;
 135 tree gfor_fndecl_sr_kind;
 136
 137
 138 static void
 139 gfc_add_decl_to_parent_function (tree decl)
 140 {
 141   gcc_assert (decl);
 142   DECL_CONTEXT (decl) = DECL_CONTEXT (current_function_decl);
 143   DECL_NONLOCAL (decl) = 1;
 144   TREE_CHAIN (decl) = saved_parent_function_decls;
 145   saved_parent_function_decls = decl;
 146 }
 147
 148 void
 149 gfc_add_decl_to_function (tree decl)
 150 {
 151   gcc_assert (decl);
 152   TREE_USED (decl) = 1;
 153   DECL_CONTEXT (decl) = current_function_decl;
 154   TREE_CHAIN (decl) = saved_function_decls;
 155   saved_function_decls = decl;
 156 }
 157
 158
 159 /* Build a  backend label declaration.  Set TREE_USED for named labels.
 160    The context of the label is always the current_function_decl.  All
 161    labels are marked artificial.  */
 162
 163 tree
 164 gfc_build_label_decl (tree label_id)
 165 {
 166   /* 2^32 temporaries should be enough.  */
 167   static unsigned int tmp_num = 1;
 168   tree label_decl;
 169   char *label_name;
 170
 171   if (label_id == NULL_TREE)
 172     {
 173       /* Build an internal label name.  */
 174       ASM_FORMAT_PRIVATE_NAME (label_name, "L", tmp_num++);
 175       label_id = get_identifier (label_name);
 176     }
 177   else
 178     label_name = NULL;
 179
 180   /* Build the LABEL_DECL node. Labels have no type.  */
 181   label_decl = build_decl (LABEL_DECL, label_id, void_type_node);
 182   DECL_CONTEXT (label_decl) = current_function_decl;
 183   DECL_MODE (label_decl) = VOIDmode;
 184
 185   /* We always define the label as used, even if the original source
 186      file never references the label.  We don't want all kinds of
 187      spurious warnings for old-style Fortran code with too many
 188      labels.  */
 189   TREE_USED (label_decl) = 1;
 190
 191   DECL_ARTIFICIAL (label_decl) = 1;
 192   return label_decl;
 193 }
 194
 195
 196 /* Returns the return label for the current function.  */
 197
 198 tree
 199 gfc_get_return_label (void)
 200 {
 201   char name[GFC_MAX_SYMBOL_LEN + 10];
 202
 203   if (current_function_return_label)
 204     return current_function_return_label;
 205
 206   sprintf (name, "__return_%s",
 207            IDENTIFIER_POINTER (DECL_NAME (current_function_decl)));
 208
 209   current_function_return_label =
 210     gfc_build_label_decl (get_identifier (name));
 211
 212   DECL_ARTIFICIAL (current_function_return_label) = 1;
 213
 214   return current_function_return_label;
 215 }
 216
 217
 218 /* Set the backend source location of a decl.  */
 219
 220 void
 221 gfc_set_decl_location (tree decl, locus * loc)
 222 {
 223 #ifdef USE_MAPPED_LOCATION
 224   DECL_SOURCE_LOCATION (decl) = loc->lb->location;
 225 #else
 226   DECL_SOURCE_LINE (decl) = loc->lb->linenum;
 227   DECL_SOURCE_FILE (decl) = loc->lb->file->filename;
 228 #endif
 229 }
 230
 231
 232 /* Return the backend label declaration for a given label structure,
 233    or create it if it doesn't exist yet.  */
 234
 235 tree
 236 gfc_get_label_decl (gfc_st_label * lp)
 237 {
 238   if (lp->backend_decl)
 239     return lp->backend_decl;
 240   else
 241     {
 242       char label_name[GFC_MAX_SYMBOL_LEN + 1];
 243       tree label_decl;
 244
 245       /* Validate the label declaration from the front end.  */
 246       gcc_assert (lp != NULL && lp->value <= MAX_LABEL_VALUE);
 247
 248       /* Build a mangled name for the label.  */
 249       sprintf (label_name, "__label_%.6d", lp->value);
 250
 251       /* Build the LABEL_DECL node.  */
 252       label_decl = gfc_build_label_decl (get_identifier (label_name));
 253
 254       /* Tell the debugger where the label came from.  */
 255       if (lp->value <= MAX_LABEL_VALUE) /* An internal label.  */
 256         gfc_set_decl_location (label_decl, &lp->where);
 257       else
 258         DECL_ARTIFICIAL (label_decl) = 1;
 259
 260       /* Store the label in the label list and return the LABEL_DECL.  */
 261       lp->backend_decl = label_decl;
 262       return label_decl;
 263     }
 264 }
 265
 266
 267 /* Convert a gfc_symbol to an identifier of the same name.  */
 268
 269 static tree
 270 gfc_sym_identifier (gfc_symbol * sym)
 271 {
 272   return (get_identifier (sym->name));
 273 }
 274
 275
 276 /* Construct mangled name from symbol name.  */
 277
 278 static tree
 279 gfc_sym_mangled_identifier (gfc_symbol * sym)
 280 {
 281   char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
 282
 283   if (sym->module == NULL)
 284     return gfc_sym_identifier (sym);
 285   else
 286     {
 287       snprintf (name, sizeof name, "__%s__%s", sym->module, sym->name);
 288       return get_identifier (name);
 289     }
 290 }
 291
 292
 293 /* Construct mangled function name from symbol name.  */
 294
 295 static tree
 296 gfc_sym_mangled_function_id (gfc_symbol * sym)
 297 {
 298   int has_underscore;
 299   char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
 300
 301   if (sym->module == NULL || sym->attr.proc == PROC_EXTERNAL
 302       || (sym->module != NULL && sym->attr.if_source == IFSRC_IFBODY))
 303     {
 304       if (strcmp (sym->name, "MAIN__") == 0
 305           || sym->attr.proc == PROC_INTRINSIC)
 306         return get_identifier (sym->name);
 307
 308       if (gfc_option.flag_underscoring)
 309         {
 310           has_underscore = strchr (sym->name, '_') != 0;
 311           if (gfc_option.flag_second_underscore && has_underscore)
 312             snprintf (name, sizeof name, "%s__", sym->name);
 313           else
 314             snprintf (name, sizeof name, "%s_", sym->name);
 315           return get_identifier (name);
 316         }
 317       else
 318         return get_identifier (sym->name);
 319     }
 320   else
 321     {
 322       snprintf (name, sizeof name, "__%s__%s", sym->module, sym->name);
 323       return get_identifier (name);
 324     }
 325 }
 326
 327
 328 /* Returns true if a variable of specified size should go on the stack.  */
 329
 330 int
 331 gfc_can_put_var_on_stack (tree size)
 332 {
 333   unsigned HOST_WIDE_INT low;
 334
 335   if (!INTEGER_CST_P (size))
 336     return 0;
 337
 338   if (gfc_option.flag_max_stack_var_size < 0)
 339     return 1;
 340
 341   if (TREE_INT_CST_HIGH (size) != 0)
 342     return 0;
 343
 344   low = TREE_INT_CST_LOW (size);
 345   if (low > (unsigned HOST_WIDE_INT) gfc_option.flag_max_stack_var_size)
 346     return 0;
 347
 348 /* TODO: Set a per-function stack size limit.  */
 349
 350   return 1;
 351 }
 352
 353
 354 /* Finish processing of a declaration and install its initial value.  */
 355
 356 static void
 357 gfc_finish_decl (tree decl, tree init)
 358 {
 359   if (TREE_CODE (decl) == PARM_DECL)
 360     gcc_assert (init == NULL_TREE);
 361   /* Remember that PARM_DECL doesn't have a DECL_INITIAL field per se
 362      -- it overlaps DECL_ARG_TYPE.  */
 363   else if (init == NULL_TREE)
 364     gcc_assert (DECL_INITIAL (decl) == NULL_TREE);
 365   else
 366     gcc_assert (DECL_INITIAL (decl) == error_mark_node);
 367
 368   if (init != NULL_TREE)
 369     {
 370       if (TREE_CODE (decl) != TYPE_DECL)
 371         DECL_INITIAL (decl) = init;
 372       else
 373         {
 374           /* typedef foo = bar; store the type of bar as the type of foo.  */
 375           TREE_TYPE (decl) = TREE_TYPE (init);
 376           DECL_INITIAL (decl) = init = 0;
 377         }
 378     }
 379
 380   if (TREE_CODE (decl) == VAR_DECL)
 381     {
 382       if (DECL_SIZE (decl) == NULL_TREE
 383           && TYPE_SIZE (TREE_TYPE (decl)) != NULL_TREE)
 384         layout_decl (decl, 0);
 385
 386       /* A static variable with an incomplete type is an error if it is
 387          initialized. Also if it is not file scope. Otherwise, let it
 388          through, but if it is not `extern' then it may cause an error
 389          message later.  */
 390       /* An automatic variable with an incomplete type is an error.  */
 391       if (DECL_SIZE (decl) == NULL_TREE
 392           && (TREE_STATIC (decl) ? (DECL_INITIAL (decl) != 0
 393                                     || DECL_CONTEXT (decl) != 0)
 394                                  : !DECL_EXTERNAL (decl)))
 395         {
 396           gfc_fatal_error ("storage size not known");
 397         }
 398
 399       if ((DECL_EXTERNAL (decl) || TREE_STATIC (decl))
 400           && (DECL_SIZE (decl) != 0)
 401           && (TREE_CODE (DECL_SIZE (decl)) != INTEGER_CST))
 402         {
 403           gfc_fatal_error ("storage size not constant");
 404         }
 405     }
 406
 407 }
 408
 409
 410 /* Apply symbol attributes to a variable, and add it to the function scope.  */
 411
 412 static void
 413 gfc_finish_var_decl (tree decl, gfc_symbol * sym)
 414 {
 415   /* TREE_ADDRESSABLE means the address of this variable is actually needed.
 416      This is the equivalent of the TARGET variables.
 417      We also need to set this if the variable is passed by reference in a
 418      CALL statement.  */
 419   if (sym->attr.target)
 420     TREE_ADDRESSABLE (decl) = 1;
 421   /* If it wasn't used we wouldn't be getting it.  */
 422   TREE_USED (decl) = 1;
 423
 424   /* Chain this decl to the pending declarations.  Don't do pushdecl()
 425      because this would add them to the current scope rather than the
 426      function scope.  */
 427   if (current_function_decl != NULL_TREE)
 428     {
 429       if (sym->ns->proc_name->backend_decl == current_function_decl)
 430         gfc_add_decl_to_function (decl);
 431       else
 432         gfc_add_decl_to_parent_function (decl);
 433     }
 434
 435   /* If a variable is USE associated, it's always external.  */
 436   if (sym->attr.use_assoc)
 437     {
 438       DECL_EXTERNAL (decl) = 1;
 439       TREE_PUBLIC (decl) = 1;
 440     }
 441   else if (sym->module && !sym->attr.result && !sym->attr.dummy)
 442     {
 443       /* TODO: Don't set sym->module for result or dummy variables.  */
 444       gcc_assert (current_function_decl == NULL_TREE);
 445       /* This is the declaration of a module variable.  */
 446       TREE_PUBLIC (decl) = 1;
 447       TREE_STATIC (decl) = 1;
 448     }
 449
 450   if ((sym->attr.save || sym->attr.data || sym->value)
 451       && !sym->attr.use_assoc)
 452     TREE_STATIC (decl) = 1;
 453
 454   /* Keep variables larger than max-stack-var-size off stack.  */
 455   if (!sym->ns->proc_name->attr.recursive
 456       && INTEGER_CST_P (DECL_SIZE_UNIT (decl))
 457       && !gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl)))
 458     TREE_STATIC (decl) = 1;
 459 }
 460
 461
 462 /* Allocate the lang-specific part of a decl.  */
 463
 464 void
 465 gfc_allocate_lang_decl (tree decl)
 466 {
 467   DECL_LANG_SPECIFIC (decl) = (struct lang_decl *)
 468     ggc_alloc_cleared (sizeof (struct lang_decl));
 469 }
 470
 471 /* Remember a symbol to generate initialization/cleanup code at function
 472    entry/exit.  */
 473
 474 static void
 475 gfc_defer_symbol_init (gfc_symbol * sym)
 476 {
 477   gfc_symbol *p;
 478   gfc_symbol *last;
 479   gfc_symbol *head;
 480
 481   /* Don't add a symbol twice.  */
 482   if (sym->tlink)
 483     return;
 484
 485   last = head = sym->ns->proc_name;
 486   p = last->tlink;
 487
 488   /* Make sure that setup code for dummy variables which are used in the
 489      setup of other variables is generated first.  */
 490   if (sym->attr.dummy)
 491     {
 492       /* Find the first dummy arg seen after us, or the first non-dummy arg.
 493          This is a circular list, so don't go past the head.  */
 494       while (p != head
 495              && (!p->attr.dummy || p->dummy_order > sym->dummy_order))
 496         {
 497           last = p;
 498           p = p->tlink;
 499         }
 500     }
 501   /* Insert in between last and p.  */
 502   last->tlink = sym;
 503   sym->tlink = p;
 504 }
 505
 506
 507 /* Create an array index type variable with function scope.  */
 508
 509 static tree
 510 create_index_var (const char * pfx, int nest)
 511 {
 512   tree decl;
 513
 514   decl = gfc_create_var_np (gfc_array_index_type, pfx);
 515   if (nest)
 516     gfc_add_decl_to_parent_function (decl);
 517   else
 518     gfc_add_decl_to_function (decl);
 519   return decl;
 520 }
 521
 522
 523 /* Create variables to hold all the non-constant bits of info for a
 524    descriptorless array.  Remember these in the lang-specific part of the
 525    type.  */
 526
 527 static void
 528 gfc_build_qualified_array (tree decl, gfc_symbol * sym)
 529 {
 530   tree type;
 531   int dim;
 532   int nest;
 533
 534   type = TREE_TYPE (decl);
 535
 536   /* We just use the descriptor, if there is one.  */
 537   if (GFC_DESCRIPTOR_TYPE_P (type))
 538     return;
 539
 540   gcc_assert (GFC_ARRAY_TYPE_P (type));
 541   nest = (sym->ns->proc_name->backend_decl != current_function_decl)
 542          && !sym->attr.contained;
 543
 544   for (dim = 0; dim < GFC_TYPE_ARRAY_RANK (type); dim++)
 545     {
 546       if (GFC_TYPE_ARRAY_LBOUND (type, dim) == NULL_TREE)
 547         GFC_TYPE_ARRAY_LBOUND (type, dim) = create_index_var ("lbound", nest);
 548       /* Don't try to use the unknown bound for assumed shape arrays.  */
 549       if (GFC_TYPE_ARRAY_UBOUND (type, dim) == NULL_TREE
 550           && (sym->as->type != AS_ASSUMED_SIZE
 551               || dim < GFC_TYPE_ARRAY_RANK (type) - 1))
 552         GFC_TYPE_ARRAY_UBOUND (type, dim) = create_index_var ("ubound", nest);
 553
 554       if (GFC_TYPE_ARRAY_STRIDE (type, dim) == NULL_TREE)
 555         GFC_TYPE_ARRAY_STRIDE (type, dim) = create_index_var ("stride", nest);
 556     }
 557   if (GFC_TYPE_ARRAY_OFFSET (type) == NULL_TREE)
 558     {
 559       GFC_TYPE_ARRAY_OFFSET (type) = gfc_create_var_np (gfc_array_index_type,
 560                                                         "offset");
 561       if (nest)
 562         gfc_add_decl_to_parent_function (GFC_TYPE_ARRAY_OFFSET (type));
 563       else
 564         gfc_add_decl_to_function (GFC_TYPE_ARRAY_OFFSET (type));
 565     }
 566 }
 567
 568
 569 /* For some dummy arguments we don't use the actual argument directly.
 570    Instead we create a local decl and use that.  This allows us to perform
 571    initialization, and construct full type information.  */
 572
 573 static tree
 574 gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy)
 575 {
 576   tree decl;
 577   tree type;
 578   gfc_array_spec *as;
 579   char *name;
 580   int packed;
 581   int n;
 582   bool known_size;
 583
 584   if (sym->attr.pointer || sym->attr.allocatable)
 585     return dummy;
 586
 587   /* Add to list of variables if not a fake result variable.  */
 588   if (sym->attr.result || sym->attr.dummy)
 589     gfc_defer_symbol_init (sym);
 590
 591   type = TREE_TYPE (dummy);
 592   gcc_assert (TREE_CODE (dummy) == PARM_DECL
 593           && POINTER_TYPE_P (type));
 594
 595   /* Do we know the element size?  */
 596   known_size = sym->ts.type != BT_CHARACTER
 597           || INTEGER_CST_P (sym->ts.cl->backend_decl);
 598
 599   if (known_size && !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type)))
 600     {
 601       /* For descriptorless arrays with known element size the actual
 602          argument is sufficient.  */
 603       gcc_assert (GFC_ARRAY_TYPE_P (type));
 604       gfc_build_qualified_array (dummy, sym);
 605       return dummy;
 606     }
 607
 608   type = TREE_TYPE (type);
 609   if (GFC_DESCRIPTOR_TYPE_P (type))
 610     {
 611       /* Create a decriptorless array pointer.  */
 612       as = sym->as;
 613       packed = 0;
 614       if (!gfc_option.flag_repack_arrays)
 615         {
 616           if (as->type == AS_ASSUMED_SIZE)
 617             packed = 2;
 618         }
 619       else
 620         {
 621           if (as->type == AS_EXPLICIT)
 622             {
 623               packed = 2;
 624               for (n = 0; n < as->rank; n++)
 625                 {
 626                   if (!(as->upper[n]
 627                         && as->lower[n]
 628                         && as->upper[n]->expr_type == EXPR_CONSTANT
 629                         && as->lower[n]->expr_type == EXPR_CONSTANT))
 630                     packed = 1;
 631                 }
 632             }
 633           else
 634             packed = 1;
 635         }
 636
 637       type = gfc_typenode_for_spec (&sym->ts);
 638       type = gfc_get_nodesc_array_type (type, sym->as, packed);
 639     }
 640   else
 641     {
 642       /* We now have an expression for the element size, so create a fully
 643          qualified type.  Reset sym->backend decl or this will just return the
 644          old type.  */
 645       sym->backend_decl = NULL_TREE;
 646       type = gfc_sym_type (sym);
 647       packed = 2;
 648     }
 649
 650   ASM_FORMAT_PRIVATE_NAME (name, IDENTIFIER_POINTER (DECL_NAME (dummy)), 0);
 651   decl = build_decl (VAR_DECL, get_identifier (name), type);
 652
 653   DECL_ARTIFICIAL (decl) = 1;
 654   TREE_PUBLIC (decl) = 0;
 655   TREE_STATIC (decl) = 0;
 656   DECL_EXTERNAL (decl) = 0;
 657
 658   /* We should never get deferred shape arrays here.  We used to because of
 659      frontend bugs.  */
 660   gcc_assert (sym->as->type != AS_DEFERRED);
 661
 662   switch (packed)
 663     {
 664     case 1:
 665       GFC_DECL_PARTIAL_PACKED_ARRAY (decl) = 1;
 666       break;
 667
 668     case 2:
 669       GFC_DECL_PACKED_ARRAY (decl) = 1;
 670       break;
 671     }
 672
 673   gfc_build_qualified_array (decl, sym);
 674
 675   if (DECL_LANG_SPECIFIC (dummy))
 676     DECL_LANG_SPECIFIC (decl) = DECL_LANG_SPECIFIC (dummy);
 677   else
 678     gfc_allocate_lang_decl (decl);
 679
 680   GFC_DECL_SAVED_DESCRIPTOR (decl) = dummy;
 681
 682   if (sym->ns->proc_name->backend_decl == current_function_decl
 683       || sym->attr.contained)
 684     gfc_add_decl_to_function (decl);
 685   else
 686     gfc_add_decl_to_parent_function (decl);
 687
 688   return decl;
 689 }
 690
 691
 692 /* Return a constant or a variable to use as a string length.  Does not
 693    add the decl to the current scope.  */
 694
 695 static tree
 696 gfc_create_string_length (gfc_symbol * sym)
 697 {
 698   tree length;
 699
 700   gcc_assert (sym->ts.cl);
 701   gfc_conv_const_charlen (sym->ts.cl);
 702
 703   if (sym->ts.cl->backend_decl == NULL_TREE)
 704     {
 705       char name[GFC_MAX_MANGLED_SYMBOL_LEN + 2];
 706
 707       /* Also prefix the mangled name.  */
 708       strcpy (&name[1], sym->name);
 709       name[0] = '.';
 710       length = build_decl (VAR_DECL, get_identifier (name),
 711                            gfc_charlen_type_node);
 712       DECL_ARTIFICIAL (length) = 1;
 713       TREE_USED (length) = 1;
 714       gfc_defer_symbol_init (sym);
 715       sym->ts.cl->backend_decl = length;
 716     }
 717
 718   return sym->ts.cl->backend_decl;
 719 }
 720
 721
 722 /* Return the decl for a gfc_symbol, create it if it doesn't already
 723    exist.  */
 724
 725 tree
 726 gfc_get_symbol_decl (gfc_symbol * sym)
 727 {
 728   tree decl;
 729   tree length = NULL_TREE;
 730   int byref;
 731
 732   gcc_assert (sym->attr.referenced);
 733
 734   if (sym->ns && sym->ns->proc_name->attr.function)
 735     byref = gfc_return_by_reference (sym->ns->proc_name);
 736   else
 737     byref = 0;
 738
 739   if ((sym->attr.dummy && ! sym->attr.function) || (sym->attr.result && byref))
 740     {
 741       /* Return via extra parameter.  */
 742       if (sym->attr.result && byref
 743           && !sym->backend_decl)
 744         {
 745           sym->backend_decl =
 746             DECL_ARGUMENTS (sym->ns->proc_name->backend_decl);
 747           /* For entry master function skip over the __entry
 748              argument.  */
 749           if (sym->ns->proc_name->attr.entry_master)
 750             sym->backend_decl = TREE_CHAIN (sym->backend_decl);
 751         }
 752
 753       /* Dummy variables should already have been created.  */
 754       gcc_assert (sym->backend_decl);
 755
 756       /* Create a character length variable.  */
 757       if (sym->ts.type == BT_CHARACTER)
 758         {
 759           if (sym->ts.cl->backend_decl == NULL_TREE)
 760             {
 761               length = gfc_create_string_length (sym);
 762               if (TREE_CODE (length) != INTEGER_CST)
 763                 {
 764                   gfc_finish_var_decl (length, sym);
 765                   gfc_defer_symbol_init (sym);
 766                 }
 767             }
 768         }
 769
 770       /* Use a copy of the descriptor for dummy arrays.  */
 771       if (sym->attr.dimension && !TREE_USED (sym->backend_decl))
 772         {
 773           sym->backend_decl =
 774             gfc_build_dummy_array_decl (sym, sym->backend_decl);
 775         }
 776
 777       TREE_USED (sym->backend_decl) = 1;
 778       return sym->backend_decl;
 779     }
 780
 781   if (sym->backend_decl)
 782     return sym->backend_decl;
 783
 784   /* Catch function declarations.  Only used for actual parameters.  */
 785   if (sym->attr.flavor == FL_PROCEDURE)
 786     {
 787       decl = gfc_get_extern_function_decl (sym);
 788       return decl;
 789     }
 790
 791   if (sym->attr.intrinsic)
 792     internal_error ("intrinsic variable which isn't a procedure");
 793
 794   /* Create string length decl first so that they can be used in the
 795      type declaration.  */
 796   if (sym->ts.type == BT_CHARACTER)
 797     length = gfc_create_string_length (sym);
 798
 799   /* Create the decl for the variable.  */
 800   decl = build_decl (VAR_DECL, gfc_sym_identifier (sym), gfc_sym_type (sym));
 801
 802   gfc_set_decl_location (decl, &sym->declared_at);
 803
 804   /* Symbols from modules should have their assembler names mangled.
 805      This is done here rather than in gfc_finish_var_decl because it
 806      is different for string length variables.  */
 807   if (sym->module)
 808     SET_DECL_ASSEMBLER_NAME (decl, gfc_sym_mangled_identifier (sym));
 809
 810   if (sym->attr.dimension)
 811     {
 812       /* Create variables to hold the non-constant bits of array info.  */
 813       gfc_build_qualified_array (decl, sym);
 814
 815       /* Remember this variable for allocation/cleanup.  */
 816       gfc_defer_symbol_init (sym);
 817
 818       if ((sym->attr.allocatable || !sym->attr.dummy) && !sym->attr.pointer)
 819         GFC_DECL_PACKED_ARRAY (decl) = 1;
 820     }
 821
 822   gfc_finish_var_decl (decl, sym);
 823
 824   if (sym->attr.assign)
 825     {
 826       gfc_allocate_lang_decl (decl);
 827       GFC_DECL_ASSIGN (decl) = 1;
 828       length = gfc_create_var (gfc_charlen_type_node, sym->name);
 829       GFC_DECL_STRING_LEN (decl) = length;
 830       GFC_DECL_ASSIGN_ADDR (decl) = gfc_create_var (pvoid_type_node, sym->name);
 831       /* TODO: Need to check we don't change TREE_STATIC (decl) later.  */
 832       TREE_STATIC (length) = TREE_STATIC (decl);
 833       /*  STRING_LENGTH is also used as flag. Less than -1 means that
 834           ASSIGN_ADDR can not be used. Equal -1 means that ASSIGN_ADDR is the
 835           target label's address. Other value is the length of format string
 836           and ASSIGN_ADDR is the address of format string.  */
 837       DECL_INITIAL (length) = build_int_cst (NULL_TREE, -2);
 838     }
 839
 840   if (sym->ts.type == BT_CHARACTER)
 841     {
 842       /* Character variables need special handling.  */
 843       gfc_allocate_lang_decl (decl);
 844
 845       if (TREE_CODE (length) != INTEGER_CST)
 846         {
 847           char name[GFC_MAX_MANGLED_SYMBOL_LEN + 2];
 848
 849           if (sym->module)
 850             {
 851               /* Also prefix the mangled name for symbols from modules.  */
 852               strcpy (&name[1], sym->name);
 853               name[0] = '.';
 854               strcpy (&name[1],
 855                       IDENTIFIER_POINTER (DECL_ASSEMBLER_NAME (length)));
 856               SET_DECL_ASSEMBLER_NAME (decl, get_identifier (name));
 857             }
 858           gfc_finish_var_decl (length, sym);
 859           gcc_assert (!sym->value);
 860         }
 861     }
 862   sym->backend_decl = decl;
 863
 864   if (TREE_STATIC (decl) && !sym->attr.use_assoc)
 865     {
 866       /* Add static initializer.  */
 867       DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
 868           TREE_TYPE (decl), sym->attr.dimension,
 869           sym->attr.pointer || sym->attr.allocatable);
 870     }
 871
 872   return decl;
 873 }
 874
 875
 876 /* Substitute a temporary variable in place of the real one.  */
 877
 878 void
 879 gfc_shadow_sym (gfc_symbol * sym, tree decl, gfc_saved_var * save)
 880 {
 881   save->attr = sym->attr;
 882   save->decl = sym->backend_decl;
 883
 884   gfc_clear_attr (&sym->attr);
 885   sym->attr.referenced = 1;
 886   sym->attr.flavor = FL_VARIABLE;
 887
 888   sym->backend_decl = decl;
 889 }
 890
 891
 892 /* Restore the original variable.  */
 893
 894 void
 895 gfc_restore_sym (gfc_symbol * sym, gfc_saved_var * save)
 896 {
 897   sym->attr = save->attr;
 898   sym->backend_decl = save->decl;
 899 }
 900
 901
 902 /* Get a basic decl for an external function.  */
 903
 904 tree
 905 gfc_get_extern_function_decl (gfc_symbol * sym)
 906 {
 907   tree type;
 908   tree fndecl;
 909   gfc_expr e;
 910   gfc_intrinsic_sym *isym;
 911   gfc_expr argexpr;
 912   char s[GFC_MAX_SYMBOL_LEN + 13]; /* "f2c_specific" and '\0'.  */
 913   tree name;
 914   tree mangled_name;
 915
 916   if (sym->backend_decl)
 917     return sym->backend_decl;
 918
 919   /* We should never be creating external decls for alternate entry points.
 920      The procedure may be an alternate entry point, but we don't want/need
 921      to know that.  */
 922   gcc_assert (!(sym->attr.entry || sym->attr.entry_master));
 923
 924   if (sym->attr.intrinsic)
 925     {
 926       /* Call the resolution function to get the actual name.  This is
 927          a nasty hack which relies on the resolution functions only looking
 928          at the first argument.  We pass NULL for the second argument
 929          otherwise things like AINT get confused.  */
 930       isym = gfc_find_function (sym->name);
 931       gcc_assert (isym->resolve.f0 != NULL);
 932
 933       memset (&e, 0, sizeof (e));
 934       e.expr_type = EXPR_FUNCTION;
 935
 936       memset (&argexpr, 0, sizeof (argexpr));
 937       gcc_assert (isym->formal);
 938       argexpr.ts = isym->formal->ts;
 939
 940       if (isym->formal->next == NULL)
 941         isym->resolve.f1 (&e, &argexpr);
 942       else
 943         {
 944           /* All specific intrinsics take one or two arguments.  */
 945           gcc_assert (isym->formal->next->next == NULL);
 946           isym->resolve.f2 (&e, &argexpr, NULL);
 947         }
 948
 949       if (gfc_option.flag_f2c
 950           && ((e.ts.type == BT_REAL && e.ts.kind == gfc_default_real_kind)
 951               || e.ts.type == BT_COMPLEX))
 952         {
 953           /* Specific which needs a different implementation if f2c
 954              calling conventions are used.  */
 955           sprintf (s, "f2c_specific%s", e.value.function.name);
 956         }
 957       else
 958         sprintf (s, "specific%s", e.value.function.name);
 959
 960       name = get_identifier (s);
 961       mangled_name = name;
 962     }
 963   else
 964     {
 965       name = gfc_sym_identifier (sym);
 966       mangled_name = gfc_sym_mangled_function_id (sym);
 967     }
 968
 969   type = gfc_get_function_type (sym);
 970   fndecl = build_decl (FUNCTION_DECL, name, type);
 971
 972   SET_DECL_ASSEMBLER_NAME (fndecl, mangled_name);
 973   /* If the return type is a pointer, avoid alias issues by setting
 974      DECL_IS_MALLOC to nonzero. This means that the function should be
 975      treated as if it were a malloc, meaning it returns a pointer that
 976      is not an alias.  */
 977   if (POINTER_TYPE_P (type))
 978     DECL_IS_MALLOC (fndecl) = 1;
 979
 980   /* Set the context of this decl.  */
 981   if (0 && sym->ns && sym->ns->proc_name)
 982     {
 983       /* TODO: Add external decls to the appropriate scope.  */
 984       DECL_CONTEXT (fndecl) = sym->ns->proc_name->backend_decl;
 985     }
 986   else
 987     {
 988       /* Global declaration, e.g. intrinsic subroutine.  */
 989       DECL_CONTEXT (fndecl) = NULL_TREE;
 990     }
 991
 992   DECL_EXTERNAL (fndecl) = 1;
 993
 994   /* This specifies if a function is globally addressable, i.e. it is
 995      the opposite of declaring static in C.  */
 996   TREE_PUBLIC (fndecl) = 1;
 997
 998   /* Set attributes for PURE functions. A call to PURE function in the
 999      Fortran 95 sense is both pure and without side effects in the C
1000      sense.  */
1001   if (sym->attr.pure || sym->attr.elemental)
1002     {
1003       if (sym->attr.function)
1004         DECL_IS_PURE (fndecl) = 1;
1005       /* TODO: check if pure SUBROUTINEs don't have INTENT(OUT)
1006          parameters and don't use alternate returns (is this
1007          allowed?). In that case, calls to them are meaningless, and
1008          can be optimized away. See also in build_function_decl().  */
1009       TREE_SIDE_EFFECTS (fndecl) = 0;
1010     }
1011
1012   /* Mark non-returning functions.  */
1013   if (sym->attr.noreturn)
1014       TREE_THIS_VOLATILE(fndecl) = 1;
1015
1016   sym->backend_decl = fndecl;
1017
1018   if (DECL_CONTEXT (fndecl) == NULL_TREE)
1019     pushdecl_top_level (fndecl);
1020
1021   return fndecl;
1022 }
1023
1024
1025 /* Create a declaration for a procedure.  For external functions (in the C
1026    sense) use gfc_get_extern_function_decl.  HAS_ENTRIES is true if this is
1027    a master function with alternate entry points.  */
1028
1029 static void
1030 build_function_decl (gfc_symbol * sym)
1031 {
1032   tree fndecl, type;
1033   symbol_attribute attr;
1034   tree result_decl;
1035   gfc_formal_arglist *f;
1036
1037   gcc_assert (!sym->backend_decl);
1038   gcc_assert (!sym->attr.external);
1039
1040   /* Set the line and filename.  sym->declared_at seems to point to the
1041      last statement for subroutines, but it'll do for now.  */
1042   gfc_set_backend_locus (&sym->declared_at);
1043
1044   /* Allow only one nesting level.  Allow public declarations.  */
1045   gcc_assert (current_function_decl == NULL_TREE
1046           || DECL_CONTEXT (current_function_decl) == NULL_TREE);
1047
1048   type = gfc_get_function_type (sym);
1049   fndecl = build_decl (FUNCTION_DECL, gfc_sym_identifier (sym), type);
1050
1051   /* Perform name mangling if this is a top level or module procedure.  */
1052   if (current_function_decl == NULL_TREE)
1053     SET_DECL_ASSEMBLER_NAME (fndecl, gfc_sym_mangled_function_id (sym));
1054
1055   /* Figure out the return type of the declared function, and build a
1056      RESULT_DECL for it.  If this is a subroutine with alternate
1057      returns, build a RESULT_DECL for it.  */
1058   attr = sym->attr;
1059
1060   result_decl = NULL_TREE;
1061   /* TODO: Shouldn't this just be TREE_TYPE (TREE_TYPE (fndecl)).  */
1062   if (attr.function)
1063     {
1064       if (gfc_return_by_reference (sym))
1065         type = void_type_node;
1066       else
1067         {
1068           if (sym->result != sym)
1069             result_decl = gfc_sym_identifier (sym->result);
1070
1071           type = TREE_TYPE (TREE_TYPE (fndecl));
1072         }
1073     }
1074   else
1075     {
1076       /* Look for alternate return placeholders.  */
1077       int has_alternate_returns = 0;
1078       for (f = sym->formal; f; f = f->next)
1079         {
1080           if (f->sym == NULL)
1081             {
1082               has_alternate_returns = 1;
1083               break;
1084             }
1085         }
1086
1087       if (has_alternate_returns)
1088         type = integer_type_node;
1089       else
1090         type = void_type_node;
1091     }
1092
1093   result_decl = build_decl (RESULT_DECL, result_decl, type);
1094   DECL_ARTIFICIAL (result_decl) = 1;
1095   DECL_IGNORED_P (result_decl) = 1;
1096   DECL_CONTEXT (result_decl) = fndecl;
1097   DECL_RESULT (fndecl) = result_decl;
1098
1099   /* Don't call layout_decl for a RESULT_DECL.
1100      layout_decl (result_decl, 0);  */
1101
1102   /* If the return type is a pointer, avoid alias issues by setting
1103      DECL_IS_MALLOC to nonzero. This means that the function should be
1104      treated as if it were a malloc, meaning it returns a pointer that
1105      is not an alias.  */
1106   if (POINTER_TYPE_P (type))
1107     DECL_IS_MALLOC (fndecl) = 1;
1108
1109   /* Set up all attributes for the function.  */
1110   DECL_CONTEXT (fndecl) = current_function_decl;
1111   DECL_EXTERNAL (fndecl) = 0;
1112
1113   /* This specifies if a function is globally visible, i.e. it is
1114      the opposite of declaring static in C.  */
1115   if (DECL_CONTEXT (fndecl) == NULL_TREE
1116       && !sym->attr.entry_master)
1117     TREE_PUBLIC (fndecl) = 1;
1118
1119   /* TREE_STATIC means the function body is defined here.  */
1120   TREE_STATIC (fndecl) = 1;
1121
1122   /* Set attributes for PURE functions. A call to a PURE function in the
1123      Fortran 95 sense is both pure and without side effects in the C
1124      sense.  */
1125   if (attr.pure || attr.elemental)
1126     {
1127       /* TODO: check if a pure SUBROUTINE has no INTENT(OUT) arguments
1128          including a alternate return. In that case it can also be
1129          marked as PURE. See also in gfc_get_extern_function_decl().  */
1130       if (attr.function)
1131         DECL_IS_PURE (fndecl) = 1;
1132       TREE_SIDE_EFFECTS (fndecl) = 0;
1133     }
1134
1135   /* Layout the function declaration and put it in the binding level
1136      of the current function.  */
1137   pushdecl (fndecl);
1138
1139   sym->backend_decl = fndecl;
1140 }
1141
1142
1143 /* Create the DECL_ARGUMENTS for a procedure.  */
1144
1145 static void
1146 create_function_arglist (gfc_symbol * sym)
1147 {
1148   tree fndecl;
1149   gfc_formal_arglist *f;
1150   tree typelist;
1151   tree arglist;
1152   tree length;
1153   tree type;
1154   tree parm;
1155
1156   fndecl = sym->backend_decl;
1157
1158   /* Build formal argument list. Make sure that their TREE_CONTEXT is
1159      the new FUNCTION_DECL node.  */
1160   arglist = NULL_TREE;
1161   typelist = TYPE_ARG_TYPES (TREE_TYPE (fndecl));
1162
1163   if (sym->attr.entry_master)
1164     {
1165       type = TREE_VALUE (typelist);
1166       parm = build_decl (PARM_DECL, get_identifier ("__entry"), type);
1167
1168       DECL_CONTEXT (parm) = fndecl;
1169       DECL_ARG_TYPE (parm) = type;
1170       TREE_READONLY (parm) = 1;
1171       gfc_finish_decl (parm, NULL_TREE);
1172
1173       arglist = chainon (arglist, parm);
1174       typelist = TREE_CHAIN (typelist);
1175     }
1176
1177   if (gfc_return_by_reference (sym))
1178     {
1179       type = TREE_VALUE (typelist);
1180       parm = build_decl (PARM_DECL, get_identifier ("__result"), type);
1181
1182       DECL_CONTEXT (parm) = fndecl;
1183       DECL_ARG_TYPE (parm) = type;
1184       TREE_READONLY (parm) = 1;
1185       DECL_ARTIFICIAL (parm) = 1;
1186       gfc_finish_decl (parm, NULL_TREE);
1187
1188       arglist = chainon (arglist, parm);
1189       typelist = TREE_CHAIN (typelist);
1190
1191       if (sym->ts.type == BT_CHARACTER)
1192         {
1193           gfc_allocate_lang_decl (parm);
1194
1195           /* Length of character result.  */
1196           type = TREE_VALUE (typelist);
1197           gcc_assert (type == gfc_charlen_type_node);
1198
1199           length = build_decl (PARM_DECL,
1200                                get_identifier (".__result"),
1201                                type);
1202           if (!sym->ts.cl->length)
1203             {
1204               sym->ts.cl->backend_decl = length;
1205               TREE_USED (length) = 1;
1206             }
1207           gcc_assert (TREE_CODE (length) == PARM_DECL);
1208           arglist = chainon (arglist, length);
1209           typelist = TREE_CHAIN (typelist);
1210           DECL_CONTEXT (length) = fndecl;
1211           DECL_ARG_TYPE (length) = type;
1212           TREE_READONLY (length) = 1;
1213           DECL_ARTIFICIAL (length) = 1;
1214           gfc_finish_decl (length, NULL_TREE);
1215         }
1216     }
1217
1218   for (f = sym->formal; f; f = f->next)
1219     {
1220       if (f->sym != NULL)       /* ignore alternate returns.  */
1221         {
1222           length = NULL_TREE;
1223
1224           type = TREE_VALUE (typelist);
1225
1226           /* Build a the argument declaration.  */
1227           parm = build_decl (PARM_DECL,
1228                              gfc_sym_identifier (f->sym), type);
1229
1230           /* Fill in arg stuff.  */
1231           DECL_CONTEXT (parm) = fndecl;
1232           DECL_ARG_TYPE (parm) = type;
1233           /* All implementation args are read-only.  */
1234           TREE_READONLY (parm) = 1;
1235
1236           gfc_finish_decl (parm, NULL_TREE);
1237
1238           f->sym->backend_decl = parm;
1239
1240           arglist = chainon (arglist, parm);
1241           typelist = TREE_CHAIN (typelist);
1242         }
1243     }
1244
1245   /* Add the hidden string length parameters.  */
1246   parm = arglist;
1247   for (f = sym->formal; f; f = f->next)
1248     {
1249       char name[GFC_MAX_SYMBOL_LEN + 2];
1250       /* Ignore alternate returns.  */
1251       if (f->sym == NULL)
1252         continue;
1253
1254       if (f->sym->ts.type != BT_CHARACTER)
1255         continue;
1256
1257       parm = f->sym->backend_decl;
1258       type = TREE_VALUE (typelist);
1259       gcc_assert (type == gfc_charlen_type_node);
1260
1261       strcpy (&name[1], f->sym->name);
1262       name[0] = '_';
1263       length = build_decl (PARM_DECL, get_identifier (name), type);
1264
1265       arglist = chainon (arglist, length);
1266       DECL_CONTEXT (length) = fndecl;
1267       DECL_ARTIFICIAL (length) = 1;
1268       DECL_ARG_TYPE (length) = type;
1269       TREE_READONLY (length) = 1;
1270       gfc_finish_decl (length, NULL_TREE);
1271
1272       /* TODO: Check string lengths when -fbounds-check.  */
1273
1274       /* Use the passed value for assumed length variables.  */
1275       if (!f->sym->ts.cl->length)
1276         {
1277           TREE_USED (length) = 1;
1278           if (!f->sym->ts.cl->backend_decl)
1279             f->sym->ts.cl->backend_decl = length;
1280           else
1281             {
1282               /* there is already another variable using this
1283                  gfc_charlen node, build a new one for this variable
1284                  and chain it into the list of gfc_charlens.
1285                  This happens for e.g. in the case
1286                  CHARACTER(*)::c1,c2
1287                  since CHARACTER declarations on the same line share
1288                  the same gfc_charlen node.  */
1289               gfc_charlen *cl;
1290
1291               cl = gfc_get_charlen ();
1292               cl->backend_decl = length;
1293               cl->next = f->sym->ts.cl->next;
1294               f->sym->ts.cl->next = cl;
1295               f->sym->ts.cl = cl;
1296             }
1297         }
1298
1299       parm = TREE_CHAIN (parm);
1300       typelist = TREE_CHAIN (typelist);
1301     }
1302
1303   gcc_assert (TREE_VALUE (typelist) == void_type_node);
1304   DECL_ARGUMENTS (fndecl) = arglist;
1305 }
1306
1307 /* Convert FNDECL's code to GIMPLE and handle any nested functions.  */
1308
1309 static void
1310 gfc_gimplify_function (tree fndecl)
1311 {
1312   struct cgraph_node *cgn;
1313
1314   gimplify_function_tree (fndecl);
1315   dump_function (TDI_generic, fndecl);
1316
1317   /* Convert all nested functions to GIMPLE now.  We do things in this order
1318      so that items like VLA sizes are expanded properly in the context of the
1319      correct function.  */
1320   cgn = cgraph_node (fndecl);
1321   for (cgn = cgn->nested; cgn; cgn = cgn->next_nested)
1322     gfc_gimplify_function (cgn->decl);
1323 }
1324
1325
1326 /* Do the setup necessary before generating the body of a function.  */
1327
1328 static void
1329 trans_function_start (gfc_symbol * sym)
1330 {
1331   tree fndecl;
1332
1333   fndecl = sym->backend_decl;
1334
1335   /* Let GCC know the current scope is this function.  */
1336   current_function_decl = fndecl;
1337
1338   /* Let the world know what we're about to do.  */
1339   announce_function (fndecl);
1340
1341   if (DECL_CONTEXT (fndecl) == NULL_TREE)
1342     {
1343       /* Create RTL for function declaration.  */
1344       rest_of_decl_compilation (fndecl, 1, 0);
1345     }
1346
1347   /* Create RTL for function definition.  */
1348   make_decl_rtl (fndecl);
1349
1350   init_function_start (fndecl);
1351
1352   /* Even though we're inside a function body, we still don't want to
1353      call expand_expr to calculate the size of a variable-sized array.
1354      We haven't necessarily assigned RTL to all variables yet, so it's
1355      not safe to try to expand expressions involving them.  */
1356   cfun->x_dont_save_pending_sizes_p = 1;
1357
1358   /* function.c requires a push at the start of the function.  */
1359   pushlevel (0);
1360 }
1361
1362 /* Create thunks for alternate entry points.  */
1363
1364 static void
1365 build_entry_thunks (gfc_namespace * ns)
1366 {
1367   gfc_formal_arglist *formal;
1368   gfc_formal_arglist *thunk_formal;
1369   gfc_entry_list *el;
1370   gfc_symbol *thunk_sym;
1371   stmtblock_t body;
1372   tree thunk_fndecl;
1373   tree args;
1374   tree string_args;
1375   tree tmp;
1376   locus old_loc;
1377
1378   /* This should always be a toplevel function.  */
1379   gcc_assert (current_function_decl == NULL_TREE);
1380
1381   gfc_get_backend_locus (&old_loc);
1382   for (el = ns->entries; el; el = el->next)
1383     {
1384       thunk_sym = el->sym;
1385
1386       build_function_decl (thunk_sym);
1387       create_function_arglist (thunk_sym);
1388
1389       trans_function_start (thunk_sym);
1390
1391       thunk_fndecl = thunk_sym->backend_decl;
1392
1393       gfc_start_block (&body);
1394
1395       /* Pass extra parameter identifying this entry point.  */
1396       tmp = build_int_cst (gfc_array_index_type, el->id);
1397       args = tree_cons (NULL_TREE, tmp, NULL_TREE);
1398       string_args = NULL_TREE;
1399
1400       if (thunk_sym->attr.function)
1401         {
1402           if (gfc_return_by_reference (ns->proc_name))
1403             {
1404               tree ref = DECL_ARGUMENTS (current_function_decl);
1405               args = tree_cons (NULL_TREE, ref, args);
1406               if (ns->proc_name->ts.type == BT_CHARACTER)
1407                 args = tree_cons (NULL_TREE, TREE_CHAIN (ref),
1408                                   args);
1409             }
1410         }
1411
1412       for (formal = ns->proc_name->formal; formal; formal = formal->next)
1413         {
1414           /* Ignore alternate returns.  */
1415           if (formal->sym == NULL)
1416             continue;
1417
1418           /* We don't have a clever way of identifying arguments, so resort to
1419              a brute-force search.  */
1420           for (thunk_formal = thunk_sym->formal;
1421                thunk_formal;
1422                thunk_formal = thunk_formal->next)
1423             {
1424               if (thunk_formal->sym == formal->sym)
1425                 break;
1426             }
1427
1428           if (thunk_formal)
1429             {
1430               /* Pass the argument.  */
1431               args = tree_cons (NULL_TREE, thunk_formal->sym->backend_decl,
1432                                 args);
1433               if (formal->sym->ts.type == BT_CHARACTER)
1434                 {
1435                   tmp = thunk_formal->sym->ts.cl->backend_decl;
1436                   string_args = tree_cons (NULL_TREE, tmp, string_args);
1437                 }
1438             }
1439           else
1440             {
1441               /* Pass NULL for a missing argument.  */
1442               args = tree_cons (NULL_TREE, null_pointer_node, args);
1443               if (formal->sym->ts.type == BT_CHARACTER)
1444                 {
1445                   tmp = convert (gfc_charlen_type_node, integer_zero_node);
1446                   string_args = tree_cons (NULL_TREE, tmp, string_args);
1447                 }
1448             }
1449         }
1450
1451       /* Call the master function.  */
1452       args = nreverse (args);
1453       args = chainon (args, nreverse (string_args));
1454       tmp = ns->proc_name->backend_decl;
1455       tmp = gfc_build_function_call (tmp, args);
1456       if (ns->proc_name->attr.mixed_entry_master)
1457         {
1458           tree union_decl, field;
1459           tree master_type = TREE_TYPE (ns->proc_name->backend_decl);
1460
1461           union_decl = build_decl (VAR_DECL, get_identifier ("__result"),
1462                                    TREE_TYPE (master_type));
1463           DECL_ARTIFICIAL (union_decl) = 1;
1464           DECL_EXTERNAL (union_decl) = 0;
1465           TREE_PUBLIC (union_decl) = 0;
1466           TREE_USED (union_decl) = 1;
1467           layout_decl (union_decl, 0);
1468           pushdecl (union_decl);
1469
1470           DECL_CONTEXT (union_decl) = current_function_decl;
1471           tmp = build2 (MODIFY_EXPR,
1472                         TREE_TYPE (union_decl),
1473                         union_decl, tmp);
1474           gfc_add_expr_to_block (&body, tmp);
1475
1476           for (field = TYPE_FIELDS (TREE_TYPE (union_decl));
1477                field; field = TREE_CHAIN (field))
1478             if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
1479                 thunk_sym->result->name) == 0)
1480               break;
1481           gcc_assert (field != NULL_TREE);
1482           tmp = build3 (COMPONENT_REF, TREE_TYPE (field), union_decl, field,
1483                         NULL_TREE);
1484           tmp = build2 (MODIFY_EXPR,
1485                         TREE_TYPE (DECL_RESULT (current_function_decl)),
1486                         DECL_RESULT (current_function_decl), tmp);
1487           tmp = build1_v (RETURN_EXPR, tmp);
1488         }
1489       else if (TREE_TYPE (DECL_RESULT (current_function_decl))
1490                != void_type_node)
1491         {
1492           tmp = build2 (MODIFY_EXPR,
1493                         TREE_TYPE (DECL_RESULT (current_function_decl)),
1494                         DECL_RESULT (current_function_decl), tmp);
1495           tmp = build1_v (RETURN_EXPR, tmp);
1496         }
1497       gfc_add_expr_to_block (&body, tmp);
1498
1499       /* Finish off this function and send it for code generation.  */
1500       DECL_SAVED_TREE (thunk_fndecl) = gfc_finish_block (&body);
1501       poplevel (1, 0, 1);
1502       BLOCK_SUPERCONTEXT (DECL_INITIAL (thunk_fndecl)) = thunk_fndecl;
1503
1504       /* Output the GENERIC tree.  */
1505       dump_function (TDI_original, thunk_fndecl);
1506
1507       /* Store the end of the function, so that we get good line number
1508          info for the epilogue.  */
1509       cfun->function_end_locus = input_location;
1510
1511       /* We're leaving the context of this function, so zap cfun.
1512          It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
1513          tree_rest_of_compilation.  */
1514       cfun = NULL;
1515
1516       current_function_decl = NULL_TREE;
1517
1518       gfc_gimplify_function (thunk_fndecl);
1519       cgraph_finalize_function (thunk_fndecl, false);
1520
1521       /* We share the symbols in the formal argument list with other entry
1522          points and the master function.  Clear them so that they are
1523          recreated for each function.  */
1524       for (formal = thunk_sym->formal; formal; formal = formal->next)
1525         if (formal->sym != NULL)  /* Ignore alternate returns.  */
1526           {
1527             formal->sym->backend_decl = NULL_TREE;
1528             if (formal->sym->ts.type == BT_CHARACTER)
1529               formal->sym->ts.cl->backend_decl = NULL_TREE;
1530           }
1531
1532       if (thunk_sym->attr.function)
1533         {
1534           if (thunk_sym->ts.type == BT_CHARACTER)
1535             thunk_sym->ts.cl->backend_decl = NULL_TREE;
1536           if (thunk_sym->result->ts.type == BT_CHARACTER)
1537             thunk_sym->result->ts.cl->backend_decl = NULL_TREE;
1538         }
1539     }
1540
1541   gfc_set_backend_locus (&old_loc);
1542 }
1543
1544
1545 /* Create a decl for a function, and create any thunks for alternate entry
1546    points.  */
1547
1548 void
1549 gfc_create_function_decl (gfc_namespace * ns)
1550 {
1551   /* Create a declaration for the master function.  */
1552   build_function_decl (ns->proc_name);
1553
1554   /* Compile the entry thunks.  */
1555   if (ns->entries)
1556     build_entry_thunks (ns);
1557
1558   /* Now create the read argument list.  */
1559   create_function_arglist (ns->proc_name);
1560 }
1561
1562 /* Return the decl used to hold the function return value.  */
1563
1564 tree
1565 gfc_get_fake_result_decl (gfc_symbol * sym)
1566 {
1567   tree decl;
1568   tree length;
1569
1570   char name[GFC_MAX_SYMBOL_LEN + 10];
1571
1572   if (sym
1573       && sym->ns->proc_name->backend_decl == current_function_decl
1574       && sym->ns->proc_name->attr.mixed_entry_master
1575       && sym != sym->ns->proc_name)
1576     {
1577       decl = gfc_get_fake_result_decl (sym->ns->proc_name);
1578       if (decl)
1579         {
1580           tree field;
1581
1582           for (field = TYPE_FIELDS (TREE_TYPE (decl));
1583                field; field = TREE_CHAIN (field))
1584             if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
1585                 sym->name) == 0)
1586               break;
1587
1588           gcc_assert (field != NULL_TREE);
1589           decl = build3 (COMPONENT_REF, TREE_TYPE (field), decl, field,
1590                          NULL_TREE);
1591         }
1592       return decl;
1593     }
1594
1595   if (current_fake_result_decl != NULL_TREE)
1596     return current_fake_result_decl;
1597
1598   /* Only when gfc_get_fake_result_decl is called by gfc_trans_return,
1599      sym is NULL.  */
1600   if (!sym)
1601     return NULL_TREE;
1602
1603   if (sym->ts.type == BT_CHARACTER
1604       && !sym->ts.cl->backend_decl)
1605     {
1606       length = gfc_create_string_length (sym);
1607       gfc_finish_var_decl (length, sym);
1608     }
1609
1610   if (gfc_return_by_reference (sym))
1611     {
1612       decl = DECL_ARGUMENTS (current_function_decl);
1613
1614       if (sym->ns->proc_name->backend_decl == current_function_decl
1615           && sym->ns->proc_name->attr.entry_master)
1616         decl = TREE_CHAIN (decl);
1617
1618       TREE_USED (decl) = 1;
1619       if (sym->as)
1620         decl = gfc_build_dummy_array_decl (sym, decl);
1621     }
1622   else
1623     {
1624       sprintf (name, "__result_%.20s",
1625                IDENTIFIER_POINTER (DECL_NAME (current_function_decl)));
1626
1627       decl = build_decl (VAR_DECL, get_identifier (name),
1628                          TREE_TYPE (TREE_TYPE (current_function_decl)));
1629
1630       DECL_ARTIFICIAL (decl) = 1;
1631       DECL_EXTERNAL (decl) = 0;
1632       TREE_PUBLIC (decl) = 0;
1633       TREE_USED (decl) = 1;
1634
1635       layout_decl (decl, 0);
1636
1637       gfc_add_decl_to_function (decl);
1638     }
1639
1640   current_fake_result_decl = decl;
1641
1642   return decl;
1643 }
1644
1645
1646 /* Builds a function decl.  The remaining parameters are the types of the
1647    function arguments.  Negative nargs indicates a varargs function.  */
1648
1649 tree
1650 gfc_build_library_function_decl (tree name, tree rettype, int nargs, ...)
1651 {
1652   tree arglist;
1653   tree argtype;
1654   tree fntype;
1655   tree fndecl;
1656   va_list p;
1657   int n;
1658
1659   /* Library functions must be declared with global scope.  */
1660   gcc_assert (current_function_decl == NULL_TREE);
1661
1662   va_start (p, nargs);
1663
1664
1665   /* Create a list of the argument types.  */
1666   for (arglist = NULL_TREE, n = abs (nargs); n > 0; n--)
1667     {
1668       argtype = va_arg (p, tree);
1669       arglist = gfc_chainon_list (arglist, argtype);
1670     }
1671
1672   if (nargs >= 0)
1673     {
1674       /* Terminate the list.  */
1675       arglist = gfc_chainon_list (arglist, void_type_node);
1676     }
1677
1678   /* Build the function type and decl.  */
1679   fntype = build_function_type (rettype, arglist);
1680   fndecl = build_decl (FUNCTION_DECL, name, fntype);
1681
1682   /* Mark this decl as external.  */
1683   DECL_EXTERNAL (fndecl) = 1;
1684   TREE_PUBLIC (fndecl) = 1;
1685
1686   va_end (p);
1687
1688   pushdecl (fndecl);
1689
1690   rest_of_decl_compilation (fndecl, 1, 0);
1691
1692   return fndecl;
1693 }
1694
1695 static void
1696 gfc_build_intrinsic_function_decls (void)
1697 {
1698   tree gfc_int4_type_node = gfc_get_int_type (4);
1699   tree gfc_int8_type_node = gfc_get_int_type (8);
1700   tree gfc_int16_type_node = gfc_get_int_type (16);
1701   tree gfc_logical4_type_node = gfc_get_logical_type (4);
1702   tree gfc_real4_type_node = gfc_get_real_type (4);
1703   tree gfc_real8_type_node = gfc_get_real_type (8);
1704   tree gfc_real10_type_node = gfc_get_real_type (10);
1705   tree gfc_real16_type_node = gfc_get_real_type (16);
1706   tree gfc_complex4_type_node = gfc_get_complex_type (4);
1707   tree gfc_complex8_type_node = gfc_get_complex_type (8);
1708   tree gfc_complex10_type_node = gfc_get_complex_type (10);
1709   tree gfc_complex16_type_node = gfc_get_complex_type (16);
1710
1711   /* String functions.  */
1712   gfor_fndecl_copy_string =
1713     gfc_build_library_function_decl (get_identifier (PREFIX("copy_string")),
1714                                      void_type_node,
1715                                      4,
1716                                      gfc_charlen_type_node, pchar_type_node,
1717                                      gfc_charlen_type_node, pchar_type_node);
1718
1719   gfor_fndecl_compare_string =
1720     gfc_build_library_function_decl (get_identifier (PREFIX("compare_string")),
1721                                      gfc_int4_type_node,
1722                                      4,
1723                                      gfc_charlen_type_node, pchar_type_node,
1724                                      gfc_charlen_type_node, pchar_type_node);
1725
1726   gfor_fndecl_concat_string =
1727     gfc_build_library_function_decl (get_identifier (PREFIX("concat_string")),
1728                                      void_type_node,
1729                                      6,
1730                                      gfc_charlen_type_node, pchar_type_node,
1731                                      gfc_charlen_type_node, pchar_type_node,
1732                                      gfc_charlen_type_node, pchar_type_node);
1733
1734   gfor_fndecl_string_len_trim =
1735     gfc_build_library_function_decl (get_identifier (PREFIX("string_len_trim")),
1736                                      gfc_int4_type_node,
1737                                      2, gfc_charlen_type_node,
1738                                      pchar_type_node);
1739
1740   gfor_fndecl_string_index =
1741     gfc_build_library_function_decl (get_identifier (PREFIX("string_index")),
1742                                      gfc_int4_type_node,
1743                                      5, gfc_charlen_type_node, pchar_type_node,
1744                                      gfc_charlen_type_node, pchar_type_node,
1745                                      gfc_logical4_type_node);
1746
1747   gfor_fndecl_string_scan =
1748     gfc_build_library_function_decl (get_identifier (PREFIX("string_scan")),
1749                                      gfc_int4_type_node,
1750                                      5, gfc_charlen_type_node, pchar_type_node,
1751                                      gfc_charlen_type_node, pchar_type_node,
1752                                      gfc_logical4_type_node);
1753
1754   gfor_fndecl_string_verify =
1755     gfc_build_library_function_decl (get_identifier (PREFIX("string_verify")),
1756                                      gfc_int4_type_node,
1757                                      5, gfc_charlen_type_node, pchar_type_node,
1758                                      gfc_charlen_type_node, pchar_type_node,
1759                                      gfc_logical4_type_node);
1760
1761   gfor_fndecl_string_trim =
1762     gfc_build_library_function_decl (get_identifier (PREFIX("string_trim")),
1763                                      void_type_node,
1764                                      4,
1765                                      build_pointer_type (gfc_charlen_type_node),
1766                                      ppvoid_type_node,
1767                                      gfc_charlen_type_node,
1768                                      pchar_type_node);
1769
1770   gfor_fndecl_string_repeat =
1771     gfc_build_library_function_decl (get_identifier (PREFIX("string_repeat")),
1772                                      void_type_node,
1773                                      4,
1774                                      pchar_type_node,
1775                                      gfc_charlen_type_node,
1776                                      pchar_type_node,
1777                                      gfc_int4_type_node);
1778
1779   gfor_fndecl_adjustl =
1780     gfc_build_library_function_decl (get_identifier (PREFIX("adjustl")),
1781                                      void_type_node,
1782                                      3,
1783                                      pchar_type_node,
1784                                      gfc_charlen_type_node, pchar_type_node);
1785
1786   gfor_fndecl_adjustr =
1787     gfc_build_library_function_decl (get_identifier (PREFIX("adjustr")),
1788                                      void_type_node,
1789                                      3,
1790                                      pchar_type_node,
1791                                      gfc_charlen_type_node, pchar_type_node);
1792
1793   gfor_fndecl_si_kind =
1794     gfc_build_library_function_decl (get_identifier ("selected_int_kind"),
1795                                      gfc_int4_type_node,
1796                                      1,
1797                                      pvoid_type_node);
1798
1799   gfor_fndecl_sr_kind =
1800     gfc_build_library_function_decl (get_identifier ("selected_real_kind"),
1801                                      gfc_int4_type_node,
1802                                      2, pvoid_type_node,
1803                                      pvoid_type_node);
1804
1805   /* Power functions.  */
1806   {
1807     tree ctype, rtype, itype, jtype;
1808     int rkind, ikind, jkind;
1809 #define NIKINDS 3
1810 #define NRKINDS 4
1811     static int ikinds[NIKINDS] = {4, 8, 16};
1812     static int rkinds[NRKINDS] = {4, 8, 10, 16};
1813     char name[PREFIX_LEN + 12]; /* _gfortran_pow_?n_?n */
1814
1815     for (ikind=0; ikind < NIKINDS; ikind++)
1816       {
1817         itype = gfc_get_int_type (ikinds[ikind]);
1818
1819         for (jkind=0; jkind < NIKINDS; jkind++)
1820           {
1821             jtype = gfc_get_int_type (ikinds[jkind]);
1822             if (itype && jtype)
1823               {
1824                 sprintf(name, PREFIX("pow_i%d_i%d"), ikinds[ikind],
1825                         ikinds[jkind]);
1826                 gfor_fndecl_math_powi[jkind][ikind].integer =
1827                   gfc_build_library_function_decl (get_identifier (name),
1828                     jtype, 2, jtype, itype);
1829               }
1830           }
1831
1832         for (rkind = 0; rkind < NRKINDS; rkind ++)
1833           {
1834             rtype = gfc_get_real_type (rkinds[rkind]);
1835             if (rtype && itype)
1836               {
1837                 sprintf(name, PREFIX("pow_r%d_i%d"), rkinds[rkind],
1838                         ikinds[ikind]);
1839                 gfor_fndecl_math_powi[rkind][ikind].real =
1840                   gfc_build_library_function_decl (get_identifier (name),
1841                     rtype, 2, rtype, itype);
1842               }
1843
1844             ctype = gfc_get_complex_type (rkinds[rkind]);
1845             if (ctype && itype)
1846               {
1847                 sprintf(name, PREFIX("pow_c%d_i%d"), rkinds[rkind],
1848                         ikinds[ikind]);
1849                 gfor_fndecl_math_powi[rkind][ikind].cmplx =
1850                   gfc_build_library_function_decl (get_identifier (name),
1851                     ctype, 2,ctype, itype);
1852               }
1853           }
1854       }
1855 #undef NIKINDS
1856 #undef NRKINDS
1857   }
1858
1859   gfor_fndecl_math_cpowf =
1860     gfc_build_library_function_decl (get_identifier ("cpowf"),
1861                                      gfc_complex4_type_node,
1862                                      1, gfc_complex4_type_node);
1863   gfor_fndecl_math_cpow =
1864     gfc_build_library_function_decl (get_identifier ("cpow"),
1865                                      gfc_complex8_type_node,
1866                                      1, gfc_complex8_type_node);
1867   if (gfc_complex10_type_node)
1868     gfor_fndecl_math_cpowl10 =
1869       gfc_build_library_function_decl (get_identifier ("cpowl"),
1870                                        gfc_complex10_type_node, 1,
1871                                        gfc_complex10_type_node);
1872   if (gfc_complex16_type_node)
1873     gfor_fndecl_math_cpowl16 =
1874       gfc_build_library_function_decl (get_identifier ("cpowl"),
1875                                        gfc_complex16_type_node, 1,
1876                                        gfc_complex16_type_node);
1877
1878   gfor_fndecl_math_ishftc4 =
1879     gfc_build_library_function_decl (get_identifier (PREFIX("ishftc4")),
1880                                      gfc_int4_type_node,
1881                                      3, gfc_int4_type_node,
1882                                      gfc_int4_type_node, gfc_int4_type_node);
1883   gfor_fndecl_math_ishftc8 =
1884     gfc_build_library_function_decl (get_identifier (PREFIX("ishftc8")),
1885                                      gfc_int8_type_node,
1886                                      3, gfc_int8_type_node,
1887                                      gfc_int4_type_node, gfc_int4_type_node);
1888   if (gfc_int16_type_node)
1889     gfor_fndecl_math_ishftc16 =
1890       gfc_build_library_function_decl (get_identifier (PREFIX("ishftc16")),
1891                                        gfc_int16_type_node, 3,
1892                                        gfc_int16_type_node,
1893                                        gfc_int4_type_node,
1894                                        gfc_int4_type_node);
1895
1896   gfor_fndecl_math_exponent4 =
1897     gfc_build_library_function_decl (get_identifier (PREFIX("exponent_r4")),
1898                                      gfc_int4_type_node,
1899                                      1, gfc_real4_type_node);
1900   gfor_fndecl_math_exponent8 =
1901     gfc_build_library_function_decl (get_identifier (PREFIX("exponent_r8")),
1902                                      gfc_int4_type_node,
1903                                      1, gfc_real8_type_node);
1904   if (gfc_real10_type_node)
1905     gfor_fndecl_math_exponent10 =
1906       gfc_build_library_function_decl (get_identifier (PREFIX("exponent_r10")),
1907                                        gfc_int4_type_node, 1,
1908                                        gfc_real10_type_node);
1909   if (gfc_real16_type_node)
1910     gfor_fndecl_math_exponent16 =
1911       gfc_build_library_function_decl (get_identifier (PREFIX("exponent_r16")),
1912                                        gfc_int4_type_node, 1,
1913                                        gfc_real16_type_node);
1914
1915   /* Other functions.  */
1916   gfor_fndecl_size0 =
1917     gfc_build_library_function_decl (get_identifier (PREFIX("size0")),
1918                                      gfc_array_index_type,
1919                                      1, pvoid_type_node);
1920   gfor_fndecl_size1 =
1921     gfc_build_library_function_decl (get_identifier (PREFIX("size1")),
1922                                      gfc_array_index_type,
1923                                      2, pvoid_type_node,
1924                                      gfc_array_index_type);
1925
1926   gfor_fndecl_iargc =
1927     gfc_build_library_function_decl (get_identifier (PREFIX ("iargc")),
1928                                      gfc_int4_type_node,
1929                                      0);
1930 }
1931
1932
1933 /* Make prototypes for runtime library functions.  */
1934
1935 void
1936 gfc_build_builtin_function_decls (void)
1937 {
1938   tree gfc_c_int_type_node = gfc_get_int_type (gfc_c_int_kind);
1939   tree gfc_int4_type_node = gfc_get_int_type (4);
1940   tree gfc_int8_type_node = gfc_get_int_type (8);
1941   tree gfc_logical4_type_node = gfc_get_logical_type (4);
1942   tree gfc_pint4_type_node = build_pointer_type (gfc_int4_type_node);
1943
1944   /* Treat these two internal malloc wrappers as malloc.  */
1945   gfor_fndecl_internal_malloc =
1946     gfc_build_library_function_decl (get_identifier (PREFIX("internal_malloc")),
1947                                      pvoid_type_node, 1, gfc_int4_type_node);
1948   DECL_IS_MALLOC (gfor_fndecl_internal_malloc) = 1;
1949
1950   gfor_fndecl_internal_malloc64 =
1951     gfc_build_library_function_decl (get_identifier
1952                                      (PREFIX("internal_malloc64")),
1953                                      pvoid_type_node, 1, gfc_int8_type_node);
1954   DECL_IS_MALLOC (gfor_fndecl_internal_malloc64) = 1;
1955
1956   gfor_fndecl_internal_realloc =
1957     gfc_build_library_function_decl (get_identifier
1958                                      (PREFIX("internal_realloc")),
1959                                      pvoid_type_node, 2, pvoid_type_node,
1960                                      gfc_int4_type_node);
1961
1962   gfor_fndecl_internal_realloc64 =
1963     gfc_build_library_function_decl (get_identifier
1964                                      (PREFIX("internal_realloc64")),
1965                                      pvoid_type_node, 2, pvoid_type_node,
1966                                      gfc_int8_type_node);
1967
1968   gfor_fndecl_internal_free =
1969     gfc_build_library_function_decl (get_identifier (PREFIX("internal_free")),
1970                                      void_type_node, 1, pvoid_type_node);
1971
1972   gfor_fndecl_allocate =
1973     gfc_build_library_function_decl (get_identifier (PREFIX("allocate")),
1974                                      void_type_node, 2, ppvoid_type_node,
1975                                      gfc_int4_type_node);
1976
1977   gfor_fndecl_allocate64 =
1978     gfc_build_library_function_decl (get_identifier (PREFIX("allocate64")),
1979                                      void_type_node, 2, ppvoid_type_node,
1980                                      gfc_int8_type_node);
1981
1982   gfor_fndecl_deallocate =
1983     gfc_build_library_function_decl (get_identifier (PREFIX("deallocate")),
1984                                      void_type_node, 2, ppvoid_type_node,
1985                                      gfc_pint4_type_node);
1986
1987   gfor_fndecl_stop_numeric =
1988     gfc_build_library_function_decl (get_identifier (PREFIX("stop_numeric")),
1989                                      void_type_node, 1, gfc_int4_type_node);
1990
1991   /* Stop doesn't return.  */
1992   TREE_THIS_VOLATILE (gfor_fndecl_stop_numeric) = 1;
1993
1994   gfor_fndecl_stop_string =
1995     gfc_build_library_function_decl (get_identifier (PREFIX("stop_string")),
1996                                      void_type_node, 2, pchar_type_node,
1997                                      gfc_int4_type_node);
1998   /* Stop doesn't return.  */
1999   TREE_THIS_VOLATILE (gfor_fndecl_stop_string) = 1;
2000
2001   gfor_fndecl_pause_numeric =
2002     gfc_build_library_function_decl (get_identifier (PREFIX("pause_numeric")),
2003                                      void_type_node, 1, gfc_int4_type_node);
2004
2005   gfor_fndecl_pause_string =
2006     gfc_build_library_function_decl (get_identifier (PREFIX("pause_string")),
2007                                      void_type_node, 2, pchar_type_node,
2008                                      gfc_int4_type_node);
2009
2010   gfor_fndecl_select_string =
2011     gfc_build_library_function_decl (get_identifier (PREFIX("select_string")),
2012                                      pvoid_type_node, 0);
2013
2014   gfor_fndecl_runtime_error =
2015     gfc_build_library_function_decl (get_identifier (PREFIX("runtime_error")),
2016                                      void_type_node,
2017                                      3,
2018                                      pchar_type_node, pchar_type_node,
2019                                      gfc_int4_type_node);
2020   /* The runtime_error function does not return.  */
2021   TREE_THIS_VOLATILE (gfor_fndecl_runtime_error) = 1;
2022
2023   gfor_fndecl_set_fpe =
2024     gfc_build_library_function_decl (get_identifier (PREFIX("set_fpe")),
2025                                     void_type_node, 1, gfc_c_int_type_node);
2026
2027   gfor_fndecl_set_std =
2028     gfc_build_library_function_decl (get_identifier (PREFIX("set_std")),
2029                                     void_type_node,
2030                                     2,
2031                                     gfc_int4_type_node,
2032                                     gfc_int4_type_node);
2033
2034   gfor_fndecl_in_pack = gfc_build_library_function_decl (
2035         get_identifier (PREFIX("internal_pack")),
2036         pvoid_type_node, 1, pvoid_type_node);
2037
2038   gfor_fndecl_in_unpack = gfc_build_library_function_decl (
2039         get_identifier (PREFIX("internal_unpack")),
2040         pvoid_type_node, 1, pvoid_type_node);
2041
2042   gfor_fndecl_associated =
2043     gfc_build_library_function_decl (
2044                                      get_identifier (PREFIX("associated")),
2045                                      gfc_logical4_type_node,
2046                                      2,
2047                                      ppvoid_type_node,
2048                                      ppvoid_type_node);
2049
2050   gfc_build_intrinsic_function_decls ();
2051   gfc_build_intrinsic_lib_fndecls ();
2052   gfc_build_io_library_fndecls ();
2053 }
2054
2055
2056 /* Evaluate the length of dummy character variables.  */
2057
2058 static tree
2059 gfc_trans_dummy_character (gfc_charlen * cl, tree fnbody)
2060 {
2061   stmtblock_t body;
2062
2063   gfc_finish_decl (cl->backend_decl, NULL_TREE);
2064
2065   gfc_start_block (&body);
2066
2067   /* Evaluate the string length expression.  */
2068   gfc_trans_init_string_length (cl, &body);
2069
2070   gfc_add_expr_to_block (&body, fnbody);
2071   return gfc_finish_block (&body);
2072 }
2073
2074
2075 /* Allocate and cleanup an automatic character variable.  */
2076
2077 static tree
2078 gfc_trans_auto_character_variable (gfc_symbol * sym, tree fnbody)
2079 {
2080   stmtblock_t body;
2081   tree decl;
2082   tree tmp;
2083
2084   gcc_assert (sym->backend_decl);
2085   gcc_assert (sym->ts.cl && sym->ts.cl->length);
2086
2087   gfc_start_block (&body);
2088
2089   /* Evaluate the string length expression.  */
2090   gfc_trans_init_string_length (sym->ts.cl, &body);
2091
2092   decl = sym->backend_decl;
2093
2094   /* Emit a DECL_EXPR for this variable, which will cause the
2095      gimplifier to allocate storage, and all that good stuff.  */
2096   tmp = build1 (DECL_EXPR, TREE_TYPE (decl), decl);
2097   gfc_add_expr_to_block (&body, tmp);
2098
2099   gfc_add_expr_to_block (&body, fnbody);
2100   return gfc_finish_block (&body);
2101 }
2102
2103
2104 /* Generate function entry and exit code, and add it to the function body.
2105    This includes:
2106     Allocation and initialization of array variables.
2107     Allocation of character string variables.
2108     Initialization and possibly repacking of dummy arrays.  */
2109
2110 static tree
2111 gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
2112 {
2113   locus loc;
2114   gfc_symbol *sym;
2115
2116   /* Deal with implicit return variables.  Explicit return variables will
2117      already have been added.  */
2118   if (gfc_return_by_reference (proc_sym) && proc_sym->result == proc_sym)
2119     {
2120       if (!current_fake_result_decl)
2121         {
2122           gfc_entry_list *el = NULL;
2123           if (proc_sym->attr.entry_master)
2124             {
2125               for (el = proc_sym->ns->entries; el; el = el->next)
2126                 if (el->sym != el->sym->result)
2127                   break;
2128             }
2129           if (el == NULL)
2130             warning (0, "Function does not return a value");
2131         }
2132       else if (proc_sym->as)
2133         {
2134           fnbody = gfc_trans_dummy_array_bias (proc_sym,
2135                                                current_fake_result_decl,
2136                                                fnbody);
2137         }
2138       else if (proc_sym->ts.type == BT_CHARACTER)
2139         {
2140           if (TREE_CODE (proc_sym->ts.cl->backend_decl) == VAR_DECL)
2141             fnbody = gfc_trans_dummy_character (proc_sym->ts.cl, fnbody);
2142         }
2143       else
2144         gcc_assert (gfc_option.flag_f2c
2145                     && proc_sym->ts.type == BT_COMPLEX);
2146     }
2147
2148   for (sym = proc_sym->tlink; sym != proc_sym; sym = sym->tlink)
2149     {
2150       if (sym->attr.dimension)
2151         {
2152           switch (sym->as->type)
2153             {
2154             case AS_EXPLICIT:
2155               if (sym->attr.dummy || sym->attr.result)
2156                 fnbody =
2157                   gfc_trans_dummy_array_bias (sym, sym->backend_decl, fnbody);
2158               else if (sym->attr.pointer || sym->attr.allocatable)
2159                 {
2160                   if (TREE_STATIC (sym->backend_decl))
2161                     gfc_trans_static_array_pointer (sym);
2162                   else
2163                     fnbody = gfc_trans_deferred_array (sym, fnbody);
2164                 }
2165               else
2166                 {
2167                   gfc_get_backend_locus (&loc);
2168                   gfc_set_backend_locus (&sym->declared_at);
2169                   fnbody = gfc_trans_auto_array_allocation (sym->backend_decl,
2170                       sym, fnbody);
2171                   gfc_set_backend_locus (&loc);
2172                 }
2173               break;
2174
2175             case AS_ASSUMED_SIZE:
2176               /* Must be a dummy parameter.  */
2177               gcc_assert (sym->attr.dummy);
2178
2179               /* We should always pass assumed size arrays the g77 way.  */
2180               fnbody = gfc_trans_g77_array (sym, fnbody);
2181               break;
2182
2183             case AS_ASSUMED_SHAPE:
2184               /* Must be a dummy parameter.  */
2185               gcc_assert (sym->attr.dummy);
2186
2187               fnbody = gfc_trans_dummy_array_bias (sym, sym->backend_decl,
2188                                                    fnbody);
2189               break;
2190
2191             case AS_DEFERRED:
2192               fnbody = gfc_trans_deferred_array (sym, fnbody);
2193               break;
2194
2195             default:
2196               gcc_unreachable ();
2197             }
2198         }
2199       else if (sym->ts.type == BT_CHARACTER)
2200         {
2201           gfc_get_backend_locus (&loc);
2202           gfc_set_backend_locus (&sym->declared_at);
2203           if (sym->attr.dummy || sym->attr.result)
2204             fnbody = gfc_trans_dummy_character (sym->ts.cl, fnbody);
2205           else
2206             fnbody = gfc_trans_auto_character_variable (sym, fnbody);
2207           gfc_set_backend_locus (&loc);
2208         }
2209       else
2210         gcc_unreachable ();
2211     }
2212
2213   return fnbody;
2214 }
2215
2216
2217 /* Output an initialized decl for a module variable.  */
2218
2219 static void
2220 gfc_create_module_variable (gfc_symbol * sym)
2221 {
2222   tree decl;
2223
2224   /* Only output symbols from this module.  */
2225   if (sym->ns != module_namespace)
2226     {
2227       /* I don't think this should ever happen.  */
2228       internal_error ("module symbol %s in wrong namespace", sym->name);
2229     }
2230
2231   /* Only output variables and array valued parameters.  */
2232   if (sym->attr.flavor != FL_VARIABLE
2233       && (sym->attr.flavor != FL_PARAMETER || sym->attr.dimension == 0))
2234     return;
2235
2236   /* Don't generate variables from other modules. Variables from
2237      COMMONs will already have been generated.  */
2238   if (sym->attr.use_assoc || sym->attr.in_common)
2239     return;
2240
2241   /* Equivalenced variables arrive here after creation.  */
2242   if (sym->backend_decl && sym->equiv_built)
2243       return;
2244
2245   if (sym->backend_decl)
2246     internal_error ("backend decl for module variable %s already exists",
2247                     sym->name);
2248
2249   /* We always want module variables to be created.  */
2250   sym->attr.referenced = 1;
2251   /* Create the decl.  */
2252   decl = gfc_get_symbol_decl (sym);
2253
2254   /* Create the variable.  */
2255   pushdecl (decl);
2256   rest_of_decl_compilation (decl, 1, 0);
2257
2258   /* Also add length of strings.  */
2259   if (sym->ts.type == BT_CHARACTER)
2260     {
2261       tree length;
2262
2263       length = sym->ts.cl->backend_decl;
2264       if (!INTEGER_CST_P (length))
2265         {
2266           pushdecl (length);
2267           rest_of_decl_compilation (length, 1, 0);
2268         }
2269     }
2270 }
2271
2272
2273 /* Generate all the required code for module variables.  */
2274
2275 void
2276 gfc_generate_module_vars (gfc_namespace * ns)
2277 {
2278   module_namespace = ns;
2279
2280   /* Check if the frontend left the namespace in a reasonable state.  */
2281   gcc_assert (ns->proc_name && !ns->proc_name->tlink);
2282
2283   /* Generate COMMON blocks.  */
2284   gfc_trans_common (ns);
2285
2286   /* Create decls for all the module variables.  */
2287   gfc_traverse_ns (ns, gfc_create_module_variable);
2288 }
2289
2290 static void
2291 gfc_generate_contained_functions (gfc_namespace * parent)
2292 {
2293   gfc_namespace *ns;
2294
2295   /* We create all the prototypes before generating any code.  */
2296   for (ns = parent->contained; ns; ns = ns->sibling)
2297     {
2298       /* Skip namespaces from used modules.  */
2299       if (ns->parent != parent)
2300         continue;
2301
2302       gfc_create_function_decl (ns);
2303     }
2304
2305   for (ns = parent->contained; ns; ns = ns->sibling)
2306     {
2307       /* Skip namespaces from used modules.  */
2308       if (ns->parent != parent)
2309         continue;
2310
2311       gfc_generate_function_code (ns);
2312     }
2313 }
2314
2315
2316 /* Generate decls for all local variables.  We do this to ensure correct
2317    handling of expressions which only appear in the specification of
2318    other functions.  */
2319
2320 static void
2321 generate_local_decl (gfc_symbol * sym)
2322 {
2323   if (sym->attr.flavor == FL_VARIABLE)
2324     {
2325       if (sym->attr.referenced)
2326         gfc_get_symbol_decl (sym);
2327       else if (sym->attr.dummy && warn_unused_parameter)
2328             warning (0, "unused parameter %qs", sym->name);
2329       /* Warn for unused variables, but not if they're inside a common
2330          block or are use-associated.  */
2331       else if (warn_unused_variable
2332                && !(sym->attr.in_common || sym->attr.use_assoc))
2333         warning (0, "unused variable %qs", sym->name);
2334     }
2335 }
2336
2337 static void
2338 generate_local_vars (gfc_namespace * ns)
2339 {
2340   gfc_traverse_ns (ns, generate_local_decl);
2341 }
2342
2343
2344 /* Generate a switch statement to jump to the correct entry point.  Also
2345    creates the label decls for the entry points.  */
2346
2347 static tree
2348 gfc_trans_entry_master_switch (gfc_entry_list * el)
2349 {
2350   stmtblock_t block;
2351   tree label;
2352   tree tmp;
2353   tree val;
2354
2355   gfc_init_block (&block);
2356   for (; el; el = el->next)
2357     {
2358       /* Add the case label.  */
2359       label = gfc_build_label_decl (NULL_TREE);
2360       val = build_int_cst (gfc_array_index_type, el->id);
2361       tmp = build3_v (CASE_LABEL_EXPR, val, NULL_TREE, label);
2362       gfc_add_expr_to_block (&block, tmp);
2363
2364       /* And jump to the actual entry point.  */
2365       label = gfc_build_label_decl (NULL_TREE);
2366       tmp = build1_v (GOTO_EXPR, label);
2367       gfc_add_expr_to_block (&block, tmp);
2368
2369       /* Save the label decl.  */
2370       el->label = label;
2371     }
2372   tmp = gfc_finish_block (&block);
2373   /* The first argument selects the entry point.  */
2374   val = DECL_ARGUMENTS (current_function_decl);
2375   tmp = build3_v (SWITCH_EXPR, val, tmp, NULL_TREE);
2376   return tmp;
2377 }
2378
2379
2380 /* Generate code for a function.  */
2381
2382 void
2383 gfc_generate_function_code (gfc_namespace * ns)
2384 {
2385   tree fndecl;
2386   tree old_context;
2387   tree decl;
2388   tree tmp;
2389   stmtblock_t block;
2390   stmtblock_t body;
2391   tree result;
2392   gfc_symbol *sym;
2393
2394   sym = ns->proc_name;
2395
2396   /* Check that the frontend isn't still using this.  */
2397   gcc_assert (sym->tlink == NULL);
2398   sym->tlink = sym;
2399
2400   /* Create the declaration for functions with global scope.  */
2401   if (!sym->backend_decl)
2402     gfc_create_function_decl (ns);
2403
2404   fndecl = sym->backend_decl;
2405   old_context = current_function_decl;
2406
2407   if (old_context)
2408     {
2409       push_function_context ();
2410       saved_parent_function_decls = saved_function_decls;
2411       saved_function_decls = NULL_TREE;
2412     }
2413
2414   trans_function_start (sym);
2415
2416   /* Will be created as needed.  */
2417   current_fake_result_decl = NULL_TREE;
2418
2419   gfc_start_block (&block);
2420
2421   if (ns->entries && ns->proc_name->ts.type == BT_CHARACTER)
2422     {
2423       /* Copy length backend_decls to all entry point result
2424          symbols.  */
2425       gfc_entry_list *el;
2426       tree backend_decl;
2427
2428       gfc_conv_const_charlen (ns->proc_name->ts.cl);
2429       backend_decl = ns->proc_name->result->ts.cl->backend_decl;
2430       for (el = ns->entries; el; el = el->next)
2431         el->sym->result->ts.cl->backend_decl = backend_decl;
2432     }
2433
2434   /* Translate COMMON blocks.  */
2435   gfc_trans_common (ns);
2436
2437   gfc_generate_contained_functions (ns);
2438
2439   generate_local_vars (ns);
2440
2441   current_function_return_label = NULL;
2442
2443   /* Now generate the code for the body of this function.  */
2444   gfc_init_block (&body);
2445
2446   /* If this is the main program and we compile with -pedantic, add a call
2447      to set_std to set up the runtime library Fortran language standard
2448      parameters.  */
2449   if (sym->attr.is_main_program && pedantic)
2450     {
2451       tree arglist, gfc_int4_type_node;
2452
2453       gfc_int4_type_node = gfc_get_int_type (4);
2454       arglist = gfc_chainon_list (NULL_TREE,
2455                                   build_int_cst (gfc_int4_type_node,
2456                                                  gfc_option.warn_std));
2457       arglist = gfc_chainon_list (arglist,
2458                                   build_int_cst (gfc_int4_type_node,
2459                                                  gfc_option.allow_std));
2460       tmp = gfc_build_function_call (gfor_fndecl_set_std, arglist);
2461       gfc_add_expr_to_block (&body, tmp);
2462     }
2463
2464   /* If this is the main program and a -ffpe-trap option was provided,
2465      add a call to set_fpe so that the library will raise a FPE when
2466      needed.  */
2467   if (sym->attr.is_main_program && gfc_option.fpe != 0)
2468     {
2469       tree arglist, gfc_c_int_type_node;
2470
2471       gfc_c_int_type_node = gfc_get_int_type (gfc_c_int_kind);
2472       arglist = gfc_chainon_list (NULL_TREE,
2473                                   build_int_cst (gfc_c_int_type_node,
2474                                                  gfc_option.fpe));
2475       tmp = gfc_build_function_call (gfor_fndecl_set_fpe, arglist);
2476       gfc_add_expr_to_block (&body, tmp);
2477     }
2478
2479   if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node
2480       && sym->attr.subroutine)
2481     {
2482       tree alternate_return;
2483       alternate_return = gfc_get_fake_result_decl (sym);
2484       gfc_add_modify_expr (&body, alternate_return, integer_zero_node);
2485     }
2486
2487   if (ns->entries)
2488     {
2489       /* Jump to the correct entry point.  */
2490       tmp = gfc_trans_entry_master_switch (ns->entries);
2491       gfc_add_expr_to_block (&body, tmp);
2492     }
2493
2494   tmp = gfc_trans_code (ns->code);
2495   gfc_add_expr_to_block (&body, tmp);
2496
2497   /* Add a return label if needed.  */
2498   if (current_function_return_label)
2499     {
2500       tmp = build1_v (LABEL_EXPR, current_function_return_label);
2501       gfc_add_expr_to_block (&body, tmp);
2502     }
2503
2504   tmp = gfc_finish_block (&body);
2505   /* Add code to create and cleanup arrays.  */
2506   tmp = gfc_trans_deferred_vars (sym, tmp);
2507   gfc_add_expr_to_block (&block, tmp);
2508
2509   if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node)
2510     {
2511       if (sym->attr.subroutine || sym == sym->result)
2512         {
2513           result = current_fake_result_decl;
2514           current_fake_result_decl = NULL_TREE;
2515         }
2516       else
2517         result = sym->result->backend_decl;
2518
2519       if (result == NULL_TREE)
2520         warning (0, "Function return value not set");
2521       else
2522         {
2523           /* Set the return value to the dummy result variable.  */
2524           tmp = build2 (MODIFY_EXPR, TREE_TYPE (result),
2525                         DECL_RESULT (fndecl), result);
2526           tmp = build1_v (RETURN_EXPR, tmp);
2527           gfc_add_expr_to_block (&block, tmp);
2528         }
2529     }
2530
2531   /* Add all the decls we created during processing.  */
2532   decl = saved_function_decls;
2533   while (decl)
2534     {
2535       tree next;
2536
2537       next = TREE_CHAIN (decl);
2538       TREE_CHAIN (decl) = NULL_TREE;
2539       pushdecl (decl);
2540       decl = next;
2541     }
2542   saved_function_decls = NULL_TREE;
2543
2544   DECL_SAVED_TREE (fndecl) = gfc_finish_block (&block);
2545
2546   /* Finish off this function and send it for code generation.  */
2547   poplevel (1, 0, 1);
2548   BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
2549
2550   /* Output the GENERIC tree.  */
2551   dump_function (TDI_original, fndecl);
2552
2553   /* Store the end of the function, so that we get good line number
2554      info for the epilogue.  */
2555   cfun->function_end_locus = input_location;
2556
2557   /* We're leaving the context of this function, so zap cfun.
2558      It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
2559      tree_rest_of_compilation.  */
2560   cfun = NULL;
2561
2562   if (old_context)
2563     {
2564       pop_function_context ();
2565       saved_function_decls = saved_parent_function_decls;
2566     }
2567   current_function_decl = old_context;
2568
2569   if (decl_function_context (fndecl))
2570     /* Register this function with cgraph just far enough to get it
2571        added to our parent's nested function list.  */
2572     (void) cgraph_node (fndecl);
2573   else
2574     {
2575       gfc_gimplify_function (fndecl);
2576       cgraph_finalize_function (fndecl, false);
2577     }
2578 }
2579
2580 void
2581 gfc_generate_constructors (void)
2582 {
2583   gcc_assert (gfc_static_ctors == NULL_TREE);
2584 #if 0
2585   tree fnname;
2586   tree type;
2587   tree fndecl;
2588   tree decl;
2589   tree tmp;
2590
2591   if (gfc_static_ctors == NULL_TREE)
2592     return;
2593
2594   fnname = get_file_function_name ('I');
2595   type = build_function_type (void_type_node,
2596                               gfc_chainon_list (NULL_TREE, void_type_node));
2597
2598   fndecl = build_decl (FUNCTION_DECL, fnname, type);
2599   TREE_PUBLIC (fndecl) = 1;
2600
2601   decl = build_decl (RESULT_DECL, NULL_TREE, void_type_node);
2602   DECL_ARTIFICIAL (decl) = 1;
2603   DECL_IGNORED_P (decl) = 1;
2604   DECL_CONTEXT (decl) = fndecl;
2605   DECL_RESULT (fndecl) = decl;
2606
2607   pushdecl (fndecl);
2608
2609   current_function_decl = fndecl;
2610
2611   rest_of_decl_compilation (fndecl, 1, 0);
2612
2613   make_decl_rtl (fndecl);
2614
2615   init_function_start (fndecl);
2616
2617   pushlevel (0);
2618
2619   for (; gfc_static_ctors; gfc_static_ctors = TREE_CHAIN (gfc_static_ctors))
2620     {
2621       tmp =
2622         gfc_build_function_call (TREE_VALUE (gfc_static_ctors), NULL_TREE);
2623       DECL_SAVED_TREE (fndecl) = build_stmt (EXPR_STMT, tmp);
2624     }
2625
2626   poplevel (1, 0, 1);
2627
2628   BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
2629
2630   free_after_parsing (cfun);
2631   free_after_compilation (cfun);
2632
2633   tree_rest_of_compilation (fndecl);
2634
2635   current_function_decl = NULL_TREE;
2636 #endif
2637 }
2638
2639 /* Translates a BLOCK DATA program unit. This means emitting the
2640    commons contained therein plus their initializations. We also emit
2641    a globally visible symbol to make sure that each BLOCK DATA program
2642    unit remains unique.  */
2643
2644 void
2645 gfc_generate_block_data (gfc_namespace * ns)
2646 {
2647   tree decl;
2648   tree id;
2649
2650   /* Tell the backend the source location of the block data.  */
2651   if (ns->proc_name)
2652     gfc_set_backend_locus (&ns->proc_name->declared_at);
2653   else
2654     gfc_set_backend_locus (&gfc_current_locus);
2655
2656   /* Process the DATA statements.  */
2657   gfc_trans_common (ns);
2658
2659   /* Create a global symbol with the mane of the block data.  This is to
2660      generate linker errors if the same name is used twice.  It is never
2661      really used.  */
2662   if (ns->proc_name)
2663     id = gfc_sym_mangled_function_id (ns->proc_name);
2664   else
2665     id = get_identifier ("__BLOCK_DATA__");
2666
2667   decl = build_decl (VAR_DECL, id, gfc_array_index_type);
2668   TREE_PUBLIC (decl) = 1;
2669   TREE_STATIC (decl) = 1;
2670
2671   pushdecl (decl);
2672   rest_of_decl_compilation (decl, 1, 0);
2673 }
2674
2675 #include "gt-fortran-trans-decl.h"