gcc/fortran/trans-decl.c

   1 /* Backend function setup
   2    Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
   3    Free Software Foundation, Inc.
   4    Contributed by Paul Brook
   5
   6 This file is part of GCC.
   7
   8 GCC is free software; you can redistribute it and/or modify it under
   9 the terms of the GNU General Public License as published by the Free
  10 Software Foundation; either version 3, or (at your option) any later
  11 version.
  12
  13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
  14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
  15 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  16 for more details.
  17
  18 You should have received a copy of the GNU General Public License
  19 along with GCC; see the file COPYING3.  If not see
  20 <http://www.gnu.org/licenses/>.  */
  21
  22 /* 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 "gimple.h"
  30 #include "ggc.h"
  31 #include "toplev.h"
  32 #include "tm.h"
  33 #include "rtl.h"
  34 #include "target.h"
  35 #include "function.h"
  36 #include "flags.h"
  37 #include "cgraph.h"
  38 #include "debug.h"
  39 #include "gfortran.h"
  40 #include "pointer-set.h"
  41 #include "trans.h"
  42 #include "trans-types.h"
  43 #include "trans-array.h"
  44 #include "trans-const.h"
  45 /* Only for gfc_trans_code.  Shouldn't need to include this.  */
  46 #include "trans-stmt.h"
  47
  48 #define MAX_LABEL_VALUE 99999
  49
  50
  51 /* Holds the result of the function if no result variable specified.  */
  52
  53 static GTY(()) tree current_fake_result_decl;
  54 static GTY(()) tree parent_fake_result_decl;
  55
  56 static GTY(()) tree current_function_return_label;
  57
  58
  59 /* Holds the variable DECLs for the current function.  */
  60
  61 static GTY(()) tree saved_function_decls;
  62 static GTY(()) tree saved_parent_function_decls;
  63
  64 static struct pointer_set_t *nonlocal_dummy_decl_pset;
  65 static GTY(()) tree nonlocal_dummy_decls;
  66
  67 /* The namespace of the module we're currently generating.  Only used while
  68    outputting decls for module variables.  Do not rely on this being set.  */
  69
  70 static gfc_namespace *module_namespace;
  71
  72
  73 /* List of static constructor functions.  */
  74
  75 tree gfc_static_ctors;
  76
  77
  78 /* Function declarations for builtin library functions.  */
  79
  80 tree gfor_fndecl_pause_numeric;
  81 tree gfor_fndecl_pause_string;
  82 tree gfor_fndecl_stop_numeric;
  83 tree gfor_fndecl_stop_string;
  84 tree gfor_fndecl_runtime_error;
  85 tree gfor_fndecl_runtime_error_at;
  86 tree gfor_fndecl_runtime_warning_at;
  87 tree gfor_fndecl_os_error;
  88 tree gfor_fndecl_generate_error;
  89 tree gfor_fndecl_set_args;
  90 tree gfor_fndecl_set_fpe;
  91 tree gfor_fndecl_set_options;
  92 tree gfor_fndecl_set_convert;
  93 tree gfor_fndecl_set_record_marker;
  94 tree gfor_fndecl_set_max_subrecord_length;
  95 tree gfor_fndecl_ctime;
  96 tree gfor_fndecl_fdate;
  97 tree gfor_fndecl_ttynam;
  98 tree gfor_fndecl_in_pack;
  99 tree gfor_fndecl_in_unpack;
 100 tree gfor_fndecl_associated;
 101
 102
 103 /* Math functions.  Many other math functions are handled in
 104    trans-intrinsic.c.  */
 105
 106 gfc_powdecl_list gfor_fndecl_math_powi[4][3];
 107 tree gfor_fndecl_math_ishftc4;
 108 tree gfor_fndecl_math_ishftc8;
 109 tree gfor_fndecl_math_ishftc16;
 110
 111
 112 /* String functions.  */
 113
 114 tree gfor_fndecl_compare_string;
 115 tree gfor_fndecl_concat_string;
 116 tree gfor_fndecl_string_len_trim;
 117 tree gfor_fndecl_string_index;
 118 tree gfor_fndecl_string_scan;
 119 tree gfor_fndecl_string_verify;
 120 tree gfor_fndecl_string_trim;
 121 tree gfor_fndecl_string_minmax;
 122 tree gfor_fndecl_adjustl;
 123 tree gfor_fndecl_adjustr;
 124 tree gfor_fndecl_select_string;
 125 tree gfor_fndecl_compare_string_char4;
 126 tree gfor_fndecl_concat_string_char4;
 127 tree gfor_fndecl_string_len_trim_char4;
 128 tree gfor_fndecl_string_index_char4;
 129 tree gfor_fndecl_string_scan_char4;
 130 tree gfor_fndecl_string_verify_char4;
 131 tree gfor_fndecl_string_trim_char4;
 132 tree gfor_fndecl_string_minmax_char4;
 133 tree gfor_fndecl_adjustl_char4;
 134 tree gfor_fndecl_adjustr_char4;
 135 tree gfor_fndecl_select_string_char4;
 136
 137
 138 /* Conversion between character kinds.  */
 139 tree gfor_fndecl_convert_char1_to_char4;
 140 tree gfor_fndecl_convert_char4_to_char1;
 141
 142
 143 /* Other misc. runtime library functions.  */
 144
 145 tree gfor_fndecl_size0;
 146 tree gfor_fndecl_size1;
 147 tree gfor_fndecl_iargc;
 148 tree gfor_fndecl_clz128;
 149 tree gfor_fndecl_ctz128;
 150
 151 /* Intrinsic functions implemented in Fortran.  */
 152 tree gfor_fndecl_sc_kind;
 153 tree gfor_fndecl_si_kind;
 154 tree gfor_fndecl_sr_kind;
 155
 156 /* BLAS gemm functions.  */
 157 tree gfor_fndecl_sgemm;
 158 tree gfor_fndecl_dgemm;
 159 tree gfor_fndecl_cgemm;
 160 tree gfor_fndecl_zgemm;
 161
 162
 163 static void
 164 gfc_add_decl_to_parent_function (tree decl)
 165 {
 166   gcc_assert (decl);
 167   DECL_CONTEXT (decl) = DECL_CONTEXT (current_function_decl);
 168   DECL_NONLOCAL (decl) = 1;
 169   TREE_CHAIN (decl) = saved_parent_function_decls;
 170   saved_parent_function_decls = decl;
 171 }
 172
 173 void
 174 gfc_add_decl_to_function (tree decl)
 175 {
 176   gcc_assert (decl);
 177   TREE_USED (decl) = 1;
 178   DECL_CONTEXT (decl) = current_function_decl;
 179   TREE_CHAIN (decl) = saved_function_decls;
 180   saved_function_decls = decl;
 181 }
 182
 183
 184 /* Build a  backend label declaration.  Set TREE_USED for named labels.
 185    The context of the label is always the current_function_decl.  All
 186    labels are marked artificial.  */
 187
 188 tree
 189 gfc_build_label_decl (tree label_id)
 190 {
 191   /* 2^32 temporaries should be enough.  */
 192   static unsigned int tmp_num = 1;
 193   tree label_decl;
 194   char *label_name;
 195
 196   if (label_id == NULL_TREE)
 197     {
 198       /* Build an internal label name.  */
 199       ASM_FORMAT_PRIVATE_NAME (label_name, "L", tmp_num++);
 200       label_id = get_identifier (label_name);
 201     }
 202   else
 203     label_name = NULL;
 204
 205   /* Build the LABEL_DECL node. Labels have no type.  */
 206   label_decl = build_decl (LABEL_DECL, label_id, void_type_node);
 207   DECL_CONTEXT (label_decl) = current_function_decl;
 208   DECL_MODE (label_decl) = VOIDmode;
 209
 210   /* We always define the label as used, even if the original source
 211      file never references the label.  We don't want all kinds of
 212      spurious warnings for old-style Fortran code with too many
 213      labels.  */
 214   TREE_USED (label_decl) = 1;
 215
 216   DECL_ARTIFICIAL (label_decl) = 1;
 217   return label_decl;
 218 }
 219
 220
 221 /* Returns the return label for the current function.  */
 222
 223 tree
 224 gfc_get_return_label (void)
 225 {
 226   char name[GFC_MAX_SYMBOL_LEN + 10];
 227
 228   if (current_function_return_label)
 229     return current_function_return_label;
 230
 231   sprintf (name, "__return_%s",
 232            IDENTIFIER_POINTER (DECL_NAME (current_function_decl)));
 233
 234   current_function_return_label =
 235     gfc_build_label_decl (get_identifier (name));
 236
 237   DECL_ARTIFICIAL (current_function_return_label) = 1;
 238
 239   return current_function_return_label;
 240 }
 241
 242
 243 /* Set the backend source location of a decl.  */
 244
 245 void
 246 gfc_set_decl_location (tree decl, locus * loc)
 247 {
 248   DECL_SOURCE_LOCATION (decl) = loc->lb->location;
 249 }
 250
 251
 252 /* Return the backend label declaration for a given label structure,
 253    or create it if it doesn't exist yet.  */
 254
 255 tree
 256 gfc_get_label_decl (gfc_st_label * lp)
 257 {
 258   if (lp->backend_decl)
 259     return lp->backend_decl;
 260   else
 261     {
 262       char label_name[GFC_MAX_SYMBOL_LEN + 1];
 263       tree label_decl;
 264
 265       /* Validate the label declaration from the front end.  */
 266       gcc_assert (lp != NULL && lp->value <= MAX_LABEL_VALUE);
 267
 268       /* Build a mangled name for the label.  */
 269       sprintf (label_name, "__label_%.6d", lp->value);
 270
 271       /* Build the LABEL_DECL node.  */
 272       label_decl = gfc_build_label_decl (get_identifier (label_name));
 273
 274       /* Tell the debugger where the label came from.  */
 275       if (lp->value <= MAX_LABEL_VALUE) /* An internal label.  */
 276         gfc_set_decl_location (label_decl, &lp->where);
 277       else
 278         DECL_ARTIFICIAL (label_decl) = 1;
 279
 280       /* Store the label in the label list and return the LABEL_DECL.  */
 281       lp->backend_decl = label_decl;
 282       return label_decl;
 283     }
 284 }
 285
 286
 287 /* Convert a gfc_symbol to an identifier of the same name.  */
 288
 289 static tree
 290 gfc_sym_identifier (gfc_symbol * sym)
 291 {
 292   if (sym->attr.is_main_program && strcmp (sym->name, "main") == 0)
 293     return (get_identifier ("MAIN__"));
 294   else
 295     return (get_identifier (sym->name));
 296 }
 297
 298
 299 /* Construct mangled name from symbol name.  */
 300
 301 static tree
 302 gfc_sym_mangled_identifier (gfc_symbol * sym)
 303 {
 304   char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
 305
 306   /* Prevent the mangling of identifiers that have an assigned
 307      binding label (mainly those that are bind(c)).  */
 308   if (sym->attr.is_bind_c == 1
 309       && sym->binding_label[0] != '\0')
 310     return get_identifier(sym->binding_label);
 311
 312   if (sym->module == NULL)
 313     return gfc_sym_identifier (sym);
 314   else
 315     {
 316       snprintf (name, sizeof name, "__%s_MOD_%s", sym->module, sym->name);
 317       return get_identifier (name);
 318     }
 319 }
 320
 321
 322 /* Construct mangled function name from symbol name.  */
 323
 324 static tree
 325 gfc_sym_mangled_function_id (gfc_symbol * sym)
 326 {
 327   int has_underscore;
 328   char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
 329
 330   /* It may be possible to simply use the binding label if it's
 331      provided, and remove the other checks.  Then we could use it
 332      for other things if we wished.  */
 333   if ((sym->attr.is_bind_c == 1 || sym->attr.is_iso_c == 1) &&
 334       sym->binding_label[0] != '\0')
 335     /* use the binding label rather than the mangled name */
 336     return get_identifier (sym->binding_label);
 337
 338   if (sym->module == NULL || sym->attr.proc == PROC_EXTERNAL
 339       || (sym->module != NULL && (sym->attr.external
 340             || sym->attr.if_source == IFSRC_IFBODY)))
 341     {
 342       /* Main program is mangled into MAIN__.  */
 343       if (sym->attr.is_main_program)
 344         return get_identifier ("MAIN__");
 345
 346       /* Intrinsic procedures are never mangled.  */
 347       if (sym->attr.proc == PROC_INTRINSIC)
 348         return get_identifier (sym->name);
 349
 350       if (gfc_option.flag_underscoring)
 351         {
 352           has_underscore = strchr (sym->name, '_') != 0;
 353           if (gfc_option.flag_second_underscore && has_underscore)
 354             snprintf (name, sizeof name, "%s__", sym->name);
 355           else
 356             snprintf (name, sizeof name, "%s_", sym->name);
 357           return get_identifier (name);
 358         }
 359       else
 360         return get_identifier (sym->name);
 361     }
 362   else
 363     {
 364       snprintf (name, sizeof name, "__%s_MOD_%s", sym->module, sym->name);
 365       return get_identifier (name);
 366     }
 367 }
 368
 369
 370 /* Returns true if a variable of specified size should go on the stack.  */
 371
 372 int
 373 gfc_can_put_var_on_stack (tree size)
 374 {
 375   unsigned HOST_WIDE_INT low;
 376
 377   if (!INTEGER_CST_P (size))
 378     return 0;
 379
 380   if (gfc_option.flag_max_stack_var_size < 0)
 381     return 1;
 382
 383   if (TREE_INT_CST_HIGH (size) != 0)
 384     return 0;
 385
 386   low = TREE_INT_CST_LOW (size);
 387   if (low > (unsigned HOST_WIDE_INT) gfc_option.flag_max_stack_var_size)
 388     return 0;
 389
 390 /* TODO: Set a per-function stack size limit.  */
 391
 392   return 1;
 393 }
 394
 395
 396 /* gfc_finish_cray_pointee sets DECL_VALUE_EXPR for a Cray pointee to
 397    an expression involving its corresponding pointer.  There are
 398    2 cases; one for variable size arrays, and one for everything else,
 399    because variable-sized arrays require one fewer level of
 400    indirection.  */
 401
 402 static void
 403 gfc_finish_cray_pointee (tree decl, gfc_symbol *sym)
 404 {
 405   tree ptr_decl = gfc_get_symbol_decl (sym->cp_pointer);
 406   tree value;
 407
 408   /* Parameters need to be dereferenced.  */
 409   if (sym->cp_pointer->attr.dummy)
 410     ptr_decl = build_fold_indirect_ref (ptr_decl);
 411
 412   /* Check to see if we're dealing with a variable-sized array.  */
 413   if (sym->attr.dimension
 414       && TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE)
 415     {
 416       /* These decls will be dereferenced later, so we don't dereference
 417          them here.  */
 418       value = convert (TREE_TYPE (decl), ptr_decl);
 419     }
 420   else
 421     {
 422       ptr_decl = convert (build_pointer_type (TREE_TYPE (decl)),
 423                           ptr_decl);
 424       value = build_fold_indirect_ref (ptr_decl);
 425     }
 426
 427   SET_DECL_VALUE_EXPR (decl, value);
 428   DECL_HAS_VALUE_EXPR_P (decl) = 1;
 429   GFC_DECL_CRAY_POINTEE (decl) = 1;
 430   /* This is a fake variable just for debugging purposes.  */
 431   TREE_ASM_WRITTEN (decl) = 1;
 432 }
 433
 434
 435 /* Finish processing of a declaration without an initial value.  */
 436
 437 static void
 438 gfc_finish_decl (tree decl)
 439 {
 440   gcc_assert (TREE_CODE (decl) == PARM_DECL
 441               || DECL_INITIAL (decl) == NULL_TREE);
 442
 443   if (TREE_CODE (decl) != VAR_DECL)
 444     return;
 445
 446   if (DECL_SIZE (decl) == NULL_TREE
 447       && TYPE_SIZE (TREE_TYPE (decl)) != NULL_TREE)
 448     layout_decl (decl, 0);
 449
 450   /* A few consistency checks.  */
 451   /* A static variable with an incomplete type is an error if it is
 452      initialized. Also if it is not file scope. Otherwise, let it
 453      through, but if it is not `extern' then it may cause an error
 454      message later.  */
 455   /* An automatic variable with an incomplete type is an error.  */
 456
 457   /* We should know the storage size.  */
 458   gcc_assert (DECL_SIZE (decl) != NULL_TREE
 459               || (TREE_STATIC (decl)
 460                   ? (!DECL_INITIAL (decl) || !DECL_CONTEXT (decl))
 461                   : DECL_EXTERNAL (decl)));
 462
 463   /* The storage size should be constant.  */
 464   gcc_assert ((!DECL_EXTERNAL (decl) && !TREE_STATIC (decl))
 465               || !DECL_SIZE (decl)
 466               || TREE_CODE (DECL_SIZE (decl)) == INTEGER_CST);
 467 }
 468
 469
 470 /* Apply symbol attributes to a variable, and add it to the function scope.  */
 471
 472 static void
 473 gfc_finish_var_decl (tree decl, gfc_symbol * sym)
 474 {
 475   tree new_type;
 476   /* TREE_ADDRESSABLE means the address of this variable is actually needed.
 477      This is the equivalent of the TARGET variables.
 478      We also need to set this if the variable is passed by reference in a
 479      CALL statement.  */
 480
 481   /* Set DECL_VALUE_EXPR for Cray Pointees.  */
 482   if (sym->attr.cray_pointee)
 483     gfc_finish_cray_pointee (decl, sym);
 484
 485   if (sym->attr.target)
 486     TREE_ADDRESSABLE (decl) = 1;
 487   /* If it wasn't used we wouldn't be getting it.  */
 488   TREE_USED (decl) = 1;
 489
 490   /* Chain this decl to the pending declarations.  Don't do pushdecl()
 491      because this would add them to the current scope rather than the
 492      function scope.  */
 493   if (current_function_decl != NULL_TREE)
 494     {
 495       if (sym->ns->proc_name->backend_decl == current_function_decl
 496           || sym->result == sym)
 497         gfc_add_decl_to_function (decl);
 498       else
 499         gfc_add_decl_to_parent_function (decl);
 500     }
 501
 502   if (sym->attr.cray_pointee)
 503     return;
 504
 505   if(sym->attr.is_bind_c == 1)
 506     {
 507       /* We need to put variables that are bind(c) into the common
 508          segment of the object file, because this is what C would do.
 509          gfortran would typically put them in either the BSS or
 510          initialized data segments, and only mark them as common if
 511          they were part of common blocks.  However, if they are not put
 512          into common space, then C cannot initialize global fortran
 513          variables that it interoperates with and the draft says that
 514          either Fortran or C should be able to initialize it (but not
 515          both, of course.) (J3/04-007, section 15.3).  */
 516       TREE_PUBLIC(decl) = 1;
 517       DECL_COMMON(decl) = 1;
 518     }
 519
 520   /* If a variable is USE associated, it's always external.  */
 521   if (sym->attr.use_assoc)
 522     {
 523       DECL_EXTERNAL (decl) = 1;
 524       TREE_PUBLIC (decl) = 1;
 525     }
 526   else if (sym->module && !sym->attr.result && !sym->attr.dummy)
 527     {
 528       /* TODO: Don't set sym->module for result or dummy variables.  */
 529       gcc_assert (current_function_decl == NULL_TREE || sym->result == sym);
 530       /* This is the declaration of a module variable.  */
 531       TREE_PUBLIC (decl) = 1;
 532       TREE_STATIC (decl) = 1;
 533     }
 534
 535   /* Derived types are a bit peculiar because of the possibility of
 536      a default initializer; this must be applied each time the variable
 537      comes into scope it therefore need not be static.  These variables
 538      are SAVE_NONE but have an initializer.  Otherwise explicitly
 539      initialized variables are SAVE_IMPLICIT and explicitly saved are
 540      SAVE_EXPLICIT.  */
 541   if (!sym->attr.use_assoc
 542         && (sym->attr.save != SAVE_NONE || sym->attr.data
 543               || (sym->value && sym->ns->proc_name->attr.is_main_program)))
 544     TREE_STATIC (decl) = 1;
 545
 546   if (sym->attr.volatile_)
 547     {
 548       TREE_THIS_VOLATILE (decl) = 1;
 549       new_type = build_qualified_type (TREE_TYPE (decl), TYPE_QUAL_VOLATILE);
 550       TREE_TYPE (decl) = new_type;
 551     }
 552
 553   /* Keep variables larger than max-stack-var-size off stack.  */
 554   if (!sym->ns->proc_name->attr.recursive
 555       && INTEGER_CST_P (DECL_SIZE_UNIT (decl))
 556       && !gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl))
 557          /* Put variable length auto array pointers always into stack.  */
 558       && (TREE_CODE (TREE_TYPE (decl)) != POINTER_TYPE
 559           || sym->attr.dimension == 0
 560           || sym->as->type != AS_EXPLICIT
 561           || sym->attr.pointer
 562           || sym->attr.allocatable)
 563       && !DECL_ARTIFICIAL (decl))
 564     TREE_STATIC (decl) = 1;
 565
 566   /* Handle threadprivate variables.  */
 567   if (sym->attr.threadprivate
 568       && (TREE_STATIC (decl) || DECL_EXTERNAL (decl)))
 569     DECL_TLS_MODEL (decl) = decl_default_tls_model (decl);
 570 }
 571
 572
 573 /* Allocate the lang-specific part of a decl.  */
 574
 575 void
 576 gfc_allocate_lang_decl (tree decl)
 577 {
 578   DECL_LANG_SPECIFIC (decl) = (struct lang_decl *)
 579     ggc_alloc_cleared (sizeof (struct lang_decl));
 580 }
 581
 582 /* Remember a symbol to generate initialization/cleanup code at function
 583    entry/exit.  */
 584
 585 static void
 586 gfc_defer_symbol_init (gfc_symbol * sym)
 587 {
 588   gfc_symbol *p;
 589   gfc_symbol *last;
 590   gfc_symbol *head;
 591
 592   /* Don't add a symbol twice.  */
 593   if (sym->tlink)
 594     return;
 595
 596   last = head = sym->ns->proc_name;
 597   p = last->tlink;
 598
 599   /* Make sure that setup code for dummy variables which are used in the
 600      setup of other variables is generated first.  */
 601   if (sym->attr.dummy)
 602     {
 603       /* Find the first dummy arg seen after us, or the first non-dummy arg.
 604          This is a circular list, so don't go past the head.  */
 605       while (p != head
 606              && (!p->attr.dummy || p->dummy_order > sym->dummy_order))
 607         {
 608           last = p;
 609           p = p->tlink;
 610         }
 611     }
 612   /* Insert in between last and p.  */
 613   last->tlink = sym;
 614   sym->tlink = p;
 615 }
 616
 617
 618 /* Create an array index type variable with function scope.  */
 619
 620 static tree
 621 create_index_var (const char * pfx, int nest)
 622 {
 623   tree decl;
 624
 625   decl = gfc_create_var_np (gfc_array_index_type, pfx);
 626   if (nest)
 627     gfc_add_decl_to_parent_function (decl);
 628   else
 629     gfc_add_decl_to_function (decl);
 630   return decl;
 631 }
 632
 633
 634 /* Create variables to hold all the non-constant bits of info for a
 635    descriptorless array.  Remember these in the lang-specific part of the
 636    type.  */
 637
 638 static void
 639 gfc_build_qualified_array (tree decl, gfc_symbol * sym)
 640 {
 641   tree type;
 642   int dim;
 643   int nest;
 644
 645   type = TREE_TYPE (decl);
 646
 647   /* We just use the descriptor, if there is one.  */
 648   if (GFC_DESCRIPTOR_TYPE_P (type))
 649     return;
 650
 651   gcc_assert (GFC_ARRAY_TYPE_P (type));
 652   nest = (sym->ns->proc_name->backend_decl != current_function_decl)
 653          && !sym->attr.contained;
 654
 655   for (dim = 0; dim < GFC_TYPE_ARRAY_RANK (type); dim++)
 656     {
 657       if (GFC_TYPE_ARRAY_LBOUND (type, dim) == NULL_TREE)
 658         {
 659           GFC_TYPE_ARRAY_LBOUND (type, dim) = create_index_var ("lbound", nest);
 660           TREE_NO_WARNING (GFC_TYPE_ARRAY_LBOUND (type, dim)) = 1;
 661         }
 662       /* Don't try to use the unknown bound for assumed shape arrays.  */
 663       if (GFC_TYPE_ARRAY_UBOUND (type, dim) == NULL_TREE
 664           && (sym->as->type != AS_ASSUMED_SIZE
 665               || dim < GFC_TYPE_ARRAY_RANK (type) - 1))
 666         {
 667           GFC_TYPE_ARRAY_UBOUND (type, dim) = create_index_var ("ubound", nest);
 668           TREE_NO_WARNING (GFC_TYPE_ARRAY_UBOUND (type, dim)) = 1;
 669         }
 670
 671       if (GFC_TYPE_ARRAY_STRIDE (type, dim) == NULL_TREE)
 672         {
 673           GFC_TYPE_ARRAY_STRIDE (type, dim) = create_index_var ("stride", nest);
 674           TREE_NO_WARNING (GFC_TYPE_ARRAY_STRIDE (type, dim)) = 1;
 675         }
 676     }
 677   if (GFC_TYPE_ARRAY_OFFSET (type) == NULL_TREE)
 678     {
 679       GFC_TYPE_ARRAY_OFFSET (type) = gfc_create_var_np (gfc_array_index_type,
 680                                                         "offset");
 681       TREE_NO_WARNING (GFC_TYPE_ARRAY_OFFSET (type)) = 1;
 682
 683       if (nest)
 684         gfc_add_decl_to_parent_function (GFC_TYPE_ARRAY_OFFSET (type));
 685       else
 686         gfc_add_decl_to_function (GFC_TYPE_ARRAY_OFFSET (type));
 687     }
 688
 689   if (GFC_TYPE_ARRAY_SIZE (type) == NULL_TREE
 690       && sym->as->type != AS_ASSUMED_SIZE)
 691     {
 692       GFC_TYPE_ARRAY_SIZE (type) = create_index_var ("size", nest);
 693       TREE_NO_WARNING (GFC_TYPE_ARRAY_SIZE (type)) = 1;
 694     }
 695
 696   if (POINTER_TYPE_P (type))
 697     {
 698       gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (type)));
 699       gcc_assert (TYPE_LANG_SPECIFIC (type)
 700                   == TYPE_LANG_SPECIFIC (TREE_TYPE (type)));
 701       type = TREE_TYPE (type);
 702     }
 703
 704   if (! COMPLETE_TYPE_P (type) && GFC_TYPE_ARRAY_SIZE (type))
 705     {
 706       tree size, range;
 707
 708       size = fold_build2 (MINUS_EXPR, gfc_array_index_type,
 709                           GFC_TYPE_ARRAY_SIZE (type), gfc_index_one_node);
 710       range = build_range_type (gfc_array_index_type, gfc_index_zero_node,
 711                                 size);
 712       TYPE_DOMAIN (type) = range;
 713       layout_type (type);
 714     }
 715
 716   if (write_symbols == NO_DEBUG)
 717     return;
 718
 719   if (TYPE_NAME (type) != NULL_TREE
 720       && GFC_TYPE_ARRAY_UBOUND (type, sym->as->rank - 1) != NULL_TREE
 721       && TREE_CODE (GFC_TYPE_ARRAY_UBOUND (type, sym->as->rank - 1)) == VAR_DECL)
 722     {
 723       tree gtype = DECL_ORIGINAL_TYPE (TYPE_NAME (type));
 724
 725       for (dim = 0; dim < sym->as->rank - 1; dim++)
 726         {
 727           gcc_assert (TREE_CODE (gtype) == ARRAY_TYPE);
 728           gtype = TREE_TYPE (gtype);
 729         }
 730       gcc_assert (TREE_CODE (gtype) == ARRAY_TYPE);
 731       if (TYPE_MAX_VALUE (TYPE_DOMAIN (gtype)) == NULL)
 732         TYPE_NAME (type) = NULL_TREE;
 733     }
 734
 735   if (TYPE_NAME (type) == NULL_TREE)
 736     {
 737       tree gtype = TREE_TYPE (type), rtype, type_decl;
 738
 739       for (dim = sym->as->rank - 1; dim >= 0; dim--)
 740         {
 741           rtype = build_range_type (gfc_array_index_type,
 742                                     GFC_TYPE_ARRAY_LBOUND (type, dim),
 743                                     GFC_TYPE_ARRAY_UBOUND (type, dim));
 744           gtype = build_array_type (gtype, rtype);
 745           /* Ensure the bound variables aren't optimized out at -O0.  */
 746           if (!optimize)
 747             {
 748               if (GFC_TYPE_ARRAY_LBOUND (type, dim)
 749                   && TREE_CODE (GFC_TYPE_ARRAY_LBOUND (type, dim)) == VAR_DECL)
 750                 DECL_IGNORED_P (GFC_TYPE_ARRAY_LBOUND (type, dim)) = 0;
 751               if (GFC_TYPE_ARRAY_UBOUND (type, dim)
 752                   && TREE_CODE (GFC_TYPE_ARRAY_UBOUND (type, dim)) == VAR_DECL)
 753                 DECL_IGNORED_P (GFC_TYPE_ARRAY_UBOUND (type, dim)) = 0;
 754             }
 755         }
 756       TYPE_NAME (type) = type_decl = build_decl (TYPE_DECL, NULL, gtype);
 757       DECL_ORIGINAL_TYPE (type_decl) = gtype;
 758     }
 759 }
 760
 761
 762 /* For some dummy arguments we don't use the actual argument directly.
 763    Instead we create a local decl and use that.  This allows us to perform
 764    initialization, and construct full type information.  */
 765
 766 static tree
 767 gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy)
 768 {
 769   tree decl;
 770   tree type;
 771   gfc_array_spec *as;
 772   char *name;
 773   gfc_packed packed;
 774   int n;
 775   bool known_size;
 776
 777   if (sym->attr.pointer || sym->attr.allocatable)
 778     return dummy;
 779
 780   /* Add to list of variables if not a fake result variable.  */
 781   if (sym->attr.result || sym->attr.dummy)
 782     gfc_defer_symbol_init (sym);
 783
 784   type = TREE_TYPE (dummy);
 785   gcc_assert (TREE_CODE (dummy) == PARM_DECL
 786           && POINTER_TYPE_P (type));
 787
 788   /* Do we know the element size?  */
 789   known_size = sym->ts.type != BT_CHARACTER
 790           || INTEGER_CST_P (sym->ts.cl->backend_decl);
 791
 792   if (known_size && !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type)))
 793     {
 794       /* For descriptorless arrays with known element size the actual
 795          argument is sufficient.  */
 796       gcc_assert (GFC_ARRAY_TYPE_P (type));
 797       gfc_build_qualified_array (dummy, sym);
 798       return dummy;
 799     }
 800
 801   type = TREE_TYPE (type);
 802   if (GFC_DESCRIPTOR_TYPE_P (type))
 803     {
 804       /* Create a descriptorless array pointer.  */
 805       as = sym->as;
 806       packed = PACKED_NO;
 807
 808       /* Even when -frepack-arrays is used, symbols with TARGET attribute
 809          are not repacked.  */
 810       if (!gfc_option.flag_repack_arrays || sym->attr.target)
 811         {
 812           if (as->type == AS_ASSUMED_SIZE)
 813             packed = PACKED_FULL;
 814         }
 815       else
 816         {
 817           if (as->type == AS_EXPLICIT)
 818             {
 819               packed = PACKED_FULL;
 820               for (n = 0; n < as->rank; n++)
 821                 {
 822                   if (!(as->upper[n]
 823                         && as->lower[n]
 824                         && as->upper[n]->expr_type == EXPR_CONSTANT
 825                         && as->lower[n]->expr_type == EXPR_CONSTANT))
 826                     packed = PACKED_PARTIAL;
 827                 }
 828             }
 829           else
 830             packed = PACKED_PARTIAL;
 831         }
 832
 833       type = gfc_typenode_for_spec (&sym->ts);
 834       type = gfc_get_nodesc_array_type (type, sym->as, packed);
 835     }
 836   else
 837     {
 838       /* We now have an expression for the element size, so create a fully
 839          qualified type.  Reset sym->backend decl or this will just return the
 840          old type.  */
 841       DECL_ARTIFICIAL (sym->backend_decl) = 1;
 842       sym->backend_decl = NULL_TREE;
 843       type = gfc_sym_type (sym);
 844       packed = PACKED_FULL;
 845     }
 846
 847   ASM_FORMAT_PRIVATE_NAME (name, IDENTIFIER_POINTER (DECL_NAME (dummy)), 0);
 848   decl = build_decl (VAR_DECL, get_identifier (name), type);
 849
 850   DECL_ARTIFICIAL (decl) = 1;
 851   TREE_PUBLIC (decl) = 0;
 852   TREE_STATIC (decl) = 0;
 853   DECL_EXTERNAL (decl) = 0;
 854
 855   /* We should never get deferred shape arrays here.  We used to because of
 856      frontend bugs.  */
 857   gcc_assert (sym->as->type != AS_DEFERRED);
 858
 859   if (packed == PACKED_PARTIAL)
 860     GFC_DECL_PARTIAL_PACKED_ARRAY (decl) = 1;
 861   else if (packed == PACKED_FULL)
 862     GFC_DECL_PACKED_ARRAY (decl) = 1;
 863
 864   gfc_build_qualified_array (decl, sym);
 865
 866   if (DECL_LANG_SPECIFIC (dummy))
 867     DECL_LANG_SPECIFIC (decl) = DECL_LANG_SPECIFIC (dummy);
 868   else
 869     gfc_allocate_lang_decl (decl);
 870
 871   GFC_DECL_SAVED_DESCRIPTOR (decl) = dummy;
 872
 873   if (sym->ns->proc_name->backend_decl == current_function_decl
 874       || sym->attr.contained)
 875     gfc_add_decl_to_function (decl);
 876   else
 877     gfc_add_decl_to_parent_function (decl);
 878
 879   return decl;
 880 }
 881
 882 /* For symbol SYM with GFC_DECL_SAVED_DESCRIPTOR used in contained
 883    function add a VAR_DECL to the current function with DECL_VALUE_EXPR
 884    pointing to the artificial variable for debug info purposes.  */
 885
 886 static void
 887 gfc_nonlocal_dummy_array_decl (gfc_symbol *sym)
 888 {
 889   tree decl, dummy;
 890
 891   if (! nonlocal_dummy_decl_pset)
 892     nonlocal_dummy_decl_pset = pointer_set_create ();
 893
 894   if (pointer_set_insert (nonlocal_dummy_decl_pset, sym->backend_decl))
 895     return;
 896
 897   dummy = GFC_DECL_SAVED_DESCRIPTOR (sym->backend_decl);
 898   decl = build_decl (VAR_DECL, DECL_NAME (dummy),
 899                      TREE_TYPE (sym->backend_decl));
 900   DECL_ARTIFICIAL (decl) = 0;
 901   TREE_USED (decl) = 1;
 902   TREE_PUBLIC (decl) = 0;
 903   TREE_STATIC (decl) = 0;
 904   DECL_EXTERNAL (decl) = 0;
 905   if (DECL_BY_REFERENCE (dummy))
 906     DECL_BY_REFERENCE (decl) = 1;
 907   DECL_LANG_SPECIFIC (decl) = DECL_LANG_SPECIFIC (sym->backend_decl);
 908   SET_DECL_VALUE_EXPR (decl, sym->backend_decl);
 909   DECL_HAS_VALUE_EXPR_P (decl) = 1;
 910   DECL_CONTEXT (decl) = DECL_CONTEXT (sym->backend_decl);
 911   TREE_CHAIN (decl) = nonlocal_dummy_decls;
 912   nonlocal_dummy_decls = decl;
 913 }
 914
 915 /* Return a constant or a variable to use as a string length.  Does not
 916    add the decl to the current scope.  */
 917
 918 static tree
 919 gfc_create_string_length (gfc_symbol * sym)
 920 {
 921   gcc_assert (sym->ts.cl);
 922   gfc_conv_const_charlen (sym->ts.cl);
 923
 924   if (sym->ts.cl->backend_decl == NULL_TREE)
 925     {
 926       tree length;
 927       char name[GFC_MAX_MANGLED_SYMBOL_LEN + 2];
 928
 929       /* Also prefix the mangled name.  */
 930       strcpy (&name[1], sym->name);
 931       name[0] = '.';
 932       length = build_decl (VAR_DECL, get_identifier (name),
 933                            gfc_charlen_type_node);
 934       DECL_ARTIFICIAL (length) = 1;
 935       TREE_USED (length) = 1;
 936       if (sym->ns->proc_name->tlink != NULL)
 937         gfc_defer_symbol_init (sym);
 938
 939       sym->ts.cl->backend_decl = length;
 940     }
 941
 942   gcc_assert (sym->ts.cl->backend_decl != NULL_TREE);
 943   return sym->ts.cl->backend_decl;
 944 }
 945
 946 /* If a variable is assigned a label, we add another two auxiliary
 947    variables.  */
 948
 949 static void
 950 gfc_add_assign_aux_vars (gfc_symbol * sym)
 951 {
 952   tree addr;
 953   tree length;
 954   tree decl;
 955
 956   gcc_assert (sym->backend_decl);
 957
 958   decl = sym->backend_decl;
 959   gfc_allocate_lang_decl (decl);
 960   GFC_DECL_ASSIGN (decl) = 1;
 961   length = build_decl (VAR_DECL, create_tmp_var_name (sym->name),
 962                        gfc_charlen_type_node);
 963   addr = build_decl (VAR_DECL, create_tmp_var_name (sym->name),
 964                      pvoid_type_node);
 965   gfc_finish_var_decl (length, sym);
 966   gfc_finish_var_decl (addr, sym);
 967   /*  STRING_LENGTH is also used as flag. Less than -1 means that
 968       ASSIGN_ADDR can not be used. Equal -1 means that ASSIGN_ADDR is the
 969       target label's address. Otherwise, value is the length of a format string
 970       and ASSIGN_ADDR is its address.  */
 971   if (TREE_STATIC (length))
 972     DECL_INITIAL (length) = build_int_cst (NULL_TREE, -2);
 973   else
 974     gfc_defer_symbol_init (sym);
 975
 976   GFC_DECL_STRING_LEN (decl) = length;
 977   GFC_DECL_ASSIGN_ADDR (decl) = addr;
 978 }
 979
 980 /* Return the decl for a gfc_symbol, create it if it doesn't already
 981    exist.  */
 982
 983 tree
 984 gfc_get_symbol_decl (gfc_symbol * sym)
 985 {
 986   tree decl;
 987   tree length = NULL_TREE;
 988   int byref;
 989
 990   gcc_assert (sym->attr.referenced
 991                 || sym->attr.use_assoc
 992                 || sym->ns->proc_name->attr.if_source == IFSRC_IFBODY);
 993
 994   if (sym->ns && sym->ns->proc_name->attr.function)
 995     byref = gfc_return_by_reference (sym->ns->proc_name);
 996   else
 997     byref = 0;
 998
 999   if ((sym->attr.dummy && ! sym->attr.function) || (sym->attr.result && byref))
1000     {
1001       /* Return via extra parameter.  */
1002       if (sym->attr.result && byref
1003           && !sym->backend_decl)
1004         {
1005           sym->backend_decl =
1006             DECL_ARGUMENTS (sym->ns->proc_name->backend_decl);
1007           /* For entry master function skip over the __entry
1008              argument.  */
1009           if (sym->ns->proc_name->attr.entry_master)
1010             sym->backend_decl = TREE_CHAIN (sym->backend_decl);
1011         }
1012
1013       /* Dummy variables should already have been created.  */
1014       gcc_assert (sym->backend_decl);
1015
1016       /* Create a character length variable.  */
1017       if (sym->ts.type == BT_CHARACTER)
1018         {
1019           if (sym->ts.cl->backend_decl == NULL_TREE)
1020             length = gfc_create_string_length (sym);
1021           else
1022             length = sym->ts.cl->backend_decl;
1023           if (TREE_CODE (length) == VAR_DECL
1024               && DECL_CONTEXT (length) == NULL_TREE)
1025             {
1026               /* Add the string length to the same context as the symbol.  */
1027               if (DECL_CONTEXT (sym->backend_decl) == current_function_decl)
1028                 gfc_add_decl_to_function (length);
1029               else
1030                 gfc_add_decl_to_parent_function (length);
1031
1032               gcc_assert (DECL_CONTEXT (sym->backend_decl) ==
1033                             DECL_CONTEXT (length));
1034
1035               gfc_defer_symbol_init (sym);
1036             }
1037         }
1038
1039       /* Use a copy of the descriptor for dummy arrays.  */
1040       if (sym->attr.dimension && !TREE_USED (sym->backend_decl))
1041         {
1042           decl = gfc_build_dummy_array_decl (sym, sym->backend_decl);
1043           /* Prevent the dummy from being detected as unused if it is copied.  */
1044           if (sym->backend_decl != NULL && decl != sym->backend_decl)
1045             DECL_ARTIFICIAL (sym->backend_decl) = 1;
1046           sym->backend_decl = decl;
1047         }
1048
1049       TREE_USED (sym->backend_decl) = 1;
1050       if (sym->attr.assign && GFC_DECL_ASSIGN (sym->backend_decl) == 0)
1051         {
1052           gfc_add_assign_aux_vars (sym);
1053         }
1054
1055       if (sym->attr.dimension
1056           && DECL_LANG_SPECIFIC (sym->backend_decl)
1057           && GFC_DECL_SAVED_DESCRIPTOR (sym->backend_decl)
1058           && DECL_CONTEXT (sym->backend_decl) != current_function_decl)
1059         gfc_nonlocal_dummy_array_decl (sym);
1060
1061       return sym->backend_decl;
1062     }
1063
1064   if (sym->backend_decl)
1065     return sym->backend_decl;
1066
1067   /* Catch function declarations.  Only used for actual parameters and
1068      procedure pointers.  */
1069   if (sym->attr.flavor == FL_PROCEDURE)
1070     {
1071       decl = gfc_get_extern_function_decl (sym);
1072       gfc_set_decl_location (decl, &sym->declared_at);
1073       return decl;
1074     }
1075
1076   if (sym->attr.intrinsic)
1077     internal_error ("intrinsic variable which isn't a procedure");
1078
1079   /* Create string length decl first so that they can be used in the
1080      type declaration.  */
1081   if (sym->ts.type == BT_CHARACTER)
1082     length = gfc_create_string_length (sym);
1083
1084   /* Create the decl for the variable.  */
1085   decl = build_decl (VAR_DECL, gfc_sym_identifier (sym), gfc_sym_type (sym));
1086
1087   gfc_set_decl_location (decl, &sym->declared_at);
1088
1089   /* Symbols from modules should have their assembler names mangled.
1090      This is done here rather than in gfc_finish_var_decl because it
1091      is different for string length variables.  */
1092   if (sym->module)
1093     {
1094       SET_DECL_ASSEMBLER_NAME (decl, gfc_sym_mangled_identifier (sym));
1095       if (sym->attr.use_assoc)
1096         DECL_IGNORED_P (decl) = 1;
1097     }
1098
1099   if (sym->attr.dimension)
1100     {
1101       /* Create variables to hold the non-constant bits of array info.  */
1102       gfc_build_qualified_array (decl, sym);
1103
1104       /* Remember this variable for allocation/cleanup.  */
1105       gfc_defer_symbol_init (sym);
1106
1107       if ((sym->attr.allocatable || !sym->attr.dummy) && !sym->attr.pointer)
1108         GFC_DECL_PACKED_ARRAY (decl) = 1;
1109     }
1110
1111   if (sym->ts.type == BT_DERIVED && sym->ts.derived->attr.alloc_comp)
1112     gfc_defer_symbol_init (sym);
1113   /* This applies a derived type default initializer.  */
1114   else if (sym->ts.type == BT_DERIVED
1115              && sym->attr.save == SAVE_NONE
1116              && !sym->attr.data
1117              && !sym->attr.allocatable
1118              && (sym->value && !sym->ns->proc_name->attr.is_main_program)
1119              && !sym->attr.use_assoc)
1120     gfc_defer_symbol_init (sym);
1121
1122   gfc_finish_var_decl (decl, sym);
1123
1124   if (sym->ts.type == BT_CHARACTER)
1125     {
1126       /* Character variables need special handling.  */
1127       gfc_allocate_lang_decl (decl);
1128
1129       if (TREE_CODE (length) != INTEGER_CST)
1130         {
1131           char name[GFC_MAX_MANGLED_SYMBOL_LEN + 2];
1132
1133           if (sym->module)
1134             {
1135               /* Also prefix the mangled name for symbols from modules.  */
1136               strcpy (&name[1], sym->name);
1137               name[0] = '.';
1138               strcpy (&name[1],
1139                       IDENTIFIER_POINTER (DECL_ASSEMBLER_NAME (length)));
1140               SET_DECL_ASSEMBLER_NAME (decl, get_identifier (name));
1141             }
1142           gfc_finish_var_decl (length, sym);
1143           gcc_assert (!sym->value);
1144         }
1145     }
1146   else if (sym->attr.subref_array_pointer)
1147     {
1148       /* We need the span for these beasts.  */
1149       gfc_allocate_lang_decl (decl);
1150     }
1151
1152   if (sym->attr.subref_array_pointer)
1153     {
1154       tree span;
1155       GFC_DECL_SUBREF_ARRAY_P (decl) = 1;
1156       span = build_decl (VAR_DECL, create_tmp_var_name ("span"),
1157                          gfc_array_index_type);
1158       gfc_finish_var_decl (span, sym);
1159       TREE_STATIC (span) = TREE_STATIC (decl);
1160       DECL_ARTIFICIAL (span) = 1;
1161       DECL_INITIAL (span) = build_int_cst (gfc_array_index_type, 0);
1162
1163       GFC_DECL_SPAN (decl) = span;
1164       GFC_TYPE_ARRAY_SPAN (TREE_TYPE (decl)) = span;
1165     }
1166
1167   sym->backend_decl = decl;
1168
1169   if (sym->attr.assign)
1170     gfc_add_assign_aux_vars (sym);
1171
1172   if (TREE_STATIC (decl) && !sym->attr.use_assoc)
1173     {
1174       /* Add static initializer.  */
1175       DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
1176           TREE_TYPE (decl), sym->attr.dimension,
1177           sym->attr.pointer || sym->attr.allocatable);
1178     }
1179
1180   if (!TREE_STATIC (decl)
1181       && POINTER_TYPE_P (TREE_TYPE (decl))
1182       && !sym->attr.pointer
1183       && !sym->attr.allocatable
1184       && !sym->attr.proc_pointer)
1185     DECL_BY_REFERENCE (decl) = 1;
1186
1187   return decl;
1188 }
1189
1190
1191 /* Substitute a temporary variable in place of the real one.  */
1192
1193 void
1194 gfc_shadow_sym (gfc_symbol * sym, tree decl, gfc_saved_var * save)
1195 {
1196   save->attr = sym->attr;
1197   save->decl = sym->backend_decl;
1198
1199   gfc_clear_attr (&sym->attr);
1200   sym->attr.referenced = 1;
1201   sym->attr.flavor = FL_VARIABLE;
1202
1203   sym->backend_decl = decl;
1204 }
1205
1206
1207 /* Restore the original variable.  */
1208
1209 void
1210 gfc_restore_sym (gfc_symbol * sym, gfc_saved_var * save)
1211 {
1212   sym->attr = save->attr;
1213   sym->backend_decl = save->decl;
1214 }
1215
1216
1217 /* Declare a procedure pointer.  */
1218
1219 static tree
1220 get_proc_pointer_decl (gfc_symbol *sym)
1221 {
1222   tree decl;
1223
1224   decl = sym->backend_decl;
1225   if (decl)
1226     return decl;
1227
1228   decl = build_decl (VAR_DECL, get_identifier (sym->name),
1229                      build_pointer_type (gfc_get_function_type (sym)));
1230
1231   if ((sym->ns->proc_name
1232       && sym->ns->proc_name->backend_decl == current_function_decl)
1233       || sym->attr.contained)
1234     gfc_add_decl_to_function (decl);
1235   else if (sym->ns->proc_name->attr.flavor != FL_MODULE)
1236     gfc_add_decl_to_parent_function (decl);
1237
1238   sym->backend_decl = decl;
1239
1240   /* If a variable is USE associated, it's always external.  */
1241   if (sym->attr.use_assoc)
1242     {
1243       DECL_EXTERNAL (decl) = 1;
1244       TREE_PUBLIC (decl) = 1;
1245     }
1246   else if (sym->module && sym->ns->proc_name->attr.flavor == FL_MODULE)
1247     {
1248       /* This is the declaration of a module variable.  */
1249       TREE_PUBLIC (decl) = 1;
1250       TREE_STATIC (decl) = 1;
1251     }
1252
1253   if (!sym->attr.use_assoc
1254         && (sym->attr.save != SAVE_NONE || sym->attr.data
1255               || (sym->value && sym->ns->proc_name->attr.is_main_program)))
1256     TREE_STATIC (decl) = 1;
1257
1258   if (TREE_STATIC (decl) && sym->value)
1259     {
1260       /* Add static initializer.  */
1261       DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
1262           TREE_TYPE (decl), sym->attr.dimension, sym->attr.proc_pointer);
1263     }
1264
1265   return decl;
1266 }
1267
1268
1269 /* Get a basic decl for an external function.  */
1270
1271 tree
1272 gfc_get_extern_function_decl (gfc_symbol * sym)
1273 {
1274   tree type;
1275   tree fndecl;
1276   gfc_expr e;
1277   gfc_intrinsic_sym *isym;
1278   gfc_expr argexpr;
1279   char s[GFC_MAX_SYMBOL_LEN + 23]; /* "_gfortran_f2c_specific" and '\0'.  */
1280   tree name;
1281   tree mangled_name;
1282   gfc_gsymbol *gsym;
1283
1284   if (sym->backend_decl)
1285     return sym->backend_decl;
1286
1287   /* We should never be creating external decls for alternate entry points.
1288      The procedure may be an alternate entry point, but we don't want/need
1289      to know that.  */
1290   gcc_assert (!(sym->attr.entry || sym->attr.entry_master));
1291
1292   if (sym->attr.proc_pointer)
1293     return get_proc_pointer_decl (sym);
1294
1295   /* See if this is an external procedure from the same file.  If so,
1296      return the backend_decl.  */
1297   gsym =  gfc_find_gsymbol (gfc_gsym_root, sym->name);
1298
1299   if (gfc_option.flag_whole_file
1300         && !sym->backend_decl
1301         && gsym && gsym->ns
1302         && ((gsym->type == GSYM_SUBROUTINE) || (gsym->type == GSYM_FUNCTION))
1303         && gsym->ns->proc_name->backend_decl)
1304     {
1305       /* If the namespace has entries, the proc_name is the
1306          entry master.  Find the entry and use its backend_decl.
1307          otherwise, use the proc_name backend_decl.  */
1308       if (gsym->ns->entries)
1309         {
1310           gfc_entry_list *entry = gsym->ns->entries;
1311
1312           for (; entry; entry = entry->next)
1313             {
1314               if (strcmp (gsym->name, entry->sym->name) == 0)
1315                 {
1316                   sym->backend_decl = entry->sym->backend_decl;
1317                   break;
1318                 }
1319             }
1320         }
1321       else
1322         {
1323           sym->backend_decl = gsym->ns->proc_name->backend_decl;
1324         }
1325
1326       if (sym->backend_decl)
1327         return sym->backend_decl;
1328     }
1329
1330   if (sym->attr.intrinsic)
1331     {
1332       /* Call the resolution function to get the actual name.  This is
1333          a nasty hack which relies on the resolution functions only looking
1334          at the first argument.  We pass NULL for the second argument
1335          otherwise things like AINT get confused.  */
1336       isym = gfc_find_function (sym->name);
1337       gcc_assert (isym->resolve.f0 != NULL);
1338
1339       memset (&e, 0, sizeof (e));
1340       e.expr_type = EXPR_FUNCTION;
1341
1342       memset (&argexpr, 0, sizeof (argexpr));
1343       gcc_assert (isym->formal);
1344       argexpr.ts = isym->formal->ts;
1345
1346       if (isym->formal->next == NULL)
1347         isym->resolve.f1 (&e, &argexpr);
1348       else
1349         {
1350           if (isym->formal->next->next == NULL)
1351             isym->resolve.f2 (&e, &argexpr, NULL);
1352           else
1353             {
1354               if (isym->formal->next->next->next == NULL)
1355                 isym->resolve.f3 (&e, &argexpr, NULL, NULL);
1356               else
1357                 {
1358                   /* All specific intrinsics take less than 5 arguments.  */
1359                   gcc_assert (isym->formal->next->next->next->next == NULL);
1360                   isym->resolve.f4 (&e, &argexpr, NULL, NULL, NULL);
1361                 }
1362             }
1363         }
1364
1365       if (gfc_option.flag_f2c
1366           && ((e.ts.type == BT_REAL && e.ts.kind == gfc_default_real_kind)
1367               || e.ts.type == BT_COMPLEX))
1368         {
1369           /* Specific which needs a different implementation if f2c
1370              calling conventions are used.  */
1371           sprintf (s, "_gfortran_f2c_specific%s", e.value.function.name);
1372         }
1373       else
1374         sprintf (s, "_gfortran_specific%s", e.value.function.name);
1375
1376       name = get_identifier (s);
1377       mangled_name = name;
1378     }
1379   else
1380     {
1381       name = gfc_sym_identifier (sym);
1382       mangled_name = gfc_sym_mangled_function_id (sym);
1383     }
1384
1385   type = gfc_get_function_type (sym);
1386   fndecl = build_decl (FUNCTION_DECL, name, type);
1387
1388   SET_DECL_ASSEMBLER_NAME (fndecl, mangled_name);
1389   /* If the return type is a pointer, avoid alias issues by setting
1390      DECL_IS_MALLOC to nonzero. This means that the function should be
1391      treated as if it were a malloc, meaning it returns a pointer that
1392      is not an alias.  */
1393   if (POINTER_TYPE_P (type))
1394     DECL_IS_MALLOC (fndecl) = 1;
1395
1396   /* Set the context of this decl.  */
1397   if (0 && sym->ns && sym->ns->proc_name)
1398     {
1399       /* TODO: Add external decls to the appropriate scope.  */
1400       DECL_CONTEXT (fndecl) = sym->ns->proc_name->backend_decl;
1401     }
1402   else
1403     {
1404       /* Global declaration, e.g. intrinsic subroutine.  */
1405       DECL_CONTEXT (fndecl) = NULL_TREE;
1406     }
1407
1408   DECL_EXTERNAL (fndecl) = 1;
1409
1410   /* This specifies if a function is globally addressable, i.e. it is
1411      the opposite of declaring static in C.  */
1412   TREE_PUBLIC (fndecl) = 1;
1413
1414   /* Set attributes for PURE functions. A call to PURE function in the
1415      Fortran 95 sense is both pure and without side effects in the C
1416      sense.  */
1417   if (sym->attr.pure || sym->attr.elemental)
1418     {
1419       if (sym->attr.function && !gfc_return_by_reference (sym))
1420         DECL_PURE_P (fndecl) = 1;
1421       /* TODO: check if pure SUBROUTINEs don't have INTENT(OUT)
1422          parameters and don't use alternate returns (is this
1423          allowed?). In that case, calls to them are meaningless, and
1424          can be optimized away. See also in build_function_decl().  */
1425       TREE_SIDE_EFFECTS (fndecl) = 0;
1426     }
1427
1428   /* Mark non-returning functions.  */
1429   if (sym->attr.noreturn)
1430       TREE_THIS_VOLATILE(fndecl) = 1;
1431
1432   sym->backend_decl = fndecl;
1433
1434   if (DECL_CONTEXT (fndecl) == NULL_TREE)
1435     pushdecl_top_level (fndecl);
1436
1437   return fndecl;
1438 }
1439
1440
1441 /* Create a declaration for a procedure.  For external functions (in the C
1442    sense) use gfc_get_extern_function_decl.  HAS_ENTRIES is true if this is
1443    a master function with alternate entry points.  */
1444
1445 static void
1446 build_function_decl (gfc_symbol * sym)
1447 {
1448   tree fndecl, type;
1449   symbol_attribute attr;
1450   tree result_decl;
1451   gfc_formal_arglist *f;
1452
1453   gcc_assert (!sym->backend_decl);
1454   gcc_assert (!sym->attr.external);
1455
1456   /* Set the line and filename.  sym->declared_at seems to point to the
1457      last statement for subroutines, but it'll do for now.  */
1458   gfc_set_backend_locus (&sym->declared_at);
1459
1460   /* Allow only one nesting level.  Allow public declarations.  */
1461   gcc_assert (current_function_decl == NULL_TREE
1462               || DECL_CONTEXT (current_function_decl) == NULL_TREE
1463               || TREE_CODE (DECL_CONTEXT (current_function_decl))
1464                  == NAMESPACE_DECL);
1465
1466   type = gfc_get_function_type (sym);
1467   fndecl = build_decl (FUNCTION_DECL, gfc_sym_identifier (sym), type);
1468
1469   /* Perform name mangling if this is a top level or module procedure.  */
1470   if (current_function_decl == NULL_TREE)
1471     SET_DECL_ASSEMBLER_NAME (fndecl, gfc_sym_mangled_function_id (sym));
1472
1473   /* Figure out the return type of the declared function, and build a
1474      RESULT_DECL for it.  If this is a subroutine with alternate
1475      returns, build a RESULT_DECL for it.  */
1476   attr = sym->attr;
1477
1478   result_decl = NULL_TREE;
1479   /* TODO: Shouldn't this just be TREE_TYPE (TREE_TYPE (fndecl)).  */
1480   if (attr.function)
1481     {
1482       if (gfc_return_by_reference (sym))
1483         type = void_type_node;
1484       else
1485         {
1486           if (sym->result != sym)
1487             result_decl = gfc_sym_identifier (sym->result);
1488
1489           type = TREE_TYPE (TREE_TYPE (fndecl));
1490         }
1491     }
1492   else
1493     {
1494       /* Look for alternate return placeholders.  */
1495       int has_alternate_returns = 0;
1496       for (f = sym->formal; f; f = f->next)
1497         {
1498           if (f->sym == NULL)
1499             {
1500               has_alternate_returns = 1;
1501               break;
1502             }
1503         }
1504
1505       if (has_alternate_returns)
1506         type = integer_type_node;
1507       else
1508         type = void_type_node;
1509     }
1510
1511   result_decl = build_decl (RESULT_DECL, result_decl, type);
1512   DECL_ARTIFICIAL (result_decl) = 1;
1513   DECL_IGNORED_P (result_decl) = 1;
1514   DECL_CONTEXT (result_decl) = fndecl;
1515   DECL_RESULT (fndecl) = result_decl;
1516
1517   /* Don't call layout_decl for a RESULT_DECL.
1518      layout_decl (result_decl, 0);  */
1519
1520   /* If the return type is a pointer, avoid alias issues by setting
1521      DECL_IS_MALLOC to nonzero. This means that the function should be
1522      treated as if it were a malloc, meaning it returns a pointer that
1523      is not an alias.  */
1524   if (POINTER_TYPE_P (type))
1525     DECL_IS_MALLOC (fndecl) = 1;
1526
1527   /* Set up all attributes for the function.  */
1528   DECL_CONTEXT (fndecl) = current_function_decl;
1529   DECL_EXTERNAL (fndecl) = 0;
1530
1531   /* This specifies if a function is globally visible, i.e. it is
1532      the opposite of declaring static in C.  */
1533   if (DECL_CONTEXT (fndecl) == NULL_TREE
1534       && !sym->attr.entry_master && !sym->attr.is_main_program)
1535     TREE_PUBLIC (fndecl) = 1;
1536
1537   /* TREE_STATIC means the function body is defined here.  */
1538   TREE_STATIC (fndecl) = 1;
1539
1540   /* Set attributes for PURE functions. A call to a PURE function in the
1541      Fortran 95 sense is both pure and without side effects in the C
1542      sense.  */
1543   if (attr.pure || attr.elemental)
1544     {
1545       /* TODO: check if a pure SUBROUTINE has no INTENT(OUT) arguments
1546          including an alternate return. In that case it can also be
1547          marked as PURE. See also in gfc_get_extern_function_decl().  */
1548       if (attr.function && !gfc_return_by_reference (sym))
1549         DECL_PURE_P (fndecl) = 1;
1550       TREE_SIDE_EFFECTS (fndecl) = 0;
1551     }
1552
1553   /* Layout the function declaration and put it in the binding level
1554      of the current function.  */
1555   pushdecl (fndecl);
1556
1557   sym->backend_decl = fndecl;
1558 }
1559
1560
1561 /* Create the DECL_ARGUMENTS for a procedure.  */
1562
1563 static void
1564 create_function_arglist (gfc_symbol * sym)
1565 {
1566   tree fndecl;
1567   gfc_formal_arglist *f;
1568   tree typelist, hidden_typelist;
1569   tree arglist, hidden_arglist;
1570   tree type;
1571   tree parm;
1572
1573   fndecl = sym->backend_decl;
1574
1575   /* Build formal argument list. Make sure that their TREE_CONTEXT is
1576      the new FUNCTION_DECL node.  */
1577   arglist = NULL_TREE;
1578   hidden_arglist = NULL_TREE;
1579   typelist = TYPE_ARG_TYPES (TREE_TYPE (fndecl));
1580
1581   if (sym->attr.entry_master)
1582     {
1583       type = TREE_VALUE (typelist);
1584       parm = build_decl (PARM_DECL, get_identifier ("__entry"), type);
1585
1586       DECL_CONTEXT (parm) = fndecl;
1587       DECL_ARG_TYPE (parm) = type;
1588       TREE_READONLY (parm) = 1;
1589       gfc_finish_decl (parm);
1590       DECL_ARTIFICIAL (parm) = 1;
1591
1592       arglist = chainon (arglist, parm);
1593       typelist = TREE_CHAIN (typelist);
1594     }
1595
1596   if (gfc_return_by_reference (sym))
1597     {
1598       tree type = TREE_VALUE (typelist), length = NULL;
1599
1600       if (sym->ts.type == BT_CHARACTER)
1601         {
1602           /* Length of character result.  */
1603           tree len_type = TREE_VALUE (TREE_CHAIN (typelist));
1604           gcc_assert (len_type == gfc_charlen_type_node);
1605
1606           length = build_decl (PARM_DECL,
1607                                get_identifier (".__result"),
1608                                len_type);
1609           if (!sym->ts.cl->length)
1610             {
1611               sym->ts.cl->backend_decl = length;
1612               TREE_USED (length) = 1;
1613             }
1614           gcc_assert (TREE_CODE (length) == PARM_DECL);
1615           DECL_CONTEXT (length) = fndecl;
1616           DECL_ARG_TYPE (length) = len_type;
1617           TREE_READONLY (length) = 1;
1618           DECL_ARTIFICIAL (length) = 1;
1619           gfc_finish_decl (length);
1620           if (sym->ts.cl->backend_decl == NULL
1621               || sym->ts.cl->backend_decl == length)
1622             {
1623               gfc_symbol *arg;
1624               tree backend_decl;
1625
1626               if (sym->ts.cl->backend_decl == NULL)
1627                 {
1628                   tree len = build_decl (VAR_DECL,
1629                                          get_identifier ("..__result"),
1630                                          gfc_charlen_type_node);
1631                   DECL_ARTIFICIAL (len) = 1;
1632                   TREE_USED (len) = 1;
1633                   sym->ts.cl->backend_decl = len;
1634                 }
1635
1636               /* Make sure PARM_DECL type doesn't point to incomplete type.  */
1637               arg = sym->result ? sym->result : sym;
1638               backend_decl = arg->backend_decl;
1639               /* Temporary clear it, so that gfc_sym_type creates complete
1640                  type.  */
1641               arg->backend_decl = NULL;
1642               type = gfc_sym_type (arg);
1643               arg->backend_decl = backend_decl;
1644               type = build_reference_type (type);
1645             }
1646         }
1647
1648       parm = build_decl (PARM_DECL, get_identifier ("__result"), type);
1649
1650       DECL_CONTEXT (parm) = fndecl;
1651       DECL_ARG_TYPE (parm) = TREE_VALUE (typelist);
1652       TREE_READONLY (parm) = 1;
1653       DECL_ARTIFICIAL (parm) = 1;
1654       gfc_finish_decl (parm);
1655
1656       arglist = chainon (arglist, parm);
1657       typelist = TREE_CHAIN (typelist);
1658
1659       if (sym->ts.type == BT_CHARACTER)
1660         {
1661           gfc_allocate_lang_decl (parm);
1662           arglist = chainon (arglist, length);
1663           typelist = TREE_CHAIN (typelist);
1664         }
1665     }
1666
1667   hidden_typelist = typelist;
1668   for (f = sym->formal; f; f = f->next)
1669     if (f->sym != NULL) /* Ignore alternate returns.  */
1670       hidden_typelist = TREE_CHAIN (hidden_typelist);
1671
1672   for (f = sym->formal; f; f = f->next)
1673     {
1674       char name[GFC_MAX_SYMBOL_LEN + 2];
1675
1676       /* Ignore alternate returns.  */
1677       if (f->sym == NULL)
1678         continue;
1679
1680       type = TREE_VALUE (typelist);
1681
1682       if (f->sym->ts.type == BT_CHARACTER)
1683         {
1684           tree len_type = TREE_VALUE (hidden_typelist);
1685           tree length = NULL_TREE;
1686           gcc_assert (len_type == gfc_charlen_type_node);
1687
1688           strcpy (&name[1], f->sym->name);
1689           name[0] = '_';
1690           length = build_decl (PARM_DECL, get_identifier (name), len_type);
1691
1692           hidden_arglist = chainon (hidden_arglist, length);
1693           DECL_CONTEXT (length) = fndecl;
1694           DECL_ARTIFICIAL (length) = 1;
1695           DECL_ARG_TYPE (length) = len_type;
1696           TREE_READONLY (length) = 1;
1697           gfc_finish_decl (length);
1698
1699           /* Remember the passed value.  */
1700           f->sym->ts.cl->passed_length = length;
1701
1702           /* Use the passed value for assumed length variables.  */
1703           if (!f->sym->ts.cl->length)
1704             {
1705               TREE_USED (length) = 1;
1706               gcc_assert (!f->sym->ts.cl->backend_decl);
1707               f->sym->ts.cl->backend_decl = length;
1708             }
1709
1710           hidden_typelist = TREE_CHAIN (hidden_typelist);
1711
1712           if (f->sym->ts.cl->backend_decl == NULL
1713               || f->sym->ts.cl->backend_decl == length)
1714             {
1715               if (f->sym->ts.cl->backend_decl == NULL)
1716                 gfc_create_string_length (f->sym);
1717
1718               /* Make sure PARM_DECL type doesn't point to incomplete type.  */
1719               if (f->sym->attr.flavor == FL_PROCEDURE)
1720                 type = build_pointer_type (gfc_get_function_type (f->sym));
1721               else
1722                 type = gfc_sym_type (f->sym);
1723             }
1724         }
1725
1726       /* For non-constant length array arguments, make sure they use
1727          a different type node from TYPE_ARG_TYPES type.  */
1728       if (f->sym->attr.dimension
1729           && type == TREE_VALUE (typelist)
1730           && TREE_CODE (type) == POINTER_TYPE
1731           && GFC_ARRAY_TYPE_P (type)
1732           && f->sym->as->type != AS_ASSUMED_SIZE
1733           && ! COMPLETE_TYPE_P (TREE_TYPE (type)))
1734         {
1735           if (f->sym->attr.flavor == FL_PROCEDURE)
1736             type = build_pointer_type (gfc_get_function_type (f->sym));
1737           else
1738             type = gfc_sym_type (f->sym);
1739         }
1740
1741       if (f->sym->attr.proc_pointer)
1742         type = build_pointer_type (type);
1743
1744       /* Build the argument declaration.  */
1745       parm = build_decl (PARM_DECL, gfc_sym_identifier (f->sym), type);
1746
1747       /* Fill in arg stuff.  */
1748       DECL_CONTEXT (parm) = fndecl;
1749       DECL_ARG_TYPE (parm) = TREE_VALUE (typelist);
1750       /* All implementation args are read-only.  */
1751       TREE_READONLY (parm) = 1;
1752       if (POINTER_TYPE_P (type)
1753           && (!f->sym->attr.proc_pointer
1754               && f->sym->attr.flavor != FL_PROCEDURE))
1755         DECL_BY_REFERENCE (parm) = 1;
1756
1757       gfc_finish_decl (parm);
1758
1759       f->sym->backend_decl = parm;
1760
1761       arglist = chainon (arglist, parm);
1762       typelist = TREE_CHAIN (typelist);
1763     }
1764
1765   /* Add the hidden string length parameters, unless the procedure
1766      is bind(C).  */
1767   if (!sym->attr.is_bind_c)
1768     arglist = chainon (arglist, hidden_arglist);
1769
1770   gcc_assert (hidden_typelist == NULL_TREE
1771               || TREE_VALUE (hidden_typelist) == void_type_node);
1772   DECL_ARGUMENTS (fndecl) = arglist;
1773 }
1774
1775 /* Convert FNDECL's code to GIMPLE and handle any nested functions.  */
1776
1777 static void
1778 gfc_gimplify_function (tree fndecl)
1779 {
1780   struct cgraph_node *cgn;
1781
1782   gimplify_function_tree (fndecl);
1783   dump_function (TDI_generic, fndecl);
1784
1785   /* Generate errors for structured block violations.  */
1786   /* ??? Could be done as part of resolve_labels.  */
1787   if (flag_openmp)
1788     diagnose_omp_structured_block_errors (fndecl);
1789
1790   /* Convert all nested functions to GIMPLE now.  We do things in this order
1791      so that items like VLA sizes are expanded properly in the context of the
1792      correct function.  */
1793   cgn = cgraph_node (fndecl);
1794   for (cgn = cgn->nested; cgn; cgn = cgn->next_nested)
1795     gfc_gimplify_function (cgn->decl);
1796 }
1797
1798
1799 /* Do the setup necessary before generating the body of a function.  */
1800
1801 static void
1802 trans_function_start (gfc_symbol * sym)
1803 {
1804   tree fndecl;
1805
1806   fndecl = sym->backend_decl;
1807
1808   /* Let GCC know the current scope is this function.  */
1809   current_function_decl = fndecl;
1810
1811   /* Let the world know what we're about to do.  */
1812   announce_function (fndecl);
1813
1814   if (DECL_CONTEXT (fndecl) == NULL_TREE)
1815     {
1816       /* Create RTL for function declaration.  */
1817       rest_of_decl_compilation (fndecl, 1, 0);
1818     }
1819
1820   /* Create RTL for function definition.  */
1821   make_decl_rtl (fndecl);
1822
1823   init_function_start (fndecl);
1824
1825   /* Even though we're inside a function body, we still don't want to
1826      call expand_expr to calculate the size of a variable-sized array.
1827      We haven't necessarily assigned RTL to all variables yet, so it's
1828      not safe to try to expand expressions involving them.  */
1829   cfun->dont_save_pending_sizes_p = 1;
1830
1831   /* function.c requires a push at the start of the function.  */
1832   pushlevel (0);
1833 }
1834
1835 /* Create thunks for alternate entry points.  */
1836
1837 static void
1838 build_entry_thunks (gfc_namespace * ns)
1839 {
1840   gfc_formal_arglist *formal;
1841   gfc_formal_arglist *thunk_formal;
1842   gfc_entry_list *el;
1843   gfc_symbol *thunk_sym;
1844   stmtblock_t body;
1845   tree thunk_fndecl;
1846   tree args;
1847   tree string_args;
1848   tree tmp;
1849   locus old_loc;
1850
1851   /* This should always be a toplevel function.  */
1852   gcc_assert (current_function_decl == NULL_TREE);
1853
1854   gfc_get_backend_locus (&old_loc);
1855   for (el = ns->entries; el; el = el->next)
1856     {
1857       thunk_sym = el->sym;
1858
1859       build_function_decl (thunk_sym);
1860       create_function_arglist (thunk_sym);
1861
1862       trans_function_start (thunk_sym);
1863
1864       thunk_fndecl = thunk_sym->backend_decl;
1865
1866       gfc_init_block (&body);
1867
1868       /* Pass extra parameter identifying this entry point.  */
1869       tmp = build_int_cst (gfc_array_index_type, el->id);
1870       args = tree_cons (NULL_TREE, tmp, NULL_TREE);
1871       string_args = NULL_TREE;
1872
1873       if (thunk_sym->attr.function)
1874         {
1875           if (gfc_return_by_reference (ns->proc_name))
1876             {
1877               tree ref = DECL_ARGUMENTS (current_function_decl);
1878               args = tree_cons (NULL_TREE, ref, args);
1879               if (ns->proc_name->ts.type == BT_CHARACTER)
1880                 args = tree_cons (NULL_TREE, TREE_CHAIN (ref),
1881                                   args);
1882             }
1883         }
1884
1885       for (formal = ns->proc_name->formal; formal; formal = formal->next)
1886         {
1887           /* Ignore alternate returns.  */
1888           if (formal->sym == NULL)
1889             continue;
1890
1891           /* We don't have a clever way of identifying arguments, so resort to
1892              a brute-force search.  */
1893           for (thunk_formal = thunk_sym->formal;
1894                thunk_formal;
1895                thunk_formal = thunk_formal->next)
1896             {
1897               if (thunk_formal->sym == formal->sym)
1898                 break;
1899             }
1900
1901           if (thunk_formal)
1902             {
1903               /* Pass the argument.  */
1904               DECL_ARTIFICIAL (thunk_formal->sym->backend_decl) = 1;
1905               args = tree_cons (NULL_TREE, thunk_formal->sym->backend_decl,
1906                                 args);
1907               if (formal->sym->ts.type == BT_CHARACTER)
1908                 {
1909                   tmp = thunk_formal->sym->ts.cl->backend_decl;
1910                   string_args = tree_cons (NULL_TREE, tmp, string_args);
1911                 }
1912             }
1913           else
1914             {
1915               /* Pass NULL for a missing argument.  */
1916               args = tree_cons (NULL_TREE, null_pointer_node, args);
1917               if (formal->sym->ts.type == BT_CHARACTER)
1918                 {
1919                   tmp = build_int_cst (gfc_charlen_type_node, 0);
1920                   string_args = tree_cons (NULL_TREE, tmp, string_args);
1921                 }
1922             }
1923         }
1924
1925       /* Call the master function.  */
1926       args = nreverse (args);
1927       args = chainon (args, nreverse (string_args));
1928       tmp = ns->proc_name->backend_decl;
1929       tmp = build_function_call_expr (tmp, args);
1930       if (ns->proc_name->attr.mixed_entry_master)
1931         {
1932           tree union_decl, field;
1933           tree master_type = TREE_TYPE (ns->proc_name->backend_decl);
1934
1935           union_decl = build_decl (VAR_DECL, get_identifier ("__result"),
1936                                    TREE_TYPE (master_type));
1937           DECL_ARTIFICIAL (union_decl) = 1;
1938           DECL_EXTERNAL (union_decl) = 0;
1939           TREE_PUBLIC (union_decl) = 0;
1940           TREE_USED (union_decl) = 1;
1941           layout_decl (union_decl, 0);
1942           pushdecl (union_decl);
1943
1944           DECL_CONTEXT (union_decl) = current_function_decl;
1945           tmp = fold_build2 (MODIFY_EXPR, TREE_TYPE (union_decl),
1946                              union_decl, tmp);
1947           gfc_add_expr_to_block (&body, tmp);
1948
1949           for (field = TYPE_FIELDS (TREE_TYPE (union_decl));
1950                field; field = TREE_CHAIN (field))
1951             if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
1952                 thunk_sym->result->name) == 0)
1953               break;
1954           gcc_assert (field != NULL_TREE);
1955           tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
1956                              union_decl, field, NULL_TREE);
1957           tmp = fold_build2 (MODIFY_EXPR,
1958                              TREE_TYPE (DECL_RESULT (current_function_decl)),
1959                              DECL_RESULT (current_function_decl), tmp);
1960           tmp = build1_v (RETURN_EXPR, tmp);
1961         }
1962       else if (TREE_TYPE (DECL_RESULT (current_function_decl))
1963                != void_type_node)
1964         {
1965           tmp = fold_build2 (MODIFY_EXPR,
1966                              TREE_TYPE (DECL_RESULT (current_function_decl)),
1967                              DECL_RESULT (current_function_decl), tmp);
1968           tmp = build1_v (RETURN_EXPR, tmp);
1969         }
1970       gfc_add_expr_to_block (&body, tmp);
1971
1972       /* Finish off this function and send it for code generation.  */
1973       DECL_SAVED_TREE (thunk_fndecl) = gfc_finish_block (&body);
1974       tmp = getdecls ();
1975       poplevel (1, 0, 1);
1976       BLOCK_SUPERCONTEXT (DECL_INITIAL (thunk_fndecl)) = thunk_fndecl;
1977       DECL_SAVED_TREE (thunk_fndecl)
1978         = build3_v (BIND_EXPR, tmp, DECL_SAVED_TREE (thunk_fndecl),
1979                     DECL_INITIAL (thunk_fndecl));
1980
1981       /* Output the GENERIC tree.  */
1982       dump_function (TDI_original, thunk_fndecl);
1983
1984       /* Store the end of the function, so that we get good line number
1985          info for the epilogue.  */
1986       cfun->function_end_locus = input_location;
1987
1988       /* We're leaving the context of this function, so zap cfun.
1989          It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
1990          tree_rest_of_compilation.  */
1991       set_cfun (NULL);
1992
1993       current_function_decl = NULL_TREE;
1994
1995       gfc_gimplify_function (thunk_fndecl);
1996       cgraph_finalize_function (thunk_fndecl, false);
1997
1998       /* We share the symbols in the formal argument list with other entry
1999          points and the master function.  Clear them so that they are
2000          recreated for each function.  */
2001       for (formal = thunk_sym->formal; formal; formal = formal->next)
2002         if (formal->sym != NULL)  /* Ignore alternate returns.  */
2003           {
2004             formal->sym->backend_decl = NULL_TREE;
2005             if (formal->sym->ts.type == BT_CHARACTER)
2006               formal->sym->ts.cl->backend_decl = NULL_TREE;
2007           }
2008
2009       if (thunk_sym->attr.function)
2010         {
2011           if (thunk_sym->ts.type == BT_CHARACTER)
2012             thunk_sym->ts.cl->backend_decl = NULL_TREE;
2013           if (thunk_sym->result->ts.type == BT_CHARACTER)
2014             thunk_sym->result->ts.cl->backend_decl = NULL_TREE;
2015         }
2016     }
2017
2018   gfc_set_backend_locus (&old_loc);
2019 }
2020
2021
2022 /* Create a decl for a function, and create any thunks for alternate entry
2023    points.  */
2024
2025 void
2026 gfc_create_function_decl (gfc_namespace * ns)
2027 {
2028   /* Create a declaration for the master function.  */
2029   build_function_decl (ns->proc_name);
2030
2031   /* Compile the entry thunks.  */
2032   if (ns->entries)
2033     build_entry_thunks (ns);
2034
2035   /* Now create the read argument list.  */
2036   create_function_arglist (ns->proc_name);
2037 }
2038
2039 /* Return the decl used to hold the function return value.  If
2040    parent_flag is set, the context is the parent_scope.  */
2041
2042 tree
2043 gfc_get_fake_result_decl (gfc_symbol * sym, int parent_flag)
2044 {
2045   tree decl;
2046   tree length;
2047   tree this_fake_result_decl;
2048   tree this_function_decl;
2049
2050   char name[GFC_MAX_SYMBOL_LEN + 10];
2051
2052   if (parent_flag)
2053     {
2054       this_fake_result_decl = parent_fake_result_decl;
2055       this_function_decl = DECL_CONTEXT (current_function_decl);
2056     }
2057   else
2058     {
2059       this_fake_result_decl = current_fake_result_decl;
2060       this_function_decl = current_function_decl;
2061     }
2062
2063   if (sym
2064       && sym->ns->proc_name->backend_decl == this_function_decl
2065       && sym->ns->proc_name->attr.entry_master
2066       && sym != sym->ns->proc_name)
2067     {
2068       tree t = NULL, var;
2069       if (this_fake_result_decl != NULL)
2070         for (t = TREE_CHAIN (this_fake_result_decl); t; t = TREE_CHAIN (t))
2071           if (strcmp (IDENTIFIER_POINTER (TREE_PURPOSE (t)), sym->name) == 0)
2072             break;
2073       if (t)
2074         return TREE_VALUE (t);
2075       decl = gfc_get_fake_result_decl (sym->ns->proc_name, parent_flag);
2076
2077       if (parent_flag)
2078         this_fake_result_decl = parent_fake_result_decl;
2079       else
2080         this_fake_result_decl = current_fake_result_decl;
2081
2082       if (decl && sym->ns->proc_name->attr.mixed_entry_master)
2083         {
2084           tree field;
2085
2086           for (field = TYPE_FIELDS (TREE_TYPE (decl));
2087                field; field = TREE_CHAIN (field))
2088             if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
2089                 sym->name) == 0)
2090               break;
2091
2092           gcc_assert (field != NULL_TREE);
2093           decl = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
2094                               decl, field, NULL_TREE);
2095         }
2096
2097       var = create_tmp_var_raw (TREE_TYPE (decl), sym->name);
2098       if (parent_flag)
2099         gfc_add_decl_to_parent_function (var);
2100       else
2101         gfc_add_decl_to_function (var);
2102
2103       SET_DECL_VALUE_EXPR (var, decl);
2104       DECL_HAS_VALUE_EXPR_P (var) = 1;
2105       GFC_DECL_RESULT (var) = 1;
2106
2107       TREE_CHAIN (this_fake_result_decl)
2108           = tree_cons (get_identifier (sym->name), var,
2109                        TREE_CHAIN (this_fake_result_decl));
2110       return var;
2111     }
2112
2113   if (this_fake_result_decl != NULL_TREE)
2114     return TREE_VALUE (this_fake_result_decl);
2115
2116   /* Only when gfc_get_fake_result_decl is called by gfc_trans_return,
2117      sym is NULL.  */
2118   if (!sym)
2119     return NULL_TREE;
2120
2121   if (sym->ts.type == BT_CHARACTER)
2122     {
2123       if (sym->ts.cl->backend_decl == NULL_TREE)
2124         length = gfc_create_string_length (sym);
2125       else
2126         length = sym->ts.cl->backend_decl;
2127       if (TREE_CODE (length) == VAR_DECL
2128           && DECL_CONTEXT (length) == NULL_TREE)
2129         gfc_add_decl_to_function (length);
2130     }
2131
2132   if (gfc_return_by_reference (sym))
2133     {
2134       decl = DECL_ARGUMENTS (this_function_decl);
2135
2136       if (sym->ns->proc_name->backend_decl == this_function_decl
2137           && sym->ns->proc_name->attr.entry_master)
2138         decl = TREE_CHAIN (decl);
2139
2140       TREE_USED (decl) = 1;
2141       if (sym->as)
2142         decl = gfc_build_dummy_array_decl (sym, decl);
2143     }
2144   else
2145     {
2146       sprintf (name, "__result_%.20s",
2147                IDENTIFIER_POINTER (DECL_NAME (this_function_decl)));
2148
2149       if (!sym->attr.mixed_entry_master && sym->attr.function)
2150         decl = build_decl (VAR_DECL, get_identifier (name),
2151                            gfc_sym_type (sym));
2152       else
2153         decl = build_decl (VAR_DECL, get_identifier (name),
2154                            TREE_TYPE (TREE_TYPE (this_function_decl)));
2155       DECL_ARTIFICIAL (decl) = 1;
2156       DECL_EXTERNAL (decl) = 0;
2157       TREE_PUBLIC (decl) = 0;
2158       TREE_USED (decl) = 1;
2159       GFC_DECL_RESULT (decl) = 1;
2160       TREE_ADDRESSABLE (decl) = 1;
2161
2162       layout_decl (decl, 0);
2163
2164       if (parent_flag)
2165         gfc_add_decl_to_parent_function (decl);
2166       else
2167         gfc_add_decl_to_function (decl);
2168     }
2169
2170   if (parent_flag)
2171     parent_fake_result_decl = build_tree_list (NULL, decl);
2172   else
2173     current_fake_result_decl = build_tree_list (NULL, decl);
2174
2175   return decl;
2176 }
2177
2178
2179 /* Builds a function decl.  The remaining parameters are the types of the
2180    function arguments.  Negative nargs indicates a varargs function.  */
2181
2182 tree
2183 gfc_build_library_function_decl (tree name, tree rettype, int nargs, ...)
2184 {
2185   tree arglist;
2186   tree argtype;
2187   tree fntype;
2188   tree fndecl;
2189   va_list p;
2190   int n;
2191
2192   /* Library functions must be declared with global scope.  */
2193   gcc_assert (current_function_decl == NULL_TREE);
2194
2195   va_start (p, nargs);
2196
2197
2198   /* Create a list of the argument types.  */
2199   for (arglist = NULL_TREE, n = abs (nargs); n > 0; n--)
2200     {
2201       argtype = va_arg (p, tree);
2202       arglist = gfc_chainon_list (arglist, argtype);
2203     }
2204
2205   if (nargs >= 0)
2206     {
2207       /* Terminate the list.  */
2208       arglist = gfc_chainon_list (arglist, void_type_node);
2209     }
2210
2211   /* Build the function type and decl.  */
2212   fntype = build_function_type (rettype, arglist);
2213   fndecl = build_decl (FUNCTION_DECL, name, fntype);
2214
2215   /* Mark this decl as external.  */
2216   DECL_EXTERNAL (fndecl) = 1;
2217   TREE_PUBLIC (fndecl) = 1;
2218
2219   va_end (p);
2220
2221   pushdecl (fndecl);
2222
2223   rest_of_decl_compilation (fndecl, 1, 0);
2224
2225   return fndecl;
2226 }
2227
2228 static void
2229 gfc_build_intrinsic_function_decls (void)
2230 {
2231   tree gfc_int4_type_node = gfc_get_int_type (4);
2232   tree gfc_int8_type_node = gfc_get_int_type (8);
2233   tree gfc_int16_type_node = gfc_get_int_type (16);
2234   tree gfc_logical4_type_node = gfc_get_logical_type (4);
2235   tree pchar1_type_node = gfc_get_pchar_type (1);
2236   tree pchar4_type_node = gfc_get_pchar_type (4);
2237
2238   /* String functions.  */
2239   gfor_fndecl_compare_string =
2240     gfc_build_library_function_decl (get_identifier (PREFIX("compare_string")),
2241                                      integer_type_node, 4,
2242                                      gfc_charlen_type_node, pchar1_type_node,
2243                                      gfc_charlen_type_node, pchar1_type_node);
2244
2245   gfor_fndecl_concat_string =
2246     gfc_build_library_function_decl (get_identifier (PREFIX("concat_string")),
2247                                      void_type_node, 6,
2248                                      gfc_charlen_type_node, pchar1_type_node,
2249                                      gfc_charlen_type_node, pchar1_type_node,
2250                                      gfc_charlen_type_node, pchar1_type_node);
2251
2252   gfor_fndecl_string_len_trim =
2253     gfc_build_library_function_decl (get_identifier (PREFIX("string_len_trim")),
2254                                      gfc_int4_type_node, 2,
2255                                      gfc_charlen_type_node, pchar1_type_node);
2256
2257   gfor_fndecl_string_index =
2258     gfc_build_library_function_decl (get_identifier (PREFIX("string_index")),
2259                                      gfc_int4_type_node, 5,
2260                                      gfc_charlen_type_node, pchar1_type_node,
2261                                      gfc_charlen_type_node, pchar1_type_node,
2262                                      gfc_logical4_type_node);
2263
2264   gfor_fndecl_string_scan =
2265     gfc_build_library_function_decl (get_identifier (PREFIX("string_scan")),
2266                                      gfc_int4_type_node, 5,
2267                                      gfc_charlen_type_node, pchar1_type_node,
2268                                      gfc_charlen_type_node, pchar1_type_node,
2269                                      gfc_logical4_type_node);
2270
2271   gfor_fndecl_string_verify =
2272     gfc_build_library_function_decl (get_identifier (PREFIX("string_verify")),
2273                                      gfc_int4_type_node, 5,
2274                                      gfc_charlen_type_node, pchar1_type_node,
2275                                      gfc_charlen_type_node, pchar1_type_node,
2276                                      gfc_logical4_type_node);
2277
2278   gfor_fndecl_string_trim =
2279     gfc_build_library_function_decl (get_identifier (PREFIX("string_trim")),
2280                                      void_type_node, 4,
2281                                      build_pointer_type (gfc_charlen_type_node),
2282                                      build_pointer_type (pchar1_type_node),
2283                                      gfc_charlen_type_node, pchar1_type_node);
2284
2285   gfor_fndecl_string_minmax =
2286     gfc_build_library_function_decl (get_identifier (PREFIX("string_minmax")),
2287                                      void_type_node, -4,
2288                                      build_pointer_type (gfc_charlen_type_node),
2289                                      build_pointer_type (pchar1_type_node),
2290                                      integer_type_node, integer_type_node);
2291
2292   gfor_fndecl_adjustl =
2293     gfc_build_library_function_decl (get_identifier (PREFIX("adjustl")),
2294                                      void_type_node, 3, pchar1_type_node,
2295                                      gfc_charlen_type_node, pchar1_type_node);
2296
2297   gfor_fndecl_adjustr =
2298     gfc_build_library_function_decl (get_identifier (PREFIX("adjustr")),
2299                                      void_type_node, 3, pchar1_type_node,
2300                                      gfc_charlen_type_node, pchar1_type_node);
2301
2302   gfor_fndecl_select_string =
2303     gfc_build_library_function_decl (get_identifier (PREFIX("select_string")),
2304                                      integer_type_node, 4, pvoid_type_node,
2305                                      integer_type_node, pchar1_type_node,
2306                                      gfc_charlen_type_node);
2307
2308   gfor_fndecl_compare_string_char4 =
2309     gfc_build_library_function_decl (get_identifier
2310                                         (PREFIX("compare_string_char4")),
2311                                      integer_type_node, 4,
2312                                      gfc_charlen_type_node, pchar4_type_node,
2313                                      gfc_charlen_type_node, pchar4_type_node);
2314
2315   gfor_fndecl_concat_string_char4 =
2316     gfc_build_library_function_decl (get_identifier
2317                                         (PREFIX("concat_string_char4")),
2318                                      void_type_node, 6,
2319                                      gfc_charlen_type_node, pchar4_type_node,
2320                                      gfc_charlen_type_node, pchar4_type_node,
2321                                      gfc_charlen_type_node, pchar4_type_node);
2322
2323   gfor_fndecl_string_len_trim_char4 =
2324     gfc_build_library_function_decl (get_identifier
2325                                         (PREFIX("string_len_trim_char4")),
2326                                      gfc_charlen_type_node, 2,
2327                                      gfc_charlen_type_node, pchar4_type_node);
2328
2329   gfor_fndecl_string_index_char4 =
2330     gfc_build_library_function_decl (get_identifier
2331                                         (PREFIX("string_index_char4")),
2332                                      gfc_charlen_type_node, 5,
2333                                      gfc_charlen_type_node, pchar4_type_node,
2334                                      gfc_charlen_type_node, pchar4_type_node,
2335                                      gfc_logical4_type_node);
2336
2337   gfor_fndecl_string_scan_char4 =
2338     gfc_build_library_function_decl (get_identifier
2339                                         (PREFIX("string_scan_char4")),
2340                                      gfc_charlen_type_node, 5,
2341                                      gfc_charlen_type_node, pchar4_type_node,
2342                                      gfc_charlen_type_node, pchar4_type_node,
2343                                      gfc_logical4_type_node);
2344
2345   gfor_fndecl_string_verify_char4 =
2346     gfc_build_library_function_decl (get_identifier
2347                                         (PREFIX("string_verify_char4")),
2348                                      gfc_charlen_type_node, 5,
2349                                      gfc_charlen_type_node, pchar4_type_node,
2350                                      gfc_charlen_type_node, pchar4_type_node,
2351                                      gfc_logical4_type_node);
2352
2353   gfor_fndecl_string_trim_char4 =
2354     gfc_build_library_function_decl (get_identifier
2355                                         (PREFIX("string_trim_char4")),
2356                                      void_type_node, 4,
2357                                      build_pointer_type (gfc_charlen_type_node),
2358                                      build_pointer_type (pchar4_type_node),
2359                                      gfc_charlen_type_node, pchar4_type_node);
2360
2361   gfor_fndecl_string_minmax_char4 =
2362     gfc_build_library_function_decl (get_identifier
2363                                         (PREFIX("string_minmax_char4")),
2364                                      void_type_node, -4,
2365                                      build_pointer_type (gfc_charlen_type_node),
2366                                      build_pointer_type (pchar4_type_node),
2367                                      integer_type_node, integer_type_node);
2368
2369   gfor_fndecl_adjustl_char4 =
2370     gfc_build_library_function_decl (get_identifier (PREFIX("adjustl_char4")),
2371                                      void_type_node, 3, pchar4_type_node,
2372                                      gfc_charlen_type_node, pchar4_type_node);
2373
2374   gfor_fndecl_adjustr_char4 =
2375     gfc_build_library_function_decl (get_identifier (PREFIX("adjustr_char4")),
2376                                      void_type_node, 3, pchar4_type_node,
2377                                      gfc_charlen_type_node, pchar4_type_node);
2378
2379   gfor_fndecl_select_string_char4 =
2380     gfc_build_library_function_decl (get_identifier
2381                                         (PREFIX("select_string_char4")),
2382                                      integer_type_node, 4, pvoid_type_node,
2383                                      integer_type_node, pvoid_type_node,
2384                                      gfc_charlen_type_node);
2385
2386
2387   /* Conversion between character kinds.  */
2388
2389   gfor_fndecl_convert_char1_to_char4 =
2390     gfc_build_library_function_decl (get_identifier
2391                                         (PREFIX("convert_char1_to_char4")),
2392                                      void_type_node, 3,
2393                                      build_pointer_type (pchar4_type_node),
2394                                      gfc_charlen_type_node, pchar1_type_node);
2395
2396   gfor_fndecl_convert_char4_to_char1 =
2397     gfc_build_library_function_decl (get_identifier
2398                                         (PREFIX("convert_char4_to_char1")),
2399                                      void_type_node, 3,
2400                                      build_pointer_type (pchar1_type_node),
2401                                      gfc_charlen_type_node, pchar4_type_node);
2402
2403   /* Misc. functions.  */
2404
2405   gfor_fndecl_ttynam =
2406     gfc_build_library_function_decl (get_identifier (PREFIX("ttynam")),
2407                                      void_type_node,
2408                                      3,
2409                                      pchar_type_node,
2410                                      gfc_charlen_type_node,
2411                                      integer_type_node);
2412
2413   gfor_fndecl_fdate =
2414     gfc_build_library_function_decl (get_identifier (PREFIX("fdate")),
2415                                      void_type_node,
2416                                      2,
2417                                      pchar_type_node,
2418                                      gfc_charlen_type_node);
2419
2420   gfor_fndecl_ctime =
2421     gfc_build_library_function_decl (get_identifier (PREFIX("ctime")),
2422                                      void_type_node,
2423                                      3,
2424                                      pchar_type_node,
2425                                      gfc_charlen_type_node,
2426                                      gfc_int8_type_node);
2427
2428   gfor_fndecl_sc_kind =
2429     gfc_build_library_function_decl (get_identifier
2430                                         (PREFIX("selected_char_kind")),
2431                                      gfc_int4_type_node, 2,
2432                                      gfc_charlen_type_node, pchar_type_node);
2433
2434   gfor_fndecl_si_kind =
2435     gfc_build_library_function_decl (get_identifier
2436                                         (PREFIX("selected_int_kind")),
2437                                      gfc_int4_type_node, 1, pvoid_type_node);
2438
2439   gfor_fndecl_sr_kind =
2440     gfc_build_library_function_decl (get_identifier
2441                                         (PREFIX("selected_real_kind")),
2442                                      gfc_int4_type_node, 2,
2443                                      pvoid_type_node, pvoid_type_node);
2444
2445   /* Power functions.  */
2446   {
2447     tree ctype, rtype, itype, jtype;
2448     int rkind, ikind, jkind;
2449 #define NIKINDS 3
2450 #define NRKINDS 4
2451     static int ikinds[NIKINDS] = {4, 8, 16};
2452     static int rkinds[NRKINDS] = {4, 8, 10, 16};
2453     char name[PREFIX_LEN + 12]; /* _gfortran_pow_?n_?n */
2454
2455     for (ikind=0; ikind < NIKINDS; ikind++)
2456       {
2457         itype = gfc_get_int_type (ikinds[ikind]);
2458
2459         for (jkind=0; jkind < NIKINDS; jkind++)
2460           {
2461             jtype = gfc_get_int_type (ikinds[jkind]);
2462             if (itype && jtype)
2463               {
2464                 sprintf(name, PREFIX("pow_i%d_i%d"), ikinds[ikind],
2465                         ikinds[jkind]);
2466                 gfor_fndecl_math_powi[jkind][ikind].integer =
2467                   gfc_build_library_function_decl (get_identifier (name),
2468                     jtype, 2, jtype, itype);
2469                 TREE_READONLY (gfor_fndecl_math_powi[jkind][ikind].integer) = 1;
2470               }
2471           }
2472
2473         for (rkind = 0; rkind < NRKINDS; rkind ++)
2474           {
2475             rtype = gfc_get_real_type (rkinds[rkind]);
2476             if (rtype && itype)
2477               {
2478                 sprintf(name, PREFIX("pow_r%d_i%d"), rkinds[rkind],
2479                         ikinds[ikind]);
2480                 gfor_fndecl_math_powi[rkind][ikind].real =
2481                   gfc_build_library_function_decl (get_identifier (name),
2482                     rtype, 2, rtype, itype);
2483                 TREE_READONLY (gfor_fndecl_math_powi[rkind][ikind].real) = 1;
2484               }
2485
2486             ctype = gfc_get_complex_type (rkinds[rkind]);
2487             if (ctype && itype)
2488               {
2489                 sprintf(name, PREFIX("pow_c%d_i%d"), rkinds[rkind],
2490                         ikinds[ikind]);
2491                 gfor_fndecl_math_powi[rkind][ikind].cmplx =
2492                   gfc_build_library_function_decl (get_identifier (name),
2493                     ctype, 2,ctype, itype);
2494                 TREE_READONLY (gfor_fndecl_math_powi[rkind][ikind].cmplx) = 1;
2495               }
2496           }
2497       }
2498 #undef NIKINDS
2499 #undef NRKINDS
2500   }
2501
2502   gfor_fndecl_math_ishftc4 =
2503     gfc_build_library_function_decl (get_identifier (PREFIX("ishftc4")),
2504                                      gfc_int4_type_node,
2505                                      3, gfc_int4_type_node,
2506                                      gfc_int4_type_node, gfc_int4_type_node);
2507   gfor_fndecl_math_ishftc8 =
2508     gfc_build_library_function_decl (get_identifier (PREFIX("ishftc8")),
2509                                      gfc_int8_type_node,
2510                                      3, gfc_int8_type_node,
2511                                      gfc_int4_type_node, gfc_int4_type_node);
2512   if (gfc_int16_type_node)
2513     gfor_fndecl_math_ishftc16 =
2514       gfc_build_library_function_decl (get_identifier (PREFIX("ishftc16")),
2515                                        gfc_int16_type_node, 3,
2516                                        gfc_int16_type_node,
2517                                        gfc_int4_type_node,
2518                                        gfc_int4_type_node);
2519
2520   /* BLAS functions.  */
2521   {
2522     tree pint = build_pointer_type (integer_type_node);
2523     tree ps = build_pointer_type (gfc_get_real_type (gfc_default_real_kind));
2524     tree pd = build_pointer_type (gfc_get_real_type (gfc_default_double_kind));
2525     tree pc = build_pointer_type (gfc_get_complex_type (gfc_default_real_kind));
2526     tree pz = build_pointer_type
2527                 (gfc_get_complex_type (gfc_default_double_kind));
2528
2529     gfor_fndecl_sgemm = gfc_build_library_function_decl
2530                           (get_identifier
2531                              (gfc_option.flag_underscoring ? "sgemm_"
2532                                                            : "sgemm"),
2533                            void_type_node, 15, pchar_type_node,
2534                            pchar_type_node, pint, pint, pint, ps, ps, pint,
2535                            ps, pint, ps, ps, pint, integer_type_node,
2536                            integer_type_node);
2537     gfor_fndecl_dgemm = gfc_build_library_function_decl
2538                           (get_identifier
2539                              (gfc_option.flag_underscoring ? "dgemm_"
2540                                                            : "dgemm"),
2541                            void_type_node, 15, pchar_type_node,
2542                            pchar_type_node, pint, pint, pint, pd, pd, pint,
2543                            pd, pint, pd, pd, pint, integer_type_node,
2544                            integer_type_node);
2545     gfor_fndecl_cgemm = gfc_build_library_function_decl
2546                           (get_identifier
2547                              (gfc_option.flag_underscoring ? "cgemm_"
2548                                                            : "cgemm"),
2549                            void_type_node, 15, pchar_type_node,
2550                            pchar_type_node, pint, pint, pint, pc, pc, pint,
2551                            pc, pint, pc, pc, pint, integer_type_node,
2552                            integer_type_node);
2553     gfor_fndecl_zgemm = gfc_build_library_function_decl
2554                           (get_identifier
2555                              (gfc_option.flag_underscoring ? "zgemm_"
2556                                                            : "zgemm"),
2557                            void_type_node, 15, pchar_type_node,
2558                            pchar_type_node, pint, pint, pint, pz, pz, pint,
2559                            pz, pint, pz, pz, pint, integer_type_node,
2560                            integer_type_node);
2561   }
2562
2563   /* Other functions.  */
2564   gfor_fndecl_size0 =
2565     gfc_build_library_function_decl (get_identifier (PREFIX("size0")),
2566                                      gfc_array_index_type,
2567                                      1, pvoid_type_node);
2568   gfor_fndecl_size1 =
2569     gfc_build_library_function_decl (get_identifier (PREFIX("size1")),
2570                                      gfc_array_index_type,
2571                                      2, pvoid_type_node,
2572                                      gfc_array_index_type);
2573
2574   gfor_fndecl_iargc =
2575     gfc_build_library_function_decl (get_identifier (PREFIX ("iargc")),
2576                                      gfc_int4_type_node,
2577                                      0);
2578
2579   if (gfc_type_for_size (128, true))
2580     {
2581       tree uint128 = gfc_type_for_size (128, true);
2582
2583       gfor_fndecl_clz128 =
2584         gfc_build_library_function_decl (get_identifier (PREFIX ("clz128")),
2585                                          integer_type_node, 1, uint128);
2586
2587       gfor_fndecl_ctz128 =
2588         gfc_build_library_function_decl (get_identifier (PREFIX ("ctz128")),
2589                                          integer_type_node, 1, uint128);
2590     }
2591 }
2592
2593
2594 /* Make prototypes for runtime library functions.  */
2595
2596 void
2597 gfc_build_builtin_function_decls (void)
2598 {
2599   tree gfc_int4_type_node = gfc_get_int_type (4);
2600
2601   gfor_fndecl_stop_numeric =
2602     gfc_build_library_function_decl (get_identifier (PREFIX("stop_numeric")),
2603                                      void_type_node, 1, gfc_int4_type_node);
2604   /* Stop doesn't return.  */
2605   TREE_THIS_VOLATILE (gfor_fndecl_stop_numeric) = 1;
2606
2607   gfor_fndecl_stop_string =
2608     gfc_build_library_function_decl (get_identifier (PREFIX("stop_string")),
2609                                      void_type_node, 2, pchar_type_node,
2610                                      gfc_int4_type_node);
2611   /* Stop doesn't return.  */
2612   TREE_THIS_VOLATILE (gfor_fndecl_stop_string) = 1;
2613
2614   gfor_fndecl_pause_numeric =
2615     gfc_build_library_function_decl (get_identifier (PREFIX("pause_numeric")),
2616                                      void_type_node, 1, gfc_int4_type_node);
2617
2618   gfor_fndecl_pause_string =
2619     gfc_build_library_function_decl (get_identifier (PREFIX("pause_string")),
2620                                      void_type_node, 2, pchar_type_node,
2621                                      gfc_int4_type_node);
2622
2623   gfor_fndecl_runtime_error =
2624     gfc_build_library_function_decl (get_identifier (PREFIX("runtime_error")),
2625                                      void_type_node, -1, pchar_type_node);
2626   /* The runtime_error function does not return.  */
2627   TREE_THIS_VOLATILE (gfor_fndecl_runtime_error) = 1;
2628
2629   gfor_fndecl_runtime_error_at =
2630     gfc_build_library_function_decl (get_identifier (PREFIX("runtime_error_at")),
2631                                      void_type_node, -2, pchar_type_node,
2632                                      pchar_type_node);
2633   /* The runtime_error_at function does not return.  */
2634   TREE_THIS_VOLATILE (gfor_fndecl_runtime_error_at) = 1;
2635
2636   gfor_fndecl_runtime_warning_at =
2637     gfc_build_library_function_decl (get_identifier (PREFIX("runtime_warning_at")),
2638                                      void_type_node, -2, pchar_type_node,
2639                                      pchar_type_node);
2640   gfor_fndecl_generate_error =
2641     gfc_build_library_function_decl (get_identifier (PREFIX("generate_error")),
2642                                      void_type_node, 3, pvoid_type_node,
2643                                      integer_type_node, pchar_type_node);
2644
2645   gfor_fndecl_os_error =
2646     gfc_build_library_function_decl (get_identifier (PREFIX("os_error")),
2647                                      void_type_node, 1, pchar_type_node);
2648   /* The runtime_error function does not return.  */
2649   TREE_THIS_VOLATILE (gfor_fndecl_os_error) = 1;
2650
2651   gfor_fndecl_set_args =
2652     gfc_build_library_function_decl (get_identifier (PREFIX("set_args")),
2653                                      void_type_node, 2, integer_type_node,
2654                                      build_pointer_type (pchar_type_node));
2655
2656   gfor_fndecl_set_fpe =
2657     gfc_build_library_function_decl (get_identifier (PREFIX("set_fpe")),
2658                                     void_type_node, 1, integer_type_node);
2659
2660   /* Keep the array dimension in sync with the call, later in this file.  */
2661   gfor_fndecl_set_options =
2662     gfc_build_library_function_decl (get_identifier (PREFIX("set_options")),
2663                                     void_type_node, 2, integer_type_node,
2664                                     build_pointer_type (integer_type_node));
2665
2666   gfor_fndecl_set_convert =
2667     gfc_build_library_function_decl (get_identifier (PREFIX("set_convert")),
2668                                      void_type_node, 1, integer_type_node);
2669
2670   gfor_fndecl_set_record_marker =
2671     gfc_build_library_function_decl (get_identifier (PREFIX("set_record_marker")),
2672                                      void_type_node, 1, integer_type_node);
2673
2674   gfor_fndecl_set_max_subrecord_length =
2675     gfc_build_library_function_decl (get_identifier (PREFIX("set_max_subrecord_length")),
2676                                      void_type_node, 1, integer_type_node);
2677
2678   gfor_fndecl_in_pack = gfc_build_library_function_decl (
2679         get_identifier (PREFIX("internal_pack")),
2680         pvoid_type_node, 1, pvoid_type_node);
2681
2682   gfor_fndecl_in_unpack = gfc_build_library_function_decl (
2683         get_identifier (PREFIX("internal_unpack")),
2684         void_type_node, 2, pvoid_type_node, pvoid_type_node);
2685
2686   gfor_fndecl_associated =
2687     gfc_build_library_function_decl (
2688                                      get_identifier (PREFIX("associated")),
2689                                      integer_type_node, 2, ppvoid_type_node,
2690                                      ppvoid_type_node);
2691
2692   gfc_build_intrinsic_function_decls ();
2693   gfc_build_intrinsic_lib_fndecls ();
2694   gfc_build_io_library_fndecls ();
2695 }
2696
2697
2698 /* Evaluate the length of dummy character variables.  */
2699
2700 static tree
2701 gfc_trans_dummy_character (gfc_symbol *sym, gfc_charlen *cl, tree fnbody)
2702 {
2703   stmtblock_t body;
2704
2705   gfc_finish_decl (cl->backend_decl);
2706
2707   gfc_start_block (&body);
2708
2709   /* Evaluate the string length expression.  */
2710   gfc_conv_string_length (cl, NULL, &body);
2711
2712   gfc_trans_vla_type_sizes (sym, &body);
2713
2714   gfc_add_expr_to_block (&body, fnbody);
2715   return gfc_finish_block (&body);
2716 }
2717
2718
2719 /* Allocate and cleanup an automatic character variable.  */
2720
2721 static tree
2722 gfc_trans_auto_character_variable (gfc_symbol * sym, tree fnbody)
2723 {
2724   stmtblock_t body;
2725   tree decl;
2726   tree tmp;
2727
2728   gcc_assert (sym->backend_decl);
2729   gcc_assert (sym->ts.cl && sym->ts.cl->length);
2730
2731   gfc_start_block (&body);
2732
2733   /* Evaluate the string length expression.  */
2734   gfc_conv_string_length (sym->ts.cl, NULL, &body);
2735
2736   gfc_trans_vla_type_sizes (sym, &body);
2737
2738   decl = sym->backend_decl;
2739
2740   /* Emit a DECL_EXPR for this variable, which will cause the
2741      gimplifier to allocate storage, and all that good stuff.  */
2742   tmp = fold_build1 (DECL_EXPR, TREE_TYPE (decl), decl);
2743   gfc_add_expr_to_block (&body, tmp);
2744
2745   gfc_add_expr_to_block (&body, fnbody);
2746   return gfc_finish_block (&body);
2747 }
2748
2749 /* Set the initial value of ASSIGN statement auxiliary variable explicitly.  */
2750
2751 static tree
2752 gfc_trans_assign_aux_var (gfc_symbol * sym, tree fnbody)
2753 {
2754   stmtblock_t body;
2755
2756   gcc_assert (sym->backend_decl);
2757   gfc_start_block (&body);
2758
2759   /* Set the initial value to length. See the comments in
2760      function gfc_add_assign_aux_vars in this file.  */
2761   gfc_add_modify (&body, GFC_DECL_STRING_LEN (sym->backend_decl),
2762                        build_int_cst (NULL_TREE, -2));
2763
2764   gfc_add_expr_to_block (&body, fnbody);
2765   return gfc_finish_block (&body);
2766 }
2767
2768 static void
2769 gfc_trans_vla_one_sizepos (tree *tp, stmtblock_t *body)
2770 {
2771   tree t = *tp, var, val;
2772
2773   if (t == NULL || t == error_mark_node)
2774     return;
2775   if (TREE_CONSTANT (t) || DECL_P (t))
2776     return;
2777
2778   if (TREE_CODE (t) == SAVE_EXPR)
2779     {
2780       if (SAVE_EXPR_RESOLVED_P (t))
2781         {
2782           *tp = TREE_OPERAND (t, 0);
2783           return;
2784         }
2785       val = TREE_OPERAND (t, 0);
2786     }
2787   else
2788     val = t;
2789
2790   var = gfc_create_var_np (TREE_TYPE (t), NULL);
2791   gfc_add_decl_to_function (var);
2792   gfc_add_modify (body, var, val);
2793   if (TREE_CODE (t) == SAVE_EXPR)
2794     TREE_OPERAND (t, 0) = var;
2795   *tp = var;
2796 }
2797
2798 static void
2799 gfc_trans_vla_type_sizes_1 (tree type, stmtblock_t *body)
2800 {
2801   tree t;
2802
2803   if (type == NULL || type == error_mark_node)
2804     return;
2805
2806   type = TYPE_MAIN_VARIANT (type);
2807
2808   if (TREE_CODE (type) == INTEGER_TYPE)
2809     {
2810       gfc_trans_vla_one_sizepos (&TYPE_MIN_VALUE (type), body);
2811       gfc_trans_vla_one_sizepos (&TYPE_MAX_VALUE (type), body);
2812
2813       for (t = TYPE_NEXT_VARIANT (type); t; t = TYPE_NEXT_VARIANT (t))
2814         {
2815           TYPE_MIN_VALUE (t) = TYPE_MIN_VALUE (type);
2816           TYPE_MAX_VALUE (t) = TYPE_MAX_VALUE (type);
2817         }
2818     }
2819   else if (TREE_CODE (type) == ARRAY_TYPE)
2820     {
2821       gfc_trans_vla_type_sizes_1 (TREE_TYPE (type), body);
2822       gfc_trans_vla_type_sizes_1 (TYPE_DOMAIN (type), body);
2823       gfc_trans_vla_one_sizepos (&TYPE_SIZE (type), body);
2824       gfc_trans_vla_one_sizepos (&TYPE_SIZE_UNIT (type), body);
2825
2826       for (t = TYPE_NEXT_VARIANT (type); t; t = TYPE_NEXT_VARIANT (t))
2827         {
2828           TYPE_SIZE (t) = TYPE_SIZE (type);
2829           TYPE_SIZE_UNIT (t) = TYPE_SIZE_UNIT (type);
2830         }
2831     }
2832 }
2833
2834 /* Make sure all type sizes and array domains are either constant,
2835    or variable or parameter decls.  This is a simplified variant
2836    of gimplify_type_sizes, but we can't use it here, as none of the
2837    variables in the expressions have been gimplified yet.
2838    As type sizes and domains for various variable length arrays
2839    contain VAR_DECLs that are only initialized at gfc_trans_deferred_vars
2840    time, without this routine gimplify_type_sizes in the middle-end
2841    could result in the type sizes being gimplified earlier than where
2842    those variables are initialized.  */
2843
2844 void
2845 gfc_trans_vla_type_sizes (gfc_symbol *sym, stmtblock_t *body)
2846 {
2847   tree type = TREE_TYPE (sym->backend_decl);
2848
2849   if (TREE_CODE (type) == FUNCTION_TYPE
2850       && (sym->attr.function || sym->attr.result || sym->attr.entry))
2851     {
2852       if (! current_fake_result_decl)
2853         return;
2854
2855       type = TREE_TYPE (TREE_VALUE (current_fake_result_decl));
2856     }
2857
2858   while (POINTER_TYPE_P (type))
2859     type = TREE_TYPE (type);
2860
2861   if (GFC_DESCRIPTOR_TYPE_P (type))
2862     {
2863       tree etype = GFC_TYPE_ARRAY_DATAPTR_TYPE (type);
2864
2865       while (POINTER_TYPE_P (etype))
2866         etype = TREE_TYPE (etype);
2867
2868       gfc_trans_vla_type_sizes_1 (etype, body);
2869     }
2870
2871   gfc_trans_vla_type_sizes_1 (type, body);
2872 }
2873
2874
2875 /* Initialize a derived type by building an lvalue from the symbol
2876    and using trans_assignment to do the work.  */
2877 tree
2878 gfc_init_default_dt (gfc_symbol * sym, tree body)
2879 {
2880   stmtblock_t fnblock;
2881   gfc_expr *e;
2882   tree tmp;
2883   tree present;
2884
2885   gfc_init_block (&fnblock);
2886   gcc_assert (!sym->attr.allocatable);
2887   gfc_set_sym_referenced (sym);
2888   e = gfc_lval_expr_from_sym (sym);
2889   tmp = gfc_trans_assignment (e, sym->value, false);
2890   if (sym->attr.dummy)
2891     {
2892       present = gfc_conv_expr_present (sym);
2893       tmp = build3 (COND_EXPR, TREE_TYPE (tmp), present,
2894                     tmp, build_empty_stmt ());
2895     }
2896   gfc_add_expr_to_block (&fnblock, tmp);
2897   gfc_free_expr (e);
2898   if (body)
2899     gfc_add_expr_to_block (&fnblock, body);
2900   return gfc_finish_block (&fnblock);
2901 }
2902
2903
2904 /* Initialize INTENT(OUT) derived type dummies.  As well as giving
2905    them their default initializer, if they do not have allocatable
2906    components, they have their allocatable components deallocated. */
2907
2908 static tree
2909 init_intent_out_dt (gfc_symbol * proc_sym, tree body)
2910 {
2911   stmtblock_t fnblock;
2912   gfc_formal_arglist *f;
2913   tree tmp;
2914   tree present;
2915
2916   gfc_init_block (&fnblock);
2917   for (f = proc_sym->formal; f; f = f->next)
2918     if (f->sym && f->sym->attr.intent == INTENT_OUT
2919           && f->sym->ts.type == BT_DERIVED)
2920       {
2921         if (f->sym->ts.derived->attr.alloc_comp)
2922           {
2923             tmp = gfc_deallocate_alloc_comp (f->sym->ts.derived,
2924                                              f->sym->backend_decl,
2925                                              f->sym->as ? f->sym->as->rank : 0);
2926
2927             present = gfc_conv_expr_present (f->sym);
2928             tmp = build3 (COND_EXPR, TREE_TYPE (tmp), present,
2929                           tmp, build_empty_stmt ());
2930
2931             gfc_add_expr_to_block (&fnblock, tmp);
2932           }
2933
2934         if (!f->sym->ts.derived->attr.alloc_comp
2935               && f->sym->value)
2936           body = gfc_init_default_dt (f->sym, body);
2937       }
2938
2939   gfc_add_expr_to_block (&fnblock, body);
2940   return gfc_finish_block (&fnblock);
2941 }
2942
2943
2944 /* Generate function entry and exit code, and add it to the function body.
2945    This includes:
2946     Allocation and initialization of array variables.
2947     Allocation of character string variables.
2948     Initialization and possibly repacking of dummy arrays.
2949     Initialization of ASSIGN statement auxiliary variable.  */
2950
2951 static tree
2952 gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
2953 {
2954   locus loc;
2955   gfc_symbol *sym;
2956   gfc_formal_arglist *f;
2957   stmtblock_t body;
2958   bool seen_trans_deferred_array = false;
2959
2960   /* Deal with implicit return variables.  Explicit return variables will
2961      already have been added.  */
2962   if (gfc_return_by_reference (proc_sym) && proc_sym->result == proc_sym)
2963     {
2964       if (!current_fake_result_decl)
2965         {
2966           gfc_entry_list *el = NULL;
2967           if (proc_sym->attr.entry_master)
2968             {
2969               for (el = proc_sym->ns->entries; el; el = el->next)
2970                 if (el->sym != el->sym->result)
2971                   break;
2972             }
2973           /* TODO: move to the appropriate place in resolve.c.  */
2974           if (warn_return_type && el == NULL)
2975             gfc_warning ("Return value of function '%s' at %L not set",
2976                          proc_sym->name, &proc_sym->declared_at);
2977         }
2978       else if (proc_sym->as)
2979         {
2980           tree result = TREE_VALUE (current_fake_result_decl);
2981           fnbody = gfc_trans_dummy_array_bias (proc_sym, result, fnbody);
2982
2983           /* An automatic character length, pointer array result.  */
2984           if (proc_sym->ts.type == BT_CHARACTER
2985                 && TREE_CODE (proc_sym->ts.cl->backend_decl) == VAR_DECL)
2986             fnbody = gfc_trans_dummy_character (proc_sym, proc_sym->ts.cl,
2987                                                 fnbody);
2988         }
2989       else if (proc_sym->ts.type == BT_CHARACTER)
2990         {
2991           if (TREE_CODE (proc_sym->ts.cl->backend_decl) == VAR_DECL)
2992             fnbody = gfc_trans_dummy_character (proc_sym, proc_sym->ts.cl,
2993                                                 fnbody);
2994         }
2995       else
2996         gcc_assert (gfc_option.flag_f2c
2997                     && proc_sym->ts.type == BT_COMPLEX);
2998     }
2999
3000   /* Initialize the INTENT(OUT) derived type dummy arguments.  This
3001      should be done here so that the offsets and lbounds of arrays
3002      are available.  */
3003   fnbody = init_intent_out_dt (proc_sym, fnbody);
3004
3005   for (sym = proc_sym->tlink; sym != proc_sym; sym = sym->tlink)
3006     {
3007       bool sym_has_alloc_comp = (sym->ts.type == BT_DERIVED)
3008                                    && sym->ts.derived->attr.alloc_comp;
3009       if (sym->attr.dimension)
3010         {
3011           switch (sym->as->type)
3012             {
3013             case AS_EXPLICIT:
3014               if (sym->attr.dummy || sym->attr.result)
3015                 fnbody =
3016                   gfc_trans_dummy_array_bias (sym, sym->backend_decl, fnbody);
3017               else if (sym->attr.pointer || sym->attr.allocatable)
3018                 {
3019                   if (TREE_STATIC (sym->backend_decl))
3020                     gfc_trans_static_array_pointer (sym);
3021                   else
3022                     {
3023                       seen_trans_deferred_array = true;
3024                       fnbody = gfc_trans_deferred_array (sym, fnbody);
3025                     }
3026                 }
3027               else
3028                 {
3029                   if (sym_has_alloc_comp)
3030                     {
3031                       seen_trans_deferred_array = true;
3032                       fnbody = gfc_trans_deferred_array (sym, fnbody);
3033                     }
3034                   else if (sym->ts.type == BT_DERIVED
3035                              && sym->value
3036                              && !sym->attr.data
3037                              && sym->attr.save == SAVE_NONE)
3038                     fnbody = gfc_init_default_dt (sym, fnbody);
3039
3040                   gfc_get_backend_locus (&loc);
3041                   gfc_set_backend_locus (&sym->declared_at);
3042                   fnbody = gfc_trans_auto_array_allocation (sym->backend_decl,
3043                       sym, fnbody);
3044                   gfc_set_backend_locus (&loc);
3045                 }
3046               break;
3047
3048             case AS_ASSUMED_SIZE:
3049               /* Must be a dummy parameter.  */
3050               gcc_assert (sym->attr.dummy);
3051
3052               /* We should always pass assumed size arrays the g77 way.  */
3053               fnbody = gfc_trans_g77_array (sym, fnbody);
3054               break;
3055
3056             case AS_ASSUMED_SHAPE:
3057               /* Must be a dummy parameter.  */
3058               gcc_assert (sym->attr.dummy);
3059
3060               fnbody = gfc_trans_dummy_array_bias (sym, sym->backend_decl,
3061                                                    fnbody);
3062               break;
3063
3064             case AS_DEFERRED:
3065               seen_trans_deferred_array = true;
3066               fnbody = gfc_trans_deferred_array (sym, fnbody);
3067               break;
3068
3069             default:
3070               gcc_unreachable ();
3071             }
3072           if (sym_has_alloc_comp && !seen_trans_deferred_array)
3073             fnbody = gfc_trans_deferred_array (sym, fnbody);
3074         }
3075       else if (sym_has_alloc_comp)
3076         fnbody = gfc_trans_deferred_array (sym, fnbody);
3077       else if (sym->ts.type == BT_CHARACTER)
3078         {
3079           gfc_get_backend_locus (&loc);
3080           gfc_set_backend_locus (&sym->declared_at);
3081           if (sym->attr.dummy || sym->attr.result)
3082             fnbody = gfc_trans_dummy_character (sym, sym->ts.cl, fnbody);
3083           else
3084             fnbody = gfc_trans_auto_character_variable (sym, fnbody);
3085           gfc_set_backend_locus (&loc);
3086         }
3087       else if (sym->attr.assign)
3088         {
3089           gfc_get_backend_locus (&loc);
3090           gfc_set_backend_locus (&sym->declared_at);
3091           fnbody = gfc_trans_assign_aux_var (sym, fnbody);
3092           gfc_set_backend_locus (&loc);
3093         }
3094       else if (sym->ts.type == BT_DERIVED
3095                  && sym->value
3096                  && !sym->attr.data
3097                  && sym->attr.save == SAVE_NONE)
3098         fnbody = gfc_init_default_dt (sym, fnbody);
3099       else
3100         gcc_unreachable ();
3101     }
3102
3103   gfc_init_block (&body);
3104
3105   for (f = proc_sym->formal; f; f = f->next)
3106     {
3107       if (f->sym && f->sym->tlink == NULL && f->sym->ts.type == BT_CHARACTER)
3108         {
3109           gcc_assert (f->sym->ts.cl->backend_decl != NULL);
3110           if (TREE_CODE (f->sym->ts.cl->backend_decl) == PARM_DECL)
3111             gfc_trans_vla_type_sizes (f->sym, &body);
3112         }
3113     }
3114
3115   if (gfc_return_by_reference (proc_sym) && proc_sym->ts.type == BT_CHARACTER
3116       && current_fake_result_decl != NULL)
3117     {
3118       gcc_assert (proc_sym->ts.cl->backend_decl != NULL);
3119       if (TREE_CODE (proc_sym->ts.cl->backend_decl) == PARM_DECL)
3120         gfc_trans_vla_type_sizes (proc_sym, &body);
3121     }
3122
3123   gfc_add_expr_to_block (&body, fnbody);
3124   return gfc_finish_block (&body);
3125 }
3126
3127 static GTY ((param_is (struct module_htab_entry))) htab_t module_htab;
3128
3129 /* Hash and equality functions for module_htab.  */
3130
3131 static hashval_t
3132 module_htab_do_hash (const void *x)
3133 {
3134   return htab_hash_string (((const struct module_htab_entry *)x)->name);
3135 }
3136
3137 static int
3138 module_htab_eq (const void *x1, const void *x2)
3139 {
3140   return strcmp ((((const struct module_htab_entry *)x1)->name),
3141                  (const char *)x2) == 0;
3142 }
3143
3144 /* Hash and equality functions for module_htab's decls.  */
3145
3146 static hashval_t
3147 module_htab_decls_hash (const void *x)
3148 {
3149   const_tree t = (const_tree) x;
3150   const_tree n = DECL_NAME (t);
3151   if (n == NULL_TREE)
3152     n = TYPE_NAME (TREE_TYPE (t));
3153   return htab_hash_string (IDENTIFIER_POINTER (n));
3154 }
3155
3156 static int
3157 module_htab_decls_eq (const void *x1, const void *x2)
3158 {
3159   const_tree t1 = (const_tree) x1;
3160   const_tree n1 = DECL_NAME (t1);
3161   if (n1 == NULL_TREE)
3162     n1 = TYPE_NAME (TREE_TYPE (t1));
3163   return strcmp (IDENTIFIER_POINTER (n1), (const char *) x2) == 0;
3164 }
3165
3166 struct module_htab_entry *
3167 gfc_find_module (const char *name)
3168 {
3169   void **slot;
3170
3171   if (! module_htab)
3172     module_htab = htab_create_ggc (10, module_htab_do_hash,
3173                                    module_htab_eq, NULL);
3174
3175   slot = htab_find_slot_with_hash (module_htab, name,
3176                                    htab_hash_string (name), INSERT);
3177   if (*slot == NULL)
3178     {
3179       struct module_htab_entry *entry = GGC_CNEW (struct module_htab_entry);
3180
3181       entry->name = gfc_get_string (name);
3182       entry->decls = htab_create_ggc (10, module_htab_decls_hash,
3183                                       module_htab_decls_eq, NULL);
3184       *slot = (void *) entry;
3185     }
3186   return (struct module_htab_entry *) *slot;
3187 }
3188
3189 void
3190 gfc_module_add_decl (struct module_htab_entry *entry, tree decl)
3191 {
3192   void **slot;
3193   const char *name;
3194
3195   if (DECL_NAME (decl))
3196     name = IDENTIFIER_POINTER (DECL_NAME (decl));
3197   else
3198     {
3199       gcc_assert (TREE_CODE (decl) == TYPE_DECL);
3200       name = IDENTIFIER_POINTER (TYPE_NAME (TREE_TYPE (decl)));
3201     }
3202   slot = htab_find_slot_with_hash (entry->decls, name,
3203                                    htab_hash_string (name), INSERT);
3204   if (*slot == NULL)
3205     *slot = (void *) decl;
3206 }
3207
3208 static struct module_htab_entry *cur_module;
3209
3210 /* Output an initialized decl for a module variable.  */
3211
3212 static void
3213 gfc_create_module_variable (gfc_symbol * sym)
3214 {
3215   tree decl;
3216
3217   /* Module functions with alternate entries are dealt with later and
3218      would get caught by the next condition.  */
3219   if (sym->attr.entry)
3220     return;
3221
3222   /* Make sure we convert the types of the derived types from iso_c_binding
3223      into (void *).  */
3224   if (sym->attr.flavor != FL_PROCEDURE && sym->attr.is_iso_c
3225       && sym->ts.type == BT_DERIVED)
3226     sym->backend_decl = gfc_typenode_for_spec (&(sym->ts));
3227
3228   if (sym->attr.flavor == FL_DERIVED
3229       && sym->backend_decl
3230       && TREE_CODE (sym->backend_decl) == RECORD_TYPE)
3231     {
3232       decl = sym->backend_decl;
3233       gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
3234       gcc_assert (TYPE_CONTEXT (decl) == NULL_TREE
3235                   || TYPE_CONTEXT (decl) == sym->ns->proc_name->backend_decl);
3236       gcc_assert (DECL_CONTEXT (TYPE_STUB_DECL (decl)) == NULL_TREE
3237                   || DECL_CONTEXT (TYPE_STUB_DECL (decl))
3238                      == sym->ns->proc_name->backend_decl);
3239       TYPE_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
3240       DECL_CONTEXT (TYPE_STUB_DECL (decl)) = sym->ns->proc_name->backend_decl;
3241       gfc_module_add_decl (cur_module, TYPE_STUB_DECL (decl));
3242     }
3243
3244   /* Only output variables, procedure pointers and array valued,
3245      or derived type, parameters.  */
3246   if (sym->attr.flavor != FL_VARIABLE
3247         && !(sym->attr.flavor == FL_PARAMETER
3248                && (sym->attr.dimension || sym->ts.type == BT_DERIVED))
3249         && !(sym->attr.flavor == FL_PROCEDURE && sym->attr.proc_pointer))
3250     return;
3251
3252   if ((sym->attr.in_common || sym->attr.in_equivalence) && sym->backend_decl)
3253     {
3254       decl = sym->backend_decl;
3255       gcc_assert (DECL_CONTEXT (decl) == NULL_TREE);
3256       gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
3257       DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
3258       gfc_module_add_decl (cur_module, decl);
3259     }
3260
3261   /* Don't generate variables from other modules. Variables from
3262      COMMONs will already have been generated.  */
3263   if (sym->attr.use_assoc || sym->attr.in_common)
3264     return;
3265
3266   /* Equivalenced variables arrive here after creation.  */
3267   if (sym->backend_decl
3268       && (sym->equiv_built || sym->attr.in_equivalence))
3269     return;
3270
3271   if (sym->backend_decl)
3272     internal_error ("backend decl for module variable %s already exists",
3273                     sym->name);
3274
3275   /* We always want module variables to be created.  */
3276   sym->attr.referenced = 1;
3277   /* Create the decl.  */
3278   decl = gfc_get_symbol_decl (sym);
3279
3280   /* Create the variable.  */
3281   pushdecl (decl);
3282   gcc_assert (DECL_CONTEXT (decl) == NULL_TREE);
3283   gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
3284   DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
3285   rest_of_decl_compilation (decl, 1, 0);
3286   gfc_module_add_decl (cur_module, decl);
3287
3288   /* Also add length of strings.  */
3289   if (sym->ts.type == BT_CHARACTER)
3290     {
3291       tree length;
3292
3293       length = sym->ts.cl->backend_decl;
3294       if (!INTEGER_CST_P (length))
3295         {
3296           pushdecl (length);
3297           rest_of_decl_compilation (length, 1, 0);
3298         }
3299     }
3300 }
3301
3302 /* Emit debug information for USE statements.  */
3303
3304 static void
3305 gfc_trans_use_stmts (gfc_namespace * ns)
3306 {
3307   gfc_use_list *use_stmt;
3308   for (use_stmt = ns->use_stmts; use_stmt; use_stmt = use_stmt->next)
3309     {
3310       struct module_htab_entry *entry
3311         = gfc_find_module (use_stmt->module_name);
3312       gfc_use_rename *rent;
3313
3314       if (entry->namespace_decl == NULL)
3315         {
3316           entry->namespace_decl
3317             = build_decl (NAMESPACE_DECL,
3318                           get_identifier (use_stmt->module_name),
3319                           void_type_node);
3320           DECL_EXTERNAL (entry->namespace_decl) = 1;
3321         }
3322       gfc_set_backend_locus (&use_stmt->where);
3323       if (!use_stmt->only_flag)
3324         (*debug_hooks->imported_module_or_decl) (entry->namespace_decl,
3325                                                  NULL_TREE,
3326                                                  ns->proc_name->backend_decl,
3327                                                  false);
3328       for (rent = use_stmt->rename; rent; rent = rent->next)
3329         {
3330           tree decl, local_name;
3331           void **slot;
3332
3333           if (rent->op != INTRINSIC_NONE)
3334             continue;
3335
3336           slot = htab_find_slot_with_hash (entry->decls, rent->use_name,
3337                                            htab_hash_string (rent->use_name),
3338                                            INSERT);
3339           if (*slot == NULL)
3340             {
3341               gfc_symtree *st;
3342
3343               st = gfc_find_symtree (ns->sym_root,
3344                                      rent->local_name[0]
3345                                      ? rent->local_name : rent->use_name);
3346               gcc_assert (st && st->n.sym->attr.use_assoc);
3347               if (st->n.sym->backend_decl
3348                   && DECL_P (st->n.sym->backend_decl)
3349                   && st->n.sym->module
3350                   && strcmp (st->n.sym->module, use_stmt->module_name) == 0)
3351                 {
3352                   gcc_assert (DECL_EXTERNAL (entry->namespace_decl)
3353                               || (TREE_CODE (st->n.sym->backend_decl)
3354                                   != VAR_DECL));
3355                   decl = copy_node (st->n.sym->backend_decl);
3356                   DECL_CONTEXT (decl) = entry->namespace_decl;
3357                   DECL_EXTERNAL (decl) = 1;
3358                   DECL_IGNORED_P (decl) = 0;
3359                   DECL_INITIAL (decl) = NULL_TREE;
3360                 }
3361               else
3362                 {
3363                   *slot = error_mark_node;
3364                   htab_clear_slot (entry->decls, slot);
3365                   continue;
3366                 }
3367               *slot = decl;
3368             }
3369           decl = (tree) *slot;
3370           if (rent->local_name[0])
3371             local_name = get_identifier (rent->local_name);
3372           else
3373             local_name = NULL_TREE;
3374           gfc_set_backend_locus (&rent->where);
3375           (*debug_hooks->imported_module_or_decl) (decl, local_name,
3376                                                    ns->proc_name->backend_decl,
3377                                                    !use_stmt->only_flag);
3378         }
3379     }
3380 }
3381
3382
3383 /* Return true if expr is a constant initializer that gfc_conv_initializer
3384    will handle.  */
3385
3386 static bool
3387 check_constant_initializer (gfc_expr *expr, gfc_typespec *ts, bool array,
3388                             bool pointer)
3389 {
3390   gfc_constructor *c;
3391   gfc_component *cm;
3392
3393   if (pointer)
3394     return true;
3395   else if (array)
3396     {
3397       if (expr->expr_type == EXPR_CONSTANT || expr->expr_type == EXPR_NULL)
3398         return true;
3399       else if (expr->expr_type == EXPR_STRUCTURE)
3400         return check_constant_initializer (expr, ts, false, false);
3401       else if (expr->expr_type != EXPR_ARRAY)
3402         return false;
3403       for (c = expr->value.constructor; c; c = c->next)
3404         {
3405           if (c->iterator)
3406             return false;
3407           if (c->expr->expr_type == EXPR_STRUCTURE)
3408             {
3409               if (!check_constant_initializer (c->expr, ts, false, false))
3410                 return false;
3411             }
3412           else if (c->expr->expr_type != EXPR_CONSTANT)
3413             return false;
3414         }
3415       return true;
3416     }
3417   else switch (ts->type)
3418     {
3419     case BT_DERIVED:
3420       if (expr->expr_type != EXPR_STRUCTURE)
3421         return false;
3422       cm = expr->ts.derived->components;
3423       for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
3424         {
3425           if (!c->expr || cm->attr.allocatable)
3426             continue;
3427           if (!check_constant_initializer (c->expr, &cm->ts,
3428                                            cm->attr.dimension,
3429                                            cm->attr.pointer))
3430             return false;
3431         }
3432       return true;
3433     default:
3434       return expr->expr_type == EXPR_CONSTANT;
3435     }
3436 }
3437
3438 /* Emit debug info for parameters and unreferenced variables with
3439    initializers.  */
3440
3441 static void
3442 gfc_emit_parameter_debug_info (gfc_symbol *sym)
3443 {
3444   tree decl;
3445
3446   if (sym->attr.flavor != FL_PARAMETER
3447       && (sym->attr.flavor != FL_VARIABLE || sym->attr.referenced))
3448     return;
3449
3450   if (sym->backend_decl != NULL
3451       || sym->value == NULL
3452       || sym->attr.use_assoc
3453       || sym->attr.dummy
3454       || sym->attr.result
3455       || sym->attr.function
3456       || sym->attr.intrinsic
3457       || sym->attr.pointer
3458       || sym->attr.allocatable
3459       || sym->attr.cray_pointee
3460       || sym->attr.threadprivate
3461       || sym->attr.is_bind_c
3462       || sym->attr.subref_array_pointer
3463       || sym->attr.assign)
3464     return;
3465
3466   if (sym->ts.type == BT_CHARACTER)
3467     {
3468       gfc_conv_const_charlen (sym->ts.cl);
3469       if (sym->ts.cl->backend_decl == NULL
3470           || TREE_CODE (sym->ts.cl->backend_decl) != INTEGER_CST)
3471         return;
3472     }
3473   else if (sym->ts.type == BT_DERIVED && sym->ts.derived->attr.alloc_comp)
3474     return;
3475
3476   if (sym->as)
3477     {
3478       int n;
3479
3480       if (sym->as->type != AS_EXPLICIT)
3481         return;
3482       for (n = 0; n < sym->as->rank; n++)
3483         if (sym->as->lower[n]->expr_type != EXPR_CONSTANT
3484             || sym->as->upper[n] == NULL
3485             || sym->as->upper[n]->expr_type != EXPR_CONSTANT)
3486           return;
3487     }
3488
3489   if (!check_constant_initializer (sym->value, &sym->ts,
3490                                    sym->attr.dimension, false))
3491     return;
3492
3493   /* Create the decl for the variable or constant.  */
3494   decl = build_decl (sym->attr.flavor == FL_PARAMETER ? CONST_DECL : VAR_DECL,
3495                      gfc_sym_identifier (sym), gfc_sym_type (sym));
3496   if (sym->attr.flavor == FL_PARAMETER)
3497     TREE_READONLY (decl) = 1;
3498   gfc_set_decl_location (decl, &sym->declared_at);
3499   if (sym->attr.dimension)
3500     GFC_DECL_PACKED_ARRAY (decl) = 1;
3501   DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
3502   TREE_STATIC (decl) = 1;
3503   TREE_USED (decl) = 1;
3504   if (DECL_CONTEXT (decl) && TREE_CODE (DECL_CONTEXT (decl)) == NAMESPACE_DECL)
3505     TREE_PUBLIC (decl) = 1;
3506   DECL_INITIAL (decl)
3507     = gfc_conv_initializer (sym->value, &sym->ts, TREE_TYPE (decl),
3508                             sym->attr.dimension, 0);
3509   debug_hooks->global_decl (decl);
3510 }
3511
3512 /* Generate all the required code for module variables.  */
3513
3514 void
3515 gfc_generate_module_vars (gfc_namespace * ns)
3516 {
3517   module_namespace = ns;
3518   cur_module = gfc_find_module (ns->proc_name->name);
3519
3520   /* Check if the frontend left the namespace in a reasonable state.  */
3521   gcc_assert (ns->proc_name && !ns->proc_name->tlink);
3522
3523   /* Generate COMMON blocks.  */
3524   gfc_trans_common (ns);
3525
3526   /* Create decls for all the module variables.  */
3527   gfc_traverse_ns (ns, gfc_create_module_variable);
3528
3529   cur_module = NULL;
3530
3531   gfc_trans_use_stmts (ns);
3532   gfc_traverse_ns (ns, gfc_emit_parameter_debug_info);
3533 }
3534
3535
3536 static void
3537 gfc_generate_contained_functions (gfc_namespace * parent)
3538 {
3539   gfc_namespace *ns;
3540
3541   /* We create all the prototypes before generating any code.  */
3542   for (ns = parent->contained; ns; ns = ns->sibling)
3543     {
3544       /* Skip namespaces from used modules.  */
3545       if (ns->parent != parent)
3546         continue;
3547
3548       gfc_create_function_decl (ns);
3549     }
3550
3551   for (ns = parent->contained; ns; ns = ns->sibling)
3552     {
3553       /* Skip namespaces from used modules.  */
3554       if (ns->parent != parent)
3555         continue;
3556
3557       gfc_generate_function_code (ns);
3558     }
3559 }
3560
3561
3562 /* Drill down through expressions for the array specification bounds and
3563    character length calling generate_local_decl for all those variables
3564    that have not already been declared.  */
3565
3566 static void
3567 generate_local_decl (gfc_symbol *);
3568
3569 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced.  */
3570
3571 static bool
3572 expr_decls (gfc_expr *e, gfc_symbol *sym,
3573             int *f ATTRIBUTE_UNUSED)
3574 {
3575   if (e->expr_type != EXPR_VARIABLE
3576             || sym == e->symtree->n.sym
3577             || e->symtree->n.sym->mark
3578             || e->symtree->n.sym->ns != sym->ns)
3579         return false;
3580
3581   generate_local_decl (e->symtree->n.sym);
3582   return false;
3583 }
3584
3585 static void
3586 generate_expr_decls (gfc_symbol *sym, gfc_expr *e)
3587 {
3588   gfc_traverse_expr (e, sym, expr_decls, 0);
3589 }
3590
3591
3592 /* Check for dependencies in the character length and array spec.  */
3593
3594 static void
3595 generate_dependency_declarations (gfc_symbol *sym)
3596 {
3597   int i;
3598
3599   if (sym->ts.type == BT_CHARACTER
3600       && sym->ts.cl
3601       && sym->ts.cl->length
3602       && sym->ts.cl->length->expr_type != EXPR_CONSTANT)
3603     generate_expr_decls (sym, sym->ts.cl->length);
3604
3605   if (sym->as && sym->as->rank)
3606     {
3607       for (i = 0; i < sym->as->rank; i++)
3608         {
3609           generate_expr_decls (sym, sym->as->lower[i]);
3610           generate_expr_decls (sym, sym->as->upper[i]);
3611         }
3612     }
3613 }
3614
3615
3616 /* Generate decls for all local variables.  We do this to ensure correct
3617    handling of expressions which only appear in the specification of
3618    other functions.  */
3619
3620 static void
3621 generate_local_decl (gfc_symbol * sym)
3622 {
3623   if (sym->attr.flavor == FL_VARIABLE)
3624     {
3625       if (!sym->attr.dummy && !sym->ns->proc_name->attr.entry_master)
3626         generate_dependency_declarations (sym);
3627
3628       if (sym->attr.referenced)
3629         gfc_get_symbol_decl (sym);
3630       /* INTENT(out) dummy arguments are likely meant to be set.  */
3631       else if (warn_unused_variable
3632                && sym->attr.dummy
3633                && sym->attr.intent == INTENT_OUT)
3634         gfc_warning ("Dummy argument '%s' at %L was declared INTENT(OUT) but was not set",
3635                      sym->name, &sym->declared_at);
3636       /* Specific warning for unused dummy arguments. */
3637       else if (warn_unused_variable && sym->attr.dummy)
3638         gfc_warning ("Unused dummy argument '%s' at %L", sym->name,
3639                      &sym->declared_at);
3640       /* Warn for unused variables, but not if they're inside a common
3641          block or are use-associated.  */
3642       else if (warn_unused_variable
3643                && !(sym->attr.in_common || sym->attr.use_assoc || sym->mark))
3644         gfc_warning ("Unused variable '%s' declared at %L", sym->name,
3645                      &sym->declared_at);
3646
3647       /* For variable length CHARACTER parameters, the PARM_DECL already
3648          references the length variable, so force gfc_get_symbol_decl
3649          even when not referenced.  If optimize > 0, it will be optimized
3650          away anyway.  But do this only after emitting -Wunused-parameter
3651          warning if requested.  */
3652       if (sym->attr.dummy && !sym->attr.referenced
3653             && sym->ts.type == BT_CHARACTER
3654             && sym->ts.cl->backend_decl != NULL
3655             && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
3656         {
3657           sym->attr.referenced = 1;
3658           gfc_get_symbol_decl (sym);
3659         }
3660
3661       /* INTENT(out) dummy arguments with allocatable components are reset
3662          by default and need to be set referenced to generate the code for
3663          automatic lengths.  */
3664       if (sym->attr.dummy && !sym->attr.referenced
3665             && sym->ts.type == BT_DERIVED
3666             && sym->ts.derived->attr.alloc_comp
3667             && sym->attr.intent == INTENT_OUT)
3668         {
3669           sym->attr.referenced = 1;
3670           gfc_get_symbol_decl (sym);
3671         }
3672
3673
3674       /* Check for dependencies in the array specification and string
3675         length, adding the necessary declarations to the function.  We
3676         mark the symbol now, as well as in traverse_ns, to prevent
3677         getting stuck in a circular dependency.  */
3678       sym->mark = 1;
3679
3680       /* We do not want the middle-end to warn about unused parameters
3681          as this was already done above.  */
3682       if (sym->attr.dummy && sym->backend_decl != NULL_TREE)
3683           TREE_NO_WARNING(sym->backend_decl) = 1;
3684     }
3685   else if (sym->attr.flavor == FL_PARAMETER)
3686     {
3687       if (warn_unused_parameter
3688            && !sym->attr.referenced
3689            && !sym->attr.use_assoc)
3690         gfc_warning ("Unused parameter '%s' declared at %L", sym->name,
3691                      &sym->declared_at);
3692     }
3693   else if (sym->attr.flavor == FL_PROCEDURE)
3694     {
3695       /* TODO: move to the appropriate place in resolve.c.  */
3696       if (warn_return_type
3697           && sym->attr.function
3698           && sym->result
3699           && sym != sym->result
3700           && !sym->result->attr.referenced
3701           && !sym->attr.use_assoc
3702           && sym->attr.if_source != IFSRC_IFBODY)
3703         {
3704           gfc_warning ("Return value '%s' of function '%s' declared at "
3705                        "%L not set", sym->result->name, sym->name,
3706                         &sym->result->declared_at);
3707
3708           /* Prevents "Unused variable" warning for RESULT variables.  */
3709           sym->result->mark = 1;
3710         }
3711     }
3712
3713   if (sym->attr.dummy == 1)
3714     {
3715       /* Modify the tree type for scalar character dummy arguments of bind(c)
3716          procedures if they are passed by value.  The tree type for them will
3717          be promoted to INTEGER_TYPE for the middle end, which appears to be
3718          what C would do with characters passed by-value.  The value attribute
3719          implies the dummy is a scalar.  */
3720       if (sym->attr.value == 1 && sym->backend_decl != NULL
3721           && sym->ts.type == BT_CHARACTER && sym->ts.is_c_interop
3722           && sym->ns->proc_name != NULL && sym->ns->proc_name->attr.is_bind_c)
3723         gfc_conv_scalar_char_value (sym, NULL, NULL);
3724     }
3725
3726   /* Make sure we convert the types of the derived types from iso_c_binding
3727      into (void *).  */
3728   if (sym->attr.flavor != FL_PROCEDURE && sym->attr.is_iso_c
3729       && sym->ts.type == BT_DERIVED)
3730     sym->backend_decl = gfc_typenode_for_spec (&(sym->ts));
3731 }
3732
3733 static void
3734 generate_local_vars (gfc_namespace * ns)
3735 {
3736   gfc_traverse_ns (ns, generate_local_decl);
3737 }
3738
3739
3740 /* Generate a switch statement to jump to the correct entry point.  Also
3741    creates the label decls for the entry points.  */
3742
3743 static tree
3744 gfc_trans_entry_master_switch (gfc_entry_list * el)
3745 {
3746   stmtblock_t block;
3747   tree label;
3748   tree tmp;
3749   tree val;
3750
3751   gfc_init_block (&block);
3752   for (; el; el = el->next)
3753     {
3754       /* Add the case label.  */
3755       label = gfc_build_label_decl (NULL_TREE);
3756       val = build_int_cst (gfc_array_index_type, el->id);
3757       tmp = build3_v (CASE_LABEL_EXPR, val, NULL_TREE, label);
3758       gfc_add_expr_to_block (&block, tmp);
3759
3760       /* And jump to the actual entry point.  */
3761       label = gfc_build_label_decl (NULL_TREE);
3762       tmp = build1_v (GOTO_EXPR, label);
3763       gfc_add_expr_to_block (&block, tmp);
3764
3765       /* Save the label decl.  */
3766       el->label = label;
3767     }
3768   tmp = gfc_finish_block (&block);
3769   /* The first argument selects the entry point.  */
3770   val = DECL_ARGUMENTS (current_function_decl);
3771   tmp = build3_v (SWITCH_EXPR, val, tmp, NULL_TREE);
3772   return tmp;
3773 }
3774
3775
3776 /* Add code to string lengths of actual arguments passed to a function against
3777    the expected lengths of the dummy arguments.  */
3778
3779 static void
3780 add_argument_checking (stmtblock_t *block, gfc_symbol *sym)
3781 {
3782   gfc_formal_arglist *formal;
3783
3784   for (formal = sym->formal; formal; formal = formal->next)
3785     if (formal->sym && formal->sym->ts.type == BT_CHARACTER)
3786       {
3787         enum tree_code comparison;
3788         tree cond;
3789         tree argname;
3790         gfc_symbol *fsym;
3791         gfc_charlen *cl;
3792         const char *message;
3793
3794         fsym = formal->sym;
3795         cl = fsym->ts.cl;
3796
3797         gcc_assert (cl);
3798         gcc_assert (cl->passed_length != NULL_TREE);
3799         gcc_assert (cl->backend_decl != NULL_TREE);
3800
3801         /* For POINTER, ALLOCATABLE and assumed-shape dummy arguments, the
3802            string lengths must match exactly.  Otherwise, it is only required
3803            that the actual string length is *at least* the expected one.  */
3804         if (fsym->attr.pointer || fsym->attr.allocatable
3805             || (fsym->as && fsym->as->type == AS_ASSUMED_SHAPE))
3806           {
3807             comparison = NE_EXPR;
3808             message = _("Actual string length does not match the declared one"
3809                         " for dummy argument '%s' (%ld/%ld)");
3810           }
3811         else
3812           {
3813             comparison = LT_EXPR;
3814             message = _("Actual string length is shorter than the declared one"
3815                         " for dummy argument '%s' (%ld/%ld)");
3816           }
3817
3818         /* Build the condition.  For optional arguments, an actual length
3819            of 0 is also acceptable if the associated string is NULL, which
3820            means the argument was not passed.  */
3821         cond = fold_build2 (comparison, boolean_type_node,
3822                             cl->passed_length, cl->backend_decl);
3823         if (fsym->attr.optional)
3824           {
3825             tree not_absent;
3826             tree not_0length;
3827             tree absent_failed;
3828
3829             not_0length = fold_build2 (NE_EXPR, boolean_type_node,
3830                                        cl->passed_length,
3831                                        fold_convert (gfc_charlen_type_node,
3832                                                      integer_zero_node));
3833             not_absent = fold_build2 (NE_EXPR, boolean_type_node,
3834                                       fsym->backend_decl, null_pointer_node);
3835
3836             absent_failed = fold_build2 (TRUTH_OR_EXPR, boolean_type_node,
3837                                          not_0length, not_absent);
3838
3839             cond = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3840                                 cond, absent_failed);
3841           }
3842
3843         /* Build the runtime check.  */
3844         argname = gfc_build_cstring_const (fsym->name);
3845         argname = gfc_build_addr_expr (pchar_type_node, argname);
3846         gfc_trans_runtime_check (true, false, cond, block, &fsym->declared_at,
3847                                  message, argname,
3848                                  fold_convert (long_integer_type_node,
3849                                                cl->passed_length),
3850                                  fold_convert (long_integer_type_node,
3851                                                cl->backend_decl));
3852       }
3853 }
3854
3855
3856 static void
3857 create_main_function (tree fndecl)
3858 {
3859   tree old_context;
3860   tree ftn_main;
3861   tree tmp, decl, result_decl, argc, argv, typelist, arglist;
3862   stmtblock_t body;
3863
3864   old_context = current_function_decl;
3865
3866   if (old_context)
3867     {
3868       push_function_context ();
3869       saved_parent_function_decls = saved_function_decls;
3870       saved_function_decls = NULL_TREE;
3871     }
3872
3873   /* main() function must be declared with global scope.  */
3874   gcc_assert (current_function_decl == NULL_TREE);
3875
3876   /* Declare the function.  */
3877   tmp =  build_function_type_list (integer_type_node, integer_type_node,
3878                                    build_pointer_type (pchar_type_node),
3879                                    NULL_TREE);
3880   main_identifier_node = get_identifier ("main");
3881   ftn_main = build_decl (FUNCTION_DECL, main_identifier_node, tmp);
3882   ftn_main = build_decl (FUNCTION_DECL, get_identifier ("main"), tmp);
3883   DECL_EXTERNAL (ftn_main) = 0;
3884   TREE_PUBLIC (ftn_main) = 1;
3885   TREE_STATIC (ftn_main) = 1;
3886   DECL_ATTRIBUTES (ftn_main)
3887       = tree_cons (get_identifier("externally_visible"), NULL_TREE, NULL_TREE);
3888
3889   /* Setup the result declaration (for "return 0").  */
3890   result_decl = build_decl (RESULT_DECL, NULL_TREE, integer_type_node);
3891   DECL_ARTIFICIAL (result_decl) = 1;
3892   DECL_IGNORED_P (result_decl) = 1;
3893   DECL_CONTEXT (result_decl) = ftn_main;
3894   DECL_RESULT (ftn_main) = result_decl;
3895
3896   pushdecl (ftn_main);
3897
3898   /* Get the arguments.  */
3899
3900   arglist = NULL_TREE;
3901   typelist = TYPE_ARG_TYPES (TREE_TYPE (ftn_main));
3902
3903   tmp = TREE_VALUE (typelist);
3904   argc = build_decl (PARM_DECL, get_identifier ("argc"), tmp);
3905   DECL_CONTEXT (argc) = ftn_main;
3906   DECL_ARG_TYPE (argc) = TREE_VALUE (typelist);
3907   TREE_READONLY (argc) = 1;
3908   gfc_finish_decl (argc);
3909   arglist = chainon (arglist, argc);
3910
3911   typelist = TREE_CHAIN (typelist);
3912   tmp = TREE_VALUE (typelist);
3913   argv = build_decl (PARM_DECL, get_identifier ("argv"), tmp);
3914   DECL_CONTEXT (argv) = ftn_main;
3915   DECL_ARG_TYPE (argv) = TREE_VALUE (typelist);
3916   TREE_READONLY (argv) = 1;
3917   DECL_BY_REFERENCE (argv) = 1;
3918   gfc_finish_decl (argv);
3919   arglist = chainon (arglist, argv);
3920
3921   DECL_ARGUMENTS (ftn_main) = arglist;
3922   current_function_decl = ftn_main;
3923   announce_function (ftn_main);
3924
3925   rest_of_decl_compilation (ftn_main, 1, 0);
3926   make_decl_rtl (ftn_main);
3927   init_function_start (ftn_main);
3928   pushlevel (0);
3929
3930   gfc_init_block (&body);
3931
3932   /* Call some libgfortran initialization routines, call then MAIN__(). */
3933
3934   /* Call _gfortran_set_args (argc, argv).  */
3935   TREE_USED (argc) = 1;
3936   TREE_USED (argv) = 1;
3937   tmp = build_call_expr (gfor_fndecl_set_args, 2, argc, argv);
3938   gfc_add_expr_to_block (&body, tmp);
3939
3940   /* Add a call to set_options to set up the runtime library Fortran
3941      language standard parameters.  */
3942   {
3943     tree array_type, array, var;
3944
3945     /* Passing a new option to the library requires four modifications:
3946      + add it to the tree_cons list below
3947           + change the array size in the call to build_array_type
3948           + change the first argument to the library call
3949             gfor_fndecl_set_options
3950           + modify the library (runtime/compile_options.c)!  */
3951
3952     array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,
3953                        gfc_option.warn_std), NULL_TREE);
3954     array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,
3955                        gfc_option.allow_std), array);
3956     array = tree_cons (NULL_TREE, build_int_cst (integer_type_node, pedantic),
3957                        array);
3958     array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,
3959                        gfc_option.flag_dump_core), array);
3960     array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,
3961                        gfc_option.flag_backtrace), array);
3962     array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,
3963                        gfc_option.flag_sign_zero), array);
3964
3965     array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,
3966                        (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)), array);
3967
3968     array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,
3969                        gfc_option.flag_range_check), array);
3970
3971     array_type = build_array_type (integer_type_node,
3972                        build_index_type (build_int_cst (NULL_TREE, 7)));
3973     array = build_constructor_from_list (array_type, nreverse (array));
3974     TREE_CONSTANT (array) = 1;
3975     TREE_STATIC (array) = 1;
3976
3977     /* Create a static variable to hold the jump table.  */
3978     var = gfc_create_var (array_type, "options");
3979     TREE_CONSTANT (var) = 1;
3980     TREE_STATIC (var) = 1;
3981     TREE_READONLY (var) = 1;
3982     DECL_INITIAL (var) = array;
3983     var = gfc_build_addr_expr (build_pointer_type (integer_type_node), var);
3984
3985     tmp = build_call_expr (gfor_fndecl_set_options, 2,
3986                            build_int_cst (integer_type_node, 8), var);
3987     gfc_add_expr_to_block (&body, tmp);
3988   }
3989
3990   /* If -ffpe-trap option was provided, add a call to set_fpe so that
3991      the library will raise a FPE when needed.  */
3992   if (gfc_option.fpe != 0)
3993     {
3994       tmp = build_call_expr (gfor_fndecl_set_fpe, 1,
3995                              build_int_cst (integer_type_node,
3996                                             gfc_option.fpe));
3997       gfc_add_expr_to_block (&body, tmp);
3998     }
3999
4000   /* If this is the main program and an -fconvert option was provided,
4001      add a call to set_convert.  */
4002
4003   if (gfc_option.convert != GFC_CONVERT_NATIVE)
4004     {
4005       tmp = build_call_expr (gfor_fndecl_set_convert, 1,
4006                              build_int_cst (integer_type_node,
4007                                             gfc_option.convert));
4008       gfc_add_expr_to_block (&body, tmp);
4009     }
4010
4011   /* If this is the main program and an -frecord-marker option was provided,
4012      add a call to set_record_marker.  */
4013
4014   if (gfc_option.record_marker != 0)
4015     {
4016       tmp = build_call_expr (gfor_fndecl_set_record_marker, 1,
4017                              build_int_cst (integer_type_node,
4018                                             gfc_option.record_marker));
4019       gfc_add_expr_to_block (&body, tmp);
4020     }
4021
4022   if (gfc_option.max_subrecord_length != 0)
4023     {
4024       tmp = build_call_expr (gfor_fndecl_set_max_subrecord_length, 1,
4025                              build_int_cst (integer_type_node,
4026                                             gfc_option.max_subrecord_length));
4027       gfc_add_expr_to_block (&body, tmp);
4028     }
4029
4030   /* Call MAIN__().  */
4031   tmp = build_call_expr (fndecl, 0);
4032   gfc_add_expr_to_block (&body, tmp);
4033
4034   /* Mark MAIN__ as used.  */
4035   TREE_USED (fndecl) = 1;
4036
4037   /* "return 0".  */
4038   tmp = fold_build2 (MODIFY_EXPR, integer_type_node, DECL_RESULT (ftn_main),
4039                      build_int_cst (integer_type_node, 0));
4040   tmp = build1_v (RETURN_EXPR, tmp);
4041   gfc_add_expr_to_block (&body, tmp);
4042
4043
4044   DECL_SAVED_TREE (ftn_main) = gfc_finish_block (&body);
4045   decl = getdecls ();
4046
4047   /* Finish off this function and send it for code generation.  */
4048   poplevel (1, 0, 1);
4049   BLOCK_SUPERCONTEXT (DECL_INITIAL (ftn_main)) = ftn_main;
4050
4051   DECL_SAVED_TREE (ftn_main)
4052     = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (ftn_main),
4053                 DECL_INITIAL (ftn_main));
4054
4055   /* Output the GENERIC tree.  */
4056   dump_function (TDI_original, ftn_main);
4057
4058   gfc_gimplify_function (ftn_main);
4059   cgraph_finalize_function (ftn_main, false);
4060
4061   if (old_context)
4062     {
4063       pop_function_context ();
4064       saved_function_decls = saved_parent_function_decls;
4065     }
4066   current_function_decl = old_context;
4067 }
4068
4069
4070 /* Generate code for a function.  */
4071
4072 void
4073 gfc_generate_function_code (gfc_namespace * ns)
4074 {
4075   tree fndecl;
4076   tree old_context;
4077   tree decl;
4078   tree tmp;
4079   tree tmp2;
4080   stmtblock_t block;
4081   stmtblock_t body;
4082   tree result;
4083   tree recurcheckvar = NULL;
4084   gfc_symbol *sym;
4085   int rank;
4086   bool is_recursive;
4087
4088   sym = ns->proc_name;
4089
4090   /* Check that the frontend isn't still using this.  */
4091   gcc_assert (sym->tlink == NULL);
4092   sym->tlink = sym;
4093
4094   /* Create the declaration for functions with global scope.  */
4095   if (!sym->backend_decl)
4096     gfc_create_function_decl (ns);
4097
4098   fndecl = sym->backend_decl;
4099   old_context = current_function_decl;
4100
4101   if (old_context)
4102     {
4103       push_function_context ();
4104       saved_parent_function_decls = saved_function_decls;
4105       saved_function_decls = NULL_TREE;
4106     }
4107
4108   trans_function_start (sym);
4109
4110   gfc_init_block (&block);
4111
4112   if (ns->entries && ns->proc_name->ts.type == BT_CHARACTER)
4113     {
4114       /* Copy length backend_decls to all entry point result
4115          symbols.  */
4116       gfc_entry_list *el;
4117       tree backend_decl;
4118
4119       gfc_conv_const_charlen (ns->proc_name->ts.cl);
4120       backend_decl = ns->proc_name->result->ts.cl->backend_decl;
4121       for (el = ns->entries; el; el = el->next)
4122         el->sym->result->ts.cl->backend_decl = backend_decl;
4123     }
4124
4125   /* Translate COMMON blocks.  */
4126   gfc_trans_common (ns);
4127
4128   /* Null the parent fake result declaration if this namespace is
4129      a module function or an external procedures.  */
4130   if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
4131         || ns->parent == NULL)
4132     parent_fake_result_decl = NULL_TREE;
4133
4134   gfc_generate_contained_functions (ns);
4135
4136   nonlocal_dummy_decls = NULL;
4137   nonlocal_dummy_decl_pset = NULL;
4138
4139   generate_local_vars (ns);
4140
4141   /* Keep the parent fake result declaration in module functions
4142      or external procedures.  */
4143   if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
4144         || ns->parent == NULL)
4145     current_fake_result_decl = parent_fake_result_decl;
4146   else
4147     current_fake_result_decl = NULL_TREE;
4148
4149   current_function_return_label = NULL;
4150
4151   /* Now generate the code for the body of this function.  */
4152   gfc_init_block (&body);
4153
4154    is_recursive = sym->attr.recursive
4155                   || (sym->attr.entry_master
4156                       && sym->ns->entries->sym->attr.recursive);
4157    if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION) && !is_recursive)
4158      {
4159        char * msg;
4160
4161        asprintf (&msg, "Recursive call to nonrecursive procedure '%s'",
4162                  sym->name);
4163        recurcheckvar = gfc_create_var (boolean_type_node, "is_recursive");
4164        TREE_STATIC (recurcheckvar) = 1;
4165        DECL_INITIAL (recurcheckvar) = boolean_false_node;
4166        gfc_add_expr_to_block (&block, recurcheckvar);
4167        gfc_trans_runtime_check (true, false, recurcheckvar, &block,
4168                                 &sym->declared_at, msg);
4169        gfc_add_modify (&block, recurcheckvar, boolean_true_node);
4170        gfc_free (msg);
4171     }
4172
4173   if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node
4174       && sym->attr.subroutine)
4175     {
4176       tree alternate_return;
4177       alternate_return = gfc_get_fake_result_decl (sym, 0);
4178       gfc_add_modify (&body, alternate_return, integer_zero_node);
4179     }
4180
4181   if (ns->entries)
4182     {
4183       /* Jump to the correct entry point.  */
4184       tmp = gfc_trans_entry_master_switch (ns->entries);
4185       gfc_add_expr_to_block (&body, tmp);
4186     }
4187
4188   /* If bounds-checking is enabled, generate code to check passed in actual
4189      arguments against the expected dummy argument attributes (e.g. string
4190      lengths).  */
4191   if (flag_bounds_check)
4192     add_argument_checking (&body, sym);
4193
4194   tmp = gfc_trans_code (ns->code);
4195   gfc_add_expr_to_block (&body, tmp);
4196
4197   /* Add a return label if needed.  */
4198   if (current_function_return_label)
4199     {
4200       tmp = build1_v (LABEL_EXPR, current_function_return_label);
4201       gfc_add_expr_to_block (&body, tmp);
4202     }
4203
4204   tmp = gfc_finish_block (&body);
4205   /* Add code to create and cleanup arrays.  */
4206   tmp = gfc_trans_deferred_vars (sym, tmp);
4207
4208   if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node)
4209     {
4210       if (sym->attr.subroutine || sym == sym->result)
4211         {
4212           if (current_fake_result_decl != NULL)
4213             result = TREE_VALUE (current_fake_result_decl);
4214           else
4215             result = NULL_TREE;
4216           current_fake_result_decl = NULL_TREE;
4217         }
4218       else
4219         result = sym->result->backend_decl;
4220
4221       if (result != NULL_TREE && sym->attr.function
4222             && sym->ts.type == BT_DERIVED
4223             && sym->ts.derived->attr.alloc_comp
4224             && !sym->attr.pointer)
4225         {
4226           rank = sym->as ? sym->as->rank : 0;
4227           tmp2 = gfc_nullify_alloc_comp (sym->ts.derived, result, rank);
4228           gfc_add_expr_to_block (&block, tmp2);
4229         }
4230
4231       gfc_add_expr_to_block (&block, tmp);
4232
4233       /* Reset recursion-check variable.  */
4234       if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION) && !is_recursive)
4235       {
4236         gfc_add_modify (&block, recurcheckvar, boolean_false_node);
4237         recurcheckvar = NULL;
4238       }
4239
4240       if (result == NULL_TREE)
4241         {
4242           /* TODO: move to the appropriate place in resolve.c.  */
4243           if (warn_return_type && !sym->attr.referenced && sym == sym->result)
4244             gfc_warning ("Return value of function '%s' at %L not set",
4245                          sym->name, &sym->declared_at);
4246
4247           TREE_NO_WARNING(sym->backend_decl) = 1;
4248         }
4249       else
4250         {
4251           /* Set the return value to the dummy result variable.  The
4252              types may be different for scalar default REAL functions
4253              with -ff2c, therefore we have to convert.  */
4254           tmp = convert (TREE_TYPE (DECL_RESULT (fndecl)), result);
4255           tmp = fold_build2 (MODIFY_EXPR, TREE_TYPE (tmp),
4256                              DECL_RESULT (fndecl), tmp);
4257           tmp = build1_v (RETURN_EXPR, tmp);
4258           gfc_add_expr_to_block (&block, tmp);
4259         }
4260     }
4261   else
4262     {
4263       gfc_add_expr_to_block (&block, tmp);
4264       /* Reset recursion-check variable.  */
4265       if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION) && !is_recursive)
4266       {
4267         gfc_add_modify (&block, recurcheckvar, boolean_false_node);
4268         recurcheckvar = NULL;
4269       }
4270     }
4271
4272
4273   /* Add all the decls we created during processing.  */
4274   decl = saved_function_decls;
4275   while (decl)
4276     {
4277       tree next;
4278
4279       next = TREE_CHAIN (decl);
4280       TREE_CHAIN (decl) = NULL_TREE;
4281       pushdecl (decl);
4282       decl = next;
4283     }
4284   saved_function_decls = NULL_TREE;
4285
4286   DECL_SAVED_TREE (fndecl) = gfc_finish_block (&block);
4287   decl = getdecls ();
4288
4289   /* Finish off this function and send it for code generation.  */
4290   poplevel (1, 0, 1);
4291   BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
4292
4293   DECL_SAVED_TREE (fndecl)
4294     = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (fndecl),
4295                 DECL_INITIAL (fndecl));
4296
4297   if (nonlocal_dummy_decls)
4298     {
4299       BLOCK_VARS (DECL_INITIAL (fndecl))
4300         = chainon (BLOCK_VARS (DECL_INITIAL (fndecl)), nonlocal_dummy_decls);
4301       pointer_set_destroy (nonlocal_dummy_decl_pset);
4302       nonlocal_dummy_decls = NULL;
4303       nonlocal_dummy_decl_pset = NULL;
4304     }
4305
4306   /* Output the GENERIC tree.  */
4307   dump_function (TDI_original, fndecl);
4308
4309   /* Store the end of the function, so that we get good line number
4310      info for the epilogue.  */
4311   cfun->function_end_locus = input_location;
4312
4313   /* We're leaving the context of this function, so zap cfun.
4314      It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
4315      tree_rest_of_compilation.  */
4316   set_cfun (NULL);
4317
4318   if (old_context)
4319     {
4320       pop_function_context ();
4321       saved_function_decls = saved_parent_function_decls;
4322     }
4323   current_function_decl = old_context;
4324
4325   if (decl_function_context (fndecl))
4326     /* Register this function with cgraph just far enough to get it
4327        added to our parent's nested function list.  */
4328     (void) cgraph_node (fndecl);
4329   else
4330     {
4331       gfc_gimplify_function (fndecl);
4332       cgraph_finalize_function (fndecl, false);
4333     }
4334
4335   gfc_trans_use_stmts (ns);
4336   gfc_traverse_ns (ns, gfc_emit_parameter_debug_info);
4337
4338   if (sym->attr.is_main_program)
4339     create_main_function (fndecl);
4340 }
4341
4342
4343 void
4344 gfc_generate_constructors (void)
4345 {
4346   gcc_assert (gfc_static_ctors == NULL_TREE);
4347 #if 0
4348   tree fnname;
4349   tree type;
4350   tree fndecl;
4351   tree decl;
4352   tree tmp;
4353
4354   if (gfc_static_ctors == NULL_TREE)
4355     return;
4356
4357   fnname = get_file_function_name ("I");
4358   type = build_function_type (void_type_node,
4359                               gfc_chainon_list (NULL_TREE, void_type_node));
4360
4361   fndecl = build_decl (FUNCTION_DECL, fnname, type);
4362   TREE_PUBLIC (fndecl) = 1;
4363
4364   decl = build_decl (RESULT_DECL, NULL_TREE, void_type_node);
4365   DECL_ARTIFICIAL (decl) = 1;
4366   DECL_IGNORED_P (decl) = 1;
4367   DECL_CONTEXT (decl) = fndecl;
4368   DECL_RESULT (fndecl) = decl;
4369
4370   pushdecl (fndecl);
4371
4372   current_function_decl = fndecl;
4373
4374   rest_of_decl_compilation (fndecl, 1, 0);
4375
4376   make_decl_rtl (fndecl);
4377
4378   init_function_start (fndecl);
4379
4380   pushlevel (0);
4381
4382   for (; gfc_static_ctors; gfc_static_ctors = TREE_CHAIN (gfc_static_ctors))
4383     {
4384       tmp = build_call_expr (TREE_VALUE (gfc_static_ctors), 0);
4385       DECL_SAVED_TREE (fndecl) = build_stmt (EXPR_STMT, tmp);
4386     }
4387
4388   decl = getdecls ();
4389   poplevel (1, 0, 1);
4390
4391   BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
4392   DECL_SAVED_TREE (fndecl)
4393     = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (fndecl),
4394                 DECL_INITIAL (fndecl));
4395
4396   free_after_parsing (cfun);
4397   free_after_compilation (cfun);
4398
4399   tree_rest_of_compilation (fndecl);
4400
4401   current_function_decl = NULL_TREE;
4402 #endif
4403 }
4404
4405 /* Translates a BLOCK DATA program unit. This means emitting the
4406    commons contained therein plus their initializations. We also emit
4407    a globally visible symbol to make sure that each BLOCK DATA program
4408    unit remains unique.  */
4409
4410 void
4411 gfc_generate_block_data (gfc_namespace * ns)
4412 {
4413   tree decl;
4414   tree id;
4415
4416   /* Tell the backend the source location of the block data.  */
4417   if (ns->proc_name)
4418     gfc_set_backend_locus (&ns->proc_name->declared_at);
4419   else
4420     gfc_set_backend_locus (&gfc_current_locus);
4421
4422   /* Process the DATA statements.  */
4423   gfc_trans_common (ns);
4424
4425   /* Create a global symbol with the mane of the block data.  This is to
4426      generate linker errors if the same name is used twice.  It is never
4427      really used.  */
4428   if (ns->proc_name)
4429     id = gfc_sym_mangled_function_id (ns->proc_name);
4430   else
4431     id = get_identifier ("__BLOCK_DATA__");
4432
4433   decl = build_decl (VAR_DECL, id, gfc_array_index_type);
4434   TREE_PUBLIC (decl) = 1;
4435   TREE_STATIC (decl) = 1;
4436   DECL_IGNORED_P (decl) = 1;
4437
4438   pushdecl (decl);
4439   rest_of_decl_compilation (decl, 1, 0);
4440 }
4441
4442
4443 #include "gt-fortran-trans-decl.h"