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