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