gcc/fortran/trans-decl.c

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