gcc/fortran/trans-decl.c

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