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