gcc/fortran/trans-decl.c

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