gcc/fortran/trans-decl.c

   1 /* Backend function setup
   2    Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010,
   3    2011, 2012
   4    Free Software Foundation, Inc.
   5    Contributed by Paul Brook
   6
   7 This file is part of GCC.
   8
   9 GCC is free software; you can redistribute it and/or modify it under
  10 the terms of the GNU General Public License as published by the Free
  11 Software Foundation; either version 3, or (at your option) any later
  12 version.
  13
  14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
  15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
  16 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  17 for more details.
  18
  19 You should have received a copy of the GNU General Public License
  20 along with GCC; see the file COPYING3.  If not see
  21 <http://www.gnu.org/licenses/>.  */
  22
  23 /* trans-decl.c -- Handling of backend function and variable decls, etc */
  24
  25 #include "config.h"
  26 #include "system.h"
  27 #include "coretypes.h"
  28 #include "tm.h"
  29 #include "tree.h"
  30 #include "tree-dump.h"
  31 #include "gimple.h"     /* For create_tmp_var_raw.  */
  32 #include "ggc.h"
  33 #include "diagnostic-core.h"    /* For internal_error.  */
  34 #include "toplev.h"     /* For announce_function.  */
  35 #include "output.h"     /* For decl_default_tls_model.  */
  36 #include "target.h"
  37 #include "function.h"
  38 #include "flags.h"
  39 #include "cgraph.h"
  40 #include "debug.h"
  41 #include "gfortran.h"
  42 #include "pointer-set.h"
  43 #include "constructor.h"
  44 #include "trans.h"
  45 #include "trans-types.h"
  46 #include "trans-array.h"
  47 #include "trans-const.h"
  48 /* Only for gfc_trans_code.  Shouldn't need to include this.  */
  49 #include "trans-stmt.h"
  50
  51 #define MAX_LABEL_VALUE 99999
  52
  53
  54 /* Holds the result of the function if no result variable specified.  */
  55
  56 static GTY(()) tree current_fake_result_decl;
  57 static GTY(()) tree parent_fake_result_decl;
  58
  59
  60 /* Holds the variable DECLs for the current function.  */
  61
  62 static GTY(()) tree saved_function_decls;
  63 static GTY(()) tree saved_parent_function_decls;
  64
  65 static struct pointer_set_t *nonlocal_dummy_decl_pset;
  66 static GTY(()) tree nonlocal_dummy_decls;
  67
  68 /* Holds the variable DECLs that are locals.  */
  69
  70 static GTY(()) tree saved_local_decls;
  71
  72 /* The namespace of the module we're currently generating.  Only used while
  73    outputting decls for module variables.  Do not rely on this being set.  */
  74
  75 static gfc_namespace *module_namespace;
  76
  77 /* The currently processed procedure symbol.  */
  78 static gfc_symbol* current_procedure_symbol = NULL;
  79
  80
  81 /* With -fcoarray=lib: For generating the registering call
  82    of static coarrays.  */
  83 static bool has_coarray_vars;
  84 static stmtblock_t caf_init_block;
  85
  86
  87 /* List of static constructor functions.  */
  88
  89 tree gfc_static_ctors;
  90
  91
  92 /* Function declarations for builtin library functions.  */
  93
  94 tree gfor_fndecl_pause_numeric;
  95 tree gfor_fndecl_pause_string;
  96 tree gfor_fndecl_stop_numeric;
  97 tree gfor_fndecl_stop_numeric_f08;
  98 tree gfor_fndecl_stop_string;
  99 tree gfor_fndecl_error_stop_numeric;
 100 tree gfor_fndecl_error_stop_string;
 101 tree gfor_fndecl_runtime_error;
 102 tree gfor_fndecl_runtime_error_at;
 103 tree gfor_fndecl_runtime_warning_at;
 104 tree gfor_fndecl_os_error;
 105 tree gfor_fndecl_generate_error;
 106 tree gfor_fndecl_set_args;
 107 tree gfor_fndecl_set_fpe;
 108 tree gfor_fndecl_set_options;
 109 tree gfor_fndecl_set_convert;
 110 tree gfor_fndecl_set_record_marker;
 111 tree gfor_fndecl_set_max_subrecord_length;
 112 tree gfor_fndecl_ctime;
 113 tree gfor_fndecl_fdate;
 114 tree gfor_fndecl_ttynam;
 115 tree gfor_fndecl_in_pack;
 116 tree gfor_fndecl_in_unpack;
 117 tree gfor_fndecl_associated;
 118
 119
 120 /* Coarray run-time library function decls.  */
 121 tree gfor_fndecl_caf_init;
 122 tree gfor_fndecl_caf_finalize;
 123 tree gfor_fndecl_caf_register;
 124 tree gfor_fndecl_caf_deregister;
 125 tree gfor_fndecl_caf_critical;
 126 tree gfor_fndecl_caf_end_critical;
 127 tree gfor_fndecl_caf_sync_all;
 128 tree gfor_fndecl_caf_sync_images;
 129 tree gfor_fndecl_caf_error_stop;
 130 tree gfor_fndecl_caf_error_stop_str;
 131
 132 /* Coarray global variables for num_images/this_image.  */
 133
 134 tree gfort_gvar_caf_num_images;
 135 tree gfort_gvar_caf_this_image;
 136
 137
 138 /* Math functions.  Many other math functions are handled in
 139    trans-intrinsic.c.  */
 140
 141 gfc_powdecl_list gfor_fndecl_math_powi[4][3];
 142 tree gfor_fndecl_math_ishftc4;
 143 tree gfor_fndecl_math_ishftc8;
 144 tree gfor_fndecl_math_ishftc16;
 145
 146
 147 /* String functions.  */
 148
 149 tree gfor_fndecl_compare_string;
 150 tree gfor_fndecl_concat_string;
 151 tree gfor_fndecl_string_len_trim;
 152 tree gfor_fndecl_string_index;
 153 tree gfor_fndecl_string_scan;
 154 tree gfor_fndecl_string_verify;
 155 tree gfor_fndecl_string_trim;
 156 tree gfor_fndecl_string_minmax;
 157 tree gfor_fndecl_adjustl;
 158 tree gfor_fndecl_adjustr;
 159 tree gfor_fndecl_select_string;
 160 tree gfor_fndecl_compare_string_char4;
 161 tree gfor_fndecl_concat_string_char4;
 162 tree gfor_fndecl_string_len_trim_char4;
 163 tree gfor_fndecl_string_index_char4;
 164 tree gfor_fndecl_string_scan_char4;
 165 tree gfor_fndecl_string_verify_char4;
 166 tree gfor_fndecl_string_trim_char4;
 167 tree gfor_fndecl_string_minmax_char4;
 168 tree gfor_fndecl_adjustl_char4;
 169 tree gfor_fndecl_adjustr_char4;
 170 tree gfor_fndecl_select_string_char4;
 171
 172
 173 /* Conversion between character kinds.  */
 174 tree gfor_fndecl_convert_char1_to_char4;
 175 tree gfor_fndecl_convert_char4_to_char1;
 176
 177
 178 /* Other misc. runtime library functions.  */
 179 tree gfor_fndecl_size0;
 180 tree gfor_fndecl_size1;
 181 tree gfor_fndecl_iargc;
 182
 183 /* Intrinsic functions implemented in Fortran.  */
 184 tree gfor_fndecl_sc_kind;
 185 tree gfor_fndecl_si_kind;
 186 tree gfor_fndecl_sr_kind;
 187
 188 /* BLAS gemm functions.  */
 189 tree gfor_fndecl_sgemm;
 190 tree gfor_fndecl_dgemm;
 191 tree gfor_fndecl_cgemm;
 192 tree gfor_fndecl_zgemm;
 193
 194
 195 static void
 196 gfc_add_decl_to_parent_function (tree decl)
 197 {
 198   gcc_assert (decl);
 199   DECL_CONTEXT (decl) = DECL_CONTEXT (current_function_decl);
 200   DECL_NONLOCAL (decl) = 1;
 201   DECL_CHAIN (decl) = saved_parent_function_decls;
 202   saved_parent_function_decls = decl;
 203 }
 204
 205 void
 206 gfc_add_decl_to_function (tree decl)
 207 {
 208   gcc_assert (decl);
 209   TREE_USED (decl) = 1;
 210   DECL_CONTEXT (decl) = current_function_decl;
 211   DECL_CHAIN (decl) = saved_function_decls;
 212   saved_function_decls = decl;
 213 }
 214
 215 static void
 216 add_decl_as_local (tree decl)
 217 {
 218   gcc_assert (decl);
 219   TREE_USED (decl) = 1;
 220   DECL_CONTEXT (decl) = current_function_decl;
 221   DECL_CHAIN (decl) = saved_local_decls;
 222   saved_local_decls = decl;
 223 }
 224
 225
 226 /* Build a  backend label declaration.  Set TREE_USED for named labels.
 227    The context of the label is always the current_function_decl.  All
 228    labels are marked artificial.  */
 229
 230 tree
 231 gfc_build_label_decl (tree label_id)
 232 {
 233   /* 2^32 temporaries should be enough.  */
 234   static unsigned int tmp_num = 1;
 235   tree label_decl;
 236   char *label_name;
 237
 238   if (label_id == NULL_TREE)
 239     {
 240       /* Build an internal label name.  */
 241       ASM_FORMAT_PRIVATE_NAME (label_name, "L", tmp_num++);
 242       label_id = get_identifier (label_name);
 243     }
 244   else
 245     label_name = NULL;
 246
 247   /* Build the LABEL_DECL node. Labels have no type.  */
 248   label_decl = build_decl (input_location,
 249                            LABEL_DECL, label_id, void_type_node);
 250   DECL_CONTEXT (label_decl) = current_function_decl;
 251   DECL_MODE (label_decl) = VOIDmode;
 252
 253   /* We always define the label as used, even if the original source
 254      file never references the label.  We don't want all kinds of
 255      spurious warnings for old-style Fortran code with too many
 256      labels.  */
 257   TREE_USED (label_decl) = 1;
 258
 259   DECL_ARTIFICIAL (label_decl) = 1;
 260   return label_decl;
 261 }
 262
 263
 264 /* Set the backend source location of a decl.  */
 265
 266 void
 267 gfc_set_decl_location (tree decl, locus * loc)
 268 {
 269   DECL_SOURCE_LOCATION (decl) = loc->lb->location;
 270 }
 271
 272
 273 /* Return the backend label declaration for a given label structure,
 274    or create it if it doesn't exist yet.  */
 275
 276 tree
 277 gfc_get_label_decl (gfc_st_label * lp)
 278 {
 279   if (lp->backend_decl)
 280     return lp->backend_decl;
 281   else
 282     {
 283       char label_name[GFC_MAX_SYMBOL_LEN + 1];
 284       tree label_decl;
 285
 286       /* Validate the label declaration from the front end.  */
 287       gcc_assert (lp != NULL && lp->value <= MAX_LABEL_VALUE);
 288
 289       /* Build a mangled name for the label.  */
 290       sprintf (label_name, "__label_%.6d", lp->value);
 291
 292       /* Build the LABEL_DECL node.  */
 293       label_decl = gfc_build_label_decl (get_identifier (label_name));
 294
 295       /* Tell the debugger where the label came from.  */
 296       if (lp->value <= MAX_LABEL_VALUE) /* An internal label.  */
 297         gfc_set_decl_location (label_decl, &lp->where);
 298       else
 299         DECL_ARTIFICIAL (label_decl) = 1;
 300
 301       /* Store the label in the label list and return the LABEL_DECL.  */
 302       lp->backend_decl = label_decl;
 303       return label_decl;
 304     }
 305 }
 306
 307
 308 /* Convert a gfc_symbol to an identifier of the same name.  */
 309
 310 static tree
 311 gfc_sym_identifier (gfc_symbol * sym)
 312 {
 313   if (sym->attr.is_main_program && strcmp (sym->name, "main") == 0)
 314     return (get_identifier ("MAIN__"));
 315   else
 316     return (get_identifier (sym->name));
 317 }
 318
 319
 320 /* Construct mangled name from symbol name.  */
 321
 322 static tree
 323 gfc_sym_mangled_identifier (gfc_symbol * sym)
 324 {
 325   char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
 326
 327   /* Prevent the mangling of identifiers that have an assigned
 328      binding label (mainly those that are bind(c)).  */
 329   if (sym->attr.is_bind_c == 1 && sym->binding_label)
 330     return get_identifier (sym->binding_label);
 331
 332   if (sym->module == NULL)
 333     return gfc_sym_identifier (sym);
 334   else
 335     {
 336       snprintf (name, sizeof name, "__%s_MOD_%s", sym->module, sym->name);
 337       return get_identifier (name);
 338     }
 339 }
 340
 341
 342 /* Construct mangled function name from symbol name.  */
 343
 344 static tree
 345 gfc_sym_mangled_function_id (gfc_symbol * sym)
 346 {
 347   int has_underscore;
 348   char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
 349
 350   /* It may be possible to simply use the binding label if it's
 351      provided, and remove the other checks.  Then we could use it
 352      for other things if we wished.  */
 353   if ((sym->attr.is_bind_c == 1 || sym->attr.is_iso_c == 1) &&
 354       sym->binding_label)
 355     /* use the binding label rather than the mangled name */
 356     return get_identifier (sym->binding_label);
 357
 358   if (sym->module == NULL || sym->attr.proc == PROC_EXTERNAL
 359       || (sym->module != NULL && (sym->attr.external
 360             || sym->attr.if_source == IFSRC_IFBODY)))
 361     {
 362       /* Main program is mangled into MAIN__.  */
 363       if (sym->attr.is_main_program)
 364         return get_identifier ("MAIN__");
 365
 366       /* Intrinsic procedures are never mangled.  */
 367       if (sym->attr.proc == PROC_INTRINSIC)
 368         return get_identifier (sym->name);
 369
 370       if (gfc_option.flag_underscoring)
 371         {
 372           has_underscore = strchr (sym->name, '_') != 0;
 373           if (gfc_option.flag_second_underscore && has_underscore)
 374             snprintf (name, sizeof name, "%s__", sym->name);
 375           else
 376             snprintf (name, sizeof name, "%s_", sym->name);
 377           return get_identifier (name);
 378         }
 379       else
 380         return get_identifier (sym->name);
 381     }
 382   else
 383     {
 384       snprintf (name, sizeof name, "__%s_MOD_%s", sym->module, sym->name);
 385       return get_identifier (name);
 386     }
 387 }
 388
 389
 390 void
 391 gfc_set_decl_assembler_name (tree decl, tree name)
 392 {
 393   tree target_mangled = targetm.mangle_decl_assembler_name (decl, name);
 394   SET_DECL_ASSEMBLER_NAME (decl, target_mangled);
 395 }
 396
 397
 398 /* Returns true if a variable of specified size should go on the stack.  */
 399
 400 int
 401 gfc_can_put_var_on_stack (tree size)
 402 {
 403   unsigned HOST_WIDE_INT low;
 404
 405   if (!INTEGER_CST_P (size))
 406     return 0;
 407
 408   if (gfc_option.flag_max_stack_var_size < 0)
 409     return 1;
 410
 411   if (TREE_INT_CST_HIGH (size) != 0)
 412     return 0;
 413
 414   low = TREE_INT_CST_LOW (size);
 415   if (low > (unsigned HOST_WIDE_INT) gfc_option.flag_max_stack_var_size)
 416     return 0;
 417
 418 /* TODO: Set a per-function stack size limit.  */
 419
 420   return 1;
 421 }
 422
 423
 424 /* gfc_finish_cray_pointee sets DECL_VALUE_EXPR for a Cray pointee to
 425    an expression involving its corresponding pointer.  There are
 426    2 cases; one for variable size arrays, and one for everything else,
 427    because variable-sized arrays require one fewer level of
 428    indirection.  */
 429
 430 static void
 431 gfc_finish_cray_pointee (tree decl, gfc_symbol *sym)
 432 {
 433   tree ptr_decl = gfc_get_symbol_decl (sym->cp_pointer);
 434   tree value;
 435
 436   /* Parameters need to be dereferenced.  */
 437   if (sym->cp_pointer->attr.dummy)
 438     ptr_decl = build_fold_indirect_ref_loc (input_location,
 439                                         ptr_decl);
 440
 441   /* Check to see if we're dealing with a variable-sized array.  */
 442   if (sym->attr.dimension
 443       && TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE)
 444     {
 445       /* These decls will be dereferenced later, so we don't dereference
 446          them here.  */
 447       value = convert (TREE_TYPE (decl), ptr_decl);
 448     }
 449   else
 450     {
 451       ptr_decl = convert (build_pointer_type (TREE_TYPE (decl)),
 452                           ptr_decl);
 453       value = build_fold_indirect_ref_loc (input_location,
 454                                        ptr_decl);
 455     }
 456
 457   SET_DECL_VALUE_EXPR (decl, value);
 458   DECL_HAS_VALUE_EXPR_P (decl) = 1;
 459   GFC_DECL_CRAY_POINTEE (decl) = 1;
 460   /* This is a fake variable just for debugging purposes.  */
 461   TREE_ASM_WRITTEN (decl) = 1;
 462 }
 463
 464
 465 /* Finish processing of a declaration without an initial value.  */
 466
 467 static void
 468 gfc_finish_decl (tree decl)
 469 {
 470   gcc_assert (TREE_CODE (decl) == PARM_DECL
 471               || DECL_INITIAL (decl) == NULL_TREE);
 472
 473   if (TREE_CODE (decl) != VAR_DECL)
 474     return;
 475
 476   if (DECL_SIZE (decl) == NULL_TREE
 477       && TYPE_SIZE (TREE_TYPE (decl)) != NULL_TREE)
 478     layout_decl (decl, 0);
 479
 480   /* A few consistency checks.  */
 481   /* A static variable with an incomplete type is an error if it is
 482      initialized. Also if it is not file scope. Otherwise, let it
 483      through, but if it is not `extern' then it may cause an error
 484      message later.  */
 485   /* An automatic variable with an incomplete type is an error.  */
 486
 487   /* We should know the storage size.  */
 488   gcc_assert (DECL_SIZE (decl) != NULL_TREE
 489               || (TREE_STATIC (decl)
 490                   ? (!DECL_INITIAL (decl) || !DECL_CONTEXT (decl))
 491                   : DECL_EXTERNAL (decl)));
 492
 493   /* The storage size should be constant.  */
 494   gcc_assert ((!DECL_EXTERNAL (decl) && !TREE_STATIC (decl))
 495               || !DECL_SIZE (decl)
 496               || TREE_CODE (DECL_SIZE (decl)) == INTEGER_CST);
 497 }
 498
 499
 500 /* Apply symbol attributes to a variable, and add it to the function scope.  */
 501
 502 static void
 503 gfc_finish_var_decl (tree decl, gfc_symbol * sym)
 504 {
 505   tree new_type;
 506   /* TREE_ADDRESSABLE means the address of this variable is actually needed.
 507      This is the equivalent of the TARGET variables.
 508      We also need to set this if the variable is passed by reference in a
 509      CALL statement.  */
 510
 511   /* Set DECL_VALUE_EXPR for Cray Pointees.  */
 512   if (sym->attr.cray_pointee)
 513     gfc_finish_cray_pointee (decl, sym);
 514
 515   if (sym->attr.target)
 516     TREE_ADDRESSABLE (decl) = 1;
 517   /* If it wasn't used we wouldn't be getting it.  */
 518   TREE_USED (decl) = 1;
 519
 520   if (sym->attr.flavor == FL_PARAMETER
 521       && (sym->attr.dimension || sym->ts.type == BT_DERIVED))
 522     TREE_READONLY (decl) = 1;
 523
 524   /* Chain this decl to the pending declarations.  Don't do pushdecl()
 525      because this would add them to the current scope rather than the
 526      function scope.  */
 527   if (current_function_decl != NULL_TREE)
 528     {
 529       if (sym->ns->proc_name->backend_decl == current_function_decl
 530           || sym->result == sym)
 531         gfc_add_decl_to_function (decl);
 532       else if (sym->ns->proc_name->attr.flavor == FL_LABEL)
 533         /* This is a BLOCK construct.  */
 534         add_decl_as_local (decl);
 535       else
 536         gfc_add_decl_to_parent_function (decl);
 537     }
 538
 539   if (sym->attr.cray_pointee)
 540     return;
 541
 542   if(sym->attr.is_bind_c == 1)
 543     {
 544       /* We need to put variables that are bind(c) into the common
 545          segment of the object file, because this is what C would do.
 546          gfortran would typically put them in either the BSS or
 547          initialized data segments, and only mark them as common if
 548          they were part of common blocks.  However, if they are not put
 549          into common space, then C cannot initialize global Fortran
 550          variables that it interoperates with and the draft says that
 551          either Fortran or C should be able to initialize it (but not
 552          both, of course.) (J3/04-007, section 15.3).  */
 553       TREE_PUBLIC(decl) = 1;
 554       DECL_COMMON(decl) = 1;
 555     }
 556
 557   /* If a variable is USE associated, it's always external.  */
 558   if (sym->attr.use_assoc)
 559     {
 560       DECL_EXTERNAL (decl) = 1;
 561       TREE_PUBLIC (decl) = 1;
 562     }
 563   else if (sym->module && !sym->attr.result && !sym->attr.dummy)
 564     {
 565       /* TODO: Don't set sym->module for result or dummy variables.  */
 566       gcc_assert (current_function_decl == NULL_TREE || sym->result == sym);
 567       /* This is the declaration of a module variable.  */
 568       TREE_PUBLIC (decl) = 1;
 569       TREE_STATIC (decl) = 1;
 570     }
 571
 572   /* Derived types are a bit peculiar because of the possibility of
 573      a default initializer; this must be applied each time the variable
 574      comes into scope it therefore need not be static.  These variables
 575      are SAVE_NONE but have an initializer.  Otherwise explicitly
 576      initialized variables are SAVE_IMPLICIT and explicitly saved are
 577      SAVE_EXPLICIT.  */
 578   if (!sym->attr.use_assoc
 579         && (sym->attr.save != SAVE_NONE || sym->attr.data
 580             || (sym->value && sym->ns->proc_name->attr.is_main_program)
 581             || (gfc_option.coarray == GFC_FCOARRAY_LIB
 582                 && sym->attr.codimension && !sym->attr.allocatable)))
 583     TREE_STATIC (decl) = 1;
 584
 585   if (sym->attr.volatile_)
 586     {
 587       TREE_THIS_VOLATILE (decl) = 1;
 588       TREE_SIDE_EFFECTS (decl) = 1;
 589       new_type = build_qualified_type (TREE_TYPE (decl), TYPE_QUAL_VOLATILE);
 590       TREE_TYPE (decl) = new_type;
 591     }
 592
 593   /* Keep variables larger than max-stack-var-size off stack.  */
 594   if (!sym->ns->proc_name->attr.recursive
 595       && INTEGER_CST_P (DECL_SIZE_UNIT (decl))
 596       && !gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl))
 597          /* Put variable length auto array pointers always into stack.  */
 598       && (TREE_CODE (TREE_TYPE (decl)) != POINTER_TYPE
 599           || sym->attr.dimension == 0
 600           || sym->as->type != AS_EXPLICIT
 601           || sym->attr.pointer
 602           || sym->attr.allocatable)
 603       && !DECL_ARTIFICIAL (decl))
 604     TREE_STATIC (decl) = 1;
 605
 606   /* Handle threadprivate variables.  */
 607   if (sym->attr.threadprivate
 608       && (TREE_STATIC (decl) || DECL_EXTERNAL (decl)))
 609     DECL_TLS_MODEL (decl) = decl_default_tls_model (decl);
 610
 611   if (!sym->attr.target
 612       && !sym->attr.pointer
 613       && !sym->attr.cray_pointee
 614       && !sym->attr.proc_pointer)
 615     DECL_RESTRICTED_P (decl) = 1;
 616 }
 617
 618
 619 /* Allocate the lang-specific part of a decl.  */
 620
 621 void
 622 gfc_allocate_lang_decl (tree decl)
 623 {
 624   DECL_LANG_SPECIFIC (decl) = ggc_alloc_cleared_lang_decl(sizeof
 625                                                           (struct lang_decl));
 626 }
 627
 628 /* Remember a symbol to generate initialization/cleanup code at function
 629    entry/exit.  */
 630
 631 static void
 632 gfc_defer_symbol_init (gfc_symbol * sym)
 633 {
 634   gfc_symbol *p;
 635   gfc_symbol *last;
 636   gfc_symbol *head;
 637
 638   /* Don't add a symbol twice.  */
 639   if (sym->tlink)
 640     return;
 641
 642   last = head = sym->ns->proc_name;
 643   p = last->tlink;
 644
 645   /* Make sure that setup code for dummy variables which are used in the
 646      setup of other variables is generated first.  */
 647   if (sym->attr.dummy)
 648     {
 649       /* Find the first dummy arg seen after us, or the first non-dummy arg.
 650          This is a circular list, so don't go past the head.  */
 651       while (p != head
 652              && (!p->attr.dummy || p->dummy_order > sym->dummy_order))
 653         {
 654           last = p;
 655           p = p->tlink;
 656         }
 657     }
 658   /* Insert in between last and p.  */
 659   last->tlink = sym;
 660   sym->tlink = p;
 661 }
 662
 663
 664 /* Used in gfc_get_symbol_decl and gfc_get_derived_type to obtain the
 665    backend_decl for a module symbol, if it all ready exists.  If the
 666    module gsymbol does not exist, it is created.  If the symbol does
 667    not exist, it is added to the gsymbol namespace.  Returns true if
 668    an existing backend_decl is found.  */
 669
 670 bool
 671 gfc_get_module_backend_decl (gfc_symbol *sym)
 672 {
 673   gfc_gsymbol *gsym;
 674   gfc_symbol *s;
 675   gfc_symtree *st;
 676
 677   gsym =  gfc_find_gsymbol (gfc_gsym_root, sym->module);
 678
 679   if (!gsym || (gsym->ns && gsym->type == GSYM_MODULE))
 680     {
 681       st = NULL;
 682       s = NULL;
 683
 684       if (gsym)
 685         gfc_find_symbol (sym->name, gsym->ns, 0, &s);
 686
 687       if (!s)
 688         {
 689           if (!gsym)
 690             {
 691               gsym = gfc_get_gsymbol (sym->module);
 692               gsym->type = GSYM_MODULE;
 693               gsym->ns = gfc_get_namespace (NULL, 0);
 694             }
 695
 696           st = gfc_new_symtree (&gsym->ns->sym_root, sym->name);
 697           st->n.sym = sym;
 698           sym->refs++;
 699         }
 700       else if (sym->attr.flavor == FL_DERIVED)
 701         {
 702           if (s && s->attr.flavor == FL_PROCEDURE)
 703             {
 704               gfc_interface *intr;
 705               gcc_assert (s->attr.generic);
 706               for (intr = s->generic; intr; intr = intr->next)
 707                 if (intr->sym->attr.flavor == FL_DERIVED)
 708                   {
 709                     s = intr->sym;
 710                     break;
 711                   }
 712             }
 713
 714           if (!s->backend_decl)
 715             s->backend_decl = gfc_get_derived_type (s);
 716           gfc_copy_dt_decls_ifequal (s, sym, true);
 717           return true;
 718         }
 719       else if (s->backend_decl)
 720         {
 721           if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
 722             gfc_copy_dt_decls_ifequal (s->ts.u.derived, sym->ts.u.derived,
 723                                        true);
 724           else if (sym->ts.type == BT_CHARACTER)
 725             sym->ts.u.cl->backend_decl = s->ts.u.cl->backend_decl;
 726           sym->backend_decl = s->backend_decl;
 727           return true;
 728         }
 729     }
 730   return false;
 731 }
 732
 733
 734 /* Create an array index type variable with function scope.  */
 735
 736 static tree
 737 create_index_var (const char * pfx, int nest)
 738 {
 739   tree decl;
 740
 741   decl = gfc_create_var_np (gfc_array_index_type, pfx);
 742   if (nest)
 743     gfc_add_decl_to_parent_function (decl);
 744   else
 745     gfc_add_decl_to_function (decl);
 746   return decl;
 747 }
 748
 749
 750 /* Create variables to hold all the non-constant bits of info for a
 751    descriptorless array.  Remember these in the lang-specific part of the
 752    type.  */
 753
 754 static void
 755 gfc_build_qualified_array (tree decl, gfc_symbol * sym)
 756 {
 757   tree type;
 758   int dim;
 759   int nest;
 760   gfc_namespace* procns;
 761
 762   type = TREE_TYPE (decl);
 763
 764   /* We just use the descriptor, if there is one.  */
 765   if (GFC_DESCRIPTOR_TYPE_P (type))
 766     return;
 767
 768   gcc_assert (GFC_ARRAY_TYPE_P (type));
 769   procns = gfc_find_proc_namespace (sym->ns);
 770   nest = (procns->proc_name->backend_decl != current_function_decl)
 771          && !sym->attr.contained;
 772
 773   if (sym->attr.codimension && gfc_option.coarray == GFC_FCOARRAY_LIB
 774       && sym->as->type != AS_ASSUMED_SHAPE
 775       && GFC_TYPE_ARRAY_CAF_TOKEN (type) == NULL_TREE)
 776     {
 777       tree token;
 778
 779       token = gfc_create_var_np (build_qualified_type (pvoid_type_node,
 780                                                        TYPE_QUAL_RESTRICT),
 781                                  "caf_token");
 782       GFC_TYPE_ARRAY_CAF_TOKEN (type) = token;
 783       DECL_ARTIFICIAL (token) = 1;
 784       TREE_STATIC (token) = 1;
 785       gfc_add_decl_to_function (token);
 786     }
 787
 788   for (dim = 0; dim < GFC_TYPE_ARRAY_RANK (type); dim++)
 789     {
 790       if (GFC_TYPE_ARRAY_LBOUND (type, dim) == NULL_TREE)
 791         {
 792           GFC_TYPE_ARRAY_LBOUND (type, dim) = create_index_var ("lbound", nest);
 793           TREE_NO_WARNING (GFC_TYPE_ARRAY_LBOUND (type, dim)) = 1;
 794         }
 795       /* Don't try to use the unknown bound for assumed shape arrays.  */
 796       if (GFC_TYPE_ARRAY_UBOUND (type, dim) == NULL_TREE
 797           && (sym->as->type != AS_ASSUMED_SIZE
 798               || dim < GFC_TYPE_ARRAY_RANK (type) - 1))
 799         {
 800           GFC_TYPE_ARRAY_UBOUND (type, dim) = create_index_var ("ubound", nest);
 801           TREE_NO_WARNING (GFC_TYPE_ARRAY_UBOUND (type, dim)) = 1;
 802         }
 803
 804       if (GFC_TYPE_ARRAY_STRIDE (type, dim) == NULL_TREE)
 805         {
 806           GFC_TYPE_ARRAY_STRIDE (type, dim) = create_index_var ("stride", nest);
 807           TREE_NO_WARNING (GFC_TYPE_ARRAY_STRIDE (type, dim)) = 1;
 808         }
 809     }
 810   for (dim = GFC_TYPE_ARRAY_RANK (type);
 811        dim < GFC_TYPE_ARRAY_RANK (type) + GFC_TYPE_ARRAY_CORANK (type); dim++)
 812     {
 813       if (GFC_TYPE_ARRAY_LBOUND (type, dim) == NULL_TREE)
 814         {
 815           GFC_TYPE_ARRAY_LBOUND (type, dim) = create_index_var ("lbound", nest);
 816           TREE_NO_WARNING (GFC_TYPE_ARRAY_LBOUND (type, dim)) = 1;
 817         }
 818       /* Don't try to use the unknown ubound for the last coarray dimension.  */
 819       if (GFC_TYPE_ARRAY_UBOUND (type, dim) == NULL_TREE
 820           && dim < GFC_TYPE_ARRAY_RANK (type) + GFC_TYPE_ARRAY_CORANK (type) - 1)
 821         {
 822           GFC_TYPE_ARRAY_UBOUND (type, dim) = create_index_var ("ubound", nest);
 823           TREE_NO_WARNING (GFC_TYPE_ARRAY_UBOUND (type, dim)) = 1;
 824         }
 825     }
 826   if (GFC_TYPE_ARRAY_OFFSET (type) == NULL_TREE)
 827     {
 828       GFC_TYPE_ARRAY_OFFSET (type) = gfc_create_var_np (gfc_array_index_type,
 829                                                         "offset");
 830       TREE_NO_WARNING (GFC_TYPE_ARRAY_OFFSET (type)) = 1;
 831
 832       if (nest)
 833         gfc_add_decl_to_parent_function (GFC_TYPE_ARRAY_OFFSET (type));
 834       else
 835         gfc_add_decl_to_function (GFC_TYPE_ARRAY_OFFSET (type));
 836     }
 837
 838   if (GFC_TYPE_ARRAY_SIZE (type) == NULL_TREE
 839       && sym->as->type != AS_ASSUMED_SIZE)
 840     {
 841       GFC_TYPE_ARRAY_SIZE (type) = create_index_var ("size", nest);
 842       TREE_NO_WARNING (GFC_TYPE_ARRAY_SIZE (type)) = 1;
 843     }
 844
 845   if (POINTER_TYPE_P (type))
 846     {
 847       gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (type)));
 848       gcc_assert (TYPE_LANG_SPECIFIC (type)
 849                   == TYPE_LANG_SPECIFIC (TREE_TYPE (type)));
 850       type = TREE_TYPE (type);
 851     }
 852
 853   if (! COMPLETE_TYPE_P (type) && GFC_TYPE_ARRAY_SIZE (type))
 854     {
 855       tree size, range;
 856
 857       size = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
 858                               GFC_TYPE_ARRAY_SIZE (type), gfc_index_one_node);
 859       range = build_range_type (gfc_array_index_type, gfc_index_zero_node,
 860                                 size);
 861       TYPE_DOMAIN (type) = range;
 862       layout_type (type);
 863     }
 864
 865   if (TYPE_NAME (type) != NULL_TREE
 866       && GFC_TYPE_ARRAY_UBOUND (type, sym->as->rank - 1) != NULL_TREE
 867       && TREE_CODE (GFC_TYPE_ARRAY_UBOUND (type, sym->as->rank - 1)) == VAR_DECL)
 868     {
 869       tree gtype = DECL_ORIGINAL_TYPE (TYPE_NAME (type));
 870
 871       for (dim = 0; dim < sym->as->rank - 1; dim++)
 872         {
 873           gcc_assert (TREE_CODE (gtype) == ARRAY_TYPE);
 874           gtype = TREE_TYPE (gtype);
 875         }
 876       gcc_assert (TREE_CODE (gtype) == ARRAY_TYPE);
 877       if (TYPE_MAX_VALUE (TYPE_DOMAIN (gtype)) == NULL)
 878         TYPE_NAME (type) = NULL_TREE;
 879     }
 880
 881   if (TYPE_NAME (type) == NULL_TREE)
 882     {
 883       tree gtype = TREE_TYPE (type), rtype, type_decl;
 884
 885       for (dim = sym->as->rank - 1; dim >= 0; dim--)
 886         {
 887           tree lbound, ubound;
 888           lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
 889           ubound = GFC_TYPE_ARRAY_UBOUND (type, dim);
 890           rtype = build_range_type (gfc_array_index_type, lbound, ubound);
 891           gtype = build_array_type (gtype, rtype);
 892           /* Ensure the bound variables aren't optimized out at -O0.
 893              For -O1 and above they often will be optimized out, but
 894              can be tracked by VTA.  Also set DECL_NAMELESS, so that
 895              the artificial lbound.N or ubound.N DECL_NAME doesn't
 896              end up in debug info.  */
 897           if (lbound && TREE_CODE (lbound) == VAR_DECL
 898               && DECL_ARTIFICIAL (lbound) && DECL_IGNORED_P (lbound))
 899             {
 900               if (DECL_NAME (lbound)
 901                   && strstr (IDENTIFIER_POINTER (DECL_NAME (lbound)),
 902                              "lbound") != 0)
 903                 DECL_NAMELESS (lbound) = 1;
 904               DECL_IGNORED_P (lbound) = 0;
 905             }
 906           if (ubound && TREE_CODE (ubound) == VAR_DECL
 907               && DECL_ARTIFICIAL (ubound) && DECL_IGNORED_P (ubound))
 908             {
 909               if (DECL_NAME (ubound)
 910                   && strstr (IDENTIFIER_POINTER (DECL_NAME (ubound)),
 911                              "ubound") != 0)
 912                 DECL_NAMELESS (ubound) = 1;
 913               DECL_IGNORED_P (ubound) = 0;
 914             }
 915         }
 916       TYPE_NAME (type) = type_decl = build_decl (input_location,
 917                                                  TYPE_DECL, NULL, gtype);
 918       DECL_ORIGINAL_TYPE (type_decl) = gtype;
 919     }
 920 }
 921
 922
 923 /* For some dummy arguments we don't use the actual argument directly.
 924    Instead we create a local decl and use that.  This allows us to perform
 925    initialization, and construct full type information.  */
 926
 927 static tree
 928 gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy)
 929 {
 930   tree decl;
 931   tree type;
 932   gfc_array_spec *as;
 933   char *name;
 934   gfc_packed packed;
 935   int n;
 936   bool known_size;
 937
 938   if (sym->attr.pointer || sym->attr.allocatable)
 939     return dummy;
 940
 941   /* Add to list of variables if not a fake result variable.  */
 942   if (sym->attr.result || sym->attr.dummy)
 943     gfc_defer_symbol_init (sym);
 944
 945   type = TREE_TYPE (dummy);
 946   gcc_assert (TREE_CODE (dummy) == PARM_DECL
 947           && POINTER_TYPE_P (type));
 948
 949   /* Do we know the element size?  */
 950   known_size = sym->ts.type != BT_CHARACTER
 951           || INTEGER_CST_P (sym->ts.u.cl->backend_decl);
 952
 953   if (known_size && !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type)))
 954     {
 955       /* For descriptorless arrays with known element size the actual
 956          argument is sufficient.  */
 957       gcc_assert (GFC_ARRAY_TYPE_P (type));
 958       gfc_build_qualified_array (dummy, sym);
 959       return dummy;
 960     }
 961
 962   type = TREE_TYPE (type);
 963   if (GFC_DESCRIPTOR_TYPE_P (type))
 964     {
 965       /* Create a descriptorless array pointer.  */
 966       as = sym->as;
 967       packed = PACKED_NO;
 968
 969       /* Even when -frepack-arrays is used, symbols with TARGET attribute
 970          are not repacked.  */
 971       if (!gfc_option.flag_repack_arrays || sym->attr.target)
 972         {
 973           if (as->type == AS_ASSUMED_SIZE)
 974             packed = PACKED_FULL;
 975         }
 976       else
 977         {
 978           if (as->type == AS_EXPLICIT)
 979             {
 980               packed = PACKED_FULL;
 981               for (n = 0; n < as->rank; n++)
 982                 {
 983                   if (!(as->upper[n]
 984                         && as->lower[n]
 985                         && as->upper[n]->expr_type == EXPR_CONSTANT
 986                         && as->lower[n]->expr_type == EXPR_CONSTANT))
 987                     packed = PACKED_PARTIAL;
 988                 }
 989             }
 990           else
 991             packed = PACKED_PARTIAL;
 992         }
 993
 994       type = gfc_typenode_for_spec (&sym->ts);
 995       type = gfc_get_nodesc_array_type (type, sym->as, packed,
 996                                         !sym->attr.target);
 997     }
 998   else
 999     {
1000       /* We now have an expression for the element size, so create a fully
1001          qualified type.  Reset sym->backend decl or this will just return the
1002          old type.  */
1003       DECL_ARTIFICIAL (sym->backend_decl) = 1;
1004       sym->backend_decl = NULL_TREE;
1005       type = gfc_sym_type (sym);
1006       packed = PACKED_FULL;
1007     }
1008
1009   ASM_FORMAT_PRIVATE_NAME (name, IDENTIFIER_POINTER (DECL_NAME (dummy)), 0);
1010   decl = build_decl (input_location,
1011                      VAR_DECL, get_identifier (name), type);
1012
1013   DECL_ARTIFICIAL (decl) = 1;
1014   DECL_NAMELESS (decl) = 1;
1015   TREE_PUBLIC (decl) = 0;
1016   TREE_STATIC (decl) = 0;
1017   DECL_EXTERNAL (decl) = 0;
1018
1019   /* We should never get deferred shape arrays here.  We used to because of
1020      frontend bugs.  */
1021   gcc_assert (sym->as->type != AS_DEFERRED);
1022
1023   if (packed == PACKED_PARTIAL)
1024     GFC_DECL_PARTIAL_PACKED_ARRAY (decl) = 1;
1025   else if (packed == PACKED_FULL)
1026     GFC_DECL_PACKED_ARRAY (decl) = 1;
1027
1028   gfc_build_qualified_array (decl, sym);
1029
1030   if (DECL_LANG_SPECIFIC (dummy))
1031     DECL_LANG_SPECIFIC (decl) = DECL_LANG_SPECIFIC (dummy);
1032   else
1033     gfc_allocate_lang_decl (decl);
1034
1035   GFC_DECL_SAVED_DESCRIPTOR (decl) = dummy;
1036
1037   if (sym->ns->proc_name->backend_decl == current_function_decl
1038       || sym->attr.contained)
1039     gfc_add_decl_to_function (decl);
1040   else
1041     gfc_add_decl_to_parent_function (decl);
1042
1043   return decl;
1044 }
1045
1046 /* For symbol SYM with GFC_DECL_SAVED_DESCRIPTOR used in contained
1047    function add a VAR_DECL to the current function with DECL_VALUE_EXPR
1048    pointing to the artificial variable for debug info purposes.  */
1049
1050 static void
1051 gfc_nonlocal_dummy_array_decl (gfc_symbol *sym)
1052 {
1053   tree decl, dummy;
1054
1055   if (! nonlocal_dummy_decl_pset)
1056     nonlocal_dummy_decl_pset = pointer_set_create ();
1057
1058   if (pointer_set_insert (nonlocal_dummy_decl_pset, sym->backend_decl))
1059     return;
1060
1061   dummy = GFC_DECL_SAVED_DESCRIPTOR (sym->backend_decl);
1062   decl = build_decl (input_location, VAR_DECL, DECL_NAME (dummy),
1063                      TREE_TYPE (sym->backend_decl));
1064   DECL_ARTIFICIAL (decl) = 0;
1065   TREE_USED (decl) = 1;
1066   TREE_PUBLIC (decl) = 0;
1067   TREE_STATIC (decl) = 0;
1068   DECL_EXTERNAL (decl) = 0;
1069   if (DECL_BY_REFERENCE (dummy))
1070     DECL_BY_REFERENCE (decl) = 1;
1071   DECL_LANG_SPECIFIC (decl) = DECL_LANG_SPECIFIC (sym->backend_decl);
1072   SET_DECL_VALUE_EXPR (decl, sym->backend_decl);
1073   DECL_HAS_VALUE_EXPR_P (decl) = 1;
1074   DECL_CONTEXT (decl) = DECL_CONTEXT (sym->backend_decl);
1075   DECL_CHAIN (decl) = nonlocal_dummy_decls;
1076   nonlocal_dummy_decls = decl;
1077 }
1078
1079 /* Return a constant or a variable to use as a string length.  Does not
1080    add the decl to the current scope.  */
1081
1082 static tree
1083 gfc_create_string_length (gfc_symbol * sym)
1084 {
1085   gcc_assert (sym->ts.u.cl);
1086   gfc_conv_const_charlen (sym->ts.u.cl);
1087
1088   if (sym->ts.u.cl->backend_decl == NULL_TREE)
1089     {
1090       tree length;
1091       char name[GFC_MAX_MANGLED_SYMBOL_LEN + 2];
1092
1093       /* Also prefix the mangled name.  */
1094       strcpy (&name[1], sym->name);
1095       name[0] = '.';
1096       length = build_decl (input_location,
1097                            VAR_DECL, get_identifier (name),
1098                            gfc_charlen_type_node);
1099       DECL_ARTIFICIAL (length) = 1;
1100       TREE_USED (length) = 1;
1101       if (sym->ns->proc_name->tlink != NULL)
1102         gfc_defer_symbol_init (sym);
1103
1104       sym->ts.u.cl->backend_decl = length;
1105     }
1106
1107   gcc_assert (sym->ts.u.cl->backend_decl != NULL_TREE);
1108   return sym->ts.u.cl->backend_decl;
1109 }
1110
1111 /* If a variable is assigned a label, we add another two auxiliary
1112    variables.  */
1113
1114 static void
1115 gfc_add_assign_aux_vars (gfc_symbol * sym)
1116 {
1117   tree addr;
1118   tree length;
1119   tree decl;
1120
1121   gcc_assert (sym->backend_decl);
1122
1123   decl = sym->backend_decl;
1124   gfc_allocate_lang_decl (decl);
1125   GFC_DECL_ASSIGN (decl) = 1;
1126   length = build_decl (input_location,
1127                        VAR_DECL, create_tmp_var_name (sym->name),
1128                        gfc_charlen_type_node);
1129   addr = build_decl (input_location,
1130                      VAR_DECL, create_tmp_var_name (sym->name),
1131                      pvoid_type_node);
1132   gfc_finish_var_decl (length, sym);
1133   gfc_finish_var_decl (addr, sym);
1134   /*  STRING_LENGTH is also used as flag. Less than -1 means that
1135       ASSIGN_ADDR can not be used. Equal -1 means that ASSIGN_ADDR is the
1136       target label's address. Otherwise, value is the length of a format string
1137       and ASSIGN_ADDR is its address.  */
1138   if (TREE_STATIC (length))
1139     DECL_INITIAL (length) = build_int_cst (gfc_charlen_type_node, -2);
1140   else
1141     gfc_defer_symbol_init (sym);
1142
1143   GFC_DECL_STRING_LEN (decl) = length;
1144   GFC_DECL_ASSIGN_ADDR (decl) = addr;
1145 }
1146
1147
1148 static tree
1149 add_attributes_to_decl (symbol_attribute sym_attr, tree list)
1150 {
1151   unsigned id;
1152   tree attr;
1153
1154   for (id = 0; id < EXT_ATTR_NUM; id++)
1155     if (sym_attr.ext_attr & (1 << id))
1156       {
1157         attr = build_tree_list (
1158                  get_identifier (ext_attr_list[id].middle_end_name),
1159                                  NULL_TREE);
1160         list = chainon (list, attr);
1161       }
1162
1163   return list;
1164 }
1165
1166
1167 static void build_function_decl (gfc_symbol * sym, bool global);
1168
1169
1170 /* Return the decl for a gfc_symbol, create it if it doesn't already
1171    exist.  */
1172
1173 tree
1174 gfc_get_symbol_decl (gfc_symbol * sym)
1175 {
1176   tree decl;
1177   tree length = NULL_TREE;
1178   tree attributes;
1179   int byref;
1180   bool intrinsic_array_parameter = false;
1181
1182   gcc_assert (sym->attr.referenced
1183                 || sym->attr.use_assoc
1184                 || sym->ns->proc_name->attr.if_source == IFSRC_IFBODY
1185                 || (sym->module && sym->attr.if_source != IFSRC_DECL
1186                     && sym->backend_decl));
1187
1188   if (sym->ns && sym->ns->proc_name && sym->ns->proc_name->attr.function)
1189     byref = gfc_return_by_reference (sym->ns->proc_name);
1190   else
1191     byref = 0;
1192
1193   /* Make sure that the vtab for the declared type is completed.  */
1194   if (sym->ts.type == BT_CLASS)
1195     {
1196       gfc_component *c = CLASS_DATA (sym);
1197       if (!c->ts.u.derived->backend_decl)
1198         {
1199           gfc_find_derived_vtab (c->ts.u.derived);
1200           gfc_get_derived_type (sym->ts.u.derived);
1201         }
1202     }
1203
1204   /* All deferred character length procedures need to retain the backend
1205      decl, which is a pointer to the character length in the caller's
1206      namespace and to declare a local character length.  */
1207   if (!byref && sym->attr.function
1208         && sym->ts.type == BT_CHARACTER
1209         && sym->ts.deferred
1210         && sym->ts.u.cl->passed_length == NULL
1211         && sym->ts.u.cl->backend_decl
1212         && TREE_CODE (sym->ts.u.cl->backend_decl) == PARM_DECL)
1213     {
1214       sym->ts.u.cl->passed_length = sym->ts.u.cl->backend_decl;
1215       sym->ts.u.cl->backend_decl = NULL_TREE;
1216       length = gfc_create_string_length (sym);
1217     }
1218
1219   if ((sym->attr.dummy && ! sym->attr.function) || (sym->attr.result && byref))
1220     {
1221       /* Return via extra parameter.  */
1222       if (sym->attr.result && byref
1223           && !sym->backend_decl)
1224         {
1225           sym->backend_decl =
1226             DECL_ARGUMENTS (sym->ns->proc_name->backend_decl);
1227           /* For entry master function skip over the __entry
1228              argument.  */
1229           if (sym->ns->proc_name->attr.entry_master)
1230             sym->backend_decl = DECL_CHAIN (sym->backend_decl);
1231         }
1232
1233       /* Dummy variables should already have been created.  */
1234       gcc_assert (sym->backend_decl);
1235
1236       /* Create a character length variable.  */
1237       if (sym->ts.type == BT_CHARACTER)
1238         {
1239           /* For a deferred dummy, make a new string length variable.  */
1240           if (sym->ts.deferred
1241                 &&
1242              (sym->ts.u.cl->passed_length == sym->ts.u.cl->backend_decl))
1243             sym->ts.u.cl->backend_decl = NULL_TREE;
1244
1245           if (sym->ts.deferred && sym->attr.result
1246                 && sym->ts.u.cl->passed_length == NULL
1247                 && sym->ts.u.cl->backend_decl)
1248             {
1249               sym->ts.u.cl->passed_length = sym->ts.u.cl->backend_decl;
1250               sym->ts.u.cl->backend_decl = NULL_TREE;
1251             }
1252
1253           if (sym->ts.u.cl->backend_decl == NULL_TREE)
1254             length = gfc_create_string_length (sym);
1255           else
1256             length = sym->ts.u.cl->backend_decl;
1257           if (TREE_CODE (length) == VAR_DECL
1258               && DECL_FILE_SCOPE_P (length))
1259             {
1260               /* Add the string length to the same context as the symbol.  */
1261               if (DECL_CONTEXT (sym->backend_decl) == current_function_decl)
1262                 gfc_add_decl_to_function (length);
1263               else
1264                 gfc_add_decl_to_parent_function (length);
1265
1266               gcc_assert (DECL_CONTEXT (sym->backend_decl) ==
1267                             DECL_CONTEXT (length));
1268
1269               gfc_defer_symbol_init (sym);
1270             }
1271         }
1272
1273       /* Use a copy of the descriptor for dummy arrays.  */
1274       if ((sym->attr.dimension || sym->attr.codimension)
1275          && !TREE_USED (sym->backend_decl))
1276         {
1277           decl = gfc_build_dummy_array_decl (sym, sym->backend_decl);
1278           /* Prevent the dummy from being detected as unused if it is copied.  */
1279           if (sym->backend_decl != NULL && decl != sym->backend_decl)
1280             DECL_ARTIFICIAL (sym->backend_decl) = 1;
1281           sym->backend_decl = decl;
1282         }
1283
1284       TREE_USED (sym->backend_decl) = 1;
1285       if (sym->attr.assign && GFC_DECL_ASSIGN (sym->backend_decl) == 0)
1286         {
1287           gfc_add_assign_aux_vars (sym);
1288         }
1289
1290       if (sym->attr.dimension
1291           && DECL_LANG_SPECIFIC (sym->backend_decl)
1292           && GFC_DECL_SAVED_DESCRIPTOR (sym->backend_decl)
1293           && DECL_CONTEXT (sym->backend_decl) != current_function_decl)
1294         gfc_nonlocal_dummy_array_decl (sym);
1295
1296       if (sym->ts.type == BT_CLASS && sym->backend_decl)
1297         GFC_DECL_CLASS(sym->backend_decl) = 1;
1298
1299       if (sym->ts.type == BT_CLASS && sym->backend_decl)
1300         GFC_DECL_CLASS(sym->backend_decl) = 1;
1301      return sym->backend_decl;
1302     }
1303
1304   if (sym->backend_decl)
1305     return sym->backend_decl;
1306
1307   /* Special case for array-valued named constants from intrinsic
1308      procedures; those are inlined.  */
1309   if (sym->attr.use_assoc && sym->from_intmod
1310       && sym->attr.flavor == FL_PARAMETER)
1311     intrinsic_array_parameter = true;
1312
1313   /* If use associated and whole file compilation, use the module
1314      declaration.  */
1315   if (gfc_option.flag_whole_file
1316         && (sym->attr.flavor == FL_VARIABLE
1317             || sym->attr.flavor == FL_PARAMETER)
1318         && sym->attr.use_assoc
1319         && !intrinsic_array_parameter
1320         && sym->module
1321         && gfc_get_module_backend_decl (sym))
1322     {
1323       if (sym->ts.type == BT_CLASS && sym->backend_decl)
1324         GFC_DECL_CLASS(sym->backend_decl) = 1;
1325       return sym->backend_decl;
1326     }
1327
1328   if (sym->attr.flavor == FL_PROCEDURE)
1329     {
1330       /* Catch function declarations. Only used for actual parameters,
1331          procedure pointers and procptr initialization targets.  */
1332       if (sym->attr.external || sym->attr.use_assoc || sym->attr.intrinsic)
1333         {
1334           decl = gfc_get_extern_function_decl (sym);
1335           gfc_set_decl_location (decl, &sym->declared_at);
1336         }
1337       else
1338         {
1339           if (!sym->backend_decl)
1340             build_function_decl (sym, false);
1341           decl = sym->backend_decl;
1342         }
1343       return decl;
1344     }
1345
1346   if (sym->attr.intrinsic)
1347     internal_error ("intrinsic variable which isn't a procedure");
1348
1349   /* Create string length decl first so that they can be used in the
1350      type declaration.  */
1351   if (sym->ts.type == BT_CHARACTER)
1352     length = gfc_create_string_length (sym);
1353
1354   /* Create the decl for the variable.  */
1355   decl = build_decl (sym->declared_at.lb->location,
1356                      VAR_DECL, gfc_sym_identifier (sym), gfc_sym_type (sym));
1357
1358   /* Add attributes to variables.  Functions are handled elsewhere.  */
1359   attributes = add_attributes_to_decl (sym->attr, NULL_TREE);
1360   decl_attributes (&decl, attributes, 0);
1361
1362   /* Symbols from modules should have their assembler names mangled.
1363      This is done here rather than in gfc_finish_var_decl because it
1364      is different for string length variables.  */
1365   if (sym->module)
1366     {
1367       gfc_set_decl_assembler_name (decl, gfc_sym_mangled_identifier (sym));
1368       if (sym->attr.use_assoc && !intrinsic_array_parameter)
1369         DECL_IGNORED_P (decl) = 1;
1370     }
1371
1372   if (sym->attr.select_type_temporary)
1373     {
1374       DECL_ARTIFICIAL (decl) = 1;
1375       DECL_IGNORED_P (decl) = 1;
1376     }
1377
1378   if (sym->attr.dimension || sym->attr.codimension)
1379     {
1380       /* Create variables to hold the non-constant bits of array info.  */
1381       gfc_build_qualified_array (decl, sym);
1382
1383       if (sym->attr.contiguous
1384           || ((sym->attr.allocatable || !sym->attr.dummy) && !sym->attr.pointer))
1385         GFC_DECL_PACKED_ARRAY (decl) = 1;
1386     }
1387
1388   /* Remember this variable for allocation/cleanup.  */
1389   if (sym->attr.dimension || sym->attr.allocatable || sym->attr.codimension
1390       || (sym->ts.type == BT_CLASS &&
1391           (CLASS_DATA (sym)->attr.dimension
1392            || CLASS_DATA (sym)->attr.allocatable))
1393       || (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.alloc_comp)
1394       /* This applies a derived type default initializer.  */
1395       || (sym->ts.type == BT_DERIVED
1396           && sym->attr.save == SAVE_NONE
1397           && !sym->attr.data
1398           && !sym->attr.allocatable
1399           && (sym->value && !sym->ns->proc_name->attr.is_main_program)
1400           && !(sym->attr.use_assoc && !intrinsic_array_parameter)))
1401     gfc_defer_symbol_init (sym);
1402
1403   gfc_finish_var_decl (decl, sym);
1404
1405   if (sym->ts.type == BT_CHARACTER)
1406     {
1407       /* Character variables need special handling.  */
1408       gfc_allocate_lang_decl (decl);
1409
1410       if (TREE_CODE (length) != INTEGER_CST)
1411         {
1412           char name[GFC_MAX_MANGLED_SYMBOL_LEN + 2];
1413
1414           if (sym->module)
1415             {
1416               /* Also prefix the mangled name for symbols from modules.  */
1417               strcpy (&name[1], sym->name);
1418               name[0] = '.';
1419               strcpy (&name[1],
1420                       IDENTIFIER_POINTER (DECL_ASSEMBLER_NAME (length)));
1421               gfc_set_decl_assembler_name (decl, get_identifier (name));
1422             }
1423           gfc_finish_var_decl (length, sym);
1424           gcc_assert (!sym->value);
1425         }
1426     }
1427   else if (sym->attr.subref_array_pointer)
1428     {
1429       /* We need the span for these beasts.  */
1430       gfc_allocate_lang_decl (decl);
1431     }
1432
1433   if (sym->attr.subref_array_pointer)
1434     {
1435       tree span;
1436       GFC_DECL_SUBREF_ARRAY_P (decl) = 1;
1437       span = build_decl (input_location,
1438                          VAR_DECL, create_tmp_var_name ("span"),
1439                          gfc_array_index_type);
1440       gfc_finish_var_decl (span, sym);
1441       TREE_STATIC (span) = TREE_STATIC (decl);
1442       DECL_ARTIFICIAL (span) = 1;
1443
1444       GFC_DECL_SPAN (decl) = span;
1445       GFC_TYPE_ARRAY_SPAN (TREE_TYPE (decl)) = span;
1446     }
1447
1448   if (sym->ts.type == BT_CLASS)
1449         GFC_DECL_CLASS(decl) = 1;
1450
1451   sym->backend_decl = decl;
1452
1453   if (sym->attr.assign)
1454     gfc_add_assign_aux_vars (sym);
1455
1456   if (intrinsic_array_parameter)
1457     {
1458       TREE_STATIC (decl) = 1;
1459       DECL_EXTERNAL (decl) = 0;
1460     }
1461
1462   if (TREE_STATIC (decl)
1463       && !(sym->attr.use_assoc && !intrinsic_array_parameter)
1464       && (sym->attr.save || sym->ns->proc_name->attr.is_main_program
1465           || gfc_option.flag_max_stack_var_size == 0
1466           || sym->attr.data || sym->ns->proc_name->attr.flavor == FL_MODULE)
1467       && (gfc_option.coarray != GFC_FCOARRAY_LIB
1468           || !sym->attr.codimension || sym->attr.allocatable))
1469     {
1470       /* Add static initializer. For procedures, it is only needed if
1471          SAVE is specified otherwise they need to be reinitialized
1472          every time the procedure is entered. The TREE_STATIC is
1473          in this case due to -fmax-stack-var-size=.  */
1474       DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
1475                                                   TREE_TYPE (decl),
1476                                                   sym->attr.dimension
1477                                                   || (sym->attr.codimension
1478                                                       && sym->attr.allocatable),
1479                                                   sym->attr.pointer
1480                                                   || sym->attr.allocatable,
1481                                                   sym->attr.proc_pointer);
1482     }
1483
1484   if (!TREE_STATIC (decl)
1485       && POINTER_TYPE_P (TREE_TYPE (decl))
1486       && !sym->attr.pointer
1487       && !sym->attr.allocatable
1488       && !sym->attr.proc_pointer
1489       && !sym->attr.select_type_temporary)
1490     DECL_BY_REFERENCE (decl) = 1;
1491
1492   if (sym->attr.vtab
1493       || (sym->name[0] == '_' && strncmp ("__def_init", sym->name, 10) == 0))
1494     {
1495       TREE_READONLY (decl) = 1;
1496       GFC_DECL_PUSH_TOPLEVEL (decl) = 1;
1497     }
1498
1499   return decl;
1500 }
1501
1502
1503 /* Substitute a temporary variable in place of the real one.  */
1504
1505 void
1506 gfc_shadow_sym (gfc_symbol * sym, tree decl, gfc_saved_var * save)
1507 {
1508   save->attr = sym->attr;
1509   save->decl = sym->backend_decl;
1510
1511   gfc_clear_attr (&sym->attr);
1512   sym->attr.referenced = 1;
1513   sym->attr.flavor = FL_VARIABLE;
1514
1515   sym->backend_decl = decl;
1516 }
1517
1518
1519 /* Restore the original variable.  */
1520
1521 void
1522 gfc_restore_sym (gfc_symbol * sym, gfc_saved_var * save)
1523 {
1524   sym->attr = save->attr;
1525   sym->backend_decl = save->decl;
1526 }
1527
1528
1529 /* Declare a procedure pointer.  */
1530
1531 static tree
1532 get_proc_pointer_decl (gfc_symbol *sym)
1533 {
1534   tree decl;
1535   tree attributes;
1536
1537   decl = sym->backend_decl;
1538   if (decl)
1539     return decl;
1540
1541   decl = build_decl (input_location,
1542                      VAR_DECL, get_identifier (sym->name),
1543                      build_pointer_type (gfc_get_function_type (sym)));
1544
1545   if ((sym->ns->proc_name
1546       && sym->ns->proc_name->backend_decl == current_function_decl)
1547       || sym->attr.contained)
1548     gfc_add_decl_to_function (decl);
1549   else if (sym->ns->proc_name->attr.flavor != FL_MODULE)
1550     gfc_add_decl_to_parent_function (decl);
1551
1552   sym->backend_decl = decl;
1553
1554   /* If a variable is USE associated, it's always external.  */
1555   if (sym->attr.use_assoc)
1556     {
1557       DECL_EXTERNAL (decl) = 1;
1558       TREE_PUBLIC (decl) = 1;
1559     }
1560   else if (sym->module && sym->ns->proc_name->attr.flavor == FL_MODULE)
1561     {
1562       /* This is the declaration of a module variable.  */
1563       TREE_PUBLIC (decl) = 1;
1564       TREE_STATIC (decl) = 1;
1565     }
1566
1567   if (!sym->attr.use_assoc
1568         && (sym->attr.save != SAVE_NONE || sym->attr.data
1569               || (sym->value && sym->ns->proc_name->attr.is_main_program)))
1570     TREE_STATIC (decl) = 1;
1571
1572   if (TREE_STATIC (decl) && sym->value)
1573     {
1574       /* Add static initializer.  */
1575       DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
1576                                                   TREE_TYPE (decl),
1577                                                   sym->attr.dimension,
1578                                                   false, true);
1579     }
1580
1581   /* Handle threadprivate procedure pointers.  */
1582   if (sym->attr.threadprivate
1583       && (TREE_STATIC (decl) || DECL_EXTERNAL (decl)))
1584     DECL_TLS_MODEL (decl) = decl_default_tls_model (decl);
1585
1586   attributes = add_attributes_to_decl (sym->attr, NULL_TREE);
1587   decl_attributes (&decl, attributes, 0);
1588
1589   return decl;
1590 }
1591
1592
1593 /* Get a basic decl for an external function.  */
1594
1595 tree
1596 gfc_get_extern_function_decl (gfc_symbol * sym)
1597 {
1598   tree type;
1599   tree fndecl;
1600   tree attributes;
1601   gfc_expr e;
1602   gfc_intrinsic_sym *isym;
1603   gfc_expr argexpr;
1604   char s[GFC_MAX_SYMBOL_LEN + 23]; /* "_gfortran_f2c_specific" and '\0'.  */
1605   tree name;
1606   tree mangled_name;
1607   gfc_gsymbol *gsym;
1608
1609   if (sym->backend_decl)
1610     return sym->backend_decl;
1611
1612   /* We should never be creating external decls for alternate entry points.
1613      The procedure may be an alternate entry point, but we don't want/need
1614      to know that.  */
1615   gcc_assert (!(sym->attr.entry || sym->attr.entry_master));
1616
1617   if (sym->attr.proc_pointer)
1618     return get_proc_pointer_decl (sym);
1619
1620   /* See if this is an external procedure from the same file.  If so,
1621      return the backend_decl.  */
1622   gsym =  gfc_find_gsymbol (gfc_gsym_root, sym->name);
1623
1624   if (gfc_option.flag_whole_file
1625         && (!sym->attr.use_assoc || sym->attr.if_source != IFSRC_DECL)
1626         && !sym->backend_decl
1627         && gsym && gsym->ns
1628         && ((gsym->type == GSYM_SUBROUTINE) || (gsym->type == GSYM_FUNCTION))
1629         && (gsym->ns->proc_name->backend_decl || !sym->attr.intrinsic))
1630     {
1631       if (!gsym->ns->proc_name->backend_decl)
1632         {
1633           /* By construction, the external function cannot be
1634              a contained procedure.  */
1635           locus old_loc;
1636           tree save_fn_decl = current_function_decl;
1637
1638           current_function_decl = NULL_TREE;
1639           gfc_save_backend_locus (&old_loc);
1640           push_cfun (cfun);
1641
1642           gfc_create_function_decl (gsym->ns, true);
1643
1644           pop_cfun ();
1645           gfc_restore_backend_locus (&old_loc);
1646           current_function_decl = save_fn_decl;
1647         }
1648
1649       /* If the namespace has entries, the proc_name is the
1650          entry master.  Find the entry and use its backend_decl.
1651          otherwise, use the proc_name backend_decl.  */
1652       if (gsym->ns->entries)
1653         {
1654           gfc_entry_list *entry = gsym->ns->entries;
1655
1656           for (; entry; entry = entry->next)
1657             {
1658               if (strcmp (gsym->name, entry->sym->name) == 0)
1659                 {
1660                   sym->backend_decl = entry->sym->backend_decl;
1661                   break;
1662                 }
1663             }
1664         }
1665       else
1666         sym->backend_decl = gsym->ns->proc_name->backend_decl;
1667
1668       if (sym->backend_decl)
1669         {
1670           /* Avoid problems of double deallocation of the backend declaration
1671              later in gfc_trans_use_stmts; cf. PR 45087.  */
1672           if (sym->attr.if_source != IFSRC_DECL && sym->attr.use_assoc)
1673             sym->attr.use_assoc = 0;
1674
1675           return sym->backend_decl;
1676         }
1677     }
1678
1679   /* See if this is a module procedure from the same file.  If so,
1680      return the backend_decl.  */
1681   if (sym->module)
1682     gsym =  gfc_find_gsymbol (gfc_gsym_root, sym->module);
1683
1684   if (gfc_option.flag_whole_file
1685         && gsym && gsym->ns
1686         && gsym->type == GSYM_MODULE)
1687     {
1688       gfc_symbol *s;
1689
1690       s = NULL;
1691       gfc_find_symbol (sym->name, gsym->ns, 0, &s);
1692       if (s && s->backend_decl)
1693         {
1694           if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
1695             gfc_copy_dt_decls_ifequal (s->ts.u.derived, sym->ts.u.derived,
1696                                        true);
1697           else if (sym->ts.type == BT_CHARACTER)
1698             sym->ts.u.cl->backend_decl = s->ts.u.cl->backend_decl;
1699           sym->backend_decl = s->backend_decl;
1700           return sym->backend_decl;
1701         }
1702     }
1703
1704   if (sym->attr.intrinsic)
1705     {
1706       /* Call the resolution function to get the actual name.  This is
1707          a nasty hack which relies on the resolution functions only looking
1708          at the first argument.  We pass NULL for the second argument
1709          otherwise things like AINT get confused.  */
1710       isym = gfc_find_function (sym->name);
1711       gcc_assert (isym->resolve.f0 != NULL);
1712
1713       memset (&e, 0, sizeof (e));
1714       e.expr_type = EXPR_FUNCTION;
1715
1716       memset (&argexpr, 0, sizeof (argexpr));
1717       gcc_assert (isym->formal);
1718       argexpr.ts = isym->formal->ts;
1719
1720       if (isym->formal->next == NULL)
1721         isym->resolve.f1 (&e, &argexpr);
1722       else
1723         {
1724           if (isym->formal->next->next == NULL)
1725             isym->resolve.f2 (&e, &argexpr, NULL);
1726           else
1727             {
1728               if (isym->formal->next->next->next == NULL)
1729                 isym->resolve.f3 (&e, &argexpr, NULL, NULL);
1730               else
1731                 {
1732                   /* All specific intrinsics take less than 5 arguments.  */
1733                   gcc_assert (isym->formal->next->next->next->next == NULL);
1734                   isym->resolve.f4 (&e, &argexpr, NULL, NULL, NULL);
1735                 }
1736             }
1737         }
1738
1739       if (gfc_option.flag_f2c
1740           && ((e.ts.type == BT_REAL && e.ts.kind == gfc_default_real_kind)
1741               || e.ts.type == BT_COMPLEX))
1742         {
1743           /* Specific which needs a different implementation if f2c
1744              calling conventions are used.  */
1745           sprintf (s, "_gfortran_f2c_specific%s", e.value.function.name);
1746         }
1747       else
1748         sprintf (s, "_gfortran_specific%s", e.value.function.name);
1749
1750       name = get_identifier (s);
1751       mangled_name = name;
1752     }
1753   else
1754     {
1755       name = gfc_sym_identifier (sym);
1756       mangled_name = gfc_sym_mangled_function_id (sym);
1757     }
1758
1759   type = gfc_get_function_type (sym);
1760   fndecl = build_decl (input_location,
1761                        FUNCTION_DECL, name, type);
1762
1763   /* Initialize DECL_EXTERNAL and TREE_PUBLIC before calling decl_attributes;
1764      TREE_PUBLIC specifies whether a function is globally addressable (i.e.
1765      the opposite of declaring a function as static in C).  */
1766   DECL_EXTERNAL (fndecl) = 1;
1767   TREE_PUBLIC (fndecl) = 1;
1768
1769   attributes = add_attributes_to_decl (sym->attr, NULL_TREE);
1770   decl_attributes (&fndecl, attributes, 0);
1771
1772   gfc_set_decl_assembler_name (fndecl, mangled_name);
1773
1774   /* Set the context of this decl.  */
1775   if (0 && sym->ns && sym->ns->proc_name)
1776     {
1777       /* TODO: Add external decls to the appropriate scope.  */
1778       DECL_CONTEXT (fndecl) = sym->ns->proc_name->backend_decl;
1779     }
1780   else
1781     {
1782       /* Global declaration, e.g. intrinsic subroutine.  */
1783       DECL_CONTEXT (fndecl) = NULL_TREE;
1784     }
1785
1786   /* Set attributes for PURE functions. A call to PURE function in the
1787      Fortran 95 sense is both pure and without side effects in the C
1788      sense.  */
1789   if (sym->attr.pure || sym->attr.elemental)
1790     {
1791       if (sym->attr.function && !gfc_return_by_reference (sym))
1792         DECL_PURE_P (fndecl) = 1;
1793       /* TODO: check if pure SUBROUTINEs don't have INTENT(OUT)
1794          parameters and don't use alternate returns (is this
1795          allowed?). In that case, calls to them are meaningless, and
1796          can be optimized away. See also in build_function_decl().  */
1797       TREE_SIDE_EFFECTS (fndecl) = 0;
1798     }
1799
1800   /* Mark non-returning functions.  */
1801   if (sym->attr.noreturn)
1802       TREE_THIS_VOLATILE(fndecl) = 1;
1803
1804   sym->backend_decl = fndecl;
1805
1806   if (DECL_CONTEXT (fndecl) == NULL_TREE)
1807     pushdecl_top_level (fndecl);
1808
1809   return fndecl;
1810 }
1811
1812
1813 /* Create a declaration for a procedure.  For external functions (in the C
1814    sense) use gfc_get_extern_function_decl.  HAS_ENTRIES is true if this is
1815    a master function with alternate entry points.  */
1816
1817 static void
1818 build_function_decl (gfc_symbol * sym, bool global)
1819 {
1820   tree fndecl, type, attributes;
1821   symbol_attribute attr;
1822   tree result_decl;
1823   gfc_formal_arglist *f;
1824
1825   gcc_assert (!sym->attr.external);
1826
1827   if (sym->backend_decl)
1828     return;
1829
1830   /* Set the line and filename.  sym->declared_at seems to point to the
1831      last statement for subroutines, but it'll do for now.  */
1832   gfc_set_backend_locus (&sym->declared_at);
1833
1834   /* Allow only one nesting level.  Allow public declarations.  */
1835   gcc_assert (current_function_decl == NULL_TREE
1836               || DECL_FILE_SCOPE_P (current_function_decl)
1837               || (TREE_CODE (DECL_CONTEXT (current_function_decl))
1838                   == NAMESPACE_DECL));
1839
1840   type = gfc_get_function_type (sym);
1841   fndecl = build_decl (input_location,
1842                        FUNCTION_DECL, gfc_sym_identifier (sym), type);
1843
1844   attr = sym->attr;
1845
1846   /* Initialize DECL_EXTERNAL and TREE_PUBLIC before calling decl_attributes;
1847      TREE_PUBLIC specifies whether a function is globally addressable (i.e.
1848      the opposite of declaring a function as static in C).  */
1849   DECL_EXTERNAL (fndecl) = 0;
1850
1851   if (!current_function_decl
1852       && !sym->attr.entry_master && !sym->attr.is_main_program)
1853     TREE_PUBLIC (fndecl) = 1;
1854
1855   attributes = add_attributes_to_decl (attr, NULL_TREE);
1856   decl_attributes (&fndecl, attributes, 0);
1857
1858   /* Figure out the return type of the declared function, and build a
1859      RESULT_DECL for it.  If this is a subroutine with alternate
1860      returns, build a RESULT_DECL for it.  */
1861   result_decl = NULL_TREE;
1862   /* TODO: Shouldn't this just be TREE_TYPE (TREE_TYPE (fndecl)).  */
1863   if (attr.function)
1864     {
1865       if (gfc_return_by_reference (sym))
1866         type = void_type_node;
1867       else
1868         {
1869           if (sym->result != sym)
1870             result_decl = gfc_sym_identifier (sym->result);
1871
1872           type = TREE_TYPE (TREE_TYPE (fndecl));
1873         }
1874     }
1875   else
1876     {
1877       /* Look for alternate return placeholders.  */
1878       int has_alternate_returns = 0;
1879       for (f = sym->formal; f; f = f->next)
1880         {
1881           if (f->sym == NULL)
1882             {
1883               has_alternate_returns = 1;
1884               break;
1885             }
1886         }
1887
1888       if (has_alternate_returns)
1889         type = integer_type_node;
1890       else
1891         type = void_type_node;
1892     }
1893
1894   result_decl = build_decl (input_location,
1895                             RESULT_DECL, result_decl, type);
1896   DECL_ARTIFICIAL (result_decl) = 1;
1897   DECL_IGNORED_P (result_decl) = 1;
1898   DECL_CONTEXT (result_decl) = fndecl;
1899   DECL_RESULT (fndecl) = result_decl;
1900
1901   /* Don't call layout_decl for a RESULT_DECL.
1902      layout_decl (result_decl, 0);  */
1903
1904   /* TREE_STATIC means the function body is defined here.  */
1905   TREE_STATIC (fndecl) = 1;
1906
1907   /* Set attributes for PURE functions. A call to a PURE function in the
1908      Fortran 95 sense is both pure and without side effects in the C
1909      sense.  */
1910   if (attr.pure || attr.elemental)
1911     {
1912       /* TODO: check if a pure SUBROUTINE has no INTENT(OUT) arguments
1913          including an alternate return. In that case it can also be
1914          marked as PURE. See also in gfc_get_extern_function_decl().  */
1915       if (attr.function && !gfc_return_by_reference (sym))
1916         DECL_PURE_P (fndecl) = 1;
1917       TREE_SIDE_EFFECTS (fndecl) = 0;
1918     }
1919
1920
1921   /* Layout the function declaration and put it in the binding level
1922      of the current function.  */
1923
1924   if (global
1925       || (sym->name[0] == '_' && strncmp ("__copy", sym->name, 6) == 0))
1926     pushdecl_top_level (fndecl);
1927   else
1928     pushdecl (fndecl);
1929
1930   /* Perform name mangling if this is a top level or module procedure.  */
1931   if (current_function_decl == NULL_TREE)
1932     gfc_set_decl_assembler_name (fndecl, gfc_sym_mangled_function_id (sym));
1933
1934   sym->backend_decl = fndecl;
1935 }
1936
1937
1938 /* Create the DECL_ARGUMENTS for a procedure.  */
1939
1940 static void
1941 create_function_arglist (gfc_symbol * sym)
1942 {
1943   tree fndecl;
1944   gfc_formal_arglist *f;
1945   tree typelist, hidden_typelist;
1946   tree arglist, hidden_arglist;
1947   tree type;
1948   tree parm;
1949
1950   fndecl = sym->backend_decl;
1951
1952   /* Build formal argument list. Make sure that their TREE_CONTEXT is
1953      the new FUNCTION_DECL node.  */
1954   arglist = NULL_TREE;
1955   hidden_arglist = NULL_TREE;
1956   typelist = TYPE_ARG_TYPES (TREE_TYPE (fndecl));
1957
1958   if (sym->attr.entry_master)
1959     {
1960       type = TREE_VALUE (typelist);
1961       parm = build_decl (input_location,
1962                          PARM_DECL, get_identifier ("__entry"), type);
1963
1964       DECL_CONTEXT (parm) = fndecl;
1965       DECL_ARG_TYPE (parm) = type;
1966       TREE_READONLY (parm) = 1;
1967       gfc_finish_decl (parm);
1968       DECL_ARTIFICIAL (parm) = 1;
1969
1970       arglist = chainon (arglist, parm);
1971       typelist = TREE_CHAIN (typelist);
1972     }
1973
1974   if (gfc_return_by_reference (sym))
1975     {
1976       tree type = TREE_VALUE (typelist), length = NULL;
1977
1978       if (sym->ts.type == BT_CHARACTER)
1979         {
1980           /* Length of character result.  */
1981           tree len_type = TREE_VALUE (TREE_CHAIN (typelist));
1982
1983           length = build_decl (input_location,
1984                                PARM_DECL,
1985                                get_identifier (".__result"),
1986                                len_type);
1987           if (!sym->ts.u.cl->length)
1988             {
1989               sym->ts.u.cl->backend_decl = length;
1990               TREE_USED (length) = 1;
1991             }
1992           gcc_assert (TREE_CODE (length) == PARM_DECL);
1993           DECL_CONTEXT (length) = fndecl;
1994           DECL_ARG_TYPE (length) = len_type;
1995           TREE_READONLY (length) = 1;
1996           DECL_ARTIFICIAL (length) = 1;
1997           gfc_finish_decl (length);
1998           if (sym->ts.u.cl->backend_decl == NULL
1999               || sym->ts.u.cl->backend_decl == length)
2000             {
2001               gfc_symbol *arg;
2002               tree backend_decl;
2003
2004               if (sym->ts.u.cl->backend_decl == NULL)
2005                 {
2006                   tree len = build_decl (input_location,
2007                                          VAR_DECL,
2008                                          get_identifier ("..__result"),
2009                                          gfc_charlen_type_node);
2010                   DECL_ARTIFICIAL (len) = 1;
2011                   TREE_USED (len) = 1;
2012                   sym->ts.u.cl->backend_decl = len;
2013                 }
2014
2015               /* Make sure PARM_DECL type doesn't point to incomplete type.  */
2016               arg = sym->result ? sym->result : sym;
2017               backend_decl = arg->backend_decl;
2018               /* Temporary clear it, so that gfc_sym_type creates complete
2019                  type.  */
2020               arg->backend_decl = NULL;
2021               type = gfc_sym_type (arg);
2022               arg->backend_decl = backend_decl;
2023               type = build_reference_type (type);
2024             }
2025         }
2026
2027       parm = build_decl (input_location,
2028                          PARM_DECL, get_identifier ("__result"), type);
2029
2030       DECL_CONTEXT (parm) = fndecl;
2031       DECL_ARG_TYPE (parm) = TREE_VALUE (typelist);
2032       TREE_READONLY (parm) = 1;
2033       DECL_ARTIFICIAL (parm) = 1;
2034       gfc_finish_decl (parm);
2035
2036       arglist = chainon (arglist, parm);
2037       typelist = TREE_CHAIN (typelist);
2038
2039       if (sym->ts.type == BT_CHARACTER)
2040         {
2041           gfc_allocate_lang_decl (parm);
2042           arglist = chainon (arglist, length);
2043           typelist = TREE_CHAIN (typelist);
2044         }
2045     }
2046
2047   hidden_typelist = typelist;
2048   for (f = sym->formal; f; f = f->next)
2049     if (f->sym != NULL) /* Ignore alternate returns.  */
2050       hidden_typelist = TREE_CHAIN (hidden_typelist);
2051
2052   for (f = sym->formal; f; f = f->next)
2053     {
2054       char name[GFC_MAX_SYMBOL_LEN + 2];
2055
2056       /* Ignore alternate returns.  */
2057       if (f->sym == NULL)
2058         continue;
2059
2060       type = TREE_VALUE (typelist);
2061
2062       if (f->sym->ts.type == BT_CHARACTER
2063           && (!sym->attr.is_bind_c || sym->attr.entry_master))
2064         {
2065           tree len_type = TREE_VALUE (hidden_typelist);
2066           tree length = NULL_TREE;
2067           if (!f->sym->ts.deferred)
2068             gcc_assert (len_type == gfc_charlen_type_node);
2069           else
2070             gcc_assert (POINTER_TYPE_P (len_type));
2071
2072           strcpy (&name[1], f->sym->name);
2073           name[0] = '_';
2074           length = build_decl (input_location,
2075                                PARM_DECL, get_identifier (name), len_type);
2076
2077           hidden_arglist = chainon (hidden_arglist, length);
2078           DECL_CONTEXT (length) = fndecl;
2079           DECL_ARTIFICIAL (length) = 1;
2080           DECL_ARG_TYPE (length) = len_type;
2081           TREE_READONLY (length) = 1;
2082           gfc_finish_decl (length);
2083
2084           /* Remember the passed value.  */
2085           if (f->sym->ts.u.cl->passed_length != NULL)
2086             {
2087               /* This can happen if the same type is used for multiple
2088                  arguments. We need to copy cl as otherwise
2089                  cl->passed_length gets overwritten.  */
2090               f->sym->ts.u.cl = gfc_new_charlen (f->sym->ns, f->sym->ts.u.cl);
2091             }
2092           f->sym->ts.u.cl->passed_length = length;
2093
2094           /* Use the passed value for assumed length variables.  */
2095           if (!f->sym->ts.u.cl->length)
2096             {
2097               TREE_USED (length) = 1;
2098               gcc_assert (!f->sym->ts.u.cl->backend_decl);
2099               f->sym->ts.u.cl->backend_decl = length;
2100             }
2101
2102           hidden_typelist = TREE_CHAIN (hidden_typelist);
2103
2104           if (f->sym->ts.u.cl->backend_decl == NULL
2105               || f->sym->ts.u.cl->backend_decl == length)
2106             {
2107               if (f->sym->ts.u.cl->backend_decl == NULL)
2108                 gfc_create_string_length (f->sym);
2109
2110               /* Make sure PARM_DECL type doesn't point to incomplete type.  */
2111               if (f->sym->attr.flavor == FL_PROCEDURE)
2112                 type = build_pointer_type (gfc_get_function_type (f->sym));
2113               else
2114                 type = gfc_sym_type (f->sym);
2115             }
2116         }
2117
2118       /* For non-constant length array arguments, make sure they use
2119          a different type node from TYPE_ARG_TYPES type.  */
2120       if (f->sym->attr.dimension
2121           && type == TREE_VALUE (typelist)
2122           && TREE_CODE (type) == POINTER_TYPE
2123           && GFC_ARRAY_TYPE_P (type)
2124           && f->sym->as->type != AS_ASSUMED_SIZE
2125           && ! COMPLETE_TYPE_P (TREE_TYPE (type)))
2126         {
2127           if (f->sym->attr.flavor == FL_PROCEDURE)
2128             type = build_pointer_type (gfc_get_function_type (f->sym));
2129           else
2130             type = gfc_sym_type (f->sym);
2131         }
2132
2133       if (f->sym->attr.proc_pointer)
2134         type = build_pointer_type (type);
2135
2136       if (f->sym->attr.volatile_)
2137         type = build_qualified_type (type, TYPE_QUAL_VOLATILE);
2138
2139       /* Build the argument declaration.  */
2140       parm = build_decl (input_location,
2141                          PARM_DECL, gfc_sym_identifier (f->sym), type);
2142
2143       if (f->sym->attr.volatile_)
2144         {
2145           TREE_THIS_VOLATILE (parm) = 1;
2146           TREE_SIDE_EFFECTS (parm) = 1;
2147         }
2148
2149       /* Fill in arg stuff.  */
2150       DECL_CONTEXT (parm) = fndecl;
2151       DECL_ARG_TYPE (parm) = TREE_VALUE (typelist);
2152       /* All implementation args are read-only.  */
2153       TREE_READONLY (parm) = 1;
2154       if (POINTER_TYPE_P (type)
2155           && (!f->sym->attr.proc_pointer
2156               && f->sym->attr.flavor != FL_PROCEDURE))
2157         DECL_BY_REFERENCE (parm) = 1;
2158
2159       gfc_finish_decl (parm);
2160
2161       f->sym->backend_decl = parm;
2162
2163       /* Coarrays which are descriptorless or assumed-shape pass with
2164          -fcoarray=lib the token and the offset as hidden arguments.  */
2165       if (f->sym->attr.codimension
2166           && gfc_option.coarray == GFC_FCOARRAY_LIB
2167           && !f->sym->attr.allocatable)
2168         {
2169           tree caf_type;
2170           tree token;
2171           tree offset;
2172
2173           gcc_assert (f->sym->backend_decl != NULL_TREE
2174                       && !sym->attr.is_bind_c);
2175           caf_type = TREE_TYPE (f->sym->backend_decl);
2176
2177           token = build_decl (input_location, PARM_DECL,
2178                               create_tmp_var_name ("caf_token"),
2179                               build_qualified_type (pvoid_type_node,
2180                                                     TYPE_QUAL_RESTRICT));
2181           if (f->sym->as->type == AS_ASSUMED_SHAPE)
2182             {
2183               gcc_assert (DECL_LANG_SPECIFIC (f->sym->backend_decl) == NULL
2184                           || GFC_DECL_TOKEN (f->sym->backend_decl) == NULL_TREE);
2185               if (DECL_LANG_SPECIFIC (f->sym->backend_decl) == NULL)
2186                 gfc_allocate_lang_decl (f->sym->backend_decl);
2187               GFC_DECL_TOKEN (f->sym->backend_decl) = token;
2188             }
2189           else
2190             {
2191               gcc_assert (GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) == NULL_TREE);
2192               GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) = token;
2193             }
2194
2195           DECL_CONTEXT (token) = fndecl;
2196           DECL_ARTIFICIAL (token) = 1;
2197           DECL_ARG_TYPE (token) = TREE_VALUE (typelist);
2198           TREE_READONLY (token) = 1;
2199           hidden_arglist = chainon (hidden_arglist, token);
2200           gfc_finish_decl (token);
2201
2202           offset = build_decl (input_location, PARM_DECL,
2203                                create_tmp_var_name ("caf_offset"),
2204                                gfc_array_index_type);
2205
2206           if (f->sym->as->type == AS_ASSUMED_SHAPE)
2207             {
2208               gcc_assert (GFC_DECL_CAF_OFFSET (f->sym->backend_decl)
2209                                                == NULL_TREE);
2210               GFC_DECL_CAF_OFFSET (f->sym->backend_decl) = offset;
2211             }
2212           else
2213             {
2214               gcc_assert (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type) == NULL_TREE);
2215               GFC_TYPE_ARRAY_CAF_OFFSET (caf_type) = offset;
2216             }
2217           DECL_CONTEXT (offset) = fndecl;
2218           DECL_ARTIFICIAL (offset) = 1;
2219           DECL_ARG_TYPE (offset) = TREE_VALUE (typelist);
2220           TREE_READONLY (offset) = 1;
2221           hidden_arglist = chainon (hidden_arglist, offset);
2222           gfc_finish_decl (offset);
2223         }
2224
2225       arglist = chainon (arglist, parm);
2226       typelist = TREE_CHAIN (typelist);
2227     }
2228
2229   /* Add the hidden string length parameters, unless the procedure
2230      is bind(C).  */
2231   if (!sym->attr.is_bind_c)
2232     arglist = chainon (arglist, hidden_arglist);
2233
2234   gcc_assert (hidden_typelist == NULL_TREE
2235               || TREE_VALUE (hidden_typelist) == void_type_node);
2236   DECL_ARGUMENTS (fndecl) = arglist;
2237 }
2238
2239 /* Do the setup necessary before generating the body of a function.  */
2240
2241 static void
2242 trans_function_start (gfc_symbol * sym)
2243 {
2244   tree fndecl;
2245
2246   fndecl = sym->backend_decl;
2247
2248   /* Let GCC know the current scope is this function.  */
2249   current_function_decl = fndecl;
2250
2251   /* Let the world know what we're about to do.  */
2252   announce_function (fndecl);
2253
2254   if (DECL_FILE_SCOPE_P (fndecl))
2255     {
2256       /* Create RTL for function declaration.  */
2257       rest_of_decl_compilation (fndecl, 1, 0);
2258     }
2259
2260   /* Create RTL for function definition.  */
2261   make_decl_rtl (fndecl);
2262
2263   init_function_start (fndecl);
2264
2265   /* function.c requires a push at the start of the function.  */
2266   pushlevel (0);
2267 }
2268
2269 /* Create thunks for alternate entry points.  */
2270
2271 static void
2272 build_entry_thunks (gfc_namespace * ns, bool global)
2273 {
2274   gfc_formal_arglist *formal;
2275   gfc_formal_arglist *thunk_formal;
2276   gfc_entry_list *el;
2277   gfc_symbol *thunk_sym;
2278   stmtblock_t body;
2279   tree thunk_fndecl;
2280   tree tmp;
2281   locus old_loc;
2282
2283   /* This should always be a toplevel function.  */
2284   gcc_assert (current_function_decl == NULL_TREE);
2285
2286   gfc_save_backend_locus (&old_loc);
2287   for (el = ns->entries; el; el = el->next)
2288     {
2289       VEC(tree,gc) *args = NULL;
2290       VEC(tree,gc) *string_args = NULL;
2291
2292       thunk_sym = el->sym;
2293
2294       build_function_decl (thunk_sym, global);
2295       create_function_arglist (thunk_sym);
2296
2297       trans_function_start (thunk_sym);
2298
2299       thunk_fndecl = thunk_sym->backend_decl;
2300
2301       gfc_init_block (&body);
2302
2303       /* Pass extra parameter identifying this entry point.  */
2304       tmp = build_int_cst (gfc_array_index_type, el->id);
2305       VEC_safe_push (tree, gc, args, tmp);
2306
2307       if (thunk_sym->attr.function)
2308         {
2309           if (gfc_return_by_reference (ns->proc_name))
2310             {
2311               tree ref = DECL_ARGUMENTS (current_function_decl);
2312               VEC_safe_push (tree, gc, args, ref);
2313               if (ns->proc_name->ts.type == BT_CHARACTER)
2314                 VEC_safe_push (tree, gc, args, DECL_CHAIN (ref));
2315             }
2316         }
2317
2318       for (formal = ns->proc_name->formal; formal; formal = formal->next)
2319         {
2320           /* Ignore alternate returns.  */
2321           if (formal->sym == NULL)
2322             continue;
2323
2324           /* We don't have a clever way of identifying arguments, so resort to
2325              a brute-force search.  */
2326           for (thunk_formal = thunk_sym->formal;
2327                thunk_formal;
2328                thunk_formal = thunk_formal->next)
2329             {
2330               if (thunk_formal->sym == formal->sym)
2331                 break;
2332             }
2333
2334           if (thunk_formal)
2335             {
2336               /* Pass the argument.  */
2337               DECL_ARTIFICIAL (thunk_formal->sym->backend_decl) = 1;
2338               VEC_safe_push (tree, gc, args, thunk_formal->sym->backend_decl);
2339               if (formal->sym->ts.type == BT_CHARACTER)
2340                 {
2341                   tmp = thunk_formal->sym->ts.u.cl->backend_decl;
2342                   VEC_safe_push (tree, gc, string_args, tmp);
2343                 }
2344             }
2345           else
2346             {
2347               /* Pass NULL for a missing argument.  */
2348               VEC_safe_push (tree, gc, args, null_pointer_node);
2349               if (formal->sym->ts.type == BT_CHARACTER)
2350                 {
2351                   tmp = build_int_cst (gfc_charlen_type_node, 0);
2352                   VEC_safe_push (tree, gc, string_args, tmp);
2353                 }
2354             }
2355         }
2356
2357       /* Call the master function.  */
2358       VEC_safe_splice (tree, gc, args, string_args);
2359       tmp = ns->proc_name->backend_decl;
2360       tmp = build_call_expr_loc_vec (input_location, tmp, args);
2361       if (ns->proc_name->attr.mixed_entry_master)
2362         {
2363           tree union_decl, field;
2364           tree master_type = TREE_TYPE (ns->proc_name->backend_decl);
2365
2366           union_decl = build_decl (input_location,
2367                                    VAR_DECL, get_identifier ("__result"),
2368                                    TREE_TYPE (master_type));
2369           DECL_ARTIFICIAL (union_decl) = 1;
2370           DECL_EXTERNAL (union_decl) = 0;
2371           TREE_PUBLIC (union_decl) = 0;
2372           TREE_USED (union_decl) = 1;
2373           layout_decl (union_decl, 0);
2374           pushdecl (union_decl);
2375
2376           DECL_CONTEXT (union_decl) = current_function_decl;
2377           tmp = fold_build2_loc (input_location, MODIFY_EXPR,
2378                                  TREE_TYPE (union_decl), union_decl, tmp);
2379           gfc_add_expr_to_block (&body, tmp);
2380
2381           for (field = TYPE_FIELDS (TREE_TYPE (union_decl));
2382                field; field = DECL_CHAIN (field))
2383             if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
2384                 thunk_sym->result->name) == 0)
2385               break;
2386           gcc_assert (field != NULL_TREE);
2387           tmp = fold_build3_loc (input_location, COMPONENT_REF,
2388                                  TREE_TYPE (field), union_decl, field,
2389                                  NULL_TREE);
2390           tmp = fold_build2_loc (input_location, MODIFY_EXPR,
2391                              TREE_TYPE (DECL_RESULT (current_function_decl)),
2392                              DECL_RESULT (current_function_decl), tmp);
2393           tmp = build1_v (RETURN_EXPR, tmp);
2394         }
2395       else if (TREE_TYPE (DECL_RESULT (current_function_decl))
2396                != void_type_node)
2397         {
2398           tmp = fold_build2_loc (input_location, MODIFY_EXPR,
2399                              TREE_TYPE (DECL_RESULT (current_function_decl)),
2400                              DECL_RESULT (current_function_decl), tmp);
2401           tmp = build1_v (RETURN_EXPR, tmp);
2402         }
2403       gfc_add_expr_to_block (&body, tmp);
2404
2405       /* Finish off this function and send it for code generation.  */
2406       DECL_SAVED_TREE (thunk_fndecl) = gfc_finish_block (&body);
2407       tmp = getdecls ();
2408       poplevel (1, 0, 1);
2409       BLOCK_SUPERCONTEXT (DECL_INITIAL (thunk_fndecl)) = thunk_fndecl;
2410       DECL_SAVED_TREE (thunk_fndecl)
2411         = build3_v (BIND_EXPR, tmp, DECL_SAVED_TREE (thunk_fndecl),
2412                     DECL_INITIAL (thunk_fndecl));
2413
2414       /* Output the GENERIC tree.  */
2415       dump_function (TDI_original, thunk_fndecl);
2416
2417       /* Store the end of the function, so that we get good line number
2418          info for the epilogue.  */
2419       cfun->function_end_locus = input_location;
2420
2421       /* We're leaving the context of this function, so zap cfun.
2422          It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
2423          tree_rest_of_compilation.  */
2424       set_cfun (NULL);
2425
2426       current_function_decl = NULL_TREE;
2427
2428       cgraph_finalize_function (thunk_fndecl, true);
2429
2430       /* We share the symbols in the formal argument list with other entry
2431          points and the master function.  Clear them so that they are
2432          recreated for each function.  */
2433       for (formal = thunk_sym->formal; formal; formal = formal->next)
2434         if (formal->sym != NULL)  /* Ignore alternate returns.  */
2435           {
2436             formal->sym->backend_decl = NULL_TREE;
2437             if (formal->sym->ts.type == BT_CHARACTER)
2438               formal->sym->ts.u.cl->backend_decl = NULL_TREE;
2439           }
2440
2441       if (thunk_sym->attr.function)
2442         {
2443           if (thunk_sym->ts.type == BT_CHARACTER)
2444             thunk_sym->ts.u.cl->backend_decl = NULL_TREE;
2445           if (thunk_sym->result->ts.type == BT_CHARACTER)
2446             thunk_sym->result->ts.u.cl->backend_decl = NULL_TREE;
2447         }
2448     }
2449
2450   gfc_restore_backend_locus (&old_loc);
2451 }
2452
2453
2454 /* Create a decl for a function, and create any thunks for alternate entry
2455    points. If global is true, generate the function in the global binding
2456    level, otherwise in the current binding level (which can be global).  */
2457
2458 void
2459 gfc_create_function_decl (gfc_namespace * ns, bool global)
2460 {
2461   /* Create a declaration for the master function.  */
2462   build_function_decl (ns->proc_name, global);
2463
2464   /* Compile the entry thunks.  */
2465   if (ns->entries)
2466     build_entry_thunks (ns, global);
2467
2468   /* Now create the read argument list.  */
2469   create_function_arglist (ns->proc_name);
2470 }
2471
2472 /* Return the decl used to hold the function return value.  If
2473    parent_flag is set, the context is the parent_scope.  */
2474
2475 tree
2476 gfc_get_fake_result_decl (gfc_symbol * sym, int parent_flag)
2477 {
2478   tree decl;
2479   tree length;
2480   tree this_fake_result_decl;
2481   tree this_function_decl;
2482
2483   char name[GFC_MAX_SYMBOL_LEN + 10];
2484
2485   if (parent_flag)
2486     {
2487       this_fake_result_decl = parent_fake_result_decl;
2488       this_function_decl = DECL_CONTEXT (current_function_decl);
2489     }
2490   else
2491     {
2492       this_fake_result_decl = current_fake_result_decl;
2493       this_function_decl = current_function_decl;
2494     }
2495
2496   if (sym
2497       && sym->ns->proc_name->backend_decl == this_function_decl
2498       && sym->ns->proc_name->attr.entry_master
2499       && sym != sym->ns->proc_name)
2500     {
2501       tree t = NULL, var;
2502       if (this_fake_result_decl != NULL)
2503         for (t = TREE_CHAIN (this_fake_result_decl); t; t = TREE_CHAIN (t))
2504           if (strcmp (IDENTIFIER_POINTER (TREE_PURPOSE (t)), sym->name) == 0)
2505             break;
2506       if (t)
2507         return TREE_VALUE (t);
2508       decl = gfc_get_fake_result_decl (sym->ns->proc_name, parent_flag);
2509
2510       if (parent_flag)
2511         this_fake_result_decl = parent_fake_result_decl;
2512       else
2513         this_fake_result_decl = current_fake_result_decl;
2514
2515       if (decl && sym->ns->proc_name->attr.mixed_entry_master)
2516         {
2517           tree field;
2518
2519           for (field = TYPE_FIELDS (TREE_TYPE (decl));
2520                field; field = DECL_CHAIN (field))
2521             if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
2522                 sym->name) == 0)
2523               break;
2524
2525           gcc_assert (field != NULL_TREE);
2526           decl = fold_build3_loc (input_location, COMPONENT_REF,
2527                                   TREE_TYPE (field), decl, field, NULL_TREE);
2528         }
2529
2530       var = create_tmp_var_raw (TREE_TYPE (decl), sym->name);
2531       if (parent_flag)
2532         gfc_add_decl_to_parent_function (var);
2533       else
2534         gfc_add_decl_to_function (var);
2535
2536       SET_DECL_VALUE_EXPR (var, decl);
2537       DECL_HAS_VALUE_EXPR_P (var) = 1;
2538       GFC_DECL_RESULT (var) = 1;
2539
2540       TREE_CHAIN (this_fake_result_decl)
2541           = tree_cons (get_identifier (sym->name), var,
2542                        TREE_CHAIN (this_fake_result_decl));
2543       return var;
2544     }
2545
2546   if (this_fake_result_decl != NULL_TREE)
2547     return TREE_VALUE (this_fake_result_decl);
2548
2549   /* Only when gfc_get_fake_result_decl is called by gfc_trans_return,
2550      sym is NULL.  */
2551   if (!sym)
2552     return NULL_TREE;
2553
2554   if (sym->ts.type == BT_CHARACTER)
2555     {
2556       if (sym->ts.u.cl->backend_decl == NULL_TREE)
2557         length = gfc_create_string_length (sym);
2558       else
2559         length = sym->ts.u.cl->backend_decl;
2560       if (TREE_CODE (length) == VAR_DECL
2561           && DECL_CONTEXT (length) == NULL_TREE)
2562         gfc_add_decl_to_function (length);
2563     }
2564
2565   if (gfc_return_by_reference (sym))
2566     {
2567       decl = DECL_ARGUMENTS (this_function_decl);
2568
2569       if (sym->ns->proc_name->backend_decl == this_function_decl
2570           && sym->ns->proc_name->attr.entry_master)
2571         decl = DECL_CHAIN (decl);
2572
2573       TREE_USED (decl) = 1;
2574       if (sym->as)
2575         decl = gfc_build_dummy_array_decl (sym, decl);
2576     }
2577   else
2578     {
2579       sprintf (name, "__result_%.20s",
2580                IDENTIFIER_POINTER (DECL_NAME (this_function_decl)));
2581
2582       if (!sym->attr.mixed_entry_master && sym->attr.function)
2583         decl = build_decl (DECL_SOURCE_LOCATION (this_function_decl),
2584                            VAR_DECL, get_identifier (name),
2585                            gfc_sym_type (sym));
2586       else
2587         decl = build_decl (DECL_SOURCE_LOCATION (this_function_decl),
2588                            VAR_DECL, get_identifier (name),
2589                            TREE_TYPE (TREE_TYPE (this_function_decl)));
2590       DECL_ARTIFICIAL (decl) = 1;
2591       DECL_EXTERNAL (decl) = 0;
2592       TREE_PUBLIC (decl) = 0;
2593       TREE_USED (decl) = 1;
2594       GFC_DECL_RESULT (decl) = 1;
2595       TREE_ADDRESSABLE (decl) = 1;
2596
2597       layout_decl (decl, 0);
2598
2599       if (parent_flag)
2600         gfc_add_decl_to_parent_function (decl);
2601       else
2602         gfc_add_decl_to_function (decl);
2603     }
2604
2605   if (parent_flag)
2606     parent_fake_result_decl = build_tree_list (NULL, decl);
2607   else
2608     current_fake_result_decl = build_tree_list (NULL, decl);
2609
2610   return decl;
2611 }
2612
2613
2614 /* Builds a function decl.  The remaining parameters are the types of the
2615    function arguments.  Negative nargs indicates a varargs function.  */
2616
2617 static tree
2618 build_library_function_decl_1 (tree name, const char *spec,
2619                                tree rettype, int nargs, va_list p)
2620 {
2621   VEC(tree,gc) *arglist;
2622   tree fntype;
2623   tree fndecl;
2624   int n;
2625
2626   /* Library functions must be declared with global scope.  */
2627   gcc_assert (current_function_decl == NULL_TREE);
2628
2629   /* Create a list of the argument types.  */
2630   arglist = VEC_alloc (tree, gc, abs (nargs));
2631   for (n = abs (nargs); n > 0; n--)
2632     {
2633       tree argtype = va_arg (p, tree);
2634       VEC_quick_push (tree, arglist, argtype);
2635     }
2636
2637   /* Build the function type and decl.  */
2638   if (nargs >= 0)
2639     fntype = build_function_type_vec (rettype, arglist);
2640   else
2641     fntype = build_varargs_function_type_vec (rettype, arglist);
2642   if (spec)
2643     {
2644       tree attr_args = build_tree_list (NULL_TREE,
2645                                         build_string (strlen (spec), spec));
2646       tree attrs = tree_cons (get_identifier ("fn spec"),
2647                               attr_args, TYPE_ATTRIBUTES (fntype));
2648       fntype = build_type_attribute_variant (fntype, attrs);
2649     }
2650   fndecl = build_decl (input_location,
2651                        FUNCTION_DECL, name, fntype);
2652
2653   /* Mark this decl as external.  */
2654   DECL_EXTERNAL (fndecl) = 1;
2655   TREE_PUBLIC (fndecl) = 1;
2656
2657   pushdecl (fndecl);
2658
2659   rest_of_decl_compilation (fndecl, 1, 0);
2660
2661   return fndecl;
2662 }
2663
2664 /* Builds a function decl.  The remaining parameters are the types of the
2665    function arguments.  Negative nargs indicates a varargs function.  */
2666
2667 tree
2668 gfc_build_library_function_decl (tree name, tree rettype, int nargs, ...)
2669 {
2670   tree ret;
2671   va_list args;
2672   va_start (args, nargs);
2673   ret = build_library_function_decl_1 (name, NULL, rettype, nargs, args);
2674   va_end (args);
2675   return ret;
2676 }
2677
2678 /* Builds a function decl.  The remaining parameters are the types of the
2679    function arguments.  Negative nargs indicates a varargs function.
2680    The SPEC parameter specifies the function argument and return type
2681    specification according to the fnspec function type attribute.  */
2682
2683 tree
2684 gfc_build_library_function_decl_with_spec (tree name, const char *spec,
2685                                            tree rettype, int nargs, ...)
2686 {
2687   tree ret;
2688   va_list args;
2689   va_start (args, nargs);
2690   ret = build_library_function_decl_1 (name, spec, rettype, nargs, args);
2691   va_end (args);
2692   return ret;
2693 }
2694
2695 static void
2696 gfc_build_intrinsic_function_decls (void)
2697 {
2698   tree gfc_int4_type_node = gfc_get_int_type (4);
2699   tree gfc_int8_type_node = gfc_get_int_type (8);
2700   tree gfc_int16_type_node = gfc_get_int_type (16);
2701   tree gfc_logical4_type_node = gfc_get_logical_type (4);
2702   tree pchar1_type_node = gfc_get_pchar_type (1);
2703   tree pchar4_type_node = gfc_get_pchar_type (4);
2704
2705   /* String functions.  */
2706   gfor_fndecl_compare_string = gfc_build_library_function_decl_with_spec (
2707         get_identifier (PREFIX("compare_string")), "..R.R",
2708         integer_type_node, 4, gfc_charlen_type_node, pchar1_type_node,
2709         gfc_charlen_type_node, pchar1_type_node);
2710   DECL_PURE_P (gfor_fndecl_compare_string) = 1;
2711   TREE_NOTHROW (gfor_fndecl_compare_string) = 1;
2712
2713   gfor_fndecl_concat_string = gfc_build_library_function_decl_with_spec (
2714         get_identifier (PREFIX("concat_string")), "..W.R.R",
2715         void_type_node, 6, gfc_charlen_type_node, pchar1_type_node,
2716         gfc_charlen_type_node, pchar1_type_node,
2717         gfc_charlen_type_node, pchar1_type_node);
2718   TREE_NOTHROW (gfor_fndecl_concat_string) = 1;
2719
2720   gfor_fndecl_string_len_trim = gfc_build_library_function_decl_with_spec (
2721         get_identifier (PREFIX("string_len_trim")), "..R",
2722         gfc_charlen_type_node, 2, gfc_charlen_type_node, pchar1_type_node);
2723   DECL_PURE_P (gfor_fndecl_string_len_trim) = 1;
2724   TREE_NOTHROW (gfor_fndecl_string_len_trim) = 1;
2725
2726   gfor_fndecl_string_index = gfc_build_library_function_decl_with_spec (
2727         get_identifier (PREFIX("string_index")), "..R.R.",
2728         gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar1_type_node,
2729         gfc_charlen_type_node, pchar1_type_node, gfc_logical4_type_node);
2730   DECL_PURE_P (gfor_fndecl_string_index) = 1;
2731   TREE_NOTHROW (gfor_fndecl_string_index) = 1;
2732
2733   gfor_fndecl_string_scan = gfc_build_library_function_decl_with_spec (
2734         get_identifier (PREFIX("string_scan")), "..R.R.",
2735         gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar1_type_node,
2736         gfc_charlen_type_node, pchar1_type_node, gfc_logical4_type_node);
2737   DECL_PURE_P (gfor_fndecl_string_scan) = 1;
2738   TREE_NOTHROW (gfor_fndecl_string_scan) = 1;
2739
2740   gfor_fndecl_string_verify = gfc_build_library_function_decl_with_spec (
2741         get_identifier (PREFIX("string_verify")), "..R.R.",
2742         gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar1_type_node,
2743         gfc_charlen_type_node, pchar1_type_node, gfc_logical4_type_node);
2744   DECL_PURE_P (gfor_fndecl_string_verify) = 1;
2745   TREE_NOTHROW (gfor_fndecl_string_verify) = 1;
2746
2747   gfor_fndecl_string_trim = gfc_build_library_function_decl_with_spec (
2748         get_identifier (PREFIX("string_trim")), ".Ww.R",
2749         void_type_node, 4, build_pointer_type (gfc_charlen_type_node),
2750         build_pointer_type (pchar1_type_node), gfc_charlen_type_node,
2751         pchar1_type_node);
2752
2753   gfor_fndecl_string_minmax = gfc_build_library_function_decl_with_spec (
2754         get_identifier (PREFIX("string_minmax")), ".Ww.R",
2755         void_type_node, -4, build_pointer_type (gfc_charlen_type_node),
2756         build_pointer_type (pchar1_type_node), integer_type_node,
2757         integer_type_node);
2758
2759   gfor_fndecl_adjustl = gfc_build_library_function_decl_with_spec (
2760         get_identifier (PREFIX("adjustl")), ".W.R",
2761         void_type_node, 3, pchar1_type_node, gfc_charlen_type_node,
2762         pchar1_type_node);
2763   TREE_NOTHROW (gfor_fndecl_adjustl) = 1;
2764
2765   gfor_fndecl_adjustr = gfc_build_library_function_decl_with_spec (
2766         get_identifier (PREFIX("adjustr")), ".W.R",
2767         void_type_node, 3, pchar1_type_node, gfc_charlen_type_node,
2768         pchar1_type_node);
2769   TREE_NOTHROW (gfor_fndecl_adjustr) = 1;
2770
2771   gfor_fndecl_select_string =  gfc_build_library_function_decl_with_spec (
2772         get_identifier (PREFIX("select_string")), ".R.R.",
2773         integer_type_node, 4, pvoid_type_node, integer_type_node,
2774         pchar1_type_node, gfc_charlen_type_node);
2775   DECL_PURE_P (gfor_fndecl_select_string) = 1;
2776   TREE_NOTHROW (gfor_fndecl_select_string) = 1;
2777
2778   gfor_fndecl_compare_string_char4 = gfc_build_library_function_decl_with_spec (
2779         get_identifier (PREFIX("compare_string_char4")), "..R.R",
2780         integer_type_node, 4, gfc_charlen_type_node, pchar4_type_node,
2781         gfc_charlen_type_node, pchar4_type_node);
2782   DECL_PURE_P (gfor_fndecl_compare_string_char4) = 1;
2783   TREE_NOTHROW (gfor_fndecl_compare_string_char4) = 1;
2784
2785   gfor_fndecl_concat_string_char4 = gfc_build_library_function_decl_with_spec (
2786         get_identifier (PREFIX("concat_string_char4")), "..W.R.R",
2787         void_type_node, 6, gfc_charlen_type_node, pchar4_type_node,
2788         gfc_charlen_type_node, pchar4_type_node, gfc_charlen_type_node,
2789         pchar4_type_node);
2790   TREE_NOTHROW (gfor_fndecl_concat_string_char4) = 1;
2791
2792   gfor_fndecl_string_len_trim_char4 = gfc_build_library_function_decl_with_spec (
2793         get_identifier (PREFIX("string_len_trim_char4")), "..R",
2794         gfc_charlen_type_node, 2, gfc_charlen_type_node, pchar4_type_node);
2795   DECL_PURE_P (gfor_fndecl_string_len_trim_char4) = 1;
2796   TREE_NOTHROW (gfor_fndecl_string_len_trim_char4) = 1;
2797
2798   gfor_fndecl_string_index_char4 = gfc_build_library_function_decl_with_spec (
2799         get_identifier (PREFIX("string_index_char4")), "..R.R.",
2800         gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar4_type_node,
2801         gfc_charlen_type_node, pchar4_type_node, gfc_logical4_type_node);
2802   DECL_PURE_P (gfor_fndecl_string_index_char4) = 1;
2803   TREE_NOTHROW (gfor_fndecl_string_index_char4) = 1;
2804
2805   gfor_fndecl_string_scan_char4 = gfc_build_library_function_decl_with_spec (
2806         get_identifier (PREFIX("string_scan_char4")), "..R.R.",
2807         gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar4_type_node,
2808         gfc_charlen_type_node, pchar4_type_node, gfc_logical4_type_node);
2809   DECL_PURE_P (gfor_fndecl_string_scan_char4) = 1;
2810   TREE_NOTHROW (gfor_fndecl_string_scan_char4) = 1;
2811
2812   gfor_fndecl_string_verify_char4 = gfc_build_library_function_decl_with_spec (
2813         get_identifier (PREFIX("string_verify_char4")), "..R.R.",
2814         gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar4_type_node,
2815         gfc_charlen_type_node, pchar4_type_node, gfc_logical4_type_node);
2816   DECL_PURE_P (gfor_fndecl_string_verify_char4) = 1;
2817   TREE_NOTHROW (gfor_fndecl_string_verify_char4) = 1;
2818
2819   gfor_fndecl_string_trim_char4 = gfc_build_library_function_decl_with_spec (
2820         get_identifier (PREFIX("string_trim_char4")), ".Ww.R",
2821         void_type_node, 4, build_pointer_type (gfc_charlen_type_node),
2822         build_pointer_type (pchar4_type_node), gfc_charlen_type_node,
2823         pchar4_type_node);
2824
2825   gfor_fndecl_string_minmax_char4 = gfc_build_library_function_decl_with_spec (
2826         get_identifier (PREFIX("string_minmax_char4")), ".Ww.R",
2827         void_type_node, -4, build_pointer_type (gfc_charlen_type_node),
2828         build_pointer_type (pchar4_type_node), integer_type_node,
2829         integer_type_node);
2830
2831   gfor_fndecl_adjustl_char4 = gfc_build_library_function_decl_with_spec (
2832         get_identifier (PREFIX("adjustl_char4")), ".W.R",
2833         void_type_node, 3, pchar4_type_node, gfc_charlen_type_node,
2834         pchar4_type_node);
2835   TREE_NOTHROW (gfor_fndecl_adjustl_char4) = 1;
2836
2837   gfor_fndecl_adjustr_char4 = gfc_build_library_function_decl_with_spec (
2838         get_identifier (PREFIX("adjustr_char4")), ".W.R",
2839         void_type_node, 3, pchar4_type_node, gfc_charlen_type_node,
2840         pchar4_type_node);
2841   TREE_NOTHROW (gfor_fndecl_adjustr_char4) = 1;
2842
2843   gfor_fndecl_select_string_char4 = gfc_build_library_function_decl_with_spec (
2844         get_identifier (PREFIX("select_string_char4")), ".R.R.",
2845         integer_type_node, 4, pvoid_type_node, integer_type_node,
2846         pvoid_type_node, gfc_charlen_type_node);
2847   DECL_PURE_P (gfor_fndecl_select_string_char4) = 1;
2848   TREE_NOTHROW (gfor_fndecl_select_string_char4) = 1;
2849
2850
2851   /* Conversion between character kinds.  */
2852
2853   gfor_fndecl_convert_char1_to_char4 = gfc_build_library_function_decl_with_spec (
2854         get_identifier (PREFIX("convert_char1_to_char4")), ".w.R",
2855         void_type_node, 3, build_pointer_type (pchar4_type_node),
2856         gfc_charlen_type_node, pchar1_type_node);
2857
2858   gfor_fndecl_convert_char4_to_char1 = gfc_build_library_function_decl_with_spec (
2859         get_identifier (PREFIX("convert_char4_to_char1")), ".w.R",
2860         void_type_node, 3, build_pointer_type (pchar1_type_node),
2861         gfc_charlen_type_node, pchar4_type_node);
2862
2863   /* Misc. functions.  */
2864
2865   gfor_fndecl_ttynam = gfc_build_library_function_decl_with_spec (
2866         get_identifier (PREFIX("ttynam")), ".W",
2867         void_type_node, 3, pchar_type_node, gfc_charlen_type_node,
2868         integer_type_node);
2869
2870   gfor_fndecl_fdate = gfc_build_library_function_decl_with_spec (
2871         get_identifier (PREFIX("fdate")), ".W",
2872         void_type_node, 2, pchar_type_node, gfc_charlen_type_node);
2873
2874   gfor_fndecl_ctime = gfc_build_library_function_decl_with_spec (
2875         get_identifier (PREFIX("ctime")), ".W",
2876         void_type_node, 3, pchar_type_node, gfc_charlen_type_node,
2877         gfc_int8_type_node);
2878
2879   gfor_fndecl_sc_kind = gfc_build_library_function_decl_with_spec (
2880         get_identifier (PREFIX("selected_char_kind")), "..R",
2881         gfc_int4_type_node, 2, gfc_charlen_type_node, pchar_type_node);
2882   DECL_PURE_P (gfor_fndecl_sc_kind) = 1;
2883   TREE_NOTHROW (gfor_fndecl_sc_kind) = 1;
2884
2885   gfor_fndecl_si_kind = gfc_build_library_function_decl_with_spec (
2886         get_identifier (PREFIX("selected_int_kind")), ".R",
2887         gfc_int4_type_node, 1, pvoid_type_node);
2888   DECL_PURE_P (gfor_fndecl_si_kind) = 1;
2889   TREE_NOTHROW (gfor_fndecl_si_kind) = 1;
2890
2891   gfor_fndecl_sr_kind = gfc_build_library_function_decl_with_spec (
2892         get_identifier (PREFIX("selected_real_kind2008")), ".RR",
2893         gfc_int4_type_node, 3, pvoid_type_node, pvoid_type_node,
2894         pvoid_type_node);
2895   DECL_PURE_P (gfor_fndecl_sr_kind) = 1;
2896   TREE_NOTHROW (gfor_fndecl_sr_kind) = 1;
2897
2898   /* Power functions.  */
2899   {
2900     tree ctype, rtype, itype, jtype;
2901     int rkind, ikind, jkind;
2902 #define NIKINDS 3
2903 #define NRKINDS 4
2904     static int ikinds[NIKINDS] = {4, 8, 16};
2905     static int rkinds[NRKINDS] = {4, 8, 10, 16};
2906     char name[PREFIX_LEN + 12]; /* _gfortran_pow_?n_?n */
2907
2908     for (ikind=0; ikind < NIKINDS; ikind++)
2909       {
2910         itype = gfc_get_int_type (ikinds[ikind]);
2911
2912         for (jkind=0; jkind < NIKINDS; jkind++)
2913           {
2914             jtype = gfc_get_int_type (ikinds[jkind]);
2915             if (itype && jtype)
2916               {
2917                 sprintf(name, PREFIX("pow_i%d_i%d"), ikinds[ikind],
2918                         ikinds[jkind]);
2919                 gfor_fndecl_math_powi[jkind][ikind].integer =
2920                   gfc_build_library_function_decl (get_identifier (name),
2921                     jtype, 2, jtype, itype);
2922                 TREE_READONLY (gfor_fndecl_math_powi[jkind][ikind].integer) = 1;
2923                 TREE_NOTHROW (gfor_fndecl_math_powi[jkind][ikind].integer) = 1;
2924               }
2925           }
2926
2927         for (rkind = 0; rkind < NRKINDS; rkind ++)
2928           {
2929             rtype = gfc_get_real_type (rkinds[rkind]);
2930             if (rtype && itype)
2931               {
2932                 sprintf(name, PREFIX("pow_r%d_i%d"), rkinds[rkind],
2933                         ikinds[ikind]);
2934                 gfor_fndecl_math_powi[rkind][ikind].real =
2935                   gfc_build_library_function_decl (get_identifier (name),
2936                     rtype, 2, rtype, itype);
2937                 TREE_READONLY (gfor_fndecl_math_powi[rkind][ikind].real) = 1;
2938                 TREE_NOTHROW (gfor_fndecl_math_powi[rkind][ikind].real) = 1;
2939               }
2940
2941             ctype = gfc_get_complex_type (rkinds[rkind]);
2942             if (ctype && itype)
2943               {
2944                 sprintf(name, PREFIX("pow_c%d_i%d"), rkinds[rkind],
2945                         ikinds[ikind]);
2946                 gfor_fndecl_math_powi[rkind][ikind].cmplx =
2947                   gfc_build_library_function_decl (get_identifier (name),
2948                     ctype, 2,ctype, itype);
2949                 TREE_READONLY (gfor_fndecl_math_powi[rkind][ikind].cmplx) = 1;
2950                 TREE_NOTHROW (gfor_fndecl_math_powi[rkind][ikind].cmplx) = 1;
2951               }
2952           }
2953       }
2954 #undef NIKINDS
2955 #undef NRKINDS
2956   }
2957
2958   gfor_fndecl_math_ishftc4 = gfc_build_library_function_decl (
2959         get_identifier (PREFIX("ishftc4")),
2960         gfc_int4_type_node, 3, gfc_int4_type_node, gfc_int4_type_node,
2961         gfc_int4_type_node);
2962   TREE_READONLY (gfor_fndecl_math_ishftc4) = 1;
2963   TREE_NOTHROW (gfor_fndecl_math_ishftc4) = 1;
2964
2965   gfor_fndecl_math_ishftc8 = gfc_build_library_function_decl (
2966         get_identifier (PREFIX("ishftc8")),
2967         gfc_int8_type_node, 3, gfc_int8_type_node, gfc_int4_type_node,
2968         gfc_int4_type_node);
2969   TREE_READONLY (gfor_fndecl_math_ishftc8) = 1;
2970   TREE_NOTHROW (gfor_fndecl_math_ishftc8) = 1;
2971
2972   if (gfc_int16_type_node)
2973     {
2974       gfor_fndecl_math_ishftc16 = gfc_build_library_function_decl (
2975         get_identifier (PREFIX("ishftc16")),
2976         gfc_int16_type_node, 3, gfc_int16_type_node, gfc_int4_type_node,
2977         gfc_int4_type_node);
2978       TREE_READONLY (gfor_fndecl_math_ishftc16) = 1;
2979       TREE_NOTHROW (gfor_fndecl_math_ishftc16) = 1;
2980     }
2981
2982   /* BLAS functions.  */
2983   {
2984     tree pint = build_pointer_type (integer_type_node);
2985     tree ps = build_pointer_type (gfc_get_real_type (gfc_default_real_kind));
2986     tree pd = build_pointer_type (gfc_get_real_type (gfc_default_double_kind));
2987     tree pc = build_pointer_type (gfc_get_complex_type (gfc_default_real_kind));
2988     tree pz = build_pointer_type
2989                 (gfc_get_complex_type (gfc_default_double_kind));
2990
2991     gfor_fndecl_sgemm = gfc_build_library_function_decl
2992                           (get_identifier
2993                              (gfc_option.flag_underscoring ? "sgemm_"
2994                                                            : "sgemm"),
2995                            void_type_node, 15, pchar_type_node,
2996                            pchar_type_node, pint, pint, pint, ps, ps, pint,
2997                            ps, pint, ps, ps, pint, integer_type_node,
2998                            integer_type_node);
2999     gfor_fndecl_dgemm = gfc_build_library_function_decl
3000                           (get_identifier
3001                              (gfc_option.flag_underscoring ? "dgemm_"
3002                                                            : "dgemm"),
3003                            void_type_node, 15, pchar_type_node,
3004                            pchar_type_node, pint, pint, pint, pd, pd, pint,
3005                            pd, pint, pd, pd, pint, integer_type_node,
3006                            integer_type_node);
3007     gfor_fndecl_cgemm = gfc_build_library_function_decl
3008                           (get_identifier
3009                              (gfc_option.flag_underscoring ? "cgemm_"
3010                                                            : "cgemm"),
3011                            void_type_node, 15, pchar_type_node,
3012                            pchar_type_node, pint, pint, pint, pc, pc, pint,
3013                            pc, pint, pc, pc, pint, integer_type_node,
3014                            integer_type_node);
3015     gfor_fndecl_zgemm = gfc_build_library_function_decl
3016                           (get_identifier
3017                              (gfc_option.flag_underscoring ? "zgemm_"
3018                                                            : "zgemm"),
3019                            void_type_node, 15, pchar_type_node,
3020                            pchar_type_node, pint, pint, pint, pz, pz, pint,
3021                            pz, pint, pz, pz, pint, integer_type_node,
3022                            integer_type_node);
3023   }
3024
3025   /* Other functions.  */
3026   gfor_fndecl_size0 = gfc_build_library_function_decl_with_spec (
3027         get_identifier (PREFIX("size0")), ".R",
3028         gfc_array_index_type, 1, pvoid_type_node);
3029   DECL_PURE_P (gfor_fndecl_size0) = 1;
3030   TREE_NOTHROW (gfor_fndecl_size0) = 1;
3031
3032   gfor_fndecl_size1 = gfc_build_library_function_decl_with_spec (
3033         get_identifier (PREFIX("size1")), ".R",
3034         gfc_array_index_type, 2, pvoid_type_node, gfc_array_index_type);
3035   DECL_PURE_P (gfor_fndecl_size1) = 1;
3036   TREE_NOTHROW (gfor_fndecl_size1) = 1;
3037
3038   gfor_fndecl_iargc = gfc_build_library_function_decl (
3039         get_identifier (PREFIX ("iargc")), gfc_int4_type_node, 0);
3040   TREE_NOTHROW (gfor_fndecl_iargc) = 1;
3041 }
3042
3043
3044 /* Make prototypes for runtime library functions.  */
3045
3046 void
3047 gfc_build_builtin_function_decls (void)
3048 {
3049   tree gfc_int4_type_node = gfc_get_int_type (4);
3050
3051   gfor_fndecl_stop_numeric = gfc_build_library_function_decl (
3052         get_identifier (PREFIX("stop_numeric")),
3053         void_type_node, 1, gfc_int4_type_node);
3054   /* STOP doesn't return.  */
3055   TREE_THIS_VOLATILE (gfor_fndecl_stop_numeric) = 1;
3056
3057   gfor_fndecl_stop_numeric_f08 = gfc_build_library_function_decl (
3058         get_identifier (PREFIX("stop_numeric_f08")),
3059         void_type_node, 1, gfc_int4_type_node);
3060   /* STOP doesn't return.  */
3061   TREE_THIS_VOLATILE (gfor_fndecl_stop_numeric_f08) = 1;
3062
3063   gfor_fndecl_stop_string = gfc_build_library_function_decl_with_spec (
3064         get_identifier (PREFIX("stop_string")), ".R.",
3065         void_type_node, 2, pchar_type_node, gfc_int4_type_node);
3066   /* STOP doesn't return.  */
3067   TREE_THIS_VOLATILE (gfor_fndecl_stop_string) = 1;
3068
3069   gfor_fndecl_error_stop_numeric = gfc_build_library_function_decl (
3070         get_identifier (PREFIX("error_stop_numeric")),
3071         void_type_node, 1, gfc_int4_type_node);
3072   /* ERROR STOP doesn't return.  */
3073   TREE_THIS_VOLATILE (gfor_fndecl_error_stop_numeric) = 1;
3074
3075   gfor_fndecl_error_stop_string = gfc_build_library_function_decl_with_spec (
3076         get_identifier (PREFIX("error_stop_string")), ".R.",
3077         void_type_node, 2, pchar_type_node, gfc_int4_type_node);
3078   /* ERROR STOP doesn't return.  */
3079   TREE_THIS_VOLATILE (gfor_fndecl_error_stop_string) = 1;
3080
3081   gfor_fndecl_pause_numeric = gfc_build_library_function_decl (
3082         get_identifier (PREFIX("pause_numeric")),
3083         void_type_node, 1, gfc_int4_type_node);
3084
3085   gfor_fndecl_pause_string = gfc_build_library_function_decl_with_spec (
3086         get_identifier (PREFIX("pause_string")), ".R.",
3087         void_type_node, 2, pchar_type_node, gfc_int4_type_node);
3088
3089   gfor_fndecl_runtime_error = gfc_build_library_function_decl_with_spec (
3090         get_identifier (PREFIX("runtime_error")), ".R",
3091         void_type_node, -1, pchar_type_node);
3092   /* The runtime_error function does not return.  */
3093   TREE_THIS_VOLATILE (gfor_fndecl_runtime_error) = 1;
3094
3095   gfor_fndecl_runtime_error_at = gfc_build_library_function_decl_with_spec (
3096         get_identifier (PREFIX("runtime_error_at")), ".RR",
3097         void_type_node, -2, pchar_type_node, pchar_type_node);
3098   /* The runtime_error_at function does not return.  */
3099   TREE_THIS_VOLATILE (gfor_fndecl_runtime_error_at) = 1;
3100
3101   gfor_fndecl_runtime_warning_at = gfc_build_library_function_decl_with_spec (
3102         get_identifier (PREFIX("runtime_warning_at")), ".RR",
3103         void_type_node, -2, pchar_type_node, pchar_type_node);
3104
3105   gfor_fndecl_generate_error = gfc_build_library_function_decl_with_spec (
3106         get_identifier (PREFIX("generate_error")), ".R.R",
3107         void_type_node, 3, pvoid_type_node, integer_type_node,
3108         pchar_type_node);
3109
3110   gfor_fndecl_os_error = gfc_build_library_function_decl_with_spec (
3111         get_identifier (PREFIX("os_error")), ".R",
3112         void_type_node, 1, pchar_type_node);
3113   /* The runtime_error function does not return.  */
3114   TREE_THIS_VOLATILE (gfor_fndecl_os_error) = 1;
3115
3116   gfor_fndecl_set_args = gfc_build_library_function_decl (
3117         get_identifier (PREFIX("set_args")),
3118         void_type_node, 2, integer_type_node,
3119         build_pointer_type (pchar_type_node));
3120
3121   gfor_fndecl_set_fpe = gfc_build_library_function_decl (
3122         get_identifier (PREFIX("set_fpe")),
3123         void_type_node, 1, integer_type_node);
3124
3125   /* Keep the array dimension in sync with the call, later in this file.  */
3126   gfor_fndecl_set_options = gfc_build_library_function_decl_with_spec (
3127         get_identifier (PREFIX("set_options")), "..R",
3128         void_type_node, 2, integer_type_node,
3129         build_pointer_type (integer_type_node));
3130
3131   gfor_fndecl_set_convert = gfc_build_library_function_decl (
3132         get_identifier (PREFIX("set_convert")),
3133         void_type_node, 1, integer_type_node);
3134
3135   gfor_fndecl_set_record_marker = gfc_build_library_function_decl (
3136         get_identifier (PREFIX("set_record_marker")),
3137         void_type_node, 1, integer_type_node);
3138
3139   gfor_fndecl_set_max_subrecord_length = gfc_build_library_function_decl (
3140         get_identifier (PREFIX("set_max_subrecord_length")),
3141         void_type_node, 1, integer_type_node);
3142
3143   gfor_fndecl_in_pack = gfc_build_library_function_decl_with_spec (
3144         get_identifier (PREFIX("internal_pack")), ".r",
3145         pvoid_type_node, 1, pvoid_type_node);
3146
3147   gfor_fndecl_in_unpack = gfc_build_library_function_decl_with_spec (
3148         get_identifier (PREFIX("internal_unpack")), ".wR",
3149         void_type_node, 2, pvoid_type_node, pvoid_type_node);
3150
3151   gfor_fndecl_associated = gfc_build_library_function_decl_with_spec (
3152         get_identifier (PREFIX("associated")), ".RR",
3153         integer_type_node, 2, ppvoid_type_node, ppvoid_type_node);
3154   DECL_PURE_P (gfor_fndecl_associated) = 1;
3155   TREE_NOTHROW (gfor_fndecl_associated) = 1;
3156
3157   /* Coarray library calls.  */
3158   if (gfc_option.coarray == GFC_FCOARRAY_LIB)
3159     {
3160       tree pint_type, pppchar_type;
3161
3162       pint_type = build_pointer_type (integer_type_node);
3163       pppchar_type
3164         = build_pointer_type (build_pointer_type (pchar_type_node));
3165
3166       gfor_fndecl_caf_init = gfc_build_library_function_decl (
3167                    get_identifier (PREFIX("caf_init")),  void_type_node,
3168                    4, pint_type, pppchar_type, pint_type, pint_type);
3169
3170       gfor_fndecl_caf_finalize = gfc_build_library_function_decl (
3171         get_identifier (PREFIX("caf_finalize")), void_type_node, 0);
3172
3173       gfor_fndecl_caf_register = gfc_build_library_function_decl_with_spec (
3174         get_identifier (PREFIX("caf_register")), "...WWW", pvoid_type_node, 6,
3175         size_type_node, integer_type_node, ppvoid_type_node, pint_type,
3176         pchar_type_node, integer_type_node);
3177
3178       gfor_fndecl_caf_deregister = gfc_build_library_function_decl_with_spec (
3179         get_identifier (PREFIX("caf_deregister")), ".WWW", void_type_node, 4,
3180         ppvoid_type_node, pint_type, pchar_type_node, integer_type_node);
3181
3182       gfor_fndecl_caf_critical = gfc_build_library_function_decl (
3183         get_identifier (PREFIX("caf_critical")), void_type_node, 0);
3184
3185       gfor_fndecl_caf_end_critical = gfc_build_library_function_decl (
3186         get_identifier (PREFIX("caf_end_critical")), void_type_node, 0);
3187
3188       gfor_fndecl_caf_sync_all = gfc_build_library_function_decl_with_spec (
3189         get_identifier (PREFIX("caf_sync_all")), ".WW", void_type_node,
3190         3, pint_type, build_pointer_type (pchar_type_node), integer_type_node);
3191
3192       gfor_fndecl_caf_sync_images = gfc_build_library_function_decl_with_spec (
3193         get_identifier (PREFIX("caf_sync_images")), ".RRWW", void_type_node,
3194         5, integer_type_node, pint_type, pint_type,
3195         build_pointer_type (pchar_type_node), integer_type_node);
3196
3197       gfor_fndecl_caf_error_stop = gfc_build_library_function_decl (
3198         get_identifier (PREFIX("caf_error_stop")),
3199         void_type_node, 1, gfc_int4_type_node);
3200       /* CAF's ERROR STOP doesn't return.  */
3201       TREE_THIS_VOLATILE (gfor_fndecl_caf_error_stop) = 1;
3202
3203       gfor_fndecl_caf_error_stop_str = gfc_build_library_function_decl_with_spec (
3204         get_identifier (PREFIX("caf_error_stop_str")), ".R.",
3205         void_type_node, 2, pchar_type_node, gfc_int4_type_node);
3206       /* CAF's ERROR STOP doesn't return.  */
3207       TREE_THIS_VOLATILE (gfor_fndecl_caf_error_stop_str) = 1;
3208     }
3209
3210   gfc_build_intrinsic_function_decls ();
3211   gfc_build_intrinsic_lib_fndecls ();
3212   gfc_build_io_library_fndecls ();
3213 }
3214
3215
3216 /* Evaluate the length of dummy character variables.  */
3217
3218 static void
3219 gfc_trans_dummy_character (gfc_symbol *sym, gfc_charlen *cl,
3220                            gfc_wrapped_block *block)
3221 {
3222   stmtblock_t init;
3223
3224   gfc_finish_decl (cl->backend_decl);
3225
3226   gfc_start_block (&init);
3227
3228   /* Evaluate the string length expression.  */
3229   gfc_conv_string_length (cl, NULL, &init);
3230
3231   gfc_trans_vla_type_sizes (sym, &init);
3232
3233   gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
3234 }
3235
3236
3237 /* Allocate and cleanup an automatic character variable.  */
3238
3239 static void
3240 gfc_trans_auto_character_variable (gfc_symbol * sym, gfc_wrapped_block * block)
3241 {
3242   stmtblock_t init;
3243   tree decl;
3244   tree tmp;
3245
3246   gcc_assert (sym->backend_decl);
3247   gcc_assert (sym->ts.u.cl && sym->ts.u.cl->length);
3248
3249   gfc_init_block (&init);
3250
3251   /* Evaluate the string length expression.  */
3252   gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
3253
3254   gfc_trans_vla_type_sizes (sym, &init);
3255
3256   decl = sym->backend_decl;
3257
3258   /* Emit a DECL_EXPR for this variable, which will cause the
3259      gimplifier to allocate storage, and all that good stuff.  */
3260   tmp = fold_build1_loc (input_location, DECL_EXPR, TREE_TYPE (decl), decl);
3261   gfc_add_expr_to_block (&init, tmp);
3262
3263   gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
3264 }
3265
3266 /* Set the initial value of ASSIGN statement auxiliary variable explicitly.  */
3267
3268 static void
3269 gfc_trans_assign_aux_var (gfc_symbol * sym, gfc_wrapped_block * block)
3270 {
3271   stmtblock_t init;
3272
3273   gcc_assert (sym->backend_decl);
3274   gfc_start_block (&init);
3275
3276   /* Set the initial value to length. See the comments in
3277      function gfc_add_assign_aux_vars in this file.  */
3278   gfc_add_modify (&init, GFC_DECL_STRING_LEN (sym->backend_decl),
3279                   build_int_cst (gfc_charlen_type_node, -2));
3280
3281   gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
3282 }
3283
3284 static void
3285 gfc_trans_vla_one_sizepos (tree *tp, stmtblock_t *body)
3286 {
3287   tree t = *tp, var, val;
3288
3289   if (t == NULL || t == error_mark_node)
3290     return;
3291   if (TREE_CONSTANT (t) || DECL_P (t))
3292     return;
3293
3294   if (TREE_CODE (t) == SAVE_EXPR)
3295     {
3296       if (SAVE_EXPR_RESOLVED_P (t))
3297         {
3298           *tp = TREE_OPERAND (t, 0);
3299           return;
3300         }
3301       val = TREE_OPERAND (t, 0);
3302     }
3303   else
3304     val = t;
3305
3306   var = gfc_create_var_np (TREE_TYPE (t), NULL);
3307   gfc_add_decl_to_function (var);
3308   gfc_add_modify (body, var, val);
3309   if (TREE_CODE (t) == SAVE_EXPR)
3310     TREE_OPERAND (t, 0) = var;
3311   *tp = var;
3312 }
3313
3314 static void
3315 gfc_trans_vla_type_sizes_1 (tree type, stmtblock_t *body)
3316 {
3317   tree t;
3318
3319   if (type == NULL || type == error_mark_node)
3320     return;
3321
3322   type = TYPE_MAIN_VARIANT (type);
3323
3324   if (TREE_CODE (type) == INTEGER_TYPE)
3325     {
3326       gfc_trans_vla_one_sizepos (&TYPE_MIN_VALUE (type), body);
3327       gfc_trans_vla_one_sizepos (&TYPE_MAX_VALUE (type), body);
3328
3329       for (t = TYPE_NEXT_VARIANT (type); t; t = TYPE_NEXT_VARIANT (t))
3330         {
3331           TYPE_MIN_VALUE (t) = TYPE_MIN_VALUE (type);
3332           TYPE_MAX_VALUE (t) = TYPE_MAX_VALUE (type);
3333         }
3334     }
3335   else if (TREE_CODE (type) == ARRAY_TYPE)
3336     {
3337       gfc_trans_vla_type_sizes_1 (TREE_TYPE (type), body);
3338       gfc_trans_vla_type_sizes_1 (TYPE_DOMAIN (type), body);
3339       gfc_trans_vla_one_sizepos (&TYPE_SIZE (type), body);
3340       gfc_trans_vla_one_sizepos (&TYPE_SIZE_UNIT (type), body);
3341
3342       for (t = TYPE_NEXT_VARIANT (type); t; t = TYPE_NEXT_VARIANT (t))
3343         {
3344           TYPE_SIZE (t) = TYPE_SIZE (type);
3345           TYPE_SIZE_UNIT (t) = TYPE_SIZE_UNIT (type);
3346         }
3347     }
3348 }
3349
3350 /* Make sure all type sizes and array domains are either constant,
3351    or variable or parameter decls.  This is a simplified variant
3352    of gimplify_type_sizes, but we can't use it here, as none of the
3353    variables in the expressions have been gimplified yet.
3354    As type sizes and domains for various variable length arrays
3355    contain VAR_DECLs that are only initialized at gfc_trans_deferred_vars
3356    time, without this routine gimplify_type_sizes in the middle-end
3357    could result in the type sizes being gimplified earlier than where
3358    those variables are initialized.  */
3359
3360 void
3361 gfc_trans_vla_type_sizes (gfc_symbol *sym, stmtblock_t *body)
3362 {
3363   tree type = TREE_TYPE (sym->backend_decl);
3364
3365   if (TREE_CODE (type) == FUNCTION_TYPE
3366       && (sym->attr.function || sym->attr.result || sym->attr.entry))
3367     {
3368       if (! current_fake_result_decl)
3369         return;
3370
3371       type = TREE_TYPE (TREE_VALUE (current_fake_result_decl));
3372     }
3373
3374   while (POINTER_TYPE_P (type))
3375     type = TREE_TYPE (type);
3376
3377   if (GFC_DESCRIPTOR_TYPE_P (type))
3378     {
3379       tree etype = GFC_TYPE_ARRAY_DATAPTR_TYPE (type);
3380
3381       while (POINTER_TYPE_P (etype))
3382         etype = TREE_TYPE (etype);
3383
3384       gfc_trans_vla_type_sizes_1 (etype, body);
3385     }
3386
3387   gfc_trans_vla_type_sizes_1 (type, body);
3388 }
3389
3390
3391 /* Initialize a derived type by building an lvalue from the symbol
3392    and using trans_assignment to do the work. Set dealloc to false
3393    if no deallocation prior the assignment is needed.  */
3394 void
3395 gfc_init_default_dt (gfc_symbol * sym, stmtblock_t * block, bool dealloc)
3396 {
3397   gfc_expr *e;
3398   tree tmp;
3399   tree present;
3400
3401   gcc_assert (block);
3402
3403   gcc_assert (!sym->attr.allocatable);
3404   gfc_set_sym_referenced (sym);
3405   e = gfc_lval_expr_from_sym (sym);
3406   tmp = gfc_trans_assignment (e, sym->value, false, dealloc);
3407   if (sym->attr.dummy && (sym->attr.optional
3408                           || sym->ns->proc_name->attr.entry_master))
3409     {
3410       present = gfc_conv_expr_present (sym);
3411       tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), present,
3412                         tmp, build_empty_stmt (input_location));
3413     }
3414   gfc_add_expr_to_block (block, tmp);
3415   gfc_free_expr (e);
3416 }
3417
3418
3419 /* Initialize INTENT(OUT) derived type dummies.  As well as giving
3420    them their default initializer, if they do not have allocatable
3421    components, they have their allocatable components deallocated. */
3422
3423 static void
3424 init_intent_out_dt (gfc_symbol * proc_sym, gfc_wrapped_block * block)
3425 {
3426   stmtblock_t init;
3427   gfc_formal_arglist *f;
3428   tree tmp;
3429   tree present;
3430
3431   gfc_init_block (&init);
3432   for (f = proc_sym->formal; f; f = f->next)
3433     if (f->sym && f->sym->attr.intent == INTENT_OUT
3434         && !f->sym->attr.pointer
3435         && f->sym->ts.type == BT_DERIVED)
3436       {
3437         if (f->sym->ts.u.derived->attr.alloc_comp && !f->sym->value)
3438           {
3439             tmp = gfc_deallocate_alloc_comp (f->sym->ts.u.derived,
3440                                              f->sym->backend_decl,
3441                                              f->sym->as ? f->sym->as->rank : 0);
3442
3443             if (f->sym->attr.optional
3444                 || f->sym->ns->proc_name->attr.entry_master)
3445               {
3446                 present = gfc_conv_expr_present (f->sym);
3447                 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
3448                                   present, tmp,
3449                                   build_empty_stmt (input_location));
3450               }
3451
3452             gfc_add_expr_to_block (&init, tmp);
3453           }
3454        else if (f->sym->value)
3455           gfc_init_default_dt (f->sym, &init, true);
3456       }
3457     else if (f->sym && f->sym->attr.intent == INTENT_OUT
3458              && f->sym->ts.type == BT_CLASS
3459              && !CLASS_DATA (f->sym)->attr.class_pointer
3460              && CLASS_DATA (f->sym)->ts.u.derived->attr.alloc_comp)
3461       {
3462         tree decl = build_fold_indirect_ref_loc (input_location,
3463                                                  f->sym->backend_decl);
3464         tmp = CLASS_DATA (f->sym)->backend_decl;
3465         tmp = fold_build3_loc (input_location, COMPONENT_REF,
3466                                TREE_TYPE (tmp), decl, tmp, NULL_TREE);
3467         tmp = build_fold_indirect_ref_loc (input_location, tmp);
3468         tmp = gfc_deallocate_alloc_comp (CLASS_DATA (f->sym)->ts.u.derived,
3469                                          tmp,
3470                                          CLASS_DATA (f->sym)->as ?
3471                                          CLASS_DATA (f->sym)->as->rank : 0);
3472
3473         if (f->sym->attr.optional || f->sym->ns->proc_name->attr.entry_master)
3474           {
3475             present = gfc_conv_expr_present (f->sym);
3476             tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
3477                               present, tmp,
3478                               build_empty_stmt (input_location));
3479           }
3480
3481         gfc_add_expr_to_block (&init, tmp);
3482       }
3483
3484   gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
3485 }
3486
3487
3488 /* Generate function entry and exit code, and add it to the function body.
3489    This includes:
3490     Allocation and initialization of array variables.
3491     Allocation of character string variables.
3492     Initialization and possibly repacking of dummy arrays.
3493     Initialization of ASSIGN statement auxiliary variable.
3494     Initialization of ASSOCIATE names.
3495     Automatic deallocation.  */
3496
3497 void
3498 gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
3499 {
3500   locus loc;
3501   gfc_symbol *sym;
3502   gfc_formal_arglist *f;
3503   stmtblock_t tmpblock;
3504   bool seen_trans_deferred_array = false;
3505   tree tmp = NULL;
3506   gfc_expr *e;
3507   gfc_se se;
3508   stmtblock_t init;
3509
3510   /* Deal with implicit return variables.  Explicit return variables will
3511      already have been added.  */
3512   if (gfc_return_by_reference (proc_sym) && proc_sym->result == proc_sym)
3513     {
3514       if (!current_fake_result_decl)
3515         {
3516           gfc_entry_list *el = NULL;
3517           if (proc_sym->attr.entry_master)
3518             {
3519               for (el = proc_sym->ns->entries; el; el = el->next)
3520                 if (el->sym != el->sym->result)
3521                   break;
3522             }
3523           /* TODO: move to the appropriate place in resolve.c.  */
3524           if (warn_return_type && el == NULL)
3525             gfc_warning ("Return value of function '%s' at %L not set",
3526                          proc_sym->name, &proc_sym->declared_at);
3527         }
3528       else if (proc_sym->as)
3529         {
3530           tree result = TREE_VALUE (current_fake_result_decl);
3531           gfc_trans_dummy_array_bias (proc_sym, result, block);
3532
3533           /* An automatic character length, pointer array result.  */
3534           if (proc_sym->ts.type == BT_CHARACTER
3535                 && TREE_CODE (proc_sym->ts.u.cl->backend_decl) == VAR_DECL)
3536             gfc_trans_dummy_character (proc_sym, proc_sym->ts.u.cl, block);
3537         }
3538       else if (proc_sym->ts.type == BT_CHARACTER)
3539         {
3540           if (proc_sym->ts.deferred)
3541             {
3542               tmp = NULL;
3543               gfc_save_backend_locus (&loc);
3544               gfc_set_backend_locus (&proc_sym->declared_at);
3545               gfc_start_block (&init);
3546               /* Zero the string length on entry.  */
3547               gfc_add_modify (&init, proc_sym->ts.u.cl->backend_decl,
3548                               build_int_cst (gfc_charlen_type_node, 0));
3549               /* Null the pointer.  */
3550               e = gfc_lval_expr_from_sym (proc_sym);
3551               gfc_init_se (&se, NULL);
3552               se.want_pointer = 1;
3553               gfc_conv_expr (&se, e);
3554               gfc_free_expr (e);
3555               tmp = se.expr;
3556               gfc_add_modify (&init, tmp,
3557                               fold_convert (TREE_TYPE (se.expr),
3558                                             null_pointer_node));
3559               gfc_restore_backend_locus (&loc);
3560
3561               /* Pass back the string length on exit.  */
3562               tmp = proc_sym->ts.u.cl->passed_length;
3563               tmp = build_fold_indirect_ref_loc (input_location, tmp);
3564               tmp = fold_convert (gfc_charlen_type_node, tmp);
3565               tmp = fold_build2_loc (input_location, MODIFY_EXPR,
3566                                      gfc_charlen_type_node, tmp,
3567                                      proc_sym->ts.u.cl->backend_decl);
3568               gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp);
3569             }
3570           else if (TREE_CODE (proc_sym->ts.u.cl->backend_decl) == VAR_DECL)
3571             gfc_trans_dummy_character (proc_sym, proc_sym->ts.u.cl, block);
3572         }
3573       else
3574         gcc_assert (gfc_option.flag_f2c
3575                     && proc_sym->ts.type == BT_COMPLEX);
3576     }
3577
3578   /* Initialize the INTENT(OUT) derived type dummy arguments.  This
3579      should be done here so that the offsets and lbounds of arrays
3580      are available.  */
3581   gfc_save_backend_locus (&loc);
3582   gfc_set_backend_locus (&proc_sym->declared_at);
3583   init_intent_out_dt (proc_sym, block);
3584   gfc_restore_backend_locus (&loc);
3585
3586   for (sym = proc_sym->tlink; sym != proc_sym; sym = sym->tlink)
3587     {
3588       bool sym_has_alloc_comp = (sym->ts.type == BT_DERIVED)
3589                                    && sym->ts.u.derived->attr.alloc_comp;
3590       if (sym->assoc)
3591         continue;
3592
3593       if (sym->attr.subref_array_pointer
3594           && GFC_DECL_SPAN (sym->backend_decl)
3595           && !TREE_STATIC (GFC_DECL_SPAN (sym->backend_decl)))
3596         {
3597           gfc_init_block (&tmpblock);
3598           gfc_add_modify (&tmpblock, GFC_DECL_SPAN (sym->backend_decl),
3599                           build_int_cst (gfc_array_index_type, 0));
3600           gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock),
3601                                 NULL_TREE);
3602         }
3603
3604       if (sym->attr.dimension || sym->attr.codimension)
3605         {
3606           /* Assumed-size Cray pointees need to be treated as AS_EXPLICIT.  */
3607           array_type tmp = sym->as->type;
3608           if (tmp == AS_ASSUMED_SIZE && sym->as->cp_was_assumed)
3609             tmp = AS_EXPLICIT;
3610           switch (tmp)
3611             {
3612             case AS_EXPLICIT:
3613               if (sym->attr.dummy || sym->attr.result)
3614                 gfc_trans_dummy_array_bias (sym, sym->backend_decl, block);
3615               else if (sym->attr.pointer || sym->attr.allocatable)
3616                 {
3617                   if (TREE_STATIC (sym->backend_decl))
3618                     {
3619                       gfc_save_backend_locus (&loc);
3620                       gfc_set_backend_locus (&sym->declared_at);
3621                       gfc_trans_static_array_pointer (sym);
3622                       gfc_restore_backend_locus (&loc);
3623                     }
3624                   else
3625                     {
3626                       seen_trans_deferred_array = true;
3627                       gfc_trans_deferred_array (sym, block);
3628                     }
3629                 }
3630               else if (sym->attr.codimension && TREE_STATIC (sym->backend_decl))
3631                 {
3632                   gfc_init_block (&tmpblock);
3633                   gfc_trans_array_cobounds (TREE_TYPE (sym->backend_decl),
3634                                             &tmpblock, sym);
3635                   gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock),
3636                                         NULL_TREE);
3637                   continue;
3638                 }
3639               else if (gfc_option.coarray != GFC_FCOARRAY_LIB)
3640                 {
3641                   gfc_save_backend_locus (&loc);
3642                   gfc_set_backend_locus (&sym->declared_at);
3643
3644                   if (sym_has_alloc_comp)
3645                     {
3646                       seen_trans_deferred_array = true;
3647                       gfc_trans_deferred_array (sym, block);
3648                     }
3649                   else if (sym->ts.type == BT_DERIVED
3650                              && sym->value
3651                              && !sym->attr.data
3652                              && sym->attr.save == SAVE_NONE)
3653                     {
3654                       gfc_start_block (&tmpblock);
3655                       gfc_init_default_dt (sym, &tmpblock, false);
3656                       gfc_add_init_cleanup (block,
3657                                             gfc_finish_block (&tmpblock),
3658                                             NULL_TREE);
3659                     }
3660
3661                   gfc_trans_auto_array_allocation (sym->backend_decl,
3662                                                    sym, block);
3663                   gfc_restore_backend_locus (&loc);
3664                 }
3665               break;
3666
3667             case AS_ASSUMED_SIZE:
3668               /* Must be a dummy parameter.  */
3669               gcc_assert (sym->attr.dummy || sym->as->cp_was_assumed);
3670
3671               /* We should always pass assumed size arrays the g77 way.  */
3672               if (sym->attr.dummy)
3673                 gfc_trans_g77_array (sym, block);
3674               break;
3675
3676             case AS_ASSUMED_SHAPE:
3677               /* Must be a dummy parameter.  */
3678               gcc_assert (sym->attr.dummy);
3679
3680               gfc_trans_dummy_array_bias (sym, sym->backend_decl, block);
3681               break;
3682
3683             case AS_DEFERRED:
3684               seen_trans_deferred_array = true;
3685               gfc_trans_deferred_array (sym, block);
3686               break;
3687
3688             default:
3689               gcc_unreachable ();
3690             }
3691           if (sym_has_alloc_comp && !seen_trans_deferred_array)
3692             gfc_trans_deferred_array (sym, block);
3693         }
3694       else if ((!sym->attr.dummy || sym->ts.deferred)
3695                 && (sym->ts.type == BT_CLASS
3696                 && CLASS_DATA (sym)->attr.class_pointer))
3697         continue;
3698       else if ((!sym->attr.dummy || sym->ts.deferred)
3699                 && (sym->attr.allocatable
3700                     || (sym->ts.type == BT_CLASS
3701                         && CLASS_DATA (sym)->attr.allocatable)))
3702         {
3703           if (!sym->attr.save)
3704             {
3705               tree descriptor = NULL_TREE;
3706
3707               /* Nullify and automatic deallocation of allocatable
3708                  scalars.  */
3709               e = gfc_lval_expr_from_sym (sym);
3710               if (sym->ts.type == BT_CLASS)
3711                 gfc_add_data_component (e);
3712
3713               gfc_init_se (&se, NULL);
3714               if (sym->ts.type != BT_CLASS
3715                   || sym->ts.u.derived->attr.dimension
3716                   || sym->ts.u.derived->attr.codimension)
3717                 {
3718                   se.want_pointer = 1;
3719                   gfc_conv_expr (&se, e);
3720                 }
3721               else if (sym->ts.type == BT_CLASS
3722                        && !CLASS_DATA (sym)->attr.dimension
3723                        && !CLASS_DATA (sym)->attr.codimension)
3724                 {
3725                   se.want_pointer = 1;
3726                   gfc_conv_expr (&se, e);
3727                 }
3728               else
3729                 {
3730                   gfc_conv_expr (&se, e);
3731                   descriptor = se.expr;
3732                   se.expr = gfc_conv_descriptor_data_addr (se.expr);
3733                   se.expr = build_fold_indirect_ref_loc (input_location, se.expr);
3734                 }
3735               gfc_free_expr (e);
3736
3737               gfc_save_backend_locus (&loc);
3738               gfc_set_backend_locus (&sym->declared_at);
3739               gfc_start_block (&init);
3740
3741               if (!sym->attr.dummy || sym->attr.intent == INTENT_OUT)
3742                 {
3743                   /* Nullify when entering the scope.  */
3744                   gfc_add_modify (&init, se.expr,
3745                                   fold_convert (TREE_TYPE (se.expr),
3746                                                 null_pointer_node));
3747                 }
3748
3749               if ((sym->attr.dummy ||sym->attr.result)
3750                     && sym->ts.type == BT_CHARACTER
3751                     && sym->ts.deferred)
3752                 {
3753                   /* Character length passed by reference.  */
3754                   tmp = sym->ts.u.cl->passed_length;
3755                   tmp = build_fold_indirect_ref_loc (input_location, tmp);
3756                   tmp = fold_convert (gfc_charlen_type_node, tmp);
3757
3758                   if (!sym->attr.dummy || sym->attr.intent == INTENT_OUT)
3759                     /* Zero the string length when entering the scope.  */
3760                     gfc_add_modify (&init, sym->ts.u.cl->backend_decl,
3761                                 build_int_cst (gfc_charlen_type_node, 0));
3762                   else
3763                     gfc_add_modify (&init, sym->ts.u.cl->backend_decl, tmp);
3764
3765                   gfc_restore_backend_locus (&loc);
3766
3767                   /* Pass the final character length back.  */
3768                   if (sym->attr.intent != INTENT_IN)
3769                     tmp = fold_build2_loc (input_location, MODIFY_EXPR,
3770                                            gfc_charlen_type_node, tmp,
3771                                            sym->ts.u.cl->backend_decl);
3772                   else
3773                     tmp = NULL_TREE;
3774                 }
3775               else
3776                 gfc_restore_backend_locus (&loc);
3777
3778               /* Deallocate when leaving the scope. Nullifying is not
3779                  needed.  */
3780               if (!sym->attr.result && !sym->attr.dummy)
3781                 {
3782                   if (sym->ts.type == BT_CLASS
3783                       && CLASS_DATA (sym)->attr.codimension)
3784                     tmp = gfc_deallocate_with_status (descriptor, NULL_TREE,
3785                                                       NULL_TREE, NULL_TREE,
3786                                                       NULL_TREE, true, NULL,
3787                                                       true);
3788                   else
3789                     tmp = gfc_deallocate_scalar_with_status (se.expr, NULL,
3790                                                              true, NULL,
3791                                                              sym->ts);
3792                 }
3793               if (sym->ts.type == BT_CLASS)
3794                 {
3795                   /* Initialize _vptr to declared type.  */
3796                   gfc_symbol *vtab = gfc_find_derived_vtab (sym->ts.u.derived);
3797                   tree rhs;
3798
3799                   gfc_save_backend_locus (&loc);
3800                   gfc_set_backend_locus (&sym->declared_at);
3801                   e = gfc_lval_expr_from_sym (sym);
3802                   gfc_add_vptr_component (e);
3803                   gfc_init_se (&se, NULL);
3804                   se.want_pointer = 1;
3805                   gfc_conv_expr (&se, e);
3806                   gfc_free_expr (e);
3807                   rhs = gfc_build_addr_expr (TREE_TYPE (se.expr),
3808                                              gfc_get_symbol_decl (vtab));
3809                   gfc_add_modify (&init, se.expr, rhs);
3810                   gfc_restore_backend_locus (&loc);
3811                 }
3812
3813               gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp);
3814             }
3815         }
3816       else if (sym->ts.type == BT_CHARACTER && sym->ts.deferred)
3817         {
3818           tree tmp = NULL;
3819           stmtblock_t init;
3820
3821           /* If we get to here, all that should be left are pointers.  */
3822           gcc_assert (sym->attr.pointer);
3823
3824           if (sym->attr.dummy)
3825             {
3826               gfc_start_block (&init);
3827
3828               /* Character length passed by reference.  */
3829               tmp = sym->ts.u.cl->passed_length;
3830               tmp = build_fold_indirect_ref_loc (input_location, tmp);
3831               tmp = fold_convert (gfc_charlen_type_node, tmp);
3832               gfc_add_modify (&init, sym->ts.u.cl->backend_decl, tmp);
3833               /* Pass the final character length back.  */
3834               if (sym->attr.intent != INTENT_IN)
3835                 tmp = fold_build2_loc (input_location, MODIFY_EXPR,
3836                                        gfc_charlen_type_node, tmp,
3837                                        sym->ts.u.cl->backend_decl);
3838               else
3839                 tmp = NULL_TREE;
3840               gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp);
3841             }
3842         }
3843       else if (sym->ts.deferred)
3844         gfc_fatal_error ("Deferred type parameter not yet supported");
3845       else if (sym_has_alloc_comp)
3846         gfc_trans_deferred_array (sym, block);
3847       else if (sym->ts.type == BT_CHARACTER)
3848         {
3849           gfc_save_backend_locus (&loc);
3850           gfc_set_backend_locus (&sym->declared_at);
3851           if (sym->attr.dummy || sym->attr.result)
3852             gfc_trans_dummy_character (sym, sym->ts.u.cl, block);
3853           else
3854             gfc_trans_auto_character_variable (sym, block);
3855           gfc_restore_backend_locus (&loc);
3856         }
3857       else if (sym->attr.assign)
3858         {
3859           gfc_save_backend_locus (&loc);
3860           gfc_set_backend_locus (&sym->declared_at);
3861           gfc_trans_assign_aux_var (sym, block);
3862           gfc_restore_backend_locus (&loc);
3863         }
3864       else if (sym->ts.type == BT_DERIVED
3865                  && sym->value
3866                  && !sym->attr.data
3867                  && sym->attr.save == SAVE_NONE)
3868         {
3869           gfc_start_block (&tmpblock);
3870           gfc_init_default_dt (sym, &tmpblock, false);
3871           gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock),
3872                                 NULL_TREE);
3873         }
3874       else
3875         gcc_unreachable ();
3876     }
3877
3878   gfc_init_block (&tmpblock);
3879
3880   for (f = proc_sym->formal; f; f = f->next)
3881     {
3882       if (f->sym && f->sym->tlink == NULL && f->sym->ts.type == BT_CHARACTER)
3883         {
3884           gcc_assert (f->sym->ts.u.cl->backend_decl != NULL);
3885           if (TREE_CODE (f->sym->ts.u.cl->backend_decl) == PARM_DECL)
3886             gfc_trans_vla_type_sizes (f->sym, &tmpblock);
3887         }
3888     }
3889
3890   if (gfc_return_by_reference (proc_sym) && proc_sym->ts.type == BT_CHARACTER
3891       && current_fake_result_decl != NULL)
3892     {
3893       gcc_assert (proc_sym->ts.u.cl->backend_decl != NULL);
3894       if (TREE_CODE (proc_sym->ts.u.cl->backend_decl) == PARM_DECL)
3895         gfc_trans_vla_type_sizes (proc_sym, &tmpblock);
3896     }
3897
3898   gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock), NULL_TREE);
3899 }
3900
3901 static GTY ((param_is (struct module_htab_entry))) htab_t module_htab;
3902
3903 /* Hash and equality functions for module_htab.  */
3904
3905 static hashval_t
3906 module_htab_do_hash (const void *x)
3907 {
3908   return htab_hash_string (((const struct module_htab_entry *)x)->name);
3909 }
3910
3911 static int
3912 module_htab_eq (const void *x1, const void *x2)
3913 {
3914   return strcmp ((((const struct module_htab_entry *)x1)->name),
3915                  (const char *)x2) == 0;
3916 }
3917
3918 /* Hash and equality functions for module_htab's decls.  */
3919
3920 static hashval_t
3921 module_htab_decls_hash (const void *x)
3922 {
3923   const_tree t = (const_tree) x;
3924   const_tree n = DECL_NAME (t);
3925   if (n == NULL_TREE)
3926     n = TYPE_NAME (TREE_TYPE (t));
3927   return htab_hash_string (IDENTIFIER_POINTER (n));
3928 }
3929
3930 static int
3931 module_htab_decls_eq (const void *x1, const void *x2)
3932 {
3933   const_tree t1 = (const_tree) x1;
3934   const_tree n1 = DECL_NAME (t1);
3935   if (n1 == NULL_TREE)
3936     n1 = TYPE_NAME (TREE_TYPE (t1));
3937   return strcmp (IDENTIFIER_POINTER (n1), (const char *) x2) == 0;
3938 }
3939
3940 struct module_htab_entry *
3941 gfc_find_module (const char *name)
3942 {
3943   void **slot;
3944
3945   if (! module_htab)
3946     module_htab = htab_create_ggc (10, module_htab_do_hash,
3947                                    module_htab_eq, NULL);
3948
3949   slot = htab_find_slot_with_hash (module_htab, name,
3950                                    htab_hash_string (name), INSERT);
3951   if (*slot == NULL)
3952     {
3953       struct module_htab_entry *entry = ggc_alloc_cleared_module_htab_entry ();
3954
3955       entry->name = gfc_get_string (name);
3956       entry->decls = htab_create_ggc (10, module_htab_decls_hash,
3957                                       module_htab_decls_eq, NULL);
3958       *slot = (void *) entry;
3959     }
3960   return (struct module_htab_entry *) *slot;
3961 }
3962
3963 void
3964 gfc_module_add_decl (struct module_htab_entry *entry, tree decl)
3965 {
3966   void **slot;
3967   const char *name;
3968
3969   if (DECL_NAME (decl))
3970     name = IDENTIFIER_POINTER (DECL_NAME (decl));
3971   else
3972     {
3973       gcc_assert (TREE_CODE (decl) == TYPE_DECL);
3974       name = IDENTIFIER_POINTER (TYPE_NAME (TREE_TYPE (decl)));
3975     }
3976   slot = htab_find_slot_with_hash (entry->decls, name,
3977                                    htab_hash_string (name), INSERT);
3978   if (*slot == NULL)
3979     *slot = (void *) decl;
3980 }
3981
3982 static struct module_htab_entry *cur_module;
3983
3984 /* Output an initialized decl for a module variable.  */
3985
3986 static void
3987 gfc_create_module_variable (gfc_symbol * sym)
3988 {
3989   tree decl;
3990
3991   /* Module functions with alternate entries are dealt with later and
3992      would get caught by the next condition.  */
3993   if (sym->attr.entry)
3994     return;
3995
3996   /* Make sure we convert the types of the derived types from iso_c_binding
3997      into (void *).  */
3998   if (sym->attr.flavor != FL_PROCEDURE && sym->attr.is_iso_c
3999       && sym->ts.type == BT_DERIVED)
4000     sym->backend_decl = gfc_typenode_for_spec (&(sym->ts));
4001
4002   if (sym->attr.flavor == FL_DERIVED
4003       && sym->backend_decl
4004       && TREE_CODE (sym->backend_decl) == RECORD_TYPE)
4005     {
4006       decl = sym->backend_decl;
4007       gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
4008
4009       /* -fwhole-file mixes up the contexts so these asserts are unnecessary.  */
4010       if (!(gfc_option.flag_whole_file && sym->attr.use_assoc))
4011         {
4012           gcc_assert (TYPE_CONTEXT (decl) == NULL_TREE
4013                       || TYPE_CONTEXT (decl) == sym->ns->proc_name->backend_decl);
4014           gcc_assert (DECL_CONTEXT (TYPE_STUB_DECL (decl)) == NULL_TREE
4015                       || DECL_CONTEXT (TYPE_STUB_DECL (decl))
4016                            == sym->ns->proc_name->backend_decl);
4017         }
4018       TYPE_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
4019       DECL_CONTEXT (TYPE_STUB_DECL (decl)) = sym->ns->proc_name->backend_decl;
4020       gfc_module_add_decl (cur_module, TYPE_STUB_DECL (decl));
4021     }
4022
4023   /* Only output variables, procedure pointers and array valued,
4024      or derived type, parameters.  */
4025   if (sym->attr.flavor != FL_VARIABLE
4026         && !(sym->attr.flavor == FL_PARAMETER
4027                && (sym->attr.dimension || sym->ts.type == BT_DERIVED))
4028         && !(sym->attr.flavor == FL_PROCEDURE && sym->attr.proc_pointer))
4029     return;
4030
4031   if ((sym->attr.in_common || sym->attr.in_equivalence) && sym->backend_decl)
4032     {
4033       decl = sym->backend_decl;
4034       gcc_assert (DECL_FILE_SCOPE_P (decl));
4035       gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
4036       DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
4037       gfc_module_add_decl (cur_module, decl);
4038     }
4039
4040   /* Don't generate variables from other modules. Variables from
4041      COMMONs will already have been generated.  */
4042   if (sym->attr.use_assoc || sym->attr.in_common)
4043     return;
4044
4045   /* Equivalenced variables arrive here after creation.  */
4046   if (sym->backend_decl
4047       && (sym->equiv_built || sym->attr.in_equivalence))
4048     return;
4049
4050   if (sym->backend_decl && !sym->attr.vtab && !sym->attr.target)
4051     internal_error ("backend decl for module variable %s already exists",
4052                     sym->name);
4053
4054   /* We always want module variables to be created.  */
4055   sym->attr.referenced = 1;
4056   /* Create the decl.  */
4057   decl = gfc_get_symbol_decl (sym);
4058
4059   /* Create the variable.  */
4060   pushdecl (decl);
4061   gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
4062   DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
4063   rest_of_decl_compilation (decl, 1, 0);
4064   gfc_module_add_decl (cur_module, decl);
4065
4066   /* Also add length of strings.  */
4067   if (sym->ts.type == BT_CHARACTER)
4068     {
4069       tree length;
4070
4071       length = sym->ts.u.cl->backend_decl;
4072       gcc_assert (length || sym->attr.proc_pointer);
4073       if (length && !INTEGER_CST_P (length))
4074         {
4075           pushdecl (length);
4076           rest_of_decl_compilation (length, 1, 0);
4077         }
4078     }
4079
4080   if (sym->attr.codimension && !sym->attr.dummy && !sym->attr.allocatable
4081       && sym->attr.referenced && !sym->attr.use_assoc)
4082     has_coarray_vars = true;
4083 }
4084
4085 /* Emit debug information for USE statements.  */
4086
4087 static void
4088 gfc_trans_use_stmts (gfc_namespace * ns)
4089 {
4090   gfc_use_list *use_stmt;
4091   for (use_stmt = ns->use_stmts; use_stmt; use_stmt = use_stmt->next)
4092     {
4093       struct module_htab_entry *entry
4094         = gfc_find_module (use_stmt->module_name);
4095       gfc_use_rename *rent;
4096
4097       if (entry->namespace_decl == NULL)
4098         {
4099           entry->namespace_decl
4100             = build_decl (input_location,
4101                           NAMESPACE_DECL,
4102                           get_identifier (use_stmt->module_name),
4103                           void_type_node);
4104           DECL_EXTERNAL (entry->namespace_decl) = 1;
4105         }
4106       gfc_set_backend_locus (&use_stmt->where);
4107       if (!use_stmt->only_flag)
4108         (*debug_hooks->imported_module_or_decl) (entry->namespace_decl,
4109                                                  NULL_TREE,
4110                                                  ns->proc_name->backend_decl,
4111                                                  false);
4112       for (rent = use_stmt->rename; rent; rent = rent->next)
4113         {
4114           tree decl, local_name;
4115           void **slot;
4116
4117           if (rent->op != INTRINSIC_NONE)
4118             continue;
4119
4120           slot = htab_find_slot_with_hash (entry->decls, rent->use_name,
4121                                            htab_hash_string (rent->use_name),
4122                                            INSERT);
4123           if (*slot == NULL)
4124             {
4125               gfc_symtree *st;
4126
4127               st = gfc_find_symtree (ns->sym_root,
4128                                      rent->local_name[0]
4129                                      ? rent->local_name : rent->use_name);
4130
4131               /* The following can happen if a derived type is renamed.  */
4132               if (!st)
4133                 {
4134                   char *name;
4135                   name = xstrdup (rent->local_name[0]
4136                                   ? rent->local_name : rent->use_name);
4137                   name[0] = (char) TOUPPER ((unsigned char) name[0]);
4138                   st = gfc_find_symtree (ns->sym_root, name);
4139                   free (name);
4140                   gcc_assert (st);
4141                 }
4142
4143               /* Sometimes, generic interfaces wind up being over-ruled by a
4144                  local symbol (see PR41062).  */
4145               if (!st->n.sym->attr.use_assoc)
4146                 continue;
4147
4148               if (st->n.sym->backend_decl
4149                   && DECL_P (st->n.sym->backend_decl)
4150                   && st->n.sym->module
4151                   && strcmp (st->n.sym->module, use_stmt->module_name) == 0)
4152                 {
4153                   gcc_assert (DECL_EXTERNAL (entry->namespace_decl)
4154                               || (TREE_CODE (st->n.sym->backend_decl)
4155                                   != VAR_DECL));
4156                   decl = copy_node (st->n.sym->backend_decl);
4157                   DECL_CONTEXT (decl) = entry->namespace_decl;
4158                   DECL_EXTERNAL (decl) = 1;
4159                   DECL_IGNORED_P (decl) = 0;
4160                   DECL_INITIAL (decl) = NULL_TREE;
4161                 }
4162               else
4163                 {
4164                   *slot = error_mark_node;
4165                   htab_clear_slot (entry->decls, slot);
4166                   continue;
4167                 }
4168               *slot = decl;
4169             }
4170           decl = (tree) *slot;
4171           if (rent->local_name[0])
4172             local_name = get_identifier (rent->local_name);
4173           else
4174             local_name = NULL_TREE;
4175           gfc_set_backend_locus (&rent->where);
4176           (*debug_hooks->imported_module_or_decl) (decl, local_name,
4177                                                    ns->proc_name->backend_decl,
4178                                                    !use_stmt->only_flag);
4179         }
4180     }
4181 }
4182
4183
4184 /* Return true if expr is a constant initializer that gfc_conv_initializer
4185    will handle.  */
4186
4187 static bool
4188 check_constant_initializer (gfc_expr *expr, gfc_typespec *ts, bool array,
4189                             bool pointer)
4190 {
4191   gfc_constructor *c;
4192   gfc_component *cm;
4193
4194   if (pointer)
4195     return true;
4196   else if (array)
4197     {
4198       if (expr->expr_type == EXPR_CONSTANT || expr->expr_type == EXPR_NULL)
4199         return true;
4200       else if (expr->expr_type == EXPR_STRUCTURE)
4201         return check_constant_initializer (expr, ts, false, false);
4202       else if (expr->expr_type != EXPR_ARRAY)
4203         return false;
4204       for (c = gfc_constructor_first (expr->value.constructor);
4205            c; c = gfc_constructor_next (c))
4206         {
4207           if (c->iterator)
4208             return false;
4209           if (c->expr->expr_type == EXPR_STRUCTURE)
4210             {
4211               if (!check_constant_initializer (c->expr, ts, false, false))
4212                 return false;
4213             }
4214           else if (c->expr->expr_type != EXPR_CONSTANT)
4215             return false;
4216         }
4217       return true;
4218     }
4219   else switch (ts->type)
4220     {
4221     case BT_DERIVED:
4222       if (expr->expr_type != EXPR_STRUCTURE)
4223         return false;
4224       cm = expr->ts.u.derived->components;
4225       for (c = gfc_constructor_first (expr->value.constructor);
4226            c; c = gfc_constructor_next (c), cm = cm->next)
4227         {
4228           if (!c->expr || cm->attr.allocatable)
4229             continue;
4230           if (!check_constant_initializer (c->expr, &cm->ts,
4231                                            cm->attr.dimension,
4232                                            cm->attr.pointer))
4233             return false;
4234         }
4235       return true;
4236     default:
4237       return expr->expr_type == EXPR_CONSTANT;
4238     }
4239 }
4240
4241 /* Emit debug info for parameters and unreferenced variables with
4242    initializers.  */
4243
4244 static void
4245 gfc_emit_parameter_debug_info (gfc_symbol *sym)
4246 {
4247   tree decl;
4248
4249   if (sym->attr.flavor != FL_PARAMETER
4250       && (sym->attr.flavor != FL_VARIABLE || sym->attr.referenced))
4251     return;
4252
4253   if (sym->backend_decl != NULL
4254       || sym->value == NULL
4255       || sym->attr.use_assoc
4256       || sym->attr.dummy
4257       || sym->attr.result
4258       || sym->attr.function
4259       || sym->attr.intrinsic
4260       || sym->attr.pointer
4261       || sym->attr.allocatable
4262       || sym->attr.cray_pointee
4263       || sym->attr.threadprivate
4264       || sym->attr.is_bind_c
4265       || sym->attr.subref_array_pointer
4266       || sym->attr.assign)
4267     return;
4268
4269   if (sym->ts.type == BT_CHARACTER)
4270     {
4271       gfc_conv_const_charlen (sym->ts.u.cl);
4272       if (sym->ts.u.cl->backend_decl == NULL
4273           || TREE_CODE (sym->ts.u.cl->backend_decl) != INTEGER_CST)
4274         return;
4275     }
4276   else if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.alloc_comp)
4277     return;
4278
4279   if (sym->as)
4280     {
4281       int n;
4282
4283       if (sym->as->type != AS_EXPLICIT)
4284         return;
4285       for (n = 0; n < sym->as->rank; n++)
4286         if (sym->as->lower[n]->expr_type != EXPR_CONSTANT
4287             || sym->as->upper[n] == NULL
4288             || sym->as->upper[n]->expr_type != EXPR_CONSTANT)
4289           return;
4290     }
4291
4292   if (!check_constant_initializer (sym->value, &sym->ts,
4293                                    sym->attr.dimension, false))
4294     return;
4295
4296   if (gfc_option.coarray == GFC_FCOARRAY_LIB && sym->attr.codimension)
4297     return;
4298
4299   /* Create the decl for the variable or constant.  */
4300   decl = build_decl (input_location,
4301                      sym->attr.flavor == FL_PARAMETER ? CONST_DECL : VAR_DECL,
4302                      gfc_sym_identifier (sym), gfc_sym_type (sym));
4303   if (sym->attr.flavor == FL_PARAMETER)
4304     TREE_READONLY (decl) = 1;
4305   gfc_set_decl_location (decl, &sym->declared_at);
4306   if (sym->attr.dimension)
4307     GFC_DECL_PACKED_ARRAY (decl) = 1;
4308   DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
4309   TREE_STATIC (decl) = 1;
4310   TREE_USED (decl) = 1;
4311   if (DECL_CONTEXT (decl) && TREE_CODE (DECL_CONTEXT (decl)) == NAMESPACE_DECL)
4312     TREE_PUBLIC (decl) = 1;
4313   DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
4314                                               TREE_TYPE (decl),
4315                                               sym->attr.dimension,
4316                                               false, false);
4317   debug_hooks->global_decl (decl);
4318 }
4319
4320
4321 static void
4322 generate_coarray_sym_init (gfc_symbol *sym)
4323 {
4324   tree tmp, size, decl, token;
4325
4326   if (sym->attr.dummy || sym->attr.allocatable || !sym->attr.codimension
4327       || sym->attr.use_assoc || !sym->attr.referenced)
4328     return;
4329
4330   decl = sym->backend_decl;
4331   TREE_USED(decl) = 1;
4332   gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (decl)));
4333
4334   /* FIXME: Workaround for PR middle-end/49106, cf. also PR middle-end/49108
4335      to make sure the variable is not optimized away.  */
4336   DECL_PRESERVE_P (DECL_CONTEXT (decl)) = 1;
4337
4338   size = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (decl)));
4339
4340   /* Ensure that we do not have size=0 for zero-sized arrays.  */
4341   size = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
4342                           fold_convert (size_type_node, size),
4343                           build_int_cst (size_type_node, 1));
4344
4345   if (GFC_TYPE_ARRAY_RANK (TREE_TYPE (decl)))
4346     {
4347       tmp = GFC_TYPE_ARRAY_SIZE (TREE_TYPE (decl));
4348       size = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
4349                               fold_convert (size_type_node, tmp), size);
4350     }
4351
4352   gcc_assert (GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (decl)) != NULL_TREE);
4353   token = gfc_build_addr_expr (ppvoid_type_node,
4354                                GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE(decl)));
4355
4356   tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_register, 6, size,
4357                              build_int_cst (integer_type_node,
4358                                             GFC_CAF_COARRAY_STATIC), /* type.  */
4359                              token, null_pointer_node, /* token, stat.  */
4360                              null_pointer_node, /* errgmsg, errmsg_len.  */
4361                              build_int_cst (integer_type_node, 0));
4362
4363   gfc_add_modify (&caf_init_block, decl, fold_convert (TREE_TYPE (decl), tmp));
4364
4365
4366   /* Handle "static" initializer.  */
4367   if (sym->value)
4368     {
4369       sym->attr.pointer = 1;
4370       tmp = gfc_trans_assignment (gfc_lval_expr_from_sym (sym), sym->value,
4371                                   true, false);
4372       sym->attr.pointer = 0;
4373       gfc_add_expr_to_block (&caf_init_block, tmp);
4374     }
4375 }
4376
4377
4378 /* Generate constructor function to initialize static, nonallocatable
4379    coarrays.  */
4380
4381 static void
4382 generate_coarray_init (gfc_namespace * ns __attribute((unused)))
4383 {
4384   tree fndecl, tmp, decl, save_fn_decl;
4385
4386   save_fn_decl = current_function_decl;
4387   push_function_context ();
4388
4389   tmp = build_function_type_list (void_type_node, NULL_TREE);
4390   fndecl = build_decl (input_location, FUNCTION_DECL,
4391                        create_tmp_var_name ("_caf_init"), tmp);
4392
4393   DECL_STATIC_CONSTRUCTOR (fndecl) = 1;
4394   SET_DECL_INIT_PRIORITY (fndecl, DEFAULT_INIT_PRIORITY);
4395
4396   decl = build_decl (input_location, RESULT_DECL, NULL_TREE, void_type_node);
4397   DECL_ARTIFICIAL (decl) = 1;
4398   DECL_IGNORED_P (decl) = 1;
4399   DECL_CONTEXT (decl) = fndecl;
4400   DECL_RESULT (fndecl) = decl;
4401
4402   pushdecl (fndecl);
4403   current_function_decl = fndecl;
4404   announce_function (fndecl);
4405
4406   rest_of_decl_compilation (fndecl, 0, 0);
4407   make_decl_rtl (fndecl);
4408   init_function_start (fndecl);
4409
4410   pushlevel (0);
4411   gfc_init_block (&caf_init_block);
4412
4413   gfc_traverse_ns (ns, generate_coarray_sym_init);
4414
4415   DECL_SAVED_TREE (fndecl) = gfc_finish_block (&caf_init_block);
4416   decl = getdecls ();
4417
4418   poplevel (1, 0, 1);
4419   BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
4420
4421   DECL_SAVED_TREE (fndecl)
4422     = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (fndecl),
4423                 DECL_INITIAL (fndecl));
4424   dump_function (TDI_original, fndecl);
4425
4426   cfun->function_end_locus = input_location;
4427   set_cfun (NULL);
4428
4429   if (decl_function_context (fndecl))
4430     (void) cgraph_create_node (fndecl);
4431   else
4432     cgraph_finalize_function (fndecl, true);
4433
4434   pop_function_context ();
4435   current_function_decl = save_fn_decl;
4436 }
4437
4438
4439 /* Generate all the required code for module variables.  */
4440
4441 void
4442 gfc_generate_module_vars (gfc_namespace * ns)
4443 {
4444   module_namespace = ns;
4445   cur_module = gfc_find_module (ns->proc_name->name);
4446
4447   /* Check if the frontend left the namespace in a reasonable state.  */
4448   gcc_assert (ns->proc_name && !ns->proc_name->tlink);
4449
4450   /* Generate COMMON blocks.  */
4451   gfc_trans_common (ns);
4452
4453   has_coarray_vars = false;
4454
4455   /* Create decls for all the module variables.  */
4456   gfc_traverse_ns (ns, gfc_create_module_variable);
4457
4458   if (gfc_option.coarray == GFC_FCOARRAY_LIB && has_coarray_vars)
4459     generate_coarray_init (ns);
4460
4461   cur_module = NULL;
4462
4463   gfc_trans_use_stmts (ns);
4464   gfc_traverse_ns (ns, gfc_emit_parameter_debug_info);
4465 }
4466
4467
4468 static void
4469 gfc_generate_contained_functions (gfc_namespace * parent)
4470 {
4471   gfc_namespace *ns;
4472
4473   /* We create all the prototypes before generating any code.  */
4474   for (ns = parent->contained; ns; ns = ns->sibling)
4475     {
4476       /* Skip namespaces from used modules.  */
4477       if (ns->parent != parent)
4478         continue;
4479
4480       gfc_create_function_decl (ns, false);
4481     }
4482
4483   for (ns = parent->contained; ns; ns = ns->sibling)
4484     {
4485       /* Skip namespaces from used modules.  */
4486       if (ns->parent != parent)
4487         continue;
4488
4489       gfc_generate_function_code (ns);
4490     }
4491 }
4492
4493
4494 /* Drill down through expressions for the array specification bounds and
4495    character length calling generate_local_decl for all those variables
4496    that have not already been declared.  */
4497
4498 static void
4499 generate_local_decl (gfc_symbol *);
4500
4501 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced.  */
4502
4503 static bool
4504 expr_decls (gfc_expr *e, gfc_symbol *sym,
4505             int *f ATTRIBUTE_UNUSED)
4506 {
4507   if (e->expr_type != EXPR_VARIABLE
4508             || sym == e->symtree->n.sym
4509             || e->symtree->n.sym->mark
4510             || e->symtree->n.sym->ns != sym->ns)
4511         return false;
4512
4513   generate_local_decl (e->symtree->n.sym);
4514   return false;
4515 }
4516
4517 static void
4518 generate_expr_decls (gfc_symbol *sym, gfc_expr *e)
4519 {
4520   gfc_traverse_expr (e, sym, expr_decls, 0);
4521 }
4522
4523
4524 /* Check for dependencies in the character length and array spec.  */
4525
4526 static void
4527 generate_dependency_declarations (gfc_symbol *sym)
4528 {
4529   int i;
4530
4531   if (sym->ts.type == BT_CHARACTER
4532       && sym->ts.u.cl
4533       && sym->ts.u.cl->length
4534       && sym->ts.u.cl->length->expr_type != EXPR_CONSTANT)
4535     generate_expr_decls (sym, sym->ts.u.cl->length);
4536
4537   if (sym->as && sym->as->rank)
4538     {
4539       for (i = 0; i < sym->as->rank; i++)
4540         {
4541           generate_expr_decls (sym, sym->as->lower[i]);
4542           generate_expr_decls (sym, sym->as->upper[i]);
4543         }
4544     }
4545 }
4546
4547
4548 /* Generate decls for all local variables.  We do this to ensure correct
4549    handling of expressions which only appear in the specification of
4550    other functions.  */
4551
4552 static void
4553 generate_local_decl (gfc_symbol * sym)
4554 {
4555   if (sym->attr.flavor == FL_VARIABLE)
4556     {
4557       if (sym->attr.codimension && !sym->attr.dummy && !sym->attr.allocatable
4558           && sym->attr.referenced && !sym->attr.use_assoc)
4559         has_coarray_vars = true;
4560
4561       if (!sym->attr.dummy && !sym->ns->proc_name->attr.entry_master)
4562         generate_dependency_declarations (sym);
4563
4564       if (sym->attr.referenced)
4565         gfc_get_symbol_decl (sym);
4566
4567       /* Warnings for unused dummy arguments.  */
4568       else if (sym->attr.dummy)
4569         {
4570           /* INTENT(out) dummy arguments are likely meant to be set.  */
4571           if (gfc_option.warn_unused_dummy_argument
4572               && sym->attr.intent == INTENT_OUT)
4573             {
4574               if (sym->ts.type != BT_DERIVED)
4575                 gfc_warning ("Dummy argument '%s' at %L was declared "
4576                              "INTENT(OUT) but was not set",  sym->name,
4577                              &sym->declared_at);
4578               else if (!gfc_has_default_initializer (sym->ts.u.derived))
4579                 gfc_warning ("Derived-type dummy argument '%s' at %L was "
4580                              "declared INTENT(OUT) but was not set and "
4581                              "does not have a default initializer",
4582                              sym->name, &sym->declared_at);
4583               if (sym->backend_decl != NULL_TREE)
4584                 TREE_NO_WARNING(sym->backend_decl) = 1;
4585             }
4586           else if (gfc_option.warn_unused_dummy_argument)
4587             {
4588               gfc_warning ("Unused dummy argument '%s' at %L", sym->name,
4589                          &sym->declared_at);
4590               if (sym->backend_decl != NULL_TREE)
4591                 TREE_NO_WARNING(sym->backend_decl) = 1;
4592             }
4593         }
4594
4595       /* Warn for unused variables, but not if they're inside a common
4596          block or a namelist.  */
4597       else if (warn_unused_variable
4598                && !(sym->attr.in_common || sym->mark || sym->attr.in_namelist))
4599         {
4600           if (sym->attr.use_only)
4601             {
4602               gfc_warning ("Unused module variable '%s' which has been "
4603                            "explicitly imported at %L", sym->name,
4604                            &sym->declared_at);
4605               if (sym->backend_decl != NULL_TREE)
4606                 TREE_NO_WARNING(sym->backend_decl) = 1;
4607             }
4608           else if (!sym->attr.use_assoc)
4609             {
4610               gfc_warning ("Unused variable '%s' declared at %L",
4611                            sym->name, &sym->declared_at);
4612               if (sym->backend_decl != NULL_TREE)
4613                 TREE_NO_WARNING(sym->backend_decl) = 1;
4614             }
4615         }
4616
4617       /* For variable length CHARACTER parameters, the PARM_DECL already
4618          references the length variable, so force gfc_get_symbol_decl
4619          even when not referenced.  If optimize > 0, it will be optimized
4620          away anyway.  But do this only after emitting -Wunused-parameter
4621          warning if requested.  */
4622       if (sym->attr.dummy && !sym->attr.referenced
4623             && sym->ts.type == BT_CHARACTER
4624             && sym->ts.u.cl->backend_decl != NULL
4625             && TREE_CODE (sym->ts.u.cl->backend_decl) == VAR_DECL)
4626         {
4627           sym->attr.referenced = 1;
4628           gfc_get_symbol_decl (sym);
4629         }
4630
4631       /* INTENT(out) dummy arguments and result variables with allocatable
4632          components are reset by default and need to be set referenced to
4633          generate the code for nullification and automatic lengths.  */
4634       if (!sym->attr.referenced
4635             && sym->ts.type == BT_DERIVED
4636             && sym->ts.u.derived->attr.alloc_comp
4637             && !sym->attr.pointer
4638             && ((sym->attr.dummy && sym->attr.intent == INTENT_OUT)
4639                   ||
4640                 (sym->attr.result && sym != sym->result)))
4641         {
4642           sym->attr.referenced = 1;
4643           gfc_get_symbol_decl (sym);
4644         }
4645
4646       /* Check for dependencies in the array specification and string
4647         length, adding the necessary declarations to the function.  We
4648         mark the symbol now, as well as in traverse_ns, to prevent
4649         getting stuck in a circular dependency.  */
4650       sym->mark = 1;
4651     }
4652   else if (sym->attr.flavor == FL_PARAMETER)
4653     {
4654       if (warn_unused_parameter
4655            && !sym->attr.referenced)
4656         {
4657            if (!sym->attr.use_assoc)
4658              gfc_warning ("Unused parameter '%s' declared at %L", sym->name,
4659                           &sym->declared_at);
4660            else if (sym->attr.use_only)
4661              gfc_warning ("Unused parameter '%s' which has been explicitly "
4662                           "imported at %L", sym->name, &sym->declared_at);
4663         }
4664     }
4665   else if (sym->attr.flavor == FL_PROCEDURE)
4666     {
4667       /* TODO: move to the appropriate place in resolve.c.  */
4668       if (warn_return_type
4669           && sym->attr.function
4670           && sym->result
4671           && sym != sym->result
4672           && !sym->result->attr.referenced
4673           && !sym->attr.use_assoc
4674           && sym->attr.if_source != IFSRC_IFBODY)
4675         {
4676           gfc_warning ("Return value '%s' of function '%s' declared at "
4677                        "%L not set", sym->result->name, sym->name,
4678                         &sym->result->declared_at);
4679
4680           /* Prevents "Unused variable" warning for RESULT variables.  */
4681           sym->result->mark = 1;
4682         }
4683     }
4684
4685   if (sym->attr.dummy == 1)
4686     {
4687       /* Modify the tree type for scalar character dummy arguments of bind(c)
4688          procedures if they are passed by value.  The tree type for them will
4689          be promoted to INTEGER_TYPE for the middle end, which appears to be
4690          what C would do with characters passed by-value.  The value attribute
4691          implies the dummy is a scalar.  */
4692       if (sym->attr.value == 1 && sym->backend_decl != NULL
4693           && sym->ts.type == BT_CHARACTER && sym->ts.is_c_interop
4694           && sym->ns->proc_name != NULL && sym->ns->proc_name->attr.is_bind_c)
4695         gfc_conv_scalar_char_value (sym, NULL, NULL);
4696
4697       /* Unused procedure passed as dummy argument.  */
4698       if (sym->attr.flavor == FL_PROCEDURE)
4699         {
4700           if (!sym->attr.referenced)
4701             {
4702               if (gfc_option.warn_unused_dummy_argument)
4703                 gfc_warning ("Unused dummy argument '%s' at %L", sym->name,
4704                              &sym->declared_at);
4705             }
4706
4707           /* Silence bogus "unused parameter" warnings from the
4708              middle end.  */
4709           if (sym->backend_decl != NULL_TREE)
4710                 TREE_NO_WARNING (sym->backend_decl) = 1;
4711         }
4712     }
4713
4714   /* Make sure we convert the types of the derived types from iso_c_binding
4715      into (void *).  */
4716   if (sym->attr.flavor != FL_PROCEDURE && sym->attr.is_iso_c
4717       && sym->ts.type == BT_DERIVED)
4718     sym->backend_decl = gfc_typenode_for_spec (&(sym->ts));
4719 }
4720
4721 static void
4722 generate_local_vars (gfc_namespace * ns)
4723 {
4724   gfc_traverse_ns (ns, generate_local_decl);
4725 }
4726
4727
4728 /* Generate a switch statement to jump to the correct entry point.  Also
4729    creates the label decls for the entry points.  */
4730
4731 static tree
4732 gfc_trans_entry_master_switch (gfc_entry_list * el)
4733 {
4734   stmtblock_t block;
4735   tree label;
4736   tree tmp;
4737   tree val;
4738
4739   gfc_init_block (&block);
4740   for (; el; el = el->next)
4741     {
4742       /* Add the case label.  */
4743       label = gfc_build_label_decl (NULL_TREE);
4744       val = build_int_cst (gfc_array_index_type, el->id);
4745       tmp = build_case_label (val, NULL_TREE, label);
4746       gfc_add_expr_to_block (&block, tmp);
4747
4748       /* And jump to the actual entry point.  */
4749       label = gfc_build_label_decl (NULL_TREE);
4750       tmp = build1_v (GOTO_EXPR, label);
4751       gfc_add_expr_to_block (&block, tmp);
4752
4753       /* Save the label decl.  */
4754       el->label = label;
4755     }
4756   tmp = gfc_finish_block (&block);
4757   /* The first argument selects the entry point.  */
4758   val = DECL_ARGUMENTS (current_function_decl);
4759   tmp = build3_v (SWITCH_EXPR, val, tmp, NULL_TREE);
4760   return tmp;
4761 }
4762
4763
4764 /* Add code to string lengths of actual arguments passed to a function against
4765    the expected lengths of the dummy arguments.  */
4766
4767 static void
4768 add_argument_checking (stmtblock_t *block, gfc_symbol *sym)
4769 {
4770   gfc_formal_arglist *formal;
4771
4772   for (formal = sym->formal; formal; formal = formal->next)
4773     if (formal->sym && formal->sym->ts.type == BT_CHARACTER
4774         && !formal->sym->ts.deferred)
4775       {
4776         enum tree_code comparison;
4777         tree cond;
4778         tree argname;
4779         gfc_symbol *fsym;
4780         gfc_charlen *cl;
4781         const char *message;
4782
4783         fsym = formal->sym;
4784         cl = fsym->ts.u.cl;
4785
4786         gcc_assert (cl);
4787         gcc_assert (cl->passed_length != NULL_TREE);
4788         gcc_assert (cl->backend_decl != NULL_TREE);
4789
4790         /* For POINTER, ALLOCATABLE and assumed-shape dummy arguments, the
4791            string lengths must match exactly.  Otherwise, it is only required
4792            that the actual string length is *at least* the expected one.
4793            Sequence association allows for a mismatch of the string length
4794            if the actual argument is (part of) an array, but only if the
4795            dummy argument is an array. (See "Sequence association" in
4796            Section 12.4.1.4 for F95 and 12.4.1.5 for F2003.)  */
4797         if (fsym->attr.pointer || fsym->attr.allocatable
4798             || (fsym->as && fsym->as->type == AS_ASSUMED_SHAPE))
4799           {
4800             comparison = NE_EXPR;
4801             message = _("Actual string length does not match the declared one"
4802                         " for dummy argument '%s' (%ld/%ld)");
4803           }
4804         else if (fsym->as && fsym->as->rank != 0)
4805           continue;
4806         else
4807           {
4808             comparison = LT_EXPR;
4809             message = _("Actual string length is shorter than the declared one"
4810                         " for dummy argument '%s' (%ld/%ld)");
4811           }
4812
4813         /* Build the condition.  For optional arguments, an actual length
4814            of 0 is also acceptable if the associated string is NULL, which
4815            means the argument was not passed.  */
4816         cond = fold_build2_loc (input_location, comparison, boolean_type_node,
4817                                 cl->passed_length, cl->backend_decl);
4818         if (fsym->attr.optional)
4819           {
4820             tree not_absent;
4821             tree not_0length;
4822             tree absent_failed;
4823
4824             not_0length = fold_build2_loc (input_location, NE_EXPR,
4825                                            boolean_type_node,
4826                                            cl->passed_length,
4827                                            build_zero_cst (gfc_charlen_type_node));
4828             /* The symbol needs to be referenced for gfc_get_symbol_decl.  */
4829             fsym->attr.referenced = 1;
4830             not_absent = gfc_conv_expr_present (fsym);
4831
4832             absent_failed = fold_build2_loc (input_location, TRUTH_OR_EXPR,
4833                                              boolean_type_node, not_0length,
4834                                              not_absent);
4835
4836             cond = fold_build2_loc (input_location, TRUTH_AND_EXPR,
4837                                     boolean_type_node, cond, absent_failed);
4838           }
4839
4840         /* Build the runtime check.  */
4841         argname = gfc_build_cstring_const (fsym->name);
4842         argname = gfc_build_addr_expr (pchar_type_node, argname);
4843         gfc_trans_runtime_check (true, false, cond, block, &fsym->declared_at,
4844                                  message, argname,
4845                                  fold_convert (long_integer_type_node,
4846                                                cl->passed_length),
4847                                  fold_convert (long_integer_type_node,
4848                                                cl->backend_decl));
4849       }
4850 }
4851
4852
4853 /* Generate the _gfortran_caf_this_image and _gfortran_caf_num_images
4854    global variables for -fcoarray=lib. They are placed into the translation
4855    unit of the main program.  Make sure that in one TU (the one of the main
4856    program), the first call to gfc_init_coarray_decl is done with true.
4857    Otherwise, expect link errors.  */
4858
4859 void
4860 gfc_init_coarray_decl (bool main_tu)
4861 {
4862   tree save_fn_decl;
4863
4864   if (gfc_option.coarray != GFC_FCOARRAY_LIB)
4865     return;
4866
4867   if (gfort_gvar_caf_this_image || gfort_gvar_caf_num_images)
4868     return;
4869
4870   save_fn_decl = current_function_decl;
4871   current_function_decl = NULL_TREE;
4872   push_cfun (cfun);
4873
4874   gfort_gvar_caf_this_image
4875         = build_decl (input_location, VAR_DECL,
4876                       get_identifier (PREFIX("caf_this_image")),
4877                       integer_type_node);
4878   DECL_ARTIFICIAL (gfort_gvar_caf_this_image) = 1;
4879   TREE_USED (gfort_gvar_caf_this_image) = 1;
4880   TREE_PUBLIC (gfort_gvar_caf_this_image) = 1;
4881   TREE_READONLY (gfort_gvar_caf_this_image) = 0;
4882
4883   if (main_tu)
4884     TREE_STATIC (gfort_gvar_caf_this_image) = 1;
4885   else
4886     DECL_EXTERNAL (gfort_gvar_caf_this_image) = 1;
4887
4888   pushdecl_top_level (gfort_gvar_caf_this_image);
4889
4890   gfort_gvar_caf_num_images
4891         = build_decl (input_location, VAR_DECL,
4892                       get_identifier (PREFIX("caf_num_images")),
4893                       integer_type_node);
4894   DECL_ARTIFICIAL (gfort_gvar_caf_num_images) = 1;
4895   TREE_USED (gfort_gvar_caf_num_images) = 1;
4896   TREE_PUBLIC (gfort_gvar_caf_num_images) = 1;
4897   TREE_READONLY (gfort_gvar_caf_num_images) = 0;
4898
4899   if (main_tu)
4900     TREE_STATIC (gfort_gvar_caf_num_images) = 1;
4901   else
4902     DECL_EXTERNAL (gfort_gvar_caf_num_images) = 1;
4903
4904   pushdecl_top_level (gfort_gvar_caf_num_images);
4905
4906   pop_cfun ();
4907   current_function_decl = save_fn_decl;
4908 }
4909
4910
4911 static void
4912 create_main_function (tree fndecl)
4913 {
4914   tree old_context;
4915   tree ftn_main;
4916   tree tmp, decl, result_decl, argc, argv, typelist, arglist;
4917   stmtblock_t body;
4918
4919   old_context = current_function_decl;
4920
4921   if (old_context)
4922     {
4923       push_function_context ();
4924       saved_parent_function_decls = saved_function_decls;
4925       saved_function_decls = NULL_TREE;
4926     }
4927
4928   /* main() function must be declared with global scope.  */
4929   gcc_assert (current_function_decl == NULL_TREE);
4930
4931   /* Declare the function.  */
4932   tmp =  build_function_type_list (integer_type_node, integer_type_node,
4933                                    build_pointer_type (pchar_type_node),
4934                                    NULL_TREE);
4935   main_identifier_node = get_identifier ("main");
4936   ftn_main = build_decl (input_location, FUNCTION_DECL,
4937                          main_identifier_node, tmp);
4938   DECL_EXTERNAL (ftn_main) = 0;
4939   TREE_PUBLIC (ftn_main) = 1;
4940   TREE_STATIC (ftn_main) = 1;
4941   DECL_ATTRIBUTES (ftn_main)
4942       = tree_cons (get_identifier("externally_visible"), NULL_TREE, NULL_TREE);
4943
4944   /* Setup the result declaration (for "return 0").  */
4945   result_decl = build_decl (input_location,
4946                             RESULT_DECL, NULL_TREE, integer_type_node);
4947   DECL_ARTIFICIAL (result_decl) = 1;
4948   DECL_IGNORED_P (result_decl) = 1;
4949   DECL_CONTEXT (result_decl) = ftn_main;
4950   DECL_RESULT (ftn_main) = result_decl;
4951
4952   pushdecl (ftn_main);
4953
4954   /* Get the arguments.  */
4955
4956   arglist = NULL_TREE;
4957   typelist = TYPE_ARG_TYPES (TREE_TYPE (ftn_main));
4958
4959   tmp = TREE_VALUE (typelist);
4960   argc = build_decl (input_location, PARM_DECL, get_identifier ("argc"), tmp);
4961   DECL_CONTEXT (argc) = ftn_main;
4962   DECL_ARG_TYPE (argc) = TREE_VALUE (typelist);
4963   TREE_READONLY (argc) = 1;
4964   gfc_finish_decl (argc);
4965   arglist = chainon (arglist, argc);
4966
4967   typelist = TREE_CHAIN (typelist);
4968   tmp = TREE_VALUE (typelist);
4969   argv = build_decl (input_location, PARM_DECL, get_identifier ("argv"), tmp);
4970   DECL_CONTEXT (argv) = ftn_main;
4971   DECL_ARG_TYPE (argv) = TREE_VALUE (typelist);
4972   TREE_READONLY (argv) = 1;
4973   DECL_BY_REFERENCE (argv) = 1;
4974   gfc_finish_decl (argv);
4975   arglist = chainon (arglist, argv);
4976
4977   DECL_ARGUMENTS (ftn_main) = arglist;
4978   current_function_decl = ftn_main;
4979   announce_function (ftn_main);
4980
4981   rest_of_decl_compilation (ftn_main, 1, 0);
4982   make_decl_rtl (ftn_main);
4983   init_function_start (ftn_main);
4984   pushlevel (0);
4985
4986   gfc_init_block (&body);
4987
4988   /* Call some libgfortran initialization routines, call then MAIN__(). */
4989
4990   /* Call _gfortran_caf_init (*argc, ***argv, *this_image, *num_images).  */
4991   if (gfc_option.coarray == GFC_FCOARRAY_LIB)
4992     {
4993       tree pint_type, pppchar_type;
4994       pint_type = build_pointer_type (integer_type_node);
4995       pppchar_type
4996         = build_pointer_type (build_pointer_type (pchar_type_node));
4997
4998       gfc_init_coarray_decl (true);
4999       tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_init, 4,
5000                 gfc_build_addr_expr (pint_type, argc),
5001                 gfc_build_addr_expr (pppchar_type, argv),
5002                 gfc_build_addr_expr (pint_type, gfort_gvar_caf_this_image),
5003                 gfc_build_addr_expr (pint_type, gfort_gvar_caf_num_images));
5004       gfc_add_expr_to_block (&body, tmp);
5005     }
5006
5007   /* Call _gfortran_set_args (argc, argv).  */
5008   TREE_USED (argc) = 1;
5009   TREE_USED (argv) = 1;
5010   tmp = build_call_expr_loc (input_location,
5011                          gfor_fndecl_set_args, 2, argc, argv);
5012   gfc_add_expr_to_block (&body, tmp);
5013
5014   /* Add a call to set_options to set up the runtime library Fortran
5015      language standard parameters.  */
5016   {
5017     tree array_type, array, var;
5018     VEC(constructor_elt,gc) *v = NULL;
5019
5020     /* Passing a new option to the library requires four modifications:
5021      + add it to the tree_cons list below
5022           + change the array size in the call to build_array_type
5023           + change the first argument to the library call
5024             gfor_fndecl_set_options
5025           + modify the library (runtime/compile_options.c)!  */
5026
5027     CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
5028                             build_int_cst (integer_type_node,
5029                                            gfc_option.warn_std));
5030     CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
5031                             build_int_cst (integer_type_node,
5032                                            gfc_option.allow_std));
5033     CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
5034                             build_int_cst (integer_type_node, pedantic));
5035     /* TODO: This is the old -fdump-core option, which is unused but
5036        passed due to ABI compatibility; remove when bumping the
5037        library ABI.  */
5038     CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
5039                             build_int_cst (integer_type_node,
5040                                            0));
5041     CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
5042                             build_int_cst (integer_type_node,
5043                                            gfc_option.flag_backtrace));
5044     CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
5045                             build_int_cst (integer_type_node,
5046                                            gfc_option.flag_sign_zero));
5047     CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
5048                             build_int_cst (integer_type_node,
5049                                            (gfc_option.rtcheck
5050                                             & GFC_RTCHECK_BOUNDS)));
5051     CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
5052                             build_int_cst (integer_type_node,
5053                                            gfc_option.flag_range_check));
5054
5055     array_type = build_array_type (integer_type_node,
5056                                    build_index_type (size_int (7)));
5057     array = build_constructor (array_type, v);
5058     TREE_CONSTANT (array) = 1;
5059     TREE_STATIC (array) = 1;
5060
5061     /* Create a static variable to hold the jump table.  */
5062     var = gfc_create_var (array_type, "options");
5063     TREE_CONSTANT (var) = 1;
5064     TREE_STATIC (var) = 1;
5065     TREE_READONLY (var) = 1;
5066     DECL_INITIAL (var) = array;
5067     var = gfc_build_addr_expr (build_pointer_type (integer_type_node), var);
5068
5069     tmp = build_call_expr_loc (input_location,
5070                            gfor_fndecl_set_options, 2,
5071                            build_int_cst (integer_type_node, 8), var);
5072     gfc_add_expr_to_block (&body, tmp);
5073   }
5074
5075   /* If -ffpe-trap option was provided, add a call to set_fpe so that
5076      the library will raise a FPE when needed.  */
5077   if (gfc_option.fpe != 0)
5078     {
5079       tmp = build_call_expr_loc (input_location,
5080                              gfor_fndecl_set_fpe, 1,
5081                              build_int_cst (integer_type_node,
5082                                             gfc_option.fpe));
5083       gfc_add_expr_to_block (&body, tmp);
5084     }
5085
5086   /* If this is the main program and an -fconvert option was provided,
5087      add a call to set_convert.  */
5088
5089   if (gfc_option.convert != GFC_CONVERT_NATIVE)
5090     {
5091       tmp = build_call_expr_loc (input_location,
5092                              gfor_fndecl_set_convert, 1,
5093                              build_int_cst (integer_type_node,
5094                                             gfc_option.convert));
5095       gfc_add_expr_to_block (&body, tmp);
5096     }
5097
5098   /* If this is the main program and an -frecord-marker option was provided,
5099      add a call to set_record_marker.  */
5100
5101   if (gfc_option.record_marker != 0)
5102     {
5103       tmp = build_call_expr_loc (input_location,
5104                              gfor_fndecl_set_record_marker, 1,
5105                              build_int_cst (integer_type_node,
5106                                             gfc_option.record_marker));
5107       gfc_add_expr_to_block (&body, tmp);
5108     }
5109
5110   if (gfc_option.max_subrecord_length != 0)
5111     {
5112       tmp = build_call_expr_loc (input_location,
5113                              gfor_fndecl_set_max_subrecord_length, 1,
5114                              build_int_cst (integer_type_node,
5115                                             gfc_option.max_subrecord_length));
5116       gfc_add_expr_to_block (&body, tmp);
5117     }
5118
5119   /* Call MAIN__().  */
5120   tmp = build_call_expr_loc (input_location,
5121                          fndecl, 0);
5122   gfc_add_expr_to_block (&body, tmp);
5123
5124   /* Mark MAIN__ as used.  */
5125   TREE_USED (fndecl) = 1;
5126
5127   /* Coarray: Call _gfortran_caf_finalize(void).  */
5128   if (gfc_option.coarray == GFC_FCOARRAY_LIB)
5129     {
5130       /* Per F2008, 8.5.1 END of the main program implies a
5131          SYNC MEMORY.  */
5132       tmp = builtin_decl_explicit (BUILT_IN_SYNC_SYNCHRONIZE);
5133       tmp = build_call_expr_loc (input_location, tmp, 0);
5134       gfc_add_expr_to_block (&body, tmp);
5135
5136       tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_finalize, 0);
5137       gfc_add_expr_to_block (&body, tmp);
5138     }
5139
5140   /* "return 0".  */
5141   tmp = fold_build2_loc (input_location, MODIFY_EXPR, integer_type_node,
5142                          DECL_RESULT (ftn_main),
5143                          build_int_cst (integer_type_node, 0));
5144   tmp = build1_v (RETURN_EXPR, tmp);
5145   gfc_add_expr_to_block (&body, tmp);
5146
5147
5148   DECL_SAVED_TREE (ftn_main) = gfc_finish_block (&body);
5149   decl = getdecls ();
5150
5151   /* Finish off this function and send it for code generation.  */
5152   poplevel (1, 0, 1);
5153   BLOCK_SUPERCONTEXT (DECL_INITIAL (ftn_main)) = ftn_main;
5154
5155   DECL_SAVED_TREE (ftn_main)
5156     = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (ftn_main),
5157                 DECL_INITIAL (ftn_main));
5158
5159   /* Output the GENERIC tree.  */
5160   dump_function (TDI_original, ftn_main);
5161
5162   cgraph_finalize_function (ftn_main, true);
5163
5164   if (old_context)
5165     {
5166       pop_function_context ();
5167       saved_function_decls = saved_parent_function_decls;
5168     }
5169   current_function_decl = old_context;
5170 }
5171
5172
5173 /* Get the result expression for a procedure.  */
5174
5175 static tree
5176 get_proc_result (gfc_symbol* sym)
5177 {
5178   if (sym->attr.subroutine || sym == sym->result)
5179     {
5180       if (current_fake_result_decl != NULL)
5181         return TREE_VALUE (current_fake_result_decl);
5182
5183       return NULL_TREE;
5184     }
5185
5186   return sym->result->backend_decl;
5187 }
5188
5189
5190 /* Generate an appropriate return-statement for a procedure.  */
5191
5192 tree
5193 gfc_generate_return (void)
5194 {
5195   gfc_symbol* sym;
5196   tree result;
5197   tree fndecl;
5198
5199   sym = current_procedure_symbol;
5200   fndecl = sym->backend_decl;
5201
5202   if (TREE_TYPE (DECL_RESULT (fndecl)) == void_type_node)
5203     result = NULL_TREE;
5204   else
5205     {
5206       result = get_proc_result (sym);
5207
5208       /* Set the return value to the dummy result variable.  The
5209          types may be different for scalar default REAL functions
5210          with -ff2c, therefore we have to convert.  */
5211       if (result != NULL_TREE)
5212         {
5213           result = convert (TREE_TYPE (DECL_RESULT (fndecl)), result);
5214           result = fold_build2_loc (input_location, MODIFY_EXPR,
5215                                     TREE_TYPE (result), DECL_RESULT (fndecl),
5216                                     result);
5217         }
5218     }
5219
5220   return build1_v (RETURN_EXPR, result);
5221 }
5222
5223
5224 /* Generate code for a function.  */
5225
5226 void
5227 gfc_generate_function_code (gfc_namespace * ns)
5228 {
5229   tree fndecl;
5230   tree old_context;
5231   tree decl;
5232   tree tmp;
5233   stmtblock_t init, cleanup;
5234   stmtblock_t body;
5235   gfc_wrapped_block try_block;
5236   tree recurcheckvar = NULL_TREE;
5237   gfc_symbol *sym;
5238   gfc_symbol *previous_procedure_symbol;
5239   int rank;
5240   bool is_recursive;
5241
5242   sym = ns->proc_name;
5243   previous_procedure_symbol = current_procedure_symbol;
5244   current_procedure_symbol = sym;
5245
5246   /* Check that the frontend isn't still using this.  */
5247   gcc_assert (sym->tlink == NULL);
5248   sym->tlink = sym;
5249
5250   /* Create the declaration for functions with global scope.  */
5251   if (!sym->backend_decl)
5252     gfc_create_function_decl (ns, false);
5253
5254   fndecl = sym->backend_decl;
5255   old_context = current_function_decl;
5256
5257   if (old_context)
5258     {
5259       push_function_context ();
5260       saved_parent_function_decls = saved_function_decls;
5261       saved_function_decls = NULL_TREE;
5262     }
5263
5264   trans_function_start (sym);
5265
5266   gfc_init_block (&init);
5267
5268   if (ns->entries && ns->proc_name->ts.type == BT_CHARACTER)
5269     {
5270       /* Copy length backend_decls to all entry point result
5271          symbols.  */
5272       gfc_entry_list *el;
5273       tree backend_decl;
5274
5275       gfc_conv_const_charlen (ns->proc_name->ts.u.cl);
5276       backend_decl = ns->proc_name->result->ts.u.cl->backend_decl;
5277       for (el = ns->entries; el; el = el->next)
5278         el->sym->result->ts.u.cl->backend_decl = backend_decl;
5279     }
5280
5281   /* Translate COMMON blocks.  */
5282   gfc_trans_common (ns);
5283
5284   /* Null the parent fake result declaration if this namespace is
5285      a module function or an external procedures.  */
5286   if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
5287         || ns->parent == NULL)
5288     parent_fake_result_decl = NULL_TREE;
5289
5290   gfc_generate_contained_functions (ns);
5291
5292   nonlocal_dummy_decls = NULL;
5293   nonlocal_dummy_decl_pset = NULL;
5294
5295   has_coarray_vars = false;
5296   generate_local_vars (ns);
5297
5298   if (gfc_option.coarray == GFC_FCOARRAY_LIB && has_coarray_vars)
5299     generate_coarray_init (ns);
5300
5301   /* Keep the parent fake result declaration in module functions
5302      or external procedures.  */
5303   if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
5304         || ns->parent == NULL)
5305     current_fake_result_decl = parent_fake_result_decl;
5306   else
5307     current_fake_result_decl = NULL_TREE;
5308
5309   is_recursive = sym->attr.recursive
5310                  || (sym->attr.entry_master
5311                      && sym->ns->entries->sym->attr.recursive);
5312   if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION)
5313         && !is_recursive
5314         && !gfc_option.flag_recursive)
5315     {
5316       char * msg;
5317
5318       asprintf (&msg, "Recursive call to nonrecursive procedure '%s'",
5319                 sym->name);
5320       recurcheckvar = gfc_create_var (boolean_type_node, "is_recursive");
5321       TREE_STATIC (recurcheckvar) = 1;
5322       DECL_INITIAL (recurcheckvar) = boolean_false_node;
5323       gfc_add_expr_to_block (&init, recurcheckvar);
5324       gfc_trans_runtime_check (true, false, recurcheckvar, &init,
5325                                &sym->declared_at, msg);
5326       gfc_add_modify (&init, recurcheckvar, boolean_true_node);
5327       free (msg);
5328     }
5329
5330   /* Now generate the code for the body of this function.  */
5331   gfc_init_block (&body);
5332
5333   if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node
5334         && sym->attr.subroutine)
5335     {
5336       tree alternate_return;
5337       alternate_return = gfc_get_fake_result_decl (sym, 0);
5338       gfc_add_modify (&body, alternate_return, integer_zero_node);
5339     }
5340
5341   if (ns->entries)
5342     {
5343       /* Jump to the correct entry point.  */
5344       tmp = gfc_trans_entry_master_switch (ns->entries);
5345       gfc_add_expr_to_block (&body, tmp);
5346     }
5347
5348   /* If bounds-checking is enabled, generate code to check passed in actual
5349      arguments against the expected dummy argument attributes (e.g. string
5350      lengths).  */
5351   if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) && !sym->attr.is_bind_c)
5352     add_argument_checking (&body, sym);
5353
5354   tmp = gfc_trans_code (ns->code);
5355   gfc_add_expr_to_block (&body, tmp);
5356
5357   if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node)
5358     {
5359       tree result = get_proc_result (sym);
5360
5361       if (result != NULL_TREE && sym->attr.function && !sym->attr.pointer)
5362         {
5363           if (sym->attr.allocatable && sym->attr.dimension == 0
5364               && sym->result == sym)
5365             gfc_add_modify (&init, result, fold_convert (TREE_TYPE (result),
5366                                                          null_pointer_node));
5367           else if (sym->ts.type == BT_CLASS
5368                    && CLASS_DATA (sym)->attr.allocatable
5369                    && CLASS_DATA (sym)->attr.dimension == 0
5370                    && sym->result == sym)
5371             {
5372               tmp = CLASS_DATA (sym)->backend_decl;
5373               tmp = fold_build3_loc (input_location, COMPONENT_REF,
5374                                      TREE_TYPE (tmp), result, tmp, NULL_TREE);
5375               gfc_add_modify (&init, tmp, fold_convert (TREE_TYPE (tmp),
5376                                                         null_pointer_node));
5377             }
5378           else if (sym->ts.type == BT_DERIVED
5379                    && sym->ts.u.derived->attr.alloc_comp
5380                    && !sym->attr.allocatable)
5381             {
5382               rank = sym->as ? sym->as->rank : 0;
5383               tmp = gfc_nullify_alloc_comp (sym->ts.u.derived, result, rank);
5384               gfc_add_expr_to_block (&init, tmp);
5385             }
5386         }
5387
5388       if (result == NULL_TREE)
5389         {
5390           /* TODO: move to the appropriate place in resolve.c.  */
5391           if (warn_return_type && sym == sym->result)
5392             gfc_warning ("Return value of function '%s' at %L not set",
5393                          sym->name, &sym->declared_at);
5394           if (warn_return_type)
5395             TREE_NO_WARNING(sym->backend_decl) = 1;
5396         }
5397       else
5398         gfc_add_expr_to_block (&body, gfc_generate_return ());
5399     }
5400
5401   gfc_init_block (&cleanup);
5402
5403   /* Reset recursion-check variable.  */
5404   if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION)
5405          && !is_recursive
5406          && !gfc_option.gfc_flag_openmp
5407          && recurcheckvar != NULL_TREE)
5408     {
5409       gfc_add_modify (&cleanup, recurcheckvar, boolean_false_node);
5410       recurcheckvar = NULL;
5411     }
5412
5413   /* Finish the function body and add init and cleanup code.  */
5414   tmp = gfc_finish_block (&body);
5415   gfc_start_wrapped_block (&try_block, tmp);
5416   /* Add code to create and cleanup arrays.  */
5417   gfc_trans_deferred_vars (sym, &try_block);
5418   gfc_add_init_cleanup (&try_block, gfc_finish_block (&init),
5419                         gfc_finish_block (&cleanup));
5420
5421   /* Add all the decls we created during processing.  */
5422   decl = saved_function_decls;
5423   while (decl)
5424     {
5425       tree next;
5426
5427       next = DECL_CHAIN (decl);
5428       DECL_CHAIN (decl) = NULL_TREE;
5429       if (GFC_DECL_PUSH_TOPLEVEL (decl))
5430         pushdecl_top_level (decl);
5431       else
5432         pushdecl (decl);
5433       decl = next;
5434     }
5435   saved_function_decls = NULL_TREE;
5436
5437   DECL_SAVED_TREE (fndecl) = gfc_finish_wrapped_block (&try_block);
5438   decl = getdecls ();
5439
5440   /* Finish off this function and send it for code generation.  */
5441   poplevel (1, 0, 1);
5442   BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
5443
5444   DECL_SAVED_TREE (fndecl)
5445     = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (fndecl),
5446                 DECL_INITIAL (fndecl));
5447
5448   if (nonlocal_dummy_decls)
5449     {
5450       BLOCK_VARS (DECL_INITIAL (fndecl))
5451         = chainon (BLOCK_VARS (DECL_INITIAL (fndecl)), nonlocal_dummy_decls);
5452       pointer_set_destroy (nonlocal_dummy_decl_pset);
5453       nonlocal_dummy_decls = NULL;
5454       nonlocal_dummy_decl_pset = NULL;
5455     }
5456
5457   /* Output the GENERIC tree.  */
5458   dump_function (TDI_original, fndecl);
5459
5460   /* Store the end of the function, so that we get good line number
5461      info for the epilogue.  */
5462   cfun->function_end_locus = input_location;
5463
5464   /* We're leaving the context of this function, so zap cfun.
5465      It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
5466      tree_rest_of_compilation.  */
5467   set_cfun (NULL);
5468
5469   if (old_context)
5470     {
5471       pop_function_context ();
5472       saved_function_decls = saved_parent_function_decls;
5473     }
5474   current_function_decl = old_context;
5475
5476   if (decl_function_context (fndecl) && !gfc_option.coarray == GFC_FCOARRAY_LIB
5477       && has_coarray_vars)
5478     /* Register this function with cgraph just far enough to get it
5479        added to our parent's nested function list.
5480        If there are static coarrays in this function, the nested _caf_init
5481        function has already called cgraph_create_node, which also created
5482        the cgraph node for this function.  */
5483     (void) cgraph_create_node (fndecl);
5484   else
5485     cgraph_finalize_function (fndecl, true);
5486
5487   gfc_trans_use_stmts (ns);
5488   gfc_traverse_ns (ns, gfc_emit_parameter_debug_info);
5489
5490   if (sym->attr.is_main_program)
5491     create_main_function (fndecl);
5492
5493   current_procedure_symbol = previous_procedure_symbol;
5494 }
5495
5496
5497 void
5498 gfc_generate_constructors (void)
5499 {
5500   gcc_assert (gfc_static_ctors == NULL_TREE);
5501 #if 0
5502   tree fnname;
5503   tree type;
5504   tree fndecl;
5505   tree decl;
5506   tree tmp;
5507
5508   if (gfc_static_ctors == NULL_TREE)
5509     return;
5510
5511   fnname = get_file_function_name ("I");
5512   type = build_function_type_list (void_type_node, NULL_TREE);
5513
5514   fndecl = build_decl (input_location,
5515                        FUNCTION_DECL, fnname, type);
5516   TREE_PUBLIC (fndecl) = 1;
5517
5518   decl = build_decl (input_location,
5519                      RESULT_DECL, NULL_TREE, void_type_node);
5520   DECL_ARTIFICIAL (decl) = 1;
5521   DECL_IGNORED_P (decl) = 1;
5522   DECL_CONTEXT (decl) = fndecl;
5523   DECL_RESULT (fndecl) = decl;
5524
5525   pushdecl (fndecl);
5526
5527   current_function_decl = fndecl;
5528
5529   rest_of_decl_compilation (fndecl, 1, 0);
5530
5531   make_decl_rtl (fndecl);
5532
5533   init_function_start (fndecl);
5534
5535   pushlevel (0);
5536
5537   for (; gfc_static_ctors; gfc_static_ctors = TREE_CHAIN (gfc_static_ctors))
5538     {
5539       tmp = build_call_expr_loc (input_location,
5540                              TREE_VALUE (gfc_static_ctors), 0);
5541       DECL_SAVED_TREE (fndecl) = build_stmt (input_location, EXPR_STMT, tmp);
5542     }
5543
5544   decl = getdecls ();
5545   poplevel (1, 0, 1);
5546
5547   BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
5548   DECL_SAVED_TREE (fndecl)
5549     = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (fndecl),
5550                 DECL_INITIAL (fndecl));
5551
5552   free_after_parsing (cfun);
5553   free_after_compilation (cfun);
5554
5555   tree_rest_of_compilation (fndecl);
5556
5557   current_function_decl = NULL_TREE;
5558 #endif
5559 }
5560
5561 /* Translates a BLOCK DATA program unit. This means emitting the
5562    commons contained therein plus their initializations. We also emit
5563    a globally visible symbol to make sure that each BLOCK DATA program
5564    unit remains unique.  */
5565
5566 void
5567 gfc_generate_block_data (gfc_namespace * ns)
5568 {
5569   tree decl;
5570   tree id;
5571
5572   /* Tell the backend the source location of the block data.  */
5573   if (ns->proc_name)
5574     gfc_set_backend_locus (&ns->proc_name->declared_at);
5575   else
5576     gfc_set_backend_locus (&gfc_current_locus);
5577
5578   /* Process the DATA statements.  */
5579   gfc_trans_common (ns);
5580
5581   /* Create a global symbol with the mane of the block data.  This is to
5582      generate linker errors if the same name is used twice.  It is never
5583      really used.  */
5584   if (ns->proc_name)
5585     id = gfc_sym_mangled_function_id (ns->proc_name);
5586   else
5587     id = get_identifier ("__BLOCK_DATA__");
5588
5589   decl = build_decl (input_location,
5590                      VAR_DECL, id, gfc_array_index_type);
5591   TREE_PUBLIC (decl) = 1;
5592   TREE_STATIC (decl) = 1;
5593   DECL_IGNORED_P (decl) = 1;
5594
5595   pushdecl (decl);
5596   rest_of_decl_compilation (decl, 1, 0);
5597 }
5598
5599
5600 /* Process the local variables of a BLOCK construct.  */
5601
5602 void
5603 gfc_process_block_locals (gfc_namespace* ns)
5604 {
5605   tree decl;
5606
5607   gcc_assert (saved_local_decls == NULL_TREE);
5608   has_coarray_vars = false;
5609
5610   generate_local_vars (ns);
5611
5612   if (gfc_option.coarray == GFC_FCOARRAY_LIB && has_coarray_vars)
5613     generate_coarray_init (ns);
5614
5615   decl = saved_local_decls;
5616   while (decl)
5617     {
5618       tree next;
5619
5620       next = DECL_CHAIN (decl);
5621       DECL_CHAIN (decl) = NULL_TREE;
5622       pushdecl (decl);
5623       decl = next;
5624     }
5625   saved_local_decls = NULL_TREE;
5626 }
5627
5628
5629 #include "gt-fortran-trans-decl.h"