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           if (f->sym->ts.cl->passed_length != NULL)
1713             {
1714               /* This can happen if the same type is used for multiple
1715                  arguments. We need to copy cl as otherwise
1716                  cl->passed_length gets overwritten.  */
1717               gfc_charlen *cl, *cl2;
1718               cl = f->sym->ts.cl;
1719               f->sym->ts.cl = gfc_get_charlen();
1720               f->sym->ts.cl->length = cl->length;
1721               f->sym->ts.cl->backend_decl = cl->backend_decl;
1722               f->sym->ts.cl->length_from_typespec = cl->length_from_typespec;
1723               f->sym->ts.cl->resolved = cl->resolved;
1724               cl2 = f->sym->ts.cl->next;
1725               f->sym->ts.cl->next = cl;
1726               cl->next = cl2;
1727             }
1728           f->sym->ts.cl->passed_length = length;
1729
1730           /* Use the passed value for assumed length variables.  */
1731           if (!f->sym->ts.cl->length)
1732             {
1733               TREE_USED (length) = 1;
1734               gcc_assert (!f->sym->ts.cl->backend_decl);
1735               f->sym->ts.cl->backend_decl = length;
1736             }
1737
1738           hidden_typelist = TREE_CHAIN (hidden_typelist);
1739
1740           if (f->sym->ts.cl->backend_decl == NULL
1741               || f->sym->ts.cl->backend_decl == length)
1742             {
1743               if (f->sym->ts.cl->backend_decl == NULL)
1744                 gfc_create_string_length (f->sym);
1745
1746               /* Make sure PARM_DECL type doesn't point to incomplete type.  */
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
1754       /* For non-constant length array arguments, make sure they use
1755          a different type node from TYPE_ARG_TYPES type.  */
1756       if (f->sym->attr.dimension
1757           && type == TREE_VALUE (typelist)
1758           && TREE_CODE (type) == POINTER_TYPE
1759           && GFC_ARRAY_TYPE_P (type)
1760           && f->sym->as->type != AS_ASSUMED_SIZE
1761           && ! COMPLETE_TYPE_P (TREE_TYPE (type)))
1762         {
1763           if (f->sym->attr.flavor == FL_PROCEDURE)
1764             type = build_pointer_type (gfc_get_function_type (f->sym));
1765           else
1766             type = gfc_sym_type (f->sym);
1767         }
1768
1769       if (f->sym->attr.proc_pointer)
1770         type = build_pointer_type (type);
1771
1772       /* Build the argument declaration.  */
1773       parm = build_decl (input_location,
1774                          PARM_DECL, gfc_sym_identifier (f->sym), type);
1775
1776       /* Fill in arg stuff.  */
1777       DECL_CONTEXT (parm) = fndecl;
1778       DECL_ARG_TYPE (parm) = TREE_VALUE (typelist);
1779       /* All implementation args are read-only.  */
1780       TREE_READONLY (parm) = 1;
1781       if (POINTER_TYPE_P (type)
1782           && (!f->sym->attr.proc_pointer
1783               && f->sym->attr.flavor != FL_PROCEDURE))
1784         DECL_BY_REFERENCE (parm) = 1;
1785
1786       gfc_finish_decl (parm);
1787
1788       f->sym->backend_decl = parm;
1789
1790       arglist = chainon (arglist, parm);
1791       typelist = TREE_CHAIN (typelist);
1792     }
1793
1794   /* Add the hidden string length parameters, unless the procedure
1795      is bind(C).  */
1796   if (!sym->attr.is_bind_c)
1797     arglist = chainon (arglist, hidden_arglist);
1798
1799   gcc_assert (hidden_typelist == NULL_TREE
1800               || TREE_VALUE (hidden_typelist) == void_type_node);
1801   DECL_ARGUMENTS (fndecl) = arglist;
1802 }
1803
1804 /* Convert FNDECL's code to GIMPLE and handle any nested functions.  */
1805
1806 static void
1807 gfc_gimplify_function (tree fndecl)
1808 {
1809   struct cgraph_node *cgn;
1810
1811   gimplify_function_tree (fndecl);
1812   dump_function (TDI_generic, fndecl);
1813
1814   /* Generate errors for structured block violations.  */
1815   /* ??? Could be done as part of resolve_labels.  */
1816   if (flag_openmp)
1817     diagnose_omp_structured_block_errors (fndecl);
1818
1819   /* Convert all nested functions to GIMPLE now.  We do things in this order
1820      so that items like VLA sizes are expanded properly in the context of the
1821      correct function.  */
1822   cgn = cgraph_node (fndecl);
1823   for (cgn = cgn->nested; cgn; cgn = cgn->next_nested)
1824     gfc_gimplify_function (cgn->decl);
1825 }
1826
1827
1828 /* Do the setup necessary before generating the body of a function.  */
1829
1830 static void
1831 trans_function_start (gfc_symbol * sym)
1832 {
1833   tree fndecl;
1834
1835   fndecl = sym->backend_decl;
1836
1837   /* Let GCC know the current scope is this function.  */
1838   current_function_decl = fndecl;
1839
1840   /* Let the world know what we're about to do.  */
1841   announce_function (fndecl);
1842
1843   if (DECL_CONTEXT (fndecl) == NULL_TREE)
1844     {
1845       /* Create RTL for function declaration.  */
1846       rest_of_decl_compilation (fndecl, 1, 0);
1847     }
1848
1849   /* Create RTL for function definition.  */
1850   make_decl_rtl (fndecl);
1851
1852   init_function_start (fndecl);
1853
1854   /* Even though we're inside a function body, we still don't want to
1855      call expand_expr to calculate the size of a variable-sized array.
1856      We haven't necessarily assigned RTL to all variables yet, so it's
1857      not safe to try to expand expressions involving them.  */
1858   cfun->dont_save_pending_sizes_p = 1;
1859
1860   /* function.c requires a push at the start of the function.  */
1861   pushlevel (0);
1862 }
1863
1864 /* Create thunks for alternate entry points.  */
1865
1866 static void
1867 build_entry_thunks (gfc_namespace * ns)
1868 {
1869   gfc_formal_arglist *formal;
1870   gfc_formal_arglist *thunk_formal;
1871   gfc_entry_list *el;
1872   gfc_symbol *thunk_sym;
1873   stmtblock_t body;
1874   tree thunk_fndecl;
1875   tree args;
1876   tree string_args;
1877   tree tmp;
1878   locus old_loc;
1879
1880   /* This should always be a toplevel function.  */
1881   gcc_assert (current_function_decl == NULL_TREE);
1882
1883   gfc_get_backend_locus (&old_loc);
1884   for (el = ns->entries; el; el = el->next)
1885     {
1886       thunk_sym = el->sym;
1887
1888       build_function_decl (thunk_sym);
1889       create_function_arglist (thunk_sym);
1890
1891       trans_function_start (thunk_sym);
1892
1893       thunk_fndecl = thunk_sym->backend_decl;
1894
1895       gfc_init_block (&body);
1896
1897       /* Pass extra parameter identifying this entry point.  */
1898       tmp = build_int_cst (gfc_array_index_type, el->id);
1899       args = tree_cons (NULL_TREE, tmp, NULL_TREE);
1900       string_args = NULL_TREE;
1901
1902       if (thunk_sym->attr.function)
1903         {
1904           if (gfc_return_by_reference (ns->proc_name))
1905             {
1906               tree ref = DECL_ARGUMENTS (current_function_decl);
1907               args = tree_cons (NULL_TREE, ref, args);
1908               if (ns->proc_name->ts.type == BT_CHARACTER)
1909                 args = tree_cons (NULL_TREE, TREE_CHAIN (ref),
1910                                   args);
1911             }
1912         }
1913
1914       for (formal = ns->proc_name->formal; formal; formal = formal->next)
1915         {
1916           /* Ignore alternate returns.  */
1917           if (formal->sym == NULL)
1918             continue;
1919
1920           /* We don't have a clever way of identifying arguments, so resort to
1921              a brute-force search.  */
1922           for (thunk_formal = thunk_sym->formal;
1923                thunk_formal;
1924                thunk_formal = thunk_formal->next)
1925             {
1926               if (thunk_formal->sym == formal->sym)
1927                 break;
1928             }
1929
1930           if (thunk_formal)
1931             {
1932               /* Pass the argument.  */
1933               DECL_ARTIFICIAL (thunk_formal->sym->backend_decl) = 1;
1934               args = tree_cons (NULL_TREE, thunk_formal->sym->backend_decl,
1935                                 args);
1936               if (formal->sym->ts.type == BT_CHARACTER)
1937                 {
1938                   tmp = thunk_formal->sym->ts.cl->backend_decl;
1939                   string_args = tree_cons (NULL_TREE, tmp, string_args);
1940                 }
1941             }
1942           else
1943             {
1944               /* Pass NULL for a missing argument.  */
1945               args = tree_cons (NULL_TREE, null_pointer_node, args);
1946               if (formal->sym->ts.type == BT_CHARACTER)
1947                 {
1948                   tmp = build_int_cst (gfc_charlen_type_node, 0);
1949                   string_args = tree_cons (NULL_TREE, tmp, string_args);
1950                 }
1951             }
1952         }
1953
1954       /* Call the master function.  */
1955       args = nreverse (args);
1956       args = chainon (args, nreverse (string_args));
1957       tmp = ns->proc_name->backend_decl;
1958       tmp = build_function_call_expr (tmp, args);
1959       if (ns->proc_name->attr.mixed_entry_master)
1960         {
1961           tree union_decl, field;
1962           tree master_type = TREE_TYPE (ns->proc_name->backend_decl);
1963
1964           union_decl = build_decl (input_location,
1965                                    VAR_DECL, get_identifier ("__result"),
1966                                    TREE_TYPE (master_type));
1967           DECL_ARTIFICIAL (union_decl) = 1;
1968           DECL_EXTERNAL (union_decl) = 0;
1969           TREE_PUBLIC (union_decl) = 0;
1970           TREE_USED (union_decl) = 1;
1971           layout_decl (union_decl, 0);
1972           pushdecl (union_decl);
1973
1974           DECL_CONTEXT (union_decl) = current_function_decl;
1975           tmp = fold_build2 (MODIFY_EXPR, TREE_TYPE (union_decl),
1976                              union_decl, tmp);
1977           gfc_add_expr_to_block (&body, tmp);
1978
1979           for (field = TYPE_FIELDS (TREE_TYPE (union_decl));
1980                field; field = TREE_CHAIN (field))
1981             if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
1982                 thunk_sym->result->name) == 0)
1983               break;
1984           gcc_assert (field != NULL_TREE);
1985           tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
1986                              union_decl, field, NULL_TREE);
1987           tmp = fold_build2 (MODIFY_EXPR,
1988                              TREE_TYPE (DECL_RESULT (current_function_decl)),
1989                              DECL_RESULT (current_function_decl), tmp);
1990           tmp = build1_v (RETURN_EXPR, tmp);
1991         }
1992       else if (TREE_TYPE (DECL_RESULT (current_function_decl))
1993                != void_type_node)
1994         {
1995           tmp = fold_build2 (MODIFY_EXPR,
1996                              TREE_TYPE (DECL_RESULT (current_function_decl)),
1997                              DECL_RESULT (current_function_decl), tmp);
1998           tmp = build1_v (RETURN_EXPR, tmp);
1999         }
2000       gfc_add_expr_to_block (&body, tmp);
2001
2002       /* Finish off this function and send it for code generation.  */
2003       DECL_SAVED_TREE (thunk_fndecl) = gfc_finish_block (&body);
2004       tmp = getdecls ();
2005       poplevel (1, 0, 1);
2006       BLOCK_SUPERCONTEXT (DECL_INITIAL (thunk_fndecl)) = thunk_fndecl;
2007       DECL_SAVED_TREE (thunk_fndecl)
2008         = build3_v (BIND_EXPR, tmp, DECL_SAVED_TREE (thunk_fndecl),
2009                     DECL_INITIAL (thunk_fndecl));
2010
2011       /* Output the GENERIC tree.  */
2012       dump_function (TDI_original, thunk_fndecl);
2013
2014       /* Store the end of the function, so that we get good line number
2015          info for the epilogue.  */
2016       cfun->function_end_locus = input_location;
2017
2018       /* We're leaving the context of this function, so zap cfun.
2019          It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
2020          tree_rest_of_compilation.  */
2021       set_cfun (NULL);
2022
2023       current_function_decl = NULL_TREE;
2024
2025       gfc_gimplify_function (thunk_fndecl);
2026       cgraph_finalize_function (thunk_fndecl, false);
2027
2028       /* We share the symbols in the formal argument list with other entry
2029          points and the master function.  Clear them so that they are
2030          recreated for each function.  */
2031       for (formal = thunk_sym->formal; formal; formal = formal->next)
2032         if (formal->sym != NULL)  /* Ignore alternate returns.  */
2033           {
2034             formal->sym->backend_decl = NULL_TREE;
2035             if (formal->sym->ts.type == BT_CHARACTER)
2036               formal->sym->ts.cl->backend_decl = NULL_TREE;
2037           }
2038
2039       if (thunk_sym->attr.function)
2040         {
2041           if (thunk_sym->ts.type == BT_CHARACTER)
2042             thunk_sym->ts.cl->backend_decl = NULL_TREE;
2043           if (thunk_sym->result->ts.type == BT_CHARACTER)
2044             thunk_sym->result->ts.cl->backend_decl = NULL_TREE;
2045         }
2046     }
2047
2048   gfc_set_backend_locus (&old_loc);
2049 }
2050
2051
2052 /* Create a decl for a function, and create any thunks for alternate entry
2053    points.  */
2054
2055 void
2056 gfc_create_function_decl (gfc_namespace * ns)
2057 {
2058   /* Create a declaration for the master function.  */
2059   build_function_decl (ns->proc_name);
2060
2061   /* Compile the entry thunks.  */
2062   if (ns->entries)
2063     build_entry_thunks (ns);
2064
2065   /* Now create the read argument list.  */
2066   create_function_arglist (ns->proc_name);
2067 }
2068
2069 /* Return the decl used to hold the function return value.  If
2070    parent_flag is set, the context is the parent_scope.  */
2071
2072 tree
2073 gfc_get_fake_result_decl (gfc_symbol * sym, int parent_flag)
2074 {
2075   tree decl;
2076   tree length;
2077   tree this_fake_result_decl;
2078   tree this_function_decl;
2079
2080   char name[GFC_MAX_SYMBOL_LEN + 10];
2081
2082   if (parent_flag)
2083     {
2084       this_fake_result_decl = parent_fake_result_decl;
2085       this_function_decl = DECL_CONTEXT (current_function_decl);
2086     }
2087   else
2088     {
2089       this_fake_result_decl = current_fake_result_decl;
2090       this_function_decl = current_function_decl;
2091     }
2092
2093   if (sym
2094       && sym->ns->proc_name->backend_decl == this_function_decl
2095       && sym->ns->proc_name->attr.entry_master
2096       && sym != sym->ns->proc_name)
2097     {
2098       tree t = NULL, var;
2099       if (this_fake_result_decl != NULL)
2100         for (t = TREE_CHAIN (this_fake_result_decl); t; t = TREE_CHAIN (t))
2101           if (strcmp (IDENTIFIER_POINTER (TREE_PURPOSE (t)), sym->name) == 0)
2102             break;
2103       if (t)
2104         return TREE_VALUE (t);
2105       decl = gfc_get_fake_result_decl (sym->ns->proc_name, parent_flag);
2106
2107       if (parent_flag)
2108         this_fake_result_decl = parent_fake_result_decl;
2109       else
2110         this_fake_result_decl = current_fake_result_decl;
2111
2112       if (decl && sym->ns->proc_name->attr.mixed_entry_master)
2113         {
2114           tree field;
2115
2116           for (field = TYPE_FIELDS (TREE_TYPE (decl));
2117                field; field = TREE_CHAIN (field))
2118             if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
2119                 sym->name) == 0)
2120               break;
2121
2122           gcc_assert (field != NULL_TREE);
2123           decl = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
2124                               decl, field, NULL_TREE);
2125         }
2126
2127       var = create_tmp_var_raw (TREE_TYPE (decl), sym->name);
2128       if (parent_flag)
2129         gfc_add_decl_to_parent_function (var);
2130       else
2131         gfc_add_decl_to_function (var);
2132
2133       SET_DECL_VALUE_EXPR (var, decl);
2134       DECL_HAS_VALUE_EXPR_P (var) = 1;
2135       GFC_DECL_RESULT (var) = 1;
2136
2137       TREE_CHAIN (this_fake_result_decl)
2138           = tree_cons (get_identifier (sym->name), var,
2139                        TREE_CHAIN (this_fake_result_decl));
2140       return var;
2141     }
2142
2143   if (this_fake_result_decl != NULL_TREE)
2144     return TREE_VALUE (this_fake_result_decl);
2145
2146   /* Only when gfc_get_fake_result_decl is called by gfc_trans_return,
2147      sym is NULL.  */
2148   if (!sym)
2149     return NULL_TREE;
2150
2151   if (sym->ts.type == BT_CHARACTER)
2152     {
2153       if (sym->ts.cl->backend_decl == NULL_TREE)
2154         length = gfc_create_string_length (sym);
2155       else
2156         length = sym->ts.cl->backend_decl;
2157       if (TREE_CODE (length) == VAR_DECL
2158           && DECL_CONTEXT (length) == NULL_TREE)
2159         gfc_add_decl_to_function (length);
2160     }
2161
2162   if (gfc_return_by_reference (sym))
2163     {
2164       decl = DECL_ARGUMENTS (this_function_decl);
2165
2166       if (sym->ns->proc_name->backend_decl == this_function_decl
2167           && sym->ns->proc_name->attr.entry_master)
2168         decl = TREE_CHAIN (decl);
2169
2170       TREE_USED (decl) = 1;
2171       if (sym->as)
2172         decl = gfc_build_dummy_array_decl (sym, decl);
2173     }
2174   else
2175     {
2176       sprintf (name, "__result_%.20s",
2177                IDENTIFIER_POINTER (DECL_NAME (this_function_decl)));
2178
2179       if (!sym->attr.mixed_entry_master && sym->attr.function)
2180         decl = build_decl (input_location,
2181                            VAR_DECL, get_identifier (name),
2182                            gfc_sym_type (sym));
2183       else
2184         decl = build_decl (input_location,
2185                            VAR_DECL, get_identifier (name),
2186                            TREE_TYPE (TREE_TYPE (this_function_decl)));
2187       DECL_ARTIFICIAL (decl) = 1;
2188       DECL_EXTERNAL (decl) = 0;
2189       TREE_PUBLIC (decl) = 0;
2190       TREE_USED (decl) = 1;
2191       GFC_DECL_RESULT (decl) = 1;
2192       TREE_ADDRESSABLE (decl) = 1;
2193
2194       layout_decl (decl, 0);
2195
2196       if (parent_flag)
2197         gfc_add_decl_to_parent_function (decl);
2198       else
2199         gfc_add_decl_to_function (decl);
2200     }
2201
2202   if (parent_flag)
2203     parent_fake_result_decl = build_tree_list (NULL, decl);
2204   else
2205     current_fake_result_decl = build_tree_list (NULL, decl);
2206
2207   return decl;
2208 }
2209
2210
2211 /* Builds a function decl.  The remaining parameters are the types of the
2212    function arguments.  Negative nargs indicates a varargs function.  */
2213
2214 tree
2215 gfc_build_library_function_decl (tree name, tree rettype, int nargs, ...)
2216 {
2217   tree arglist;
2218   tree argtype;
2219   tree fntype;
2220   tree fndecl;
2221   va_list p;
2222   int n;
2223
2224   /* Library functions must be declared with global scope.  */
2225   gcc_assert (current_function_decl == NULL_TREE);
2226
2227   va_start (p, nargs);
2228
2229
2230   /* Create a list of the argument types.  */
2231   for (arglist = NULL_TREE, n = abs (nargs); n > 0; n--)
2232     {
2233       argtype = va_arg (p, tree);
2234       arglist = gfc_chainon_list (arglist, argtype);
2235     }
2236
2237   if (nargs >= 0)
2238     {
2239       /* Terminate the list.  */
2240       arglist = gfc_chainon_list (arglist, void_type_node);
2241     }
2242
2243   /* Build the function type and decl.  */
2244   fntype = build_function_type (rettype, arglist);
2245   fndecl = build_decl (input_location,
2246                        FUNCTION_DECL, name, fntype);
2247
2248   /* Mark this decl as external.  */
2249   DECL_EXTERNAL (fndecl) = 1;
2250   TREE_PUBLIC (fndecl) = 1;
2251
2252   va_end (p);
2253
2254   pushdecl (fndecl);
2255
2256   rest_of_decl_compilation (fndecl, 1, 0);
2257
2258   return fndecl;
2259 }
2260
2261 static void
2262 gfc_build_intrinsic_function_decls (void)
2263 {
2264   tree gfc_int4_type_node = gfc_get_int_type (4);
2265   tree gfc_int8_type_node = gfc_get_int_type (8);
2266   tree gfc_int16_type_node = gfc_get_int_type (16);
2267   tree gfc_logical4_type_node = gfc_get_logical_type (4);
2268   tree pchar1_type_node = gfc_get_pchar_type (1);
2269   tree pchar4_type_node = gfc_get_pchar_type (4);
2270
2271   /* String functions.  */
2272   gfor_fndecl_compare_string =
2273     gfc_build_library_function_decl (get_identifier (PREFIX("compare_string")),
2274                                      integer_type_node, 4,
2275                                      gfc_charlen_type_node, pchar1_type_node,
2276                                      gfc_charlen_type_node, pchar1_type_node);
2277
2278   gfor_fndecl_concat_string =
2279     gfc_build_library_function_decl (get_identifier (PREFIX("concat_string")),
2280                                      void_type_node, 6,
2281                                      gfc_charlen_type_node, pchar1_type_node,
2282                                      gfc_charlen_type_node, pchar1_type_node,
2283                                      gfc_charlen_type_node, pchar1_type_node);
2284
2285   gfor_fndecl_string_len_trim =
2286     gfc_build_library_function_decl (get_identifier (PREFIX("string_len_trim")),
2287                                      gfc_int4_type_node, 2,
2288                                      gfc_charlen_type_node, pchar1_type_node);
2289
2290   gfor_fndecl_string_index =
2291     gfc_build_library_function_decl (get_identifier (PREFIX("string_index")),
2292                                      gfc_int4_type_node, 5,
2293                                      gfc_charlen_type_node, pchar1_type_node,
2294                                      gfc_charlen_type_node, pchar1_type_node,
2295                                      gfc_logical4_type_node);
2296
2297   gfor_fndecl_string_scan =
2298     gfc_build_library_function_decl (get_identifier (PREFIX("string_scan")),
2299                                      gfc_int4_type_node, 5,
2300                                      gfc_charlen_type_node, pchar1_type_node,
2301                                      gfc_charlen_type_node, pchar1_type_node,
2302                                      gfc_logical4_type_node);
2303
2304   gfor_fndecl_string_verify =
2305     gfc_build_library_function_decl (get_identifier (PREFIX("string_verify")),
2306                                      gfc_int4_type_node, 5,
2307                                      gfc_charlen_type_node, pchar1_type_node,
2308                                      gfc_charlen_type_node, pchar1_type_node,
2309                                      gfc_logical4_type_node);
2310
2311   gfor_fndecl_string_trim =
2312     gfc_build_library_function_decl (get_identifier (PREFIX("string_trim")),
2313                                      void_type_node, 4,
2314                                      build_pointer_type (gfc_charlen_type_node),
2315                                      build_pointer_type (pchar1_type_node),
2316                                      gfc_charlen_type_node, pchar1_type_node);
2317
2318   gfor_fndecl_string_minmax =
2319     gfc_build_library_function_decl (get_identifier (PREFIX("string_minmax")),
2320                                      void_type_node, -4,
2321                                      build_pointer_type (gfc_charlen_type_node),
2322                                      build_pointer_type (pchar1_type_node),
2323                                      integer_type_node, integer_type_node);
2324
2325   gfor_fndecl_adjustl =
2326     gfc_build_library_function_decl (get_identifier (PREFIX("adjustl")),
2327                                      void_type_node, 3, pchar1_type_node,
2328                                      gfc_charlen_type_node, pchar1_type_node);
2329
2330   gfor_fndecl_adjustr =
2331     gfc_build_library_function_decl (get_identifier (PREFIX("adjustr")),
2332                                      void_type_node, 3, pchar1_type_node,
2333                                      gfc_charlen_type_node, pchar1_type_node);
2334
2335   gfor_fndecl_select_string =
2336     gfc_build_library_function_decl (get_identifier (PREFIX("select_string")),
2337                                      integer_type_node, 4, pvoid_type_node,
2338                                      integer_type_node, pchar1_type_node,
2339                                      gfc_charlen_type_node);
2340
2341   gfor_fndecl_compare_string_char4 =
2342     gfc_build_library_function_decl (get_identifier
2343                                         (PREFIX("compare_string_char4")),
2344                                      integer_type_node, 4,
2345                                      gfc_charlen_type_node, pchar4_type_node,
2346                                      gfc_charlen_type_node, pchar4_type_node);
2347
2348   gfor_fndecl_concat_string_char4 =
2349     gfc_build_library_function_decl (get_identifier
2350                                         (PREFIX("concat_string_char4")),
2351                                      void_type_node, 6,
2352                                      gfc_charlen_type_node, pchar4_type_node,
2353                                      gfc_charlen_type_node, pchar4_type_node,
2354                                      gfc_charlen_type_node, pchar4_type_node);
2355
2356   gfor_fndecl_string_len_trim_char4 =
2357     gfc_build_library_function_decl (get_identifier
2358                                         (PREFIX("string_len_trim_char4")),
2359                                      gfc_charlen_type_node, 2,
2360                                      gfc_charlen_type_node, pchar4_type_node);
2361
2362   gfor_fndecl_string_index_char4 =
2363     gfc_build_library_function_decl (get_identifier
2364                                         (PREFIX("string_index_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_scan_char4 =
2371     gfc_build_library_function_decl (get_identifier
2372                                         (PREFIX("string_scan_char4")),
2373                                      gfc_charlen_type_node, 5,
2374                                      gfc_charlen_type_node, pchar4_type_node,
2375                                      gfc_charlen_type_node, pchar4_type_node,
2376                                      gfc_logical4_type_node);
2377
2378   gfor_fndecl_string_verify_char4 =
2379     gfc_build_library_function_decl (get_identifier
2380                                         (PREFIX("string_verify_char4")),
2381                                      gfc_charlen_type_node, 5,
2382                                      gfc_charlen_type_node, pchar4_type_node,
2383                                      gfc_charlen_type_node, pchar4_type_node,
2384                                      gfc_logical4_type_node);
2385
2386   gfor_fndecl_string_trim_char4 =
2387     gfc_build_library_function_decl (get_identifier
2388                                         (PREFIX("string_trim_char4")),
2389                                      void_type_node, 4,
2390                                      build_pointer_type (gfc_charlen_type_node),
2391                                      build_pointer_type (pchar4_type_node),
2392                                      gfc_charlen_type_node, pchar4_type_node);
2393
2394   gfor_fndecl_string_minmax_char4 =
2395     gfc_build_library_function_decl (get_identifier
2396                                         (PREFIX("string_minmax_char4")),
2397                                      void_type_node, -4,
2398                                      build_pointer_type (gfc_charlen_type_node),
2399                                      build_pointer_type (pchar4_type_node),
2400                                      integer_type_node, integer_type_node);
2401
2402   gfor_fndecl_adjustl_char4 =
2403     gfc_build_library_function_decl (get_identifier (PREFIX("adjustl_char4")),
2404                                      void_type_node, 3, pchar4_type_node,
2405                                      gfc_charlen_type_node, pchar4_type_node);
2406
2407   gfor_fndecl_adjustr_char4 =
2408     gfc_build_library_function_decl (get_identifier (PREFIX("adjustr_char4")),
2409                                      void_type_node, 3, pchar4_type_node,
2410                                      gfc_charlen_type_node, pchar4_type_node);
2411
2412   gfor_fndecl_select_string_char4 =
2413     gfc_build_library_function_decl (get_identifier
2414                                         (PREFIX("select_string_char4")),
2415                                      integer_type_node, 4, pvoid_type_node,
2416                                      integer_type_node, pvoid_type_node,
2417                                      gfc_charlen_type_node);
2418
2419
2420   /* Conversion between character kinds.  */
2421
2422   gfor_fndecl_convert_char1_to_char4 =
2423     gfc_build_library_function_decl (get_identifier
2424                                         (PREFIX("convert_char1_to_char4")),
2425                                      void_type_node, 3,
2426                                      build_pointer_type (pchar4_type_node),
2427                                      gfc_charlen_type_node, pchar1_type_node);
2428
2429   gfor_fndecl_convert_char4_to_char1 =
2430     gfc_build_library_function_decl (get_identifier
2431                                         (PREFIX("convert_char4_to_char1")),
2432                                      void_type_node, 3,
2433                                      build_pointer_type (pchar1_type_node),
2434                                      gfc_charlen_type_node, pchar4_type_node);
2435
2436   /* Misc. functions.  */
2437
2438   gfor_fndecl_ttynam =
2439     gfc_build_library_function_decl (get_identifier (PREFIX("ttynam")),
2440                                      void_type_node,
2441                                      3,
2442                                      pchar_type_node,
2443                                      gfc_charlen_type_node,
2444                                      integer_type_node);
2445
2446   gfor_fndecl_fdate =
2447     gfc_build_library_function_decl (get_identifier (PREFIX("fdate")),
2448                                      void_type_node,
2449                                      2,
2450                                      pchar_type_node,
2451                                      gfc_charlen_type_node);
2452
2453   gfor_fndecl_ctime =
2454     gfc_build_library_function_decl (get_identifier (PREFIX("ctime")),
2455                                      void_type_node,
2456                                      3,
2457                                      pchar_type_node,
2458                                      gfc_charlen_type_node,
2459                                      gfc_int8_type_node);
2460
2461   gfor_fndecl_sc_kind =
2462     gfc_build_library_function_decl (get_identifier
2463                                         (PREFIX("selected_char_kind")),
2464                                      gfc_int4_type_node, 2,
2465                                      gfc_charlen_type_node, pchar_type_node);
2466
2467   gfor_fndecl_si_kind =
2468     gfc_build_library_function_decl (get_identifier
2469                                         (PREFIX("selected_int_kind")),
2470                                      gfc_int4_type_node, 1, pvoid_type_node);
2471
2472   gfor_fndecl_sr_kind =
2473     gfc_build_library_function_decl (get_identifier
2474                                         (PREFIX("selected_real_kind")),
2475                                      gfc_int4_type_node, 2,
2476                                      pvoid_type_node, pvoid_type_node);
2477
2478   /* Power functions.  */
2479   {
2480     tree ctype, rtype, itype, jtype;
2481     int rkind, ikind, jkind;
2482 #define NIKINDS 3
2483 #define NRKINDS 4
2484     static int ikinds[NIKINDS] = {4, 8, 16};
2485     static int rkinds[NRKINDS] = {4, 8, 10, 16};
2486     char name[PREFIX_LEN + 12]; /* _gfortran_pow_?n_?n */
2487
2488     for (ikind=0; ikind < NIKINDS; ikind++)
2489       {
2490         itype = gfc_get_int_type (ikinds[ikind]);
2491
2492         for (jkind=0; jkind < NIKINDS; jkind++)
2493           {
2494             jtype = gfc_get_int_type (ikinds[jkind]);
2495             if (itype && jtype)
2496               {
2497                 sprintf(name, PREFIX("pow_i%d_i%d"), ikinds[ikind],
2498                         ikinds[jkind]);
2499                 gfor_fndecl_math_powi[jkind][ikind].integer =
2500                   gfc_build_library_function_decl (get_identifier (name),
2501                     jtype, 2, jtype, itype);
2502                 TREE_READONLY (gfor_fndecl_math_powi[jkind][ikind].integer) = 1;
2503               }
2504           }
2505
2506         for (rkind = 0; rkind < NRKINDS; rkind ++)
2507           {
2508             rtype = gfc_get_real_type (rkinds[rkind]);
2509             if (rtype && itype)
2510               {
2511                 sprintf(name, PREFIX("pow_r%d_i%d"), rkinds[rkind],
2512                         ikinds[ikind]);
2513                 gfor_fndecl_math_powi[rkind][ikind].real =
2514                   gfc_build_library_function_decl (get_identifier (name),
2515                     rtype, 2, rtype, itype);
2516                 TREE_READONLY (gfor_fndecl_math_powi[rkind][ikind].real) = 1;
2517               }
2518
2519             ctype = gfc_get_complex_type (rkinds[rkind]);
2520             if (ctype && itype)
2521               {
2522                 sprintf(name, PREFIX("pow_c%d_i%d"), rkinds[rkind],
2523                         ikinds[ikind]);
2524                 gfor_fndecl_math_powi[rkind][ikind].cmplx =
2525                   gfc_build_library_function_decl (get_identifier (name),
2526                     ctype, 2,ctype, itype);
2527                 TREE_READONLY (gfor_fndecl_math_powi[rkind][ikind].cmplx) = 1;
2528               }
2529           }
2530       }
2531 #undef NIKINDS
2532 #undef NRKINDS
2533   }
2534
2535   gfor_fndecl_math_ishftc4 =
2536     gfc_build_library_function_decl (get_identifier (PREFIX("ishftc4")),
2537                                      gfc_int4_type_node,
2538                                      3, gfc_int4_type_node,
2539                                      gfc_int4_type_node, gfc_int4_type_node);
2540   gfor_fndecl_math_ishftc8 =
2541     gfc_build_library_function_decl (get_identifier (PREFIX("ishftc8")),
2542                                      gfc_int8_type_node,
2543                                      3, gfc_int8_type_node,
2544                                      gfc_int4_type_node, gfc_int4_type_node);
2545   if (gfc_int16_type_node)
2546     gfor_fndecl_math_ishftc16 =
2547       gfc_build_library_function_decl (get_identifier (PREFIX("ishftc16")),
2548                                        gfc_int16_type_node, 3,
2549                                        gfc_int16_type_node,
2550                                        gfc_int4_type_node,
2551                                        gfc_int4_type_node);
2552
2553   /* BLAS functions.  */
2554   {
2555     tree pint = build_pointer_type (integer_type_node);
2556     tree ps = build_pointer_type (gfc_get_real_type (gfc_default_real_kind));
2557     tree pd = build_pointer_type (gfc_get_real_type (gfc_default_double_kind));
2558     tree pc = build_pointer_type (gfc_get_complex_type (gfc_default_real_kind));
2559     tree pz = build_pointer_type
2560                 (gfc_get_complex_type (gfc_default_double_kind));
2561
2562     gfor_fndecl_sgemm = gfc_build_library_function_decl
2563                           (get_identifier
2564                              (gfc_option.flag_underscoring ? "sgemm_"
2565                                                            : "sgemm"),
2566                            void_type_node, 15, pchar_type_node,
2567                            pchar_type_node, pint, pint, pint, ps, ps, pint,
2568                            ps, pint, ps, ps, pint, integer_type_node,
2569                            integer_type_node);
2570     gfor_fndecl_dgemm = gfc_build_library_function_decl
2571                           (get_identifier
2572                              (gfc_option.flag_underscoring ? "dgemm_"
2573                                                            : "dgemm"),
2574                            void_type_node, 15, pchar_type_node,
2575                            pchar_type_node, pint, pint, pint, pd, pd, pint,
2576                            pd, pint, pd, pd, pint, integer_type_node,
2577                            integer_type_node);
2578     gfor_fndecl_cgemm = gfc_build_library_function_decl
2579                           (get_identifier
2580                              (gfc_option.flag_underscoring ? "cgemm_"
2581                                                            : "cgemm"),
2582                            void_type_node, 15, pchar_type_node,
2583                            pchar_type_node, pint, pint, pint, pc, pc, pint,
2584                            pc, pint, pc, pc, pint, integer_type_node,
2585                            integer_type_node);
2586     gfor_fndecl_zgemm = gfc_build_library_function_decl
2587                           (get_identifier
2588                              (gfc_option.flag_underscoring ? "zgemm_"
2589                                                            : "zgemm"),
2590                            void_type_node, 15, pchar_type_node,
2591                            pchar_type_node, pint, pint, pint, pz, pz, pint,
2592                            pz, pint, pz, pz, pint, integer_type_node,
2593                            integer_type_node);
2594   }
2595
2596   /* Other functions.  */
2597   gfor_fndecl_size0 =
2598     gfc_build_library_function_decl (get_identifier (PREFIX("size0")),
2599                                      gfc_array_index_type,
2600                                      1, pvoid_type_node);
2601   gfor_fndecl_size1 =
2602     gfc_build_library_function_decl (get_identifier (PREFIX("size1")),
2603                                      gfc_array_index_type,
2604                                      2, pvoid_type_node,
2605                                      gfc_array_index_type);
2606
2607   gfor_fndecl_iargc =
2608     gfc_build_library_function_decl (get_identifier (PREFIX ("iargc")),
2609                                      gfc_int4_type_node,
2610                                      0);
2611
2612   if (gfc_type_for_size (128, true))
2613     {
2614       tree uint128 = gfc_type_for_size (128, true);
2615
2616       gfor_fndecl_clz128 =
2617         gfc_build_library_function_decl (get_identifier (PREFIX ("clz128")),
2618                                          integer_type_node, 1, uint128);
2619
2620       gfor_fndecl_ctz128 =
2621         gfc_build_library_function_decl (get_identifier (PREFIX ("ctz128")),
2622                                          integer_type_node, 1, uint128);
2623     }
2624 }
2625
2626
2627 /* Make prototypes for runtime library functions.  */
2628
2629 void
2630 gfc_build_builtin_function_decls (void)
2631 {
2632   tree gfc_int4_type_node = gfc_get_int_type (4);
2633
2634   gfor_fndecl_stop_numeric =
2635     gfc_build_library_function_decl (get_identifier (PREFIX("stop_numeric")),
2636                                      void_type_node, 1, gfc_int4_type_node);
2637   /* Stop doesn't return.  */
2638   TREE_THIS_VOLATILE (gfor_fndecl_stop_numeric) = 1;
2639
2640   gfor_fndecl_stop_string =
2641     gfc_build_library_function_decl (get_identifier (PREFIX("stop_string")),
2642                                      void_type_node, 2, pchar_type_node,
2643                                      gfc_int4_type_node);
2644   /* Stop doesn't return.  */
2645   TREE_THIS_VOLATILE (gfor_fndecl_stop_string) = 1;
2646
2647   gfor_fndecl_pause_numeric =
2648     gfc_build_library_function_decl (get_identifier (PREFIX("pause_numeric")),
2649                                      void_type_node, 1, gfc_int4_type_node);
2650
2651   gfor_fndecl_pause_string =
2652     gfc_build_library_function_decl (get_identifier (PREFIX("pause_string")),
2653                                      void_type_node, 2, pchar_type_node,
2654                                      gfc_int4_type_node);
2655
2656   gfor_fndecl_runtime_error =
2657     gfc_build_library_function_decl (get_identifier (PREFIX("runtime_error")),
2658                                      void_type_node, -1, pchar_type_node);
2659   /* The runtime_error function does not return.  */
2660   TREE_THIS_VOLATILE (gfor_fndecl_runtime_error) = 1;
2661
2662   gfor_fndecl_runtime_error_at =
2663     gfc_build_library_function_decl (get_identifier (PREFIX("runtime_error_at")),
2664                                      void_type_node, -2, pchar_type_node,
2665                                      pchar_type_node);
2666   /* The runtime_error_at function does not return.  */
2667   TREE_THIS_VOLATILE (gfor_fndecl_runtime_error_at) = 1;
2668
2669   gfor_fndecl_runtime_warning_at =
2670     gfc_build_library_function_decl (get_identifier (PREFIX("runtime_warning_at")),
2671                                      void_type_node, -2, pchar_type_node,
2672                                      pchar_type_node);
2673   gfor_fndecl_generate_error =
2674     gfc_build_library_function_decl (get_identifier (PREFIX("generate_error")),
2675                                      void_type_node, 3, pvoid_type_node,
2676                                      integer_type_node, pchar_type_node);
2677
2678   gfor_fndecl_os_error =
2679     gfc_build_library_function_decl (get_identifier (PREFIX("os_error")),
2680                                      void_type_node, 1, pchar_type_node);
2681   /* The runtime_error function does not return.  */
2682   TREE_THIS_VOLATILE (gfor_fndecl_os_error) = 1;
2683
2684   gfor_fndecl_set_args =
2685     gfc_build_library_function_decl (get_identifier (PREFIX("set_args")),
2686                                      void_type_node, 2, integer_type_node,
2687                                      build_pointer_type (pchar_type_node));
2688
2689   gfor_fndecl_set_fpe =
2690     gfc_build_library_function_decl (get_identifier (PREFIX("set_fpe")),
2691                                     void_type_node, 1, integer_type_node);
2692
2693   /* Keep the array dimension in sync with the call, later in this file.  */
2694   gfor_fndecl_set_options =
2695     gfc_build_library_function_decl (get_identifier (PREFIX("set_options")),
2696                                     void_type_node, 2, integer_type_node,
2697                                     build_pointer_type (integer_type_node));
2698
2699   gfor_fndecl_set_convert =
2700     gfc_build_library_function_decl (get_identifier (PREFIX("set_convert")),
2701                                      void_type_node, 1, integer_type_node);
2702
2703   gfor_fndecl_set_record_marker =
2704     gfc_build_library_function_decl (get_identifier (PREFIX("set_record_marker")),
2705                                      void_type_node, 1, integer_type_node);
2706
2707   gfor_fndecl_set_max_subrecord_length =
2708     gfc_build_library_function_decl (get_identifier (PREFIX("set_max_subrecord_length")),
2709                                      void_type_node, 1, integer_type_node);
2710
2711   gfor_fndecl_in_pack = gfc_build_library_function_decl (
2712         get_identifier (PREFIX("internal_pack")),
2713         pvoid_type_node, 1, pvoid_type_node);
2714
2715   gfor_fndecl_in_unpack = gfc_build_library_function_decl (
2716         get_identifier (PREFIX("internal_unpack")),
2717         void_type_node, 2, pvoid_type_node, pvoid_type_node);
2718
2719   gfor_fndecl_associated =
2720     gfc_build_library_function_decl (
2721                                      get_identifier (PREFIX("associated")),
2722                                      integer_type_node, 2, ppvoid_type_node,
2723                                      ppvoid_type_node);
2724
2725   gfc_build_intrinsic_function_decls ();
2726   gfc_build_intrinsic_lib_fndecls ();
2727   gfc_build_io_library_fndecls ();
2728 }
2729
2730
2731 /* Evaluate the length of dummy character variables.  */
2732
2733 static tree
2734 gfc_trans_dummy_character (gfc_symbol *sym, gfc_charlen *cl, tree fnbody)
2735 {
2736   stmtblock_t body;
2737
2738   gfc_finish_decl (cl->backend_decl);
2739
2740   gfc_start_block (&body);
2741
2742   /* Evaluate the string length expression.  */
2743   gfc_conv_string_length (cl, NULL, &body);
2744
2745   gfc_trans_vla_type_sizes (sym, &body);
2746
2747   gfc_add_expr_to_block (&body, fnbody);
2748   return gfc_finish_block (&body);
2749 }
2750
2751
2752 /* Allocate and cleanup an automatic character variable.  */
2753
2754 static tree
2755 gfc_trans_auto_character_variable (gfc_symbol * sym, tree fnbody)
2756 {
2757   stmtblock_t body;
2758   tree decl;
2759   tree tmp;
2760
2761   gcc_assert (sym->backend_decl);
2762   gcc_assert (sym->ts.cl && sym->ts.cl->length);
2763
2764   gfc_start_block (&body);
2765
2766   /* Evaluate the string length expression.  */
2767   gfc_conv_string_length (sym->ts.cl, NULL, &body);
2768
2769   gfc_trans_vla_type_sizes (sym, &body);
2770
2771   decl = sym->backend_decl;
2772
2773   /* Emit a DECL_EXPR for this variable, which will cause the
2774      gimplifier to allocate storage, and all that good stuff.  */
2775   tmp = fold_build1 (DECL_EXPR, TREE_TYPE (decl), decl);
2776   gfc_add_expr_to_block (&body, tmp);
2777
2778   gfc_add_expr_to_block (&body, fnbody);
2779   return gfc_finish_block (&body);
2780 }
2781
2782 /* Set the initial value of ASSIGN statement auxiliary variable explicitly.  */
2783
2784 static tree
2785 gfc_trans_assign_aux_var (gfc_symbol * sym, tree fnbody)
2786 {
2787   stmtblock_t body;
2788
2789   gcc_assert (sym->backend_decl);
2790   gfc_start_block (&body);
2791
2792   /* Set the initial value to length. See the comments in
2793      function gfc_add_assign_aux_vars in this file.  */
2794   gfc_add_modify (&body, GFC_DECL_STRING_LEN (sym->backend_decl),
2795                        build_int_cst (NULL_TREE, -2));
2796
2797   gfc_add_expr_to_block (&body, fnbody);
2798   return gfc_finish_block (&body);
2799 }
2800
2801 static void
2802 gfc_trans_vla_one_sizepos (tree *tp, stmtblock_t *body)
2803 {
2804   tree t = *tp, var, val;
2805
2806   if (t == NULL || t == error_mark_node)
2807     return;
2808   if (TREE_CONSTANT (t) || DECL_P (t))
2809     return;
2810
2811   if (TREE_CODE (t) == SAVE_EXPR)
2812     {
2813       if (SAVE_EXPR_RESOLVED_P (t))
2814         {
2815           *tp = TREE_OPERAND (t, 0);
2816           return;
2817         }
2818       val = TREE_OPERAND (t, 0);
2819     }
2820   else
2821     val = t;
2822
2823   var = gfc_create_var_np (TREE_TYPE (t), NULL);
2824   gfc_add_decl_to_function (var);
2825   gfc_add_modify (body, var, val);
2826   if (TREE_CODE (t) == SAVE_EXPR)
2827     TREE_OPERAND (t, 0) = var;
2828   *tp = var;
2829 }
2830
2831 static void
2832 gfc_trans_vla_type_sizes_1 (tree type, stmtblock_t *body)
2833 {
2834   tree t;
2835
2836   if (type == NULL || type == error_mark_node)
2837     return;
2838
2839   type = TYPE_MAIN_VARIANT (type);
2840
2841   if (TREE_CODE (type) == INTEGER_TYPE)
2842     {
2843       gfc_trans_vla_one_sizepos (&TYPE_MIN_VALUE (type), body);
2844       gfc_trans_vla_one_sizepos (&TYPE_MAX_VALUE (type), body);
2845
2846       for (t = TYPE_NEXT_VARIANT (type); t; t = TYPE_NEXT_VARIANT (t))
2847         {
2848           TYPE_MIN_VALUE (t) = TYPE_MIN_VALUE (type);
2849           TYPE_MAX_VALUE (t) = TYPE_MAX_VALUE (type);
2850         }
2851     }
2852   else if (TREE_CODE (type) == ARRAY_TYPE)
2853     {
2854       gfc_trans_vla_type_sizes_1 (TREE_TYPE (type), body);
2855       gfc_trans_vla_type_sizes_1 (TYPE_DOMAIN (type), body);
2856       gfc_trans_vla_one_sizepos (&TYPE_SIZE (type), body);
2857       gfc_trans_vla_one_sizepos (&TYPE_SIZE_UNIT (type), body);
2858
2859       for (t = TYPE_NEXT_VARIANT (type); t; t = TYPE_NEXT_VARIANT (t))
2860         {
2861           TYPE_SIZE (t) = TYPE_SIZE (type);
2862           TYPE_SIZE_UNIT (t) = TYPE_SIZE_UNIT (type);
2863         }
2864     }
2865 }
2866
2867 /* Make sure all type sizes and array domains are either constant,
2868    or variable or parameter decls.  This is a simplified variant
2869    of gimplify_type_sizes, but we can't use it here, as none of the
2870    variables in the expressions have been gimplified yet.
2871    As type sizes and domains for various variable length arrays
2872    contain VAR_DECLs that are only initialized at gfc_trans_deferred_vars
2873    time, without this routine gimplify_type_sizes in the middle-end
2874    could result in the type sizes being gimplified earlier than where
2875    those variables are initialized.  */
2876
2877 void
2878 gfc_trans_vla_type_sizes (gfc_symbol *sym, stmtblock_t *body)
2879 {
2880   tree type = TREE_TYPE (sym->backend_decl);
2881
2882   if (TREE_CODE (type) == FUNCTION_TYPE
2883       && (sym->attr.function || sym->attr.result || sym->attr.entry))
2884     {
2885       if (! current_fake_result_decl)
2886         return;
2887
2888       type = TREE_TYPE (TREE_VALUE (current_fake_result_decl));
2889     }
2890
2891   while (POINTER_TYPE_P (type))
2892     type = TREE_TYPE (type);
2893
2894   if (GFC_DESCRIPTOR_TYPE_P (type))
2895     {
2896       tree etype = GFC_TYPE_ARRAY_DATAPTR_TYPE (type);
2897
2898       while (POINTER_TYPE_P (etype))
2899         etype = TREE_TYPE (etype);
2900
2901       gfc_trans_vla_type_sizes_1 (etype, body);
2902     }
2903
2904   gfc_trans_vla_type_sizes_1 (type, body);
2905 }
2906
2907
2908 /* Initialize a derived type by building an lvalue from the symbol
2909    and using trans_assignment to do the work.  */
2910 tree
2911 gfc_init_default_dt (gfc_symbol * sym, tree body)
2912 {
2913   stmtblock_t fnblock;
2914   gfc_expr *e;
2915   tree tmp;
2916   tree present;
2917
2918   gfc_init_block (&fnblock);
2919   gcc_assert (!sym->attr.allocatable);
2920   gfc_set_sym_referenced (sym);
2921   e = gfc_lval_expr_from_sym (sym);
2922   tmp = gfc_trans_assignment (e, sym->value, false);
2923   if (sym->attr.dummy)
2924     {
2925       present = gfc_conv_expr_present (sym);
2926       tmp = build3 (COND_EXPR, TREE_TYPE (tmp), present,
2927                     tmp, build_empty_stmt (input_location));
2928     }
2929   gfc_add_expr_to_block (&fnblock, tmp);
2930   gfc_free_expr (e);
2931   if (body)
2932     gfc_add_expr_to_block (&fnblock, body);
2933   return gfc_finish_block (&fnblock);
2934 }
2935
2936
2937 /* Initialize INTENT(OUT) derived type dummies.  As well as giving
2938    them their default initializer, if they do not have allocatable
2939    components, they have their allocatable components deallocated. */
2940
2941 static tree
2942 init_intent_out_dt (gfc_symbol * proc_sym, tree body)
2943 {
2944   stmtblock_t fnblock;
2945   gfc_formal_arglist *f;
2946   tree tmp;
2947   tree present;
2948
2949   gfc_init_block (&fnblock);
2950   for (f = proc_sym->formal; f; f = f->next)
2951     if (f->sym && f->sym->attr.intent == INTENT_OUT
2952           && f->sym->ts.type == BT_DERIVED)
2953       {
2954         if (f->sym->ts.derived->attr.alloc_comp)
2955           {
2956             tmp = gfc_deallocate_alloc_comp (f->sym->ts.derived,
2957                                              f->sym->backend_decl,
2958                                              f->sym->as ? f->sym->as->rank : 0);
2959
2960             present = gfc_conv_expr_present (f->sym);
2961             tmp = build3 (COND_EXPR, TREE_TYPE (tmp), present,
2962                           tmp, build_empty_stmt (input_location));
2963
2964             gfc_add_expr_to_block (&fnblock, tmp);
2965           }
2966
2967         if (!f->sym->ts.derived->attr.alloc_comp
2968               && f->sym->value)
2969           body = gfc_init_default_dt (f->sym, body);
2970       }
2971
2972   gfc_add_expr_to_block (&fnblock, body);
2973   return gfc_finish_block (&fnblock);
2974 }
2975
2976
2977 /* Generate function entry and exit code, and add it to the function body.
2978    This includes:
2979     Allocation and initialization of array variables.
2980     Allocation of character string variables.
2981     Initialization and possibly repacking of dummy arrays.
2982     Initialization of ASSIGN statement auxiliary variable.  */
2983
2984 static tree
2985 gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
2986 {
2987   locus loc;
2988   gfc_symbol *sym;
2989   gfc_formal_arglist *f;
2990   stmtblock_t body;
2991   bool seen_trans_deferred_array = false;
2992
2993   /* Deal with implicit return variables.  Explicit return variables will
2994      already have been added.  */
2995   if (gfc_return_by_reference (proc_sym) && proc_sym->result == proc_sym)
2996     {
2997       if (!current_fake_result_decl)
2998         {
2999           gfc_entry_list *el = NULL;
3000           if (proc_sym->attr.entry_master)
3001             {
3002               for (el = proc_sym->ns->entries; el; el = el->next)
3003                 if (el->sym != el->sym->result)
3004                   break;
3005             }
3006           /* TODO: move to the appropriate place in resolve.c.  */
3007           if (warn_return_type && el == NULL)
3008             gfc_warning ("Return value of function '%s' at %L not set",
3009                          proc_sym->name, &proc_sym->declared_at);
3010         }
3011       else if (proc_sym->as)
3012         {
3013           tree result = TREE_VALUE (current_fake_result_decl);
3014           fnbody = gfc_trans_dummy_array_bias (proc_sym, result, fnbody);
3015
3016           /* An automatic character length, pointer array result.  */
3017           if (proc_sym->ts.type == BT_CHARACTER
3018                 && TREE_CODE (proc_sym->ts.cl->backend_decl) == VAR_DECL)
3019             fnbody = gfc_trans_dummy_character (proc_sym, proc_sym->ts.cl,
3020                                                 fnbody);
3021         }
3022       else if (proc_sym->ts.type == BT_CHARACTER)
3023         {
3024           if (TREE_CODE (proc_sym->ts.cl->backend_decl) == VAR_DECL)
3025             fnbody = gfc_trans_dummy_character (proc_sym, proc_sym->ts.cl,
3026                                                 fnbody);
3027         }
3028       else
3029         gcc_assert (gfc_option.flag_f2c
3030                     && proc_sym->ts.type == BT_COMPLEX);
3031     }
3032
3033   /* Initialize the INTENT(OUT) derived type dummy arguments.  This
3034      should be done here so that the offsets and lbounds of arrays
3035      are available.  */
3036   fnbody = init_intent_out_dt (proc_sym, fnbody);
3037
3038   for (sym = proc_sym->tlink; sym != proc_sym; sym = sym->tlink)
3039     {
3040       bool sym_has_alloc_comp = (sym->ts.type == BT_DERIVED)
3041                                    && sym->ts.derived->attr.alloc_comp;
3042       if (sym->attr.dimension)
3043         {
3044           switch (sym->as->type)
3045             {
3046             case AS_EXPLICIT:
3047               if (sym->attr.dummy || sym->attr.result)
3048                 fnbody =
3049                   gfc_trans_dummy_array_bias (sym, sym->backend_decl, fnbody);
3050               else if (sym->attr.pointer || sym->attr.allocatable)
3051                 {
3052                   if (TREE_STATIC (sym->backend_decl))
3053                     gfc_trans_static_array_pointer (sym);
3054                   else
3055                     {
3056                       seen_trans_deferred_array = true;
3057                       fnbody = gfc_trans_deferred_array (sym, fnbody);
3058                     }
3059                 }
3060               else
3061                 {
3062                   if (sym_has_alloc_comp)
3063                     {
3064                       seen_trans_deferred_array = true;
3065                       fnbody = gfc_trans_deferred_array (sym, fnbody);
3066                     }
3067                   else if (sym->ts.type == BT_DERIVED
3068                              && sym->value
3069                              && !sym->attr.data
3070                              && sym->attr.save == SAVE_NONE)
3071                     fnbody = gfc_init_default_dt (sym, fnbody);
3072
3073                   gfc_get_backend_locus (&loc);
3074                   gfc_set_backend_locus (&sym->declared_at);
3075                   fnbody = gfc_trans_auto_array_allocation (sym->backend_decl,
3076                       sym, fnbody);
3077                   gfc_set_backend_locus (&loc);
3078                 }
3079               break;
3080
3081             case AS_ASSUMED_SIZE:
3082               /* Must be a dummy parameter.  */
3083               gcc_assert (sym->attr.dummy);
3084
3085               /* We should always pass assumed size arrays the g77 way.  */
3086               fnbody = gfc_trans_g77_array (sym, fnbody);
3087               break;
3088
3089             case AS_ASSUMED_SHAPE:
3090               /* Must be a dummy parameter.  */
3091               gcc_assert (sym->attr.dummy);
3092
3093               fnbody = gfc_trans_dummy_array_bias (sym, sym->backend_decl,
3094                                                    fnbody);
3095               break;
3096
3097             case AS_DEFERRED:
3098               seen_trans_deferred_array = true;
3099               fnbody = gfc_trans_deferred_array (sym, fnbody);
3100               break;
3101
3102             default:
3103               gcc_unreachable ();
3104             }
3105           if (sym_has_alloc_comp && !seen_trans_deferred_array)
3106             fnbody = gfc_trans_deferred_array (sym, fnbody);
3107         }
3108       else if (sym_has_alloc_comp)
3109         fnbody = gfc_trans_deferred_array (sym, fnbody);
3110       else if (sym->ts.type == BT_CHARACTER)
3111         {
3112           gfc_get_backend_locus (&loc);
3113           gfc_set_backend_locus (&sym->declared_at);
3114           if (sym->attr.dummy || sym->attr.result)
3115             fnbody = gfc_trans_dummy_character (sym, sym->ts.cl, fnbody);
3116           else
3117             fnbody = gfc_trans_auto_character_variable (sym, fnbody);
3118           gfc_set_backend_locus (&loc);
3119         }
3120       else if (sym->attr.assign)
3121         {
3122           gfc_get_backend_locus (&loc);
3123           gfc_set_backend_locus (&sym->declared_at);
3124           fnbody = gfc_trans_assign_aux_var (sym, fnbody);
3125           gfc_set_backend_locus (&loc);
3126         }
3127       else if (sym->ts.type == BT_DERIVED
3128                  && sym->value
3129                  && !sym->attr.data
3130                  && sym->attr.save == SAVE_NONE)
3131         fnbody = gfc_init_default_dt (sym, fnbody);
3132       else
3133         gcc_unreachable ();
3134     }
3135
3136   gfc_init_block (&body);
3137
3138   for (f = proc_sym->formal; f; f = f->next)
3139     {
3140       if (f->sym && f->sym->tlink == NULL && f->sym->ts.type == BT_CHARACTER)
3141         {
3142           gcc_assert (f->sym->ts.cl->backend_decl != NULL);
3143           if (TREE_CODE (f->sym->ts.cl->backend_decl) == PARM_DECL)
3144             gfc_trans_vla_type_sizes (f->sym, &body);
3145         }
3146     }
3147
3148   if (gfc_return_by_reference (proc_sym) && proc_sym->ts.type == BT_CHARACTER
3149       && current_fake_result_decl != NULL)
3150     {
3151       gcc_assert (proc_sym->ts.cl->backend_decl != NULL);
3152       if (TREE_CODE (proc_sym->ts.cl->backend_decl) == PARM_DECL)
3153         gfc_trans_vla_type_sizes (proc_sym, &body);
3154     }
3155
3156   gfc_add_expr_to_block (&body, fnbody);
3157   return gfc_finish_block (&body);
3158 }
3159
3160 static GTY ((param_is (struct module_htab_entry))) htab_t module_htab;
3161
3162 /* Hash and equality functions for module_htab.  */
3163
3164 static hashval_t
3165 module_htab_do_hash (const void *x)
3166 {
3167   return htab_hash_string (((const struct module_htab_entry *)x)->name);
3168 }
3169
3170 static int
3171 module_htab_eq (const void *x1, const void *x2)
3172 {
3173   return strcmp ((((const struct module_htab_entry *)x1)->name),
3174                  (const char *)x2) == 0;
3175 }
3176
3177 /* Hash and equality functions for module_htab's decls.  */
3178
3179 static hashval_t
3180 module_htab_decls_hash (const void *x)
3181 {
3182   const_tree t = (const_tree) x;
3183   const_tree n = DECL_NAME (t);
3184   if (n == NULL_TREE)
3185     n = TYPE_NAME (TREE_TYPE (t));
3186   return htab_hash_string (IDENTIFIER_POINTER (n));
3187 }
3188
3189 static int
3190 module_htab_decls_eq (const void *x1, const void *x2)
3191 {
3192   const_tree t1 = (const_tree) x1;
3193   const_tree n1 = DECL_NAME (t1);
3194   if (n1 == NULL_TREE)
3195     n1 = TYPE_NAME (TREE_TYPE (t1));
3196   return strcmp (IDENTIFIER_POINTER (n1), (const char *) x2) == 0;
3197 }
3198
3199 struct module_htab_entry *
3200 gfc_find_module (const char *name)
3201 {
3202   void **slot;
3203
3204   if (! module_htab)
3205     module_htab = htab_create_ggc (10, module_htab_do_hash,
3206                                    module_htab_eq, NULL);
3207
3208   slot = htab_find_slot_with_hash (module_htab, name,
3209                                    htab_hash_string (name), INSERT);
3210   if (*slot == NULL)
3211     {
3212       struct module_htab_entry *entry = GGC_CNEW (struct module_htab_entry);
3213
3214       entry->name = gfc_get_string (name);
3215       entry->decls = htab_create_ggc (10, module_htab_decls_hash,
3216                                       module_htab_decls_eq, NULL);
3217       *slot = (void *) entry;
3218     }
3219   return (struct module_htab_entry *) *slot;
3220 }
3221
3222 void
3223 gfc_module_add_decl (struct module_htab_entry *entry, tree decl)
3224 {
3225   void **slot;
3226   const char *name;
3227
3228   if (DECL_NAME (decl))
3229     name = IDENTIFIER_POINTER (DECL_NAME (decl));
3230   else
3231     {
3232       gcc_assert (TREE_CODE (decl) == TYPE_DECL);
3233       name = IDENTIFIER_POINTER (TYPE_NAME (TREE_TYPE (decl)));
3234     }
3235   slot = htab_find_slot_with_hash (entry->decls, name,
3236                                    htab_hash_string (name), INSERT);
3237   if (*slot == NULL)
3238     *slot = (void *) decl;
3239 }
3240
3241 static struct module_htab_entry *cur_module;
3242
3243 /* Output an initialized decl for a module variable.  */
3244
3245 static void
3246 gfc_create_module_variable (gfc_symbol * sym)
3247 {
3248   tree decl;
3249
3250   /* Module functions with alternate entries are dealt with later and
3251      would get caught by the next condition.  */
3252   if (sym->attr.entry)
3253     return;
3254
3255   /* Make sure we convert the types of the derived types from iso_c_binding
3256      into (void *).  */
3257   if (sym->attr.flavor != FL_PROCEDURE && sym->attr.is_iso_c
3258       && sym->ts.type == BT_DERIVED)
3259     sym->backend_decl = gfc_typenode_for_spec (&(sym->ts));
3260
3261   if (sym->attr.flavor == FL_DERIVED
3262       && sym->backend_decl
3263       && TREE_CODE (sym->backend_decl) == RECORD_TYPE)
3264     {
3265       decl = sym->backend_decl;
3266       gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
3267       gcc_assert (TYPE_CONTEXT (decl) == NULL_TREE
3268                   || TYPE_CONTEXT (decl) == sym->ns->proc_name->backend_decl);
3269       gcc_assert (DECL_CONTEXT (TYPE_STUB_DECL (decl)) == NULL_TREE
3270                   || DECL_CONTEXT (TYPE_STUB_DECL (decl))
3271                      == sym->ns->proc_name->backend_decl);
3272       TYPE_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
3273       DECL_CONTEXT (TYPE_STUB_DECL (decl)) = sym->ns->proc_name->backend_decl;
3274       gfc_module_add_decl (cur_module, TYPE_STUB_DECL (decl));
3275     }
3276
3277   /* Only output variables, procedure pointers and array valued,
3278      or derived type, parameters.  */
3279   if (sym->attr.flavor != FL_VARIABLE
3280         && !(sym->attr.flavor == FL_PARAMETER
3281                && (sym->attr.dimension || sym->ts.type == BT_DERIVED))
3282         && !(sym->attr.flavor == FL_PROCEDURE && sym->attr.proc_pointer))
3283     return;
3284
3285   if ((sym->attr.in_common || sym->attr.in_equivalence) && sym->backend_decl)
3286     {
3287       decl = sym->backend_decl;
3288       gcc_assert (DECL_CONTEXT (decl) == NULL_TREE);
3289       gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
3290       DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
3291       gfc_module_add_decl (cur_module, decl);
3292     }
3293
3294   /* Don't generate variables from other modules. Variables from
3295      COMMONs will already have been generated.  */
3296   if (sym->attr.use_assoc || sym->attr.in_common)
3297     return;
3298
3299   /* Equivalenced variables arrive here after creation.  */
3300   if (sym->backend_decl
3301       && (sym->equiv_built || sym->attr.in_equivalence))
3302     return;
3303
3304   if (sym->backend_decl)
3305     internal_error ("backend decl for module variable %s already exists",
3306                     sym->name);
3307
3308   /* We always want module variables to be created.  */
3309   sym->attr.referenced = 1;
3310   /* Create the decl.  */
3311   decl = gfc_get_symbol_decl (sym);
3312
3313   /* Create the variable.  */
3314   pushdecl (decl);
3315   gcc_assert (DECL_CONTEXT (decl) == NULL_TREE);
3316   gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
3317   DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
3318   rest_of_decl_compilation (decl, 1, 0);
3319   gfc_module_add_decl (cur_module, decl);
3320
3321   /* Also add length of strings.  */
3322   if (sym->ts.type == BT_CHARACTER)
3323     {
3324       tree length;
3325
3326       length = sym->ts.cl->backend_decl;
3327       if (!INTEGER_CST_P (length))
3328         {
3329           pushdecl (length);
3330           rest_of_decl_compilation (length, 1, 0);
3331         }
3332     }
3333 }
3334
3335 /* Emit debug information for USE statements.  */
3336
3337 static void
3338 gfc_trans_use_stmts (gfc_namespace * ns)
3339 {
3340   gfc_use_list *use_stmt;
3341   for (use_stmt = ns->use_stmts; use_stmt; use_stmt = use_stmt->next)
3342     {
3343       struct module_htab_entry *entry
3344         = gfc_find_module (use_stmt->module_name);
3345       gfc_use_rename *rent;
3346
3347       if (entry->namespace_decl == NULL)
3348         {
3349           entry->namespace_decl
3350             = build_decl (input_location,
3351                           NAMESPACE_DECL,
3352                           get_identifier (use_stmt->module_name),
3353                           void_type_node);
3354           DECL_EXTERNAL (entry->namespace_decl) = 1;
3355         }
3356       gfc_set_backend_locus (&use_stmt->where);
3357       if (!use_stmt->only_flag)
3358         (*debug_hooks->imported_module_or_decl) (entry->namespace_decl,
3359                                                  NULL_TREE,
3360                                                  ns->proc_name->backend_decl,
3361                                                  false);
3362       for (rent = use_stmt->rename; rent; rent = rent->next)
3363         {
3364           tree decl, local_name;
3365           void **slot;
3366
3367           if (rent->op != INTRINSIC_NONE)
3368             continue;
3369
3370           slot = htab_find_slot_with_hash (entry->decls, rent->use_name,
3371                                            htab_hash_string (rent->use_name),
3372                                            INSERT);
3373           if (*slot == NULL)
3374             {
3375               gfc_symtree *st;
3376
3377               st = gfc_find_symtree (ns->sym_root,
3378                                      rent->local_name[0]
3379                                      ? rent->local_name : rent->use_name);
3380               gcc_assert (st && st->n.sym->attr.use_assoc);
3381               if (st->n.sym->backend_decl
3382                   && DECL_P (st->n.sym->backend_decl)
3383                   && st->n.sym->module
3384                   && strcmp (st->n.sym->module, use_stmt->module_name) == 0)
3385                 {
3386                   gcc_assert (DECL_EXTERNAL (entry->namespace_decl)
3387                               || (TREE_CODE (st->n.sym->backend_decl)
3388                                   != VAR_DECL));
3389                   decl = copy_node (st->n.sym->backend_decl);
3390                   DECL_CONTEXT (decl) = entry->namespace_decl;
3391                   DECL_EXTERNAL (decl) = 1;
3392                   DECL_IGNORED_P (decl) = 0;
3393                   DECL_INITIAL (decl) = NULL_TREE;
3394                 }
3395               else
3396                 {
3397                   *slot = error_mark_node;
3398                   htab_clear_slot (entry->decls, slot);
3399                   continue;
3400                 }
3401               *slot = decl;
3402             }
3403           decl = (tree) *slot;
3404           if (rent->local_name[0])
3405             local_name = get_identifier (rent->local_name);
3406           else
3407             local_name = NULL_TREE;
3408           gfc_set_backend_locus (&rent->where);
3409           (*debug_hooks->imported_module_or_decl) (decl, local_name,
3410                                                    ns->proc_name->backend_decl,
3411                                                    !use_stmt->only_flag);
3412         }
3413     }
3414 }
3415
3416
3417 /* Return true if expr is a constant initializer that gfc_conv_initializer
3418    will handle.  */
3419
3420 static bool
3421 check_constant_initializer (gfc_expr *expr, gfc_typespec *ts, bool array,
3422                             bool pointer)
3423 {
3424   gfc_constructor *c;
3425   gfc_component *cm;
3426
3427   if (pointer)
3428     return true;
3429   else if (array)
3430     {
3431       if (expr->expr_type == EXPR_CONSTANT || expr->expr_type == EXPR_NULL)
3432         return true;
3433       else if (expr->expr_type == EXPR_STRUCTURE)
3434         return check_constant_initializer (expr, ts, false, false);
3435       else if (expr->expr_type != EXPR_ARRAY)
3436         return false;
3437       for (c = expr->value.constructor; c; c = c->next)
3438         {
3439           if (c->iterator)
3440             return false;
3441           if (c->expr->expr_type == EXPR_STRUCTURE)
3442             {
3443               if (!check_constant_initializer (c->expr, ts, false, false))
3444                 return false;
3445             }
3446           else if (c->expr->expr_type != EXPR_CONSTANT)
3447             return false;
3448         }
3449       return true;
3450     }
3451   else switch (ts->type)
3452     {
3453     case BT_DERIVED:
3454       if (expr->expr_type != EXPR_STRUCTURE)
3455         return false;
3456       cm = expr->ts.derived->components;
3457       for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
3458         {
3459           if (!c->expr || cm->attr.allocatable)
3460             continue;
3461           if (!check_constant_initializer (c->expr, &cm->ts,
3462                                            cm->attr.dimension,
3463                                            cm->attr.pointer))
3464             return false;
3465         }
3466       return true;
3467     default:
3468       return expr->expr_type == EXPR_CONSTANT;
3469     }
3470 }
3471
3472 /* Emit debug info for parameters and unreferenced variables with
3473    initializers.  */
3474
3475 static void
3476 gfc_emit_parameter_debug_info (gfc_symbol *sym)
3477 {
3478   tree decl;
3479
3480   if (sym->attr.flavor != FL_PARAMETER
3481       && (sym->attr.flavor != FL_VARIABLE || sym->attr.referenced))
3482     return;
3483
3484   if (sym->backend_decl != NULL
3485       || sym->value == NULL
3486       || sym->attr.use_assoc
3487       || sym->attr.dummy
3488       || sym->attr.result
3489       || sym->attr.function
3490       || sym->attr.intrinsic
3491       || sym->attr.pointer
3492       || sym->attr.allocatable
3493       || sym->attr.cray_pointee
3494       || sym->attr.threadprivate
3495       || sym->attr.is_bind_c
3496       || sym->attr.subref_array_pointer
3497       || sym->attr.assign)
3498     return;
3499
3500   if (sym->ts.type == BT_CHARACTER)
3501     {
3502       gfc_conv_const_charlen (sym->ts.cl);
3503       if (sym->ts.cl->backend_decl == NULL
3504           || TREE_CODE (sym->ts.cl->backend_decl) != INTEGER_CST)
3505         return;
3506     }
3507   else if (sym->ts.type == BT_DERIVED && sym->ts.derived->attr.alloc_comp)
3508     return;
3509
3510   if (sym->as)
3511     {
3512       int n;
3513
3514       if (sym->as->type != AS_EXPLICIT)
3515         return;
3516       for (n = 0; n < sym->as->rank; n++)
3517         if (sym->as->lower[n]->expr_type != EXPR_CONSTANT
3518             || sym->as->upper[n] == NULL
3519             || sym->as->upper[n]->expr_type != EXPR_CONSTANT)
3520           return;
3521     }
3522
3523   if (!check_constant_initializer (sym->value, &sym->ts,
3524                                    sym->attr.dimension, false))
3525     return;
3526
3527   /* Create the decl for the variable or constant.  */
3528   decl = build_decl (input_location,
3529                      sym->attr.flavor == FL_PARAMETER ? CONST_DECL : VAR_DECL,
3530                      gfc_sym_identifier (sym), gfc_sym_type (sym));
3531   if (sym->attr.flavor == FL_PARAMETER)
3532     TREE_READONLY (decl) = 1;
3533   gfc_set_decl_location (decl, &sym->declared_at);
3534   if (sym->attr.dimension)
3535     GFC_DECL_PACKED_ARRAY (decl) = 1;
3536   DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
3537   TREE_STATIC (decl) = 1;
3538   TREE_USED (decl) = 1;
3539   if (DECL_CONTEXT (decl) && TREE_CODE (DECL_CONTEXT (decl)) == NAMESPACE_DECL)
3540     TREE_PUBLIC (decl) = 1;
3541   DECL_INITIAL (decl)
3542     = gfc_conv_initializer (sym->value, &sym->ts, TREE_TYPE (decl),
3543                             sym->attr.dimension, 0);
3544   debug_hooks->global_decl (decl);
3545 }
3546
3547 /* Generate all the required code for module variables.  */
3548
3549 void
3550 gfc_generate_module_vars (gfc_namespace * ns)
3551 {
3552   module_namespace = ns;
3553   cur_module = gfc_find_module (ns->proc_name->name);
3554
3555   /* Check if the frontend left the namespace in a reasonable state.  */
3556   gcc_assert (ns->proc_name && !ns->proc_name->tlink);
3557
3558   /* Generate COMMON blocks.  */
3559   gfc_trans_common (ns);
3560
3561   /* Create decls for all the module variables.  */
3562   gfc_traverse_ns (ns, gfc_create_module_variable);
3563
3564   cur_module = NULL;
3565
3566   gfc_trans_use_stmts (ns);
3567   gfc_traverse_ns (ns, gfc_emit_parameter_debug_info);
3568 }
3569
3570
3571 static void
3572 gfc_generate_contained_functions (gfc_namespace * parent)
3573 {
3574   gfc_namespace *ns;
3575
3576   /* We create all the prototypes before generating any code.  */
3577   for (ns = parent->contained; ns; ns = ns->sibling)
3578     {
3579       /* Skip namespaces from used modules.  */
3580       if (ns->parent != parent)
3581         continue;
3582
3583       gfc_create_function_decl (ns);
3584     }
3585
3586   for (ns = parent->contained; ns; ns = ns->sibling)
3587     {
3588       /* Skip namespaces from used modules.  */
3589       if (ns->parent != parent)
3590         continue;
3591
3592       gfc_generate_function_code (ns);
3593     }
3594 }
3595
3596
3597 /* Drill down through expressions for the array specification bounds and
3598    character length calling generate_local_decl for all those variables
3599    that have not already been declared.  */
3600
3601 static void
3602 generate_local_decl (gfc_symbol *);
3603
3604 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced.  */
3605
3606 static bool
3607 expr_decls (gfc_expr *e, gfc_symbol *sym,
3608             int *f ATTRIBUTE_UNUSED)
3609 {
3610   if (e->expr_type != EXPR_VARIABLE
3611             || sym == e->symtree->n.sym
3612             || e->symtree->n.sym->mark
3613             || e->symtree->n.sym->ns != sym->ns)
3614         return false;
3615
3616   generate_local_decl (e->symtree->n.sym);
3617   return false;
3618 }
3619
3620 static void
3621 generate_expr_decls (gfc_symbol *sym, gfc_expr *e)
3622 {
3623   gfc_traverse_expr (e, sym, expr_decls, 0);
3624 }
3625
3626
3627 /* Check for dependencies in the character length and array spec.  */
3628
3629 static void
3630 generate_dependency_declarations (gfc_symbol *sym)
3631 {
3632   int i;
3633
3634   if (sym->ts.type == BT_CHARACTER
3635       && sym->ts.cl
3636       && sym->ts.cl->length
3637       && sym->ts.cl->length->expr_type != EXPR_CONSTANT)
3638     generate_expr_decls (sym, sym->ts.cl->length);
3639
3640   if (sym->as && sym->as->rank)
3641     {
3642       for (i = 0; i < sym->as->rank; i++)
3643         {
3644           generate_expr_decls (sym, sym->as->lower[i]);
3645           generate_expr_decls (sym, sym->as->upper[i]);
3646         }
3647     }
3648 }
3649
3650
3651 /* Generate decls for all local variables.  We do this to ensure correct
3652    handling of expressions which only appear in the specification of
3653    other functions.  */
3654
3655 static void
3656 generate_local_decl (gfc_symbol * sym)
3657 {
3658   if (sym->attr.flavor == FL_VARIABLE)
3659     {
3660       if (!sym->attr.dummy && !sym->ns->proc_name->attr.entry_master)
3661         generate_dependency_declarations (sym);
3662
3663       if (sym->attr.referenced)
3664         gfc_get_symbol_decl (sym);
3665       /* INTENT(out) dummy arguments are likely meant to be set.  */
3666       else if (warn_unused_variable
3667                && sym->attr.dummy
3668                && sym->attr.intent == INTENT_OUT)
3669         gfc_warning ("Dummy argument '%s' at %L was declared INTENT(OUT) but was not set",
3670                      sym->name, &sym->declared_at);
3671       /* Specific warning for unused dummy arguments. */
3672       else if (warn_unused_variable && sym->attr.dummy)
3673         gfc_warning ("Unused dummy argument '%s' at %L", sym->name,
3674                      &sym->declared_at);
3675       /* Warn for unused variables, but not if they're inside a common
3676          block or are use-associated.  */
3677       else if (warn_unused_variable
3678                && !(sym->attr.in_common || sym->attr.use_assoc || sym->mark))
3679         gfc_warning ("Unused variable '%s' declared at %L", sym->name,
3680                      &sym->declared_at);
3681
3682       /* For variable length CHARACTER parameters, the PARM_DECL already
3683          references the length variable, so force gfc_get_symbol_decl
3684          even when not referenced.  If optimize > 0, it will be optimized
3685          away anyway.  But do this only after emitting -Wunused-parameter
3686          warning if requested.  */
3687       if (sym->attr.dummy && !sym->attr.referenced
3688             && sym->ts.type == BT_CHARACTER
3689             && sym->ts.cl->backend_decl != NULL
3690             && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
3691         {
3692           sym->attr.referenced = 1;
3693           gfc_get_symbol_decl (sym);
3694         }
3695
3696       /* INTENT(out) dummy arguments with allocatable components are reset
3697          by default and need to be set referenced to generate the code for
3698          automatic lengths.  */
3699       if (sym->attr.dummy && !sym->attr.referenced
3700             && sym->ts.type == BT_DERIVED
3701             && sym->ts.derived->attr.alloc_comp
3702             && sym->attr.intent == INTENT_OUT)
3703         {
3704           sym->attr.referenced = 1;
3705           gfc_get_symbol_decl (sym);
3706         }
3707
3708
3709       /* Check for dependencies in the array specification and string
3710         length, adding the necessary declarations to the function.  We
3711         mark the symbol now, as well as in traverse_ns, to prevent
3712         getting stuck in a circular dependency.  */
3713       sym->mark = 1;
3714
3715       /* We do not want the middle-end to warn about unused parameters
3716          as this was already done above.  */
3717       if (sym->attr.dummy && sym->backend_decl != NULL_TREE)
3718           TREE_NO_WARNING(sym->backend_decl) = 1;
3719     }
3720   else if (sym->attr.flavor == FL_PARAMETER)
3721     {
3722       if (warn_unused_parameter
3723            && !sym->attr.referenced
3724            && !sym->attr.use_assoc)
3725         gfc_warning ("Unused parameter '%s' declared at %L", sym->name,
3726                      &sym->declared_at);
3727     }
3728   else if (sym->attr.flavor == FL_PROCEDURE)
3729     {
3730       /* TODO: move to the appropriate place in resolve.c.  */
3731       if (warn_return_type
3732           && sym->attr.function
3733           && sym->result
3734           && sym != sym->result
3735           && !sym->result->attr.referenced
3736           && !sym->attr.use_assoc
3737           && sym->attr.if_source != IFSRC_IFBODY)
3738         {
3739           gfc_warning ("Return value '%s' of function '%s' declared at "
3740                        "%L not set", sym->result->name, sym->name,
3741                         &sym->result->declared_at);
3742
3743           /* Prevents "Unused variable" warning for RESULT variables.  */
3744           sym->result->mark = 1;
3745         }
3746     }
3747
3748   if (sym->attr.dummy == 1)
3749     {
3750       /* Modify the tree type for scalar character dummy arguments of bind(c)
3751          procedures if they are passed by value.  The tree type for them will
3752          be promoted to INTEGER_TYPE for the middle end, which appears to be
3753          what C would do with characters passed by-value.  The value attribute
3754          implies the dummy is a scalar.  */
3755       if (sym->attr.value == 1 && sym->backend_decl != NULL
3756           && sym->ts.type == BT_CHARACTER && sym->ts.is_c_interop
3757           && sym->ns->proc_name != NULL && sym->ns->proc_name->attr.is_bind_c)
3758         gfc_conv_scalar_char_value (sym, NULL, NULL);
3759     }
3760
3761   /* Make sure we convert the types of the derived types from iso_c_binding
3762      into (void *).  */
3763   if (sym->attr.flavor != FL_PROCEDURE && sym->attr.is_iso_c
3764       && sym->ts.type == BT_DERIVED)
3765     sym->backend_decl = gfc_typenode_for_spec (&(sym->ts));
3766 }
3767
3768 static void
3769 generate_local_vars (gfc_namespace * ns)
3770 {
3771   gfc_traverse_ns (ns, generate_local_decl);
3772 }
3773
3774
3775 /* Generate a switch statement to jump to the correct entry point.  Also
3776    creates the label decls for the entry points.  */
3777
3778 static tree
3779 gfc_trans_entry_master_switch (gfc_entry_list * el)
3780 {
3781   stmtblock_t block;
3782   tree label;
3783   tree tmp;
3784   tree val;
3785
3786   gfc_init_block (&block);
3787   for (; el; el = el->next)
3788     {
3789       /* Add the case label.  */
3790       label = gfc_build_label_decl (NULL_TREE);
3791       val = build_int_cst (gfc_array_index_type, el->id);
3792       tmp = build3_v (CASE_LABEL_EXPR, val, NULL_TREE, label);
3793       gfc_add_expr_to_block (&block, tmp);
3794
3795       /* And jump to the actual entry point.  */
3796       label = gfc_build_label_decl (NULL_TREE);
3797       tmp = build1_v (GOTO_EXPR, label);
3798       gfc_add_expr_to_block (&block, tmp);
3799
3800       /* Save the label decl.  */
3801       el->label = label;
3802     }
3803   tmp = gfc_finish_block (&block);
3804   /* The first argument selects the entry point.  */
3805   val = DECL_ARGUMENTS (current_function_decl);
3806   tmp = build3_v (SWITCH_EXPR, val, tmp, NULL_TREE);
3807   return tmp;
3808 }
3809
3810
3811 /* Add code to string lengths of actual arguments passed to a function against
3812    the expected lengths of the dummy arguments.  */
3813
3814 static void
3815 add_argument_checking (stmtblock_t *block, gfc_symbol *sym)
3816 {
3817   gfc_formal_arglist *formal;
3818
3819   for (formal = sym->formal; formal; formal = formal->next)
3820     if (formal->sym && formal->sym->ts.type == BT_CHARACTER)
3821       {
3822         enum tree_code comparison;
3823         tree cond;
3824         tree argname;
3825         gfc_symbol *fsym;
3826         gfc_charlen *cl;
3827         const char *message;
3828
3829         fsym = formal->sym;
3830         cl = fsym->ts.cl;
3831
3832         gcc_assert (cl);
3833         gcc_assert (cl->passed_length != NULL_TREE);
3834         gcc_assert (cl->backend_decl != NULL_TREE);
3835
3836         /* For POINTER, ALLOCATABLE and assumed-shape dummy arguments, the
3837            string lengths must match exactly.  Otherwise, it is only required
3838            that the actual string length is *at least* the expected one.
3839            Sequence association allows for a mismatch of the string length
3840            if the actual argument is (part of) an array, but only if the
3841            dummy argument is an array. (See "Sequence association" in
3842            Section 12.4.1.4 for F95 and 12.4.1.5 for F2003.)  */
3843         if (fsym->attr.pointer || fsym->attr.allocatable
3844             || (fsym->as && fsym->as->type == AS_ASSUMED_SHAPE))
3845           {
3846             comparison = NE_EXPR;
3847             message = _("Actual string length does not match the declared one"
3848                         " for dummy argument '%s' (%ld/%ld)");
3849           }
3850         else if (fsym->as && fsym->as->rank != 0)
3851           continue;
3852         else
3853           {
3854             comparison = LT_EXPR;
3855             message = _("Actual string length is shorter than the declared one"
3856                         " for dummy argument '%s' (%ld/%ld)");
3857           }
3858
3859         /* Build the condition.  For optional arguments, an actual length
3860            of 0 is also acceptable if the associated string is NULL, which
3861            means the argument was not passed.  */
3862         cond = fold_build2 (comparison, boolean_type_node,
3863                             cl->passed_length, cl->backend_decl);
3864         if (fsym->attr.optional)
3865           {
3866             tree not_absent;
3867             tree not_0length;
3868             tree absent_failed;
3869
3870             not_0length = fold_build2 (NE_EXPR, boolean_type_node,
3871                                        cl->passed_length,
3872                                        fold_convert (gfc_charlen_type_node,
3873                                                      integer_zero_node));
3874             not_absent = fold_build2 (NE_EXPR, boolean_type_node,
3875                                       fsym->backend_decl, null_pointer_node);
3876
3877             absent_failed = fold_build2 (TRUTH_OR_EXPR, boolean_type_node,
3878                                          not_0length, not_absent);
3879
3880             cond = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3881                                 cond, absent_failed);
3882           }
3883
3884         /* Build the runtime check.  */
3885         argname = gfc_build_cstring_const (fsym->name);
3886         argname = gfc_build_addr_expr (pchar_type_node, argname);
3887         gfc_trans_runtime_check (true, false, cond, block, &fsym->declared_at,
3888                                  message, argname,
3889                                  fold_convert (long_integer_type_node,
3890                                                cl->passed_length),
3891                                  fold_convert (long_integer_type_node,
3892                                                cl->backend_decl));
3893       }
3894 }
3895
3896
3897 static void
3898 create_main_function (tree fndecl)
3899 {
3900   tree old_context;
3901   tree ftn_main;
3902   tree tmp, decl, result_decl, argc, argv, typelist, arglist;
3903   stmtblock_t body;
3904
3905   old_context = current_function_decl;
3906
3907   if (old_context)
3908     {
3909       push_function_context ();
3910       saved_parent_function_decls = saved_function_decls;
3911       saved_function_decls = NULL_TREE;
3912     }
3913
3914   /* main() function must be declared with global scope.  */
3915   gcc_assert (current_function_decl == NULL_TREE);
3916
3917   /* Declare the function.  */
3918   tmp =  build_function_type_list (integer_type_node, integer_type_node,
3919                                    build_pointer_type (pchar_type_node),
3920                                    NULL_TREE);
3921   main_identifier_node = get_identifier ("main");
3922   ftn_main = build_decl (input_location, FUNCTION_DECL,
3923                          main_identifier_node, tmp);
3924   DECL_EXTERNAL (ftn_main) = 0;
3925   TREE_PUBLIC (ftn_main) = 1;
3926   TREE_STATIC (ftn_main) = 1;
3927   DECL_ATTRIBUTES (ftn_main)
3928       = tree_cons (get_identifier("externally_visible"), NULL_TREE, NULL_TREE);
3929
3930   /* Setup the result declaration (for "return 0").  */
3931   result_decl = build_decl (input_location,
3932                             RESULT_DECL, NULL_TREE, integer_type_node);
3933   DECL_ARTIFICIAL (result_decl) = 1;
3934   DECL_IGNORED_P (result_decl) = 1;
3935   DECL_CONTEXT (result_decl) = ftn_main;
3936   DECL_RESULT (ftn_main) = result_decl;
3937
3938   pushdecl (ftn_main);
3939
3940   /* Get the arguments.  */
3941
3942   arglist = NULL_TREE;
3943   typelist = TYPE_ARG_TYPES (TREE_TYPE (ftn_main));
3944
3945   tmp = TREE_VALUE (typelist);
3946   argc = build_decl (input_location, PARM_DECL, get_identifier ("argc"), tmp);
3947   DECL_CONTEXT (argc) = ftn_main;
3948   DECL_ARG_TYPE (argc) = TREE_VALUE (typelist);
3949   TREE_READONLY (argc) = 1;
3950   gfc_finish_decl (argc);
3951   arglist = chainon (arglist, argc);
3952
3953   typelist = TREE_CHAIN (typelist);
3954   tmp = TREE_VALUE (typelist);
3955   argv = build_decl (input_location, PARM_DECL, get_identifier ("argv"), tmp);
3956   DECL_CONTEXT (argv) = ftn_main;
3957   DECL_ARG_TYPE (argv) = TREE_VALUE (typelist);
3958   TREE_READONLY (argv) = 1;
3959   DECL_BY_REFERENCE (argv) = 1;
3960   gfc_finish_decl (argv);
3961   arglist = chainon (arglist, argv);
3962
3963   DECL_ARGUMENTS (ftn_main) = arglist;
3964   current_function_decl = ftn_main;
3965   announce_function (ftn_main);
3966
3967   rest_of_decl_compilation (ftn_main, 1, 0);
3968   make_decl_rtl (ftn_main);
3969   init_function_start (ftn_main);
3970   pushlevel (0);
3971
3972   gfc_init_block (&body);
3973
3974   /* Call some libgfortran initialization routines, call then MAIN__(). */
3975
3976   /* Call _gfortran_set_args (argc, argv).  */
3977   TREE_USED (argc) = 1;
3978   TREE_USED (argv) = 1;
3979   tmp = build_call_expr (gfor_fndecl_set_args, 2, argc, argv);
3980   gfc_add_expr_to_block (&body, tmp);
3981
3982   /* Add a call to set_options to set up the runtime library Fortran
3983      language standard parameters.  */
3984   {
3985     tree array_type, array, var;
3986
3987     /* Passing a new option to the library requires four modifications:
3988      + add it to the tree_cons list below
3989           + change the array size in the call to build_array_type
3990           + change the first argument to the library call
3991             gfor_fndecl_set_options
3992           + modify the library (runtime/compile_options.c)!  */
3993
3994     array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,
3995                        gfc_option.warn_std), NULL_TREE);
3996     array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,
3997                        gfc_option.allow_std), array);
3998     array = tree_cons (NULL_TREE, build_int_cst (integer_type_node, pedantic),
3999                        array);
4000     array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,
4001                        gfc_option.flag_dump_core), array);
4002     array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,
4003                        gfc_option.flag_backtrace), array);
4004     array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,
4005                        gfc_option.flag_sign_zero), array);
4006
4007     array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,
4008                        (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)), array);
4009
4010     array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,
4011                        gfc_option.flag_range_check), array);
4012
4013     array_type = build_array_type (integer_type_node,
4014                        build_index_type (build_int_cst (NULL_TREE, 7)));
4015     array = build_constructor_from_list (array_type, nreverse (array));
4016     TREE_CONSTANT (array) = 1;
4017     TREE_STATIC (array) = 1;
4018
4019     /* Create a static variable to hold the jump table.  */
4020     var = gfc_create_var (array_type, "options");
4021     TREE_CONSTANT (var) = 1;
4022     TREE_STATIC (var) = 1;
4023     TREE_READONLY (var) = 1;
4024     DECL_INITIAL (var) = array;
4025     var = gfc_build_addr_expr (build_pointer_type (integer_type_node), var);
4026
4027     tmp = build_call_expr (gfor_fndecl_set_options, 2,
4028                            build_int_cst (integer_type_node, 8), var);
4029     gfc_add_expr_to_block (&body, tmp);
4030   }
4031
4032   /* If -ffpe-trap option was provided, add a call to set_fpe so that
4033      the library will raise a FPE when needed.  */
4034   if (gfc_option.fpe != 0)
4035     {
4036       tmp = build_call_expr (gfor_fndecl_set_fpe, 1,
4037                              build_int_cst (integer_type_node,
4038                                             gfc_option.fpe));
4039       gfc_add_expr_to_block (&body, tmp);
4040     }
4041
4042   /* If this is the main program and an -fconvert option was provided,
4043      add a call to set_convert.  */
4044
4045   if (gfc_option.convert != GFC_CONVERT_NATIVE)
4046     {
4047       tmp = build_call_expr (gfor_fndecl_set_convert, 1,
4048                              build_int_cst (integer_type_node,
4049                                             gfc_option.convert));
4050       gfc_add_expr_to_block (&body, tmp);
4051     }
4052
4053   /* If this is the main program and an -frecord-marker option was provided,
4054      add a call to set_record_marker.  */
4055
4056   if (gfc_option.record_marker != 0)
4057     {
4058       tmp = build_call_expr (gfor_fndecl_set_record_marker, 1,
4059                              build_int_cst (integer_type_node,
4060                                             gfc_option.record_marker));
4061       gfc_add_expr_to_block (&body, tmp);
4062     }
4063
4064   if (gfc_option.max_subrecord_length != 0)
4065     {
4066       tmp = build_call_expr (gfor_fndecl_set_max_subrecord_length, 1,
4067                              build_int_cst (integer_type_node,
4068                                             gfc_option.max_subrecord_length));
4069       gfc_add_expr_to_block (&body, tmp);
4070     }
4071
4072   /* Call MAIN__().  */
4073   tmp = build_call_expr (fndecl, 0);
4074   gfc_add_expr_to_block (&body, tmp);
4075
4076   /* Mark MAIN__ as used.  */
4077   TREE_USED (fndecl) = 1;
4078
4079   /* "return 0".  */
4080   tmp = fold_build2 (MODIFY_EXPR, integer_type_node, DECL_RESULT (ftn_main),
4081                      build_int_cst (integer_type_node, 0));
4082   tmp = build1_v (RETURN_EXPR, tmp);
4083   gfc_add_expr_to_block (&body, tmp);
4084
4085
4086   DECL_SAVED_TREE (ftn_main) = gfc_finish_block (&body);
4087   decl = getdecls ();
4088
4089   /* Finish off this function and send it for code generation.  */
4090   poplevel (1, 0, 1);
4091   BLOCK_SUPERCONTEXT (DECL_INITIAL (ftn_main)) = ftn_main;
4092
4093   DECL_SAVED_TREE (ftn_main)
4094     = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (ftn_main),
4095                 DECL_INITIAL (ftn_main));
4096
4097   /* Output the GENERIC tree.  */
4098   dump_function (TDI_original, ftn_main);
4099
4100   gfc_gimplify_function (ftn_main);
4101   cgraph_finalize_function (ftn_main, false);
4102
4103   if (old_context)
4104     {
4105       pop_function_context ();
4106       saved_function_decls = saved_parent_function_decls;
4107     }
4108   current_function_decl = old_context;
4109 }
4110
4111
4112 /* Generate code for a function.  */
4113
4114 void
4115 gfc_generate_function_code (gfc_namespace * ns)
4116 {
4117   tree fndecl;
4118   tree old_context;
4119   tree decl;
4120   tree tmp;
4121   tree tmp2;
4122   stmtblock_t block;
4123   stmtblock_t body;
4124   tree result;
4125   tree recurcheckvar = NULL;
4126   gfc_symbol *sym;
4127   int rank;
4128   bool is_recursive;
4129
4130   sym = ns->proc_name;
4131
4132   /* Check that the frontend isn't still using this.  */
4133   gcc_assert (sym->tlink == NULL);
4134   sym->tlink = sym;
4135
4136   /* Create the declaration for functions with global scope.  */
4137   if (!sym->backend_decl)
4138     gfc_create_function_decl (ns);
4139
4140   fndecl = sym->backend_decl;
4141   old_context = current_function_decl;
4142
4143   if (old_context)
4144     {
4145       push_function_context ();
4146       saved_parent_function_decls = saved_function_decls;
4147       saved_function_decls = NULL_TREE;
4148     }
4149
4150   trans_function_start (sym);
4151
4152   gfc_init_block (&block);
4153
4154   if (ns->entries && ns->proc_name->ts.type == BT_CHARACTER)
4155     {
4156       /* Copy length backend_decls to all entry point result
4157          symbols.  */
4158       gfc_entry_list *el;
4159       tree backend_decl;
4160
4161       gfc_conv_const_charlen (ns->proc_name->ts.cl);
4162       backend_decl = ns->proc_name->result->ts.cl->backend_decl;
4163       for (el = ns->entries; el; el = el->next)
4164         el->sym->result->ts.cl->backend_decl = backend_decl;
4165     }
4166
4167   /* Translate COMMON blocks.  */
4168   gfc_trans_common (ns);
4169
4170   /* Null the parent fake result declaration if this namespace is
4171      a module function or an external procedures.  */
4172   if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
4173         || ns->parent == NULL)
4174     parent_fake_result_decl = NULL_TREE;
4175
4176   gfc_generate_contained_functions (ns);
4177
4178   nonlocal_dummy_decls = NULL;
4179   nonlocal_dummy_decl_pset = NULL;
4180
4181   generate_local_vars (ns);
4182
4183   /* Keep the parent fake result declaration in module functions
4184      or external procedures.  */
4185   if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
4186         || ns->parent == NULL)
4187     current_fake_result_decl = parent_fake_result_decl;
4188   else
4189     current_fake_result_decl = NULL_TREE;
4190
4191   current_function_return_label = NULL;
4192
4193   /* Now generate the code for the body of this function.  */
4194   gfc_init_block (&body);
4195
4196    is_recursive = sym->attr.recursive
4197                   || (sym->attr.entry_master
4198                       && sym->ns->entries->sym->attr.recursive);
4199    if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION) && !is_recursive)
4200      {
4201        char * msg;
4202
4203        asprintf (&msg, "Recursive call to nonrecursive procedure '%s'",
4204                  sym->name);
4205        recurcheckvar = gfc_create_var (boolean_type_node, "is_recursive");
4206        TREE_STATIC (recurcheckvar) = 1;
4207        DECL_INITIAL (recurcheckvar) = boolean_false_node;
4208        gfc_add_expr_to_block (&block, recurcheckvar);
4209        gfc_trans_runtime_check (true, false, recurcheckvar, &block,
4210                                 &sym->declared_at, msg);
4211        gfc_add_modify (&block, recurcheckvar, boolean_true_node);
4212        gfc_free (msg);
4213     }
4214
4215   if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node
4216       && sym->attr.subroutine)
4217     {
4218       tree alternate_return;
4219       alternate_return = gfc_get_fake_result_decl (sym, 0);
4220       gfc_add_modify (&body, alternate_return, integer_zero_node);
4221     }
4222
4223   if (ns->entries)
4224     {
4225       /* Jump to the correct entry point.  */
4226       tmp = gfc_trans_entry_master_switch (ns->entries);
4227       gfc_add_expr_to_block (&body, tmp);
4228     }
4229
4230   /* If bounds-checking is enabled, generate code to check passed in actual
4231      arguments against the expected dummy argument attributes (e.g. string
4232      lengths).  */
4233   if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
4234     add_argument_checking (&body, sym);
4235
4236   tmp = gfc_trans_code (ns->code);
4237   gfc_add_expr_to_block (&body, tmp);
4238
4239   /* Add a return label if needed.  */
4240   if (current_function_return_label)
4241     {
4242       tmp = build1_v (LABEL_EXPR, current_function_return_label);
4243       gfc_add_expr_to_block (&body, tmp);
4244     }
4245
4246   tmp = gfc_finish_block (&body);
4247   /* Add code to create and cleanup arrays.  */
4248   tmp = gfc_trans_deferred_vars (sym, tmp);
4249
4250   if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node)
4251     {
4252       if (sym->attr.subroutine || sym == sym->result)
4253         {
4254           if (current_fake_result_decl != NULL)
4255             result = TREE_VALUE (current_fake_result_decl);
4256           else
4257             result = NULL_TREE;
4258           current_fake_result_decl = NULL_TREE;
4259         }
4260       else
4261         result = sym->result->backend_decl;
4262
4263       if (result != NULL_TREE && sym->attr.function
4264             && sym->ts.type == BT_DERIVED
4265             && sym->ts.derived->attr.alloc_comp
4266             && !sym->attr.pointer)
4267         {
4268           rank = sym->as ? sym->as->rank : 0;
4269           tmp2 = gfc_nullify_alloc_comp (sym->ts.derived, result, rank);
4270           gfc_add_expr_to_block (&block, tmp2);
4271         }
4272
4273       gfc_add_expr_to_block (&block, tmp);
4274
4275       /* Reset recursion-check variable.  */
4276       if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION) && !is_recursive)
4277       {
4278         gfc_add_modify (&block, recurcheckvar, boolean_false_node);
4279         recurcheckvar = NULL;
4280       }
4281
4282       if (result == NULL_TREE)
4283         {
4284           /* TODO: move to the appropriate place in resolve.c.  */
4285           if (warn_return_type && !sym->attr.referenced && sym == sym->result)
4286             gfc_warning ("Return value of function '%s' at %L not set",
4287                          sym->name, &sym->declared_at);
4288
4289           TREE_NO_WARNING(sym->backend_decl) = 1;
4290         }
4291       else
4292         {
4293           /* Set the return value to the dummy result variable.  The
4294              types may be different for scalar default REAL functions
4295              with -ff2c, therefore we have to convert.  */
4296           tmp = convert (TREE_TYPE (DECL_RESULT (fndecl)), result);
4297           tmp = fold_build2 (MODIFY_EXPR, TREE_TYPE (tmp),
4298                              DECL_RESULT (fndecl), tmp);
4299           tmp = build1_v (RETURN_EXPR, tmp);
4300           gfc_add_expr_to_block (&block, tmp);
4301         }
4302     }
4303   else
4304     {
4305       gfc_add_expr_to_block (&block, tmp);
4306       /* Reset recursion-check variable.  */
4307       if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION) && !is_recursive)
4308       {
4309         gfc_add_modify (&block, recurcheckvar, boolean_false_node);
4310         recurcheckvar = NULL;
4311       }
4312     }
4313
4314
4315   /* Add all the decls we created during processing.  */
4316   decl = saved_function_decls;
4317   while (decl)
4318     {
4319       tree next;
4320
4321       next = TREE_CHAIN (decl);
4322       TREE_CHAIN (decl) = NULL_TREE;
4323       pushdecl (decl);
4324       decl = next;
4325     }
4326   saved_function_decls = NULL_TREE;
4327
4328   DECL_SAVED_TREE (fndecl) = gfc_finish_block (&block);
4329   decl = getdecls ();
4330
4331   /* Finish off this function and send it for code generation.  */
4332   poplevel (1, 0, 1);
4333   BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
4334
4335   DECL_SAVED_TREE (fndecl)
4336     = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (fndecl),
4337                 DECL_INITIAL (fndecl));
4338
4339   if (nonlocal_dummy_decls)
4340     {
4341       BLOCK_VARS (DECL_INITIAL (fndecl))
4342         = chainon (BLOCK_VARS (DECL_INITIAL (fndecl)), nonlocal_dummy_decls);
4343       pointer_set_destroy (nonlocal_dummy_decl_pset);
4344       nonlocal_dummy_decls = NULL;
4345       nonlocal_dummy_decl_pset = NULL;
4346     }
4347
4348   /* Output the GENERIC tree.  */
4349   dump_function (TDI_original, fndecl);
4350
4351   /* Store the end of the function, so that we get good line number
4352      info for the epilogue.  */
4353   cfun->function_end_locus = input_location;
4354
4355   /* We're leaving the context of this function, so zap cfun.
4356      It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
4357      tree_rest_of_compilation.  */
4358   set_cfun (NULL);
4359
4360   if (old_context)
4361     {
4362       pop_function_context ();
4363       saved_function_decls = saved_parent_function_decls;
4364     }
4365   current_function_decl = old_context;
4366
4367   if (decl_function_context (fndecl))
4368     /* Register this function with cgraph just far enough to get it
4369        added to our parent's nested function list.  */
4370     (void) cgraph_node (fndecl);
4371   else
4372     {
4373       gfc_gimplify_function (fndecl);
4374       cgraph_finalize_function (fndecl, false);
4375     }
4376
4377   gfc_trans_use_stmts (ns);
4378   gfc_traverse_ns (ns, gfc_emit_parameter_debug_info);
4379
4380   if (sym->attr.is_main_program)
4381     create_main_function (fndecl);
4382 }
4383
4384
4385 void
4386 gfc_generate_constructors (void)
4387 {
4388   gcc_assert (gfc_static_ctors == NULL_TREE);
4389 #if 0
4390   tree fnname;
4391   tree type;
4392   tree fndecl;
4393   tree decl;
4394   tree tmp;
4395
4396   if (gfc_static_ctors == NULL_TREE)
4397     return;
4398
4399   fnname = get_file_function_name ("I");
4400   type = build_function_type (void_type_node,
4401                               gfc_chainon_list (NULL_TREE, void_type_node));
4402
4403   fndecl = build_decl (input_location,
4404                        FUNCTION_DECL, fnname, type);
4405   TREE_PUBLIC (fndecl) = 1;
4406
4407   decl = build_decl (input_location,
4408                      RESULT_DECL, NULL_TREE, void_type_node);
4409   DECL_ARTIFICIAL (decl) = 1;
4410   DECL_IGNORED_P (decl) = 1;
4411   DECL_CONTEXT (decl) = fndecl;
4412   DECL_RESULT (fndecl) = decl;
4413
4414   pushdecl (fndecl);
4415
4416   current_function_decl = fndecl;
4417
4418   rest_of_decl_compilation (fndecl, 1, 0);
4419
4420   make_decl_rtl (fndecl);
4421
4422   init_function_start (fndecl);
4423
4424   pushlevel (0);
4425
4426   for (; gfc_static_ctors; gfc_static_ctors = TREE_CHAIN (gfc_static_ctors))
4427     {
4428       tmp = build_call_expr (TREE_VALUE (gfc_static_ctors), 0);
4429       DECL_SAVED_TREE (fndecl) = build_stmt (input_location, EXPR_STMT, tmp);
4430     }
4431
4432   decl = getdecls ();
4433   poplevel (1, 0, 1);
4434
4435   BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
4436   DECL_SAVED_TREE (fndecl)
4437     = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (fndecl),
4438                 DECL_INITIAL (fndecl));
4439
4440   free_after_parsing (cfun);
4441   free_after_compilation (cfun);
4442
4443   tree_rest_of_compilation (fndecl);
4444
4445   current_function_decl = NULL_TREE;
4446 #endif
4447 }
4448
4449 /* Translates a BLOCK DATA program unit. This means emitting the
4450    commons contained therein plus their initializations. We also emit
4451    a globally visible symbol to make sure that each BLOCK DATA program
4452    unit remains unique.  */
4453
4454 void
4455 gfc_generate_block_data (gfc_namespace * ns)
4456 {
4457   tree decl;
4458   tree id;
4459
4460   /* Tell the backend the source location of the block data.  */
4461   if (ns->proc_name)
4462     gfc_set_backend_locus (&ns->proc_name->declared_at);
4463   else
4464     gfc_set_backend_locus (&gfc_current_locus);
4465
4466   /* Process the DATA statements.  */
4467   gfc_trans_common (ns);
4468
4469   /* Create a global symbol with the mane of the block data.  This is to
4470      generate linker errors if the same name is used twice.  It is never
4471      really used.  */
4472   if (ns->proc_name)
4473     id = gfc_sym_mangled_function_id (ns->proc_name);
4474   else
4475     id = get_identifier ("__BLOCK_DATA__");
4476
4477   decl = build_decl (input_location,
4478                      VAR_DECL, id, gfc_array_index_type);
4479   TREE_PUBLIC (decl) = 1;
4480   TREE_STATIC (decl) = 1;
4481   DECL_IGNORED_P (decl) = 1;
4482
4483   pushdecl (decl);
4484   rest_of_decl_compilation (decl, 1, 0);
4485 }
4486
4487
4488 #include "gt-fortran-trans-decl.h"