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