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   attributes = add_attributes_to_decl (sym->attr, NULL_TREE);
1579   decl_attributes (&fndecl, attributes, 0);
1580
1581   gfc_set_decl_assembler_name (fndecl, mangled_name);
1582
1583   /* Set the context of this decl.  */
1584   if (0 && sym->ns && sym->ns->proc_name)
1585     {
1586       /* TODO: Add external decls to the appropriate scope.  */
1587       DECL_CONTEXT (fndecl) = sym->ns->proc_name->backend_decl;
1588     }
1589   else
1590     {
1591       /* Global declaration, e.g. intrinsic subroutine.  */
1592       DECL_CONTEXT (fndecl) = NULL_TREE;
1593     }
1594
1595   DECL_EXTERNAL (fndecl) = 1;
1596
1597   /* This specifies if a function is globally addressable, i.e. it is
1598      the opposite of declaring static in C.  */
1599   TREE_PUBLIC (fndecl) = 1;
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   attributes = add_attributes_to_decl (attr, NULL_TREE);
1662   decl_attributes (&fndecl, attributes, 0);
1663
1664   /* Figure out the return type of the declared function, and build a
1665      RESULT_DECL for it.  If this is a subroutine with alternate
1666      returns, build a RESULT_DECL for it.  */
1667   result_decl = NULL_TREE;
1668   /* TODO: Shouldn't this just be TREE_TYPE (TREE_TYPE (fndecl)).  */
1669   if (attr.function)
1670     {
1671       if (gfc_return_by_reference (sym))
1672         type = void_type_node;
1673       else
1674         {
1675           if (sym->result != sym)
1676             result_decl = gfc_sym_identifier (sym->result);
1677
1678           type = TREE_TYPE (TREE_TYPE (fndecl));
1679         }
1680     }
1681   else
1682     {
1683       /* Look for alternate return placeholders.  */
1684       int has_alternate_returns = 0;
1685       for (f = sym->formal; f; f = f->next)
1686         {
1687           if (f->sym == NULL)
1688             {
1689               has_alternate_returns = 1;
1690               break;
1691             }
1692         }
1693
1694       if (has_alternate_returns)
1695         type = integer_type_node;
1696       else
1697         type = void_type_node;
1698     }
1699
1700   result_decl = build_decl (input_location,
1701                             RESULT_DECL, result_decl, type);
1702   DECL_ARTIFICIAL (result_decl) = 1;
1703   DECL_IGNORED_P (result_decl) = 1;
1704   DECL_CONTEXT (result_decl) = fndecl;
1705   DECL_RESULT (fndecl) = result_decl;
1706
1707   /* Don't call layout_decl for a RESULT_DECL.
1708      layout_decl (result_decl, 0);  */
1709
1710   /* Set up all attributes for the function.  */
1711   DECL_EXTERNAL (fndecl) = 0;
1712
1713   /* This specifies if a function is globally visible, i.e. it is
1714      the opposite of declaring static in C.  */
1715   if (!current_function_decl
1716       && !sym->attr.entry_master && !sym->attr.is_main_program)
1717     TREE_PUBLIC (fndecl) = 1;
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;
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               else
3341                 tmp = NULL;
3342               gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp);
3343             }
3344         }
3345       else if (sym->ts.deferred)
3346         gfc_fatal_error ("Deferred type parameter not yet supported");
3347       else if (sym_has_alloc_comp)
3348         gfc_trans_deferred_array (sym, block);
3349       else if (sym->ts.type == BT_CHARACTER)
3350         {
3351           gfc_save_backend_locus (&loc);
3352           gfc_set_backend_locus (&sym->declared_at);
3353           if (sym->attr.dummy || sym->attr.result)
3354             gfc_trans_dummy_character (sym, sym->ts.u.cl, block);
3355           else
3356             gfc_trans_auto_character_variable (sym, block);
3357           gfc_restore_backend_locus (&loc);
3358         }
3359       else if (sym->attr.assign)
3360         {
3361           gfc_save_backend_locus (&loc);
3362           gfc_set_backend_locus (&sym->declared_at);
3363           gfc_trans_assign_aux_var (sym, block);
3364           gfc_restore_backend_locus (&loc);
3365         }
3366       else if (sym->ts.type == BT_DERIVED
3367                  && sym->value
3368                  && !sym->attr.data
3369                  && sym->attr.save == SAVE_NONE)
3370         {
3371           gfc_start_block (&tmpblock);
3372           gfc_init_default_dt (sym, &tmpblock, false);
3373           gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock),
3374                                 NULL_TREE);
3375         }
3376       else
3377         gcc_unreachable ();
3378     }
3379
3380   gfc_init_block (&tmpblock);
3381
3382   for (f = proc_sym->formal; f; f = f->next)
3383     {
3384       if (f->sym && f->sym->tlink == NULL && f->sym->ts.type == BT_CHARACTER)
3385         {
3386           gcc_assert (f->sym->ts.u.cl->backend_decl != NULL);
3387           if (TREE_CODE (f->sym->ts.u.cl->backend_decl) == PARM_DECL)
3388             gfc_trans_vla_type_sizes (f->sym, &tmpblock);
3389         }
3390     }
3391
3392   if (gfc_return_by_reference (proc_sym) && proc_sym->ts.type == BT_CHARACTER
3393       && current_fake_result_decl != NULL)
3394     {
3395       gcc_assert (proc_sym->ts.u.cl->backend_decl != NULL);
3396       if (TREE_CODE (proc_sym->ts.u.cl->backend_decl) == PARM_DECL)
3397         gfc_trans_vla_type_sizes (proc_sym, &tmpblock);
3398     }
3399
3400   gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock), NULL_TREE);
3401 }
3402
3403 static GTY ((param_is (struct module_htab_entry))) htab_t module_htab;
3404
3405 /* Hash and equality functions for module_htab.  */
3406
3407 static hashval_t
3408 module_htab_do_hash (const void *x)
3409 {
3410   return htab_hash_string (((const struct module_htab_entry *)x)->name);
3411 }
3412
3413 static int
3414 module_htab_eq (const void *x1, const void *x2)
3415 {
3416   return strcmp ((((const struct module_htab_entry *)x1)->name),
3417                  (const char *)x2) == 0;
3418 }
3419
3420 /* Hash and equality functions for module_htab's decls.  */
3421
3422 static hashval_t
3423 module_htab_decls_hash (const void *x)
3424 {
3425   const_tree t = (const_tree) x;
3426   const_tree n = DECL_NAME (t);
3427   if (n == NULL_TREE)
3428     n = TYPE_NAME (TREE_TYPE (t));
3429   return htab_hash_string (IDENTIFIER_POINTER (n));
3430 }
3431
3432 static int
3433 module_htab_decls_eq (const void *x1, const void *x2)
3434 {
3435   const_tree t1 = (const_tree) x1;
3436   const_tree n1 = DECL_NAME (t1);
3437   if (n1 == NULL_TREE)
3438     n1 = TYPE_NAME (TREE_TYPE (t1));
3439   return strcmp (IDENTIFIER_POINTER (n1), (const char *) x2) == 0;
3440 }
3441
3442 struct module_htab_entry *
3443 gfc_find_module (const char *name)
3444 {
3445   void **slot;
3446
3447   if (! module_htab)
3448     module_htab = htab_create_ggc (10, module_htab_do_hash,
3449                                    module_htab_eq, NULL);
3450
3451   slot = htab_find_slot_with_hash (module_htab, name,
3452                                    htab_hash_string (name), INSERT);
3453   if (*slot == NULL)
3454     {
3455       struct module_htab_entry *entry = ggc_alloc_cleared_module_htab_entry ();
3456
3457       entry->name = gfc_get_string (name);
3458       entry->decls = htab_create_ggc (10, module_htab_decls_hash,
3459                                       module_htab_decls_eq, NULL);
3460       *slot = (void *) entry;
3461     }
3462   return (struct module_htab_entry *) *slot;
3463 }
3464
3465 void
3466 gfc_module_add_decl (struct module_htab_entry *entry, tree decl)
3467 {
3468   void **slot;
3469   const char *name;
3470
3471   if (DECL_NAME (decl))
3472     name = IDENTIFIER_POINTER (DECL_NAME (decl));
3473   else
3474     {
3475       gcc_assert (TREE_CODE (decl) == TYPE_DECL);
3476       name = IDENTIFIER_POINTER (TYPE_NAME (TREE_TYPE (decl)));
3477     }
3478   slot = htab_find_slot_with_hash (entry->decls, name,
3479                                    htab_hash_string (name), INSERT);
3480   if (*slot == NULL)
3481     *slot = (void *) decl;
3482 }
3483
3484 static struct module_htab_entry *cur_module;
3485
3486 /* Output an initialized decl for a module variable.  */
3487
3488 static void
3489 gfc_create_module_variable (gfc_symbol * sym)
3490 {
3491   tree decl;
3492
3493   /* Module functions with alternate entries are dealt with later and
3494      would get caught by the next condition.  */
3495   if (sym->attr.entry)
3496     return;
3497
3498   /* Make sure we convert the types of the derived types from iso_c_binding
3499      into (void *).  */
3500   if (sym->attr.flavor != FL_PROCEDURE && sym->attr.is_iso_c
3501       && sym->ts.type == BT_DERIVED)
3502     sym->backend_decl = gfc_typenode_for_spec (&(sym->ts));
3503
3504   if (sym->attr.flavor == FL_DERIVED
3505       && sym->backend_decl
3506       && TREE_CODE (sym->backend_decl) == RECORD_TYPE)
3507     {
3508       decl = sym->backend_decl;
3509       gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
3510
3511       /* -fwhole-file mixes up the contexts so these asserts are unnecessary.  */
3512       if (!(gfc_option.flag_whole_file && sym->attr.use_assoc))
3513         {
3514           gcc_assert (TYPE_CONTEXT (decl) == NULL_TREE
3515                       || TYPE_CONTEXT (decl) == sym->ns->proc_name->backend_decl);
3516           gcc_assert (DECL_CONTEXT (TYPE_STUB_DECL (decl)) == NULL_TREE
3517                       || DECL_CONTEXT (TYPE_STUB_DECL (decl))
3518                            == sym->ns->proc_name->backend_decl);
3519         }
3520       TYPE_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
3521       DECL_CONTEXT (TYPE_STUB_DECL (decl)) = sym->ns->proc_name->backend_decl;
3522       gfc_module_add_decl (cur_module, TYPE_STUB_DECL (decl));
3523     }
3524
3525   /* Only output variables, procedure pointers and array valued,
3526      or derived type, parameters.  */
3527   if (sym->attr.flavor != FL_VARIABLE
3528         && !(sym->attr.flavor == FL_PARAMETER
3529                && (sym->attr.dimension || sym->ts.type == BT_DERIVED))
3530         && !(sym->attr.flavor == FL_PROCEDURE && sym->attr.proc_pointer))
3531     return;
3532
3533   if ((sym->attr.in_common || sym->attr.in_equivalence) && sym->backend_decl)
3534     {
3535       decl = sym->backend_decl;
3536       gcc_assert (DECL_FILE_SCOPE_P (decl));
3537       gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
3538       DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
3539       gfc_module_add_decl (cur_module, decl);
3540     }
3541
3542   /* Don't generate variables from other modules. Variables from
3543      COMMONs will already have been generated.  */
3544   if (sym->attr.use_assoc || sym->attr.in_common)
3545     return;
3546
3547   /* Equivalenced variables arrive here after creation.  */
3548   if (sym->backend_decl
3549       && (sym->equiv_built || sym->attr.in_equivalence))
3550     return;
3551
3552   if (sym->backend_decl && !sym->attr.vtab && !sym->attr.target)
3553     internal_error ("backend decl for module variable %s already exists",
3554                     sym->name);
3555
3556   /* We always want module variables to be created.  */
3557   sym->attr.referenced = 1;
3558   /* Create the decl.  */
3559   decl = gfc_get_symbol_decl (sym);
3560
3561   /* Create the variable.  */
3562   pushdecl (decl);
3563   gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
3564   DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
3565   rest_of_decl_compilation (decl, 1, 0);
3566   gfc_module_add_decl (cur_module, decl);
3567
3568   /* Also add length of strings.  */
3569   if (sym->ts.type == BT_CHARACTER)
3570     {
3571       tree length;
3572
3573       length = sym->ts.u.cl->backend_decl;
3574       gcc_assert (length || sym->attr.proc_pointer);
3575       if (length && !INTEGER_CST_P (length))
3576         {
3577           pushdecl (length);
3578           rest_of_decl_compilation (length, 1, 0);
3579         }
3580     }
3581 }
3582
3583 /* Emit debug information for USE statements.  */
3584
3585 static void
3586 gfc_trans_use_stmts (gfc_namespace * ns)
3587 {
3588   gfc_use_list *use_stmt;
3589   for (use_stmt = ns->use_stmts; use_stmt; use_stmt = use_stmt->next)
3590     {
3591       struct module_htab_entry *entry
3592         = gfc_find_module (use_stmt->module_name);
3593       gfc_use_rename *rent;
3594
3595       if (entry->namespace_decl == NULL)
3596         {
3597           entry->namespace_decl
3598             = build_decl (input_location,
3599                           NAMESPACE_DECL,
3600                           get_identifier (use_stmt->module_name),
3601                           void_type_node);
3602           DECL_EXTERNAL (entry->namespace_decl) = 1;
3603         }
3604       gfc_set_backend_locus (&use_stmt->where);
3605       if (!use_stmt->only_flag)
3606         (*debug_hooks->imported_module_or_decl) (entry->namespace_decl,
3607                                                  NULL_TREE,
3608                                                  ns->proc_name->backend_decl,
3609                                                  false);
3610       for (rent = use_stmt->rename; rent; rent = rent->next)
3611         {
3612           tree decl, local_name;
3613           void **slot;
3614
3615           if (rent->op != INTRINSIC_NONE)
3616             continue;
3617
3618           slot = htab_find_slot_with_hash (entry->decls, rent->use_name,
3619                                            htab_hash_string (rent->use_name),
3620                                            INSERT);
3621           if (*slot == NULL)
3622             {
3623               gfc_symtree *st;
3624
3625               st = gfc_find_symtree (ns->sym_root,
3626                                      rent->local_name[0]
3627                                      ? rent->local_name : rent->use_name);
3628               gcc_assert (st);
3629
3630               /* Sometimes, generic interfaces wind up being over-ruled by a
3631                  local symbol (see PR41062).  */
3632               if (!st->n.sym->attr.use_assoc)
3633                 continue;
3634
3635               if (st->n.sym->backend_decl
3636                   && DECL_P (st->n.sym->backend_decl)
3637                   && st->n.sym->module
3638                   && strcmp (st->n.sym->module, use_stmt->module_name) == 0)
3639                 {
3640                   gcc_assert (DECL_EXTERNAL (entry->namespace_decl)
3641                               || (TREE_CODE (st->n.sym->backend_decl)
3642                                   != VAR_DECL));
3643                   decl = copy_node (st->n.sym->backend_decl);
3644                   DECL_CONTEXT (decl) = entry->namespace_decl;
3645                   DECL_EXTERNAL (decl) = 1;
3646                   DECL_IGNORED_P (decl) = 0;
3647                   DECL_INITIAL (decl) = NULL_TREE;
3648                 }
3649               else
3650                 {
3651                   *slot = error_mark_node;
3652                   htab_clear_slot (entry->decls, slot);
3653                   continue;
3654                 }
3655               *slot = decl;
3656             }
3657           decl = (tree) *slot;
3658           if (rent->local_name[0])
3659             local_name = get_identifier (rent->local_name);
3660           else
3661             local_name = NULL_TREE;
3662           gfc_set_backend_locus (&rent->where);
3663           (*debug_hooks->imported_module_or_decl) (decl, local_name,
3664                                                    ns->proc_name->backend_decl,
3665                                                    !use_stmt->only_flag);
3666         }
3667     }
3668 }
3669
3670
3671 /* Return true if expr is a constant initializer that gfc_conv_initializer
3672    will handle.  */
3673
3674 static bool
3675 check_constant_initializer (gfc_expr *expr, gfc_typespec *ts, bool array,
3676                             bool pointer)
3677 {
3678   gfc_constructor *c;
3679   gfc_component *cm;
3680
3681   if (pointer)
3682     return true;
3683   else if (array)
3684     {
3685       if (expr->expr_type == EXPR_CONSTANT || expr->expr_type == EXPR_NULL)
3686         return true;
3687       else if (expr->expr_type == EXPR_STRUCTURE)
3688         return check_constant_initializer (expr, ts, false, false);
3689       else if (expr->expr_type != EXPR_ARRAY)
3690         return false;
3691       for (c = gfc_constructor_first (expr->value.constructor);
3692            c; c = gfc_constructor_next (c))
3693         {
3694           if (c->iterator)
3695             return false;
3696           if (c->expr->expr_type == EXPR_STRUCTURE)
3697             {
3698               if (!check_constant_initializer (c->expr, ts, false, false))
3699                 return false;
3700             }
3701           else if (c->expr->expr_type != EXPR_CONSTANT)
3702             return false;
3703         }
3704       return true;
3705     }
3706   else switch (ts->type)
3707     {
3708     case BT_DERIVED:
3709       if (expr->expr_type != EXPR_STRUCTURE)
3710         return false;
3711       cm = expr->ts.u.derived->components;
3712       for (c = gfc_constructor_first (expr->value.constructor);
3713            c; c = gfc_constructor_next (c), cm = cm->next)
3714         {
3715           if (!c->expr || cm->attr.allocatable)
3716             continue;
3717           if (!check_constant_initializer (c->expr, &cm->ts,
3718                                            cm->attr.dimension,
3719                                            cm->attr.pointer))
3720             return false;
3721         }
3722       return true;
3723     default:
3724       return expr->expr_type == EXPR_CONSTANT;
3725     }
3726 }
3727
3728 /* Emit debug info for parameters and unreferenced variables with
3729    initializers.  */
3730
3731 static void
3732 gfc_emit_parameter_debug_info (gfc_symbol *sym)
3733 {
3734   tree decl;
3735
3736   if (sym->attr.flavor != FL_PARAMETER
3737       && (sym->attr.flavor != FL_VARIABLE || sym->attr.referenced))
3738     return;
3739
3740   if (sym->backend_decl != NULL
3741       || sym->value == NULL
3742       || sym->attr.use_assoc
3743       || sym->attr.dummy
3744       || sym->attr.result
3745       || sym->attr.function
3746       || sym->attr.intrinsic
3747       || sym->attr.pointer
3748       || sym->attr.allocatable
3749       || sym->attr.cray_pointee
3750       || sym->attr.threadprivate
3751       || sym->attr.is_bind_c
3752       || sym->attr.subref_array_pointer
3753       || sym->attr.assign)
3754     return;
3755
3756   if (sym->ts.type == BT_CHARACTER)
3757     {
3758       gfc_conv_const_charlen (sym->ts.u.cl);
3759       if (sym->ts.u.cl->backend_decl == NULL
3760           || TREE_CODE (sym->ts.u.cl->backend_decl) != INTEGER_CST)
3761         return;
3762     }
3763   else if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.alloc_comp)
3764     return;
3765
3766   if (sym->as)
3767     {
3768       int n;
3769
3770       if (sym->as->type != AS_EXPLICIT)
3771         return;
3772       for (n = 0; n < sym->as->rank; n++)
3773         if (sym->as->lower[n]->expr_type != EXPR_CONSTANT
3774             || sym->as->upper[n] == NULL
3775             || sym->as->upper[n]->expr_type != EXPR_CONSTANT)
3776           return;
3777     }
3778
3779   if (!check_constant_initializer (sym->value, &sym->ts,
3780                                    sym->attr.dimension, false))
3781     return;
3782
3783   /* Create the decl for the variable or constant.  */
3784   decl = build_decl (input_location,
3785                      sym->attr.flavor == FL_PARAMETER ? CONST_DECL : VAR_DECL,
3786                      gfc_sym_identifier (sym), gfc_sym_type (sym));
3787   if (sym->attr.flavor == FL_PARAMETER)
3788     TREE_READONLY (decl) = 1;
3789   gfc_set_decl_location (decl, &sym->declared_at);
3790   if (sym->attr.dimension)
3791     GFC_DECL_PACKED_ARRAY (decl) = 1;
3792   DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
3793   TREE_STATIC (decl) = 1;
3794   TREE_USED (decl) = 1;
3795   if (DECL_CONTEXT (decl) && TREE_CODE (DECL_CONTEXT (decl)) == NAMESPACE_DECL)
3796     TREE_PUBLIC (decl) = 1;
3797   DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
3798                                               TREE_TYPE (decl),
3799                                               sym->attr.dimension,
3800                                               false, false);
3801   debug_hooks->global_decl (decl);
3802 }
3803
3804 /* Generate all the required code for module variables.  */
3805
3806 void
3807 gfc_generate_module_vars (gfc_namespace * ns)
3808 {
3809   module_namespace = ns;
3810   cur_module = gfc_find_module (ns->proc_name->name);
3811
3812   /* Check if the frontend left the namespace in a reasonable state.  */
3813   gcc_assert (ns->proc_name && !ns->proc_name->tlink);
3814
3815   /* Generate COMMON blocks.  */
3816   gfc_trans_common (ns);
3817
3818   /* Create decls for all the module variables.  */
3819   gfc_traverse_ns (ns, gfc_create_module_variable);
3820
3821   cur_module = NULL;
3822
3823   gfc_trans_use_stmts (ns);
3824   gfc_traverse_ns (ns, gfc_emit_parameter_debug_info);
3825 }
3826
3827
3828 static void
3829 gfc_generate_contained_functions (gfc_namespace * parent)
3830 {
3831   gfc_namespace *ns;
3832
3833   /* We create all the prototypes before generating any code.  */
3834   for (ns = parent->contained; ns; ns = ns->sibling)
3835     {
3836       /* Skip namespaces from used modules.  */
3837       if (ns->parent != parent)
3838         continue;
3839
3840       gfc_create_function_decl (ns, false);
3841     }
3842
3843   for (ns = parent->contained; ns; ns = ns->sibling)
3844     {
3845       /* Skip namespaces from used modules.  */
3846       if (ns->parent != parent)
3847         continue;
3848
3849       gfc_generate_function_code (ns);
3850     }
3851 }
3852
3853
3854 /* Drill down through expressions for the array specification bounds and
3855    character length calling generate_local_decl for all those variables
3856    that have not already been declared.  */
3857
3858 static void
3859 generate_local_decl (gfc_symbol *);
3860
3861 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced.  */
3862
3863 static bool
3864 expr_decls (gfc_expr *e, gfc_symbol *sym,
3865             int *f ATTRIBUTE_UNUSED)
3866 {
3867   if (e->expr_type != EXPR_VARIABLE
3868             || sym == e->symtree->n.sym
3869             || e->symtree->n.sym->mark
3870             || e->symtree->n.sym->ns != sym->ns)
3871         return false;
3872
3873   generate_local_decl (e->symtree->n.sym);
3874   return false;
3875 }
3876
3877 static void
3878 generate_expr_decls (gfc_symbol *sym, gfc_expr *e)
3879 {
3880   gfc_traverse_expr (e, sym, expr_decls, 0);
3881 }
3882
3883
3884 /* Check for dependencies in the character length and array spec.  */
3885
3886 static void
3887 generate_dependency_declarations (gfc_symbol *sym)
3888 {
3889   int i;
3890
3891   if (sym->ts.type == BT_CHARACTER
3892       && sym->ts.u.cl
3893       && sym->ts.u.cl->length
3894       && sym->ts.u.cl->length->expr_type != EXPR_CONSTANT)
3895     generate_expr_decls (sym, sym->ts.u.cl->length);
3896
3897   if (sym->as && sym->as->rank)
3898     {
3899       for (i = 0; i < sym->as->rank; i++)
3900         {
3901           generate_expr_decls (sym, sym->as->lower[i]);
3902           generate_expr_decls (sym, sym->as->upper[i]);
3903         }
3904     }
3905 }
3906
3907
3908 /* Generate decls for all local variables.  We do this to ensure correct
3909    handling of expressions which only appear in the specification of
3910    other functions.  */
3911
3912 static void
3913 generate_local_decl (gfc_symbol * sym)
3914 {
3915   if (sym->attr.flavor == FL_VARIABLE)
3916     {
3917       if (!sym->attr.dummy && !sym->ns->proc_name->attr.entry_master)
3918         generate_dependency_declarations (sym);
3919
3920       if (sym->attr.referenced)
3921         gfc_get_symbol_decl (sym);
3922
3923       /* Warnings for unused dummy arguments.  */
3924       else if (sym->attr.dummy)
3925         {
3926           /* INTENT(out) dummy arguments are likely meant to be set.  */
3927           if (gfc_option.warn_unused_dummy_argument
3928               && sym->attr.intent == INTENT_OUT)
3929             {
3930               if (sym->ts.type != BT_DERIVED)
3931                 gfc_warning ("Dummy argument '%s' at %L was declared "
3932                              "INTENT(OUT) but was not set",  sym->name,
3933                              &sym->declared_at);
3934               else if (!gfc_has_default_initializer (sym->ts.u.derived))
3935                 gfc_warning ("Derived-type dummy argument '%s' at %L was "
3936                              "declared INTENT(OUT) but was not set and "
3937                              "does not have a default initializer",
3938                              sym->name, &sym->declared_at);
3939             }
3940           else if (gfc_option.warn_unused_dummy_argument)
3941             gfc_warning ("Unused dummy argument '%s' at %L", sym->name,
3942                          &sym->declared_at);
3943         }
3944
3945       /* Warn for unused variables, but not if they're inside a common
3946          block, a namelist, or are use-associated.  */
3947       else if (warn_unused_variable
3948                && !(sym->attr.in_common || sym->attr.use_assoc || sym->mark
3949                     || sym->attr.in_namelist))
3950         gfc_warning ("Unused variable '%s' declared at %L", sym->name,
3951                      &sym->declared_at);
3952
3953       /* For variable length CHARACTER parameters, the PARM_DECL already
3954          references the length variable, so force gfc_get_symbol_decl
3955          even when not referenced.  If optimize > 0, it will be optimized
3956          away anyway.  But do this only after emitting -Wunused-parameter
3957          warning if requested.  */
3958       if (sym->attr.dummy && !sym->attr.referenced
3959             && sym->ts.type == BT_CHARACTER
3960             && sym->ts.u.cl->backend_decl != NULL
3961             && TREE_CODE (sym->ts.u.cl->backend_decl) == VAR_DECL)
3962         {
3963           sym->attr.referenced = 1;
3964           gfc_get_symbol_decl (sym);
3965         }
3966
3967       /* INTENT(out) dummy arguments and result variables with allocatable
3968          components are reset by default and need to be set referenced to
3969          generate the code for nullification and automatic lengths.  */
3970       if (!sym->attr.referenced
3971             && sym->ts.type == BT_DERIVED
3972             && sym->ts.u.derived->attr.alloc_comp
3973             && !sym->attr.pointer
3974             && ((sym->attr.dummy && sym->attr.intent == INTENT_OUT)
3975                   ||
3976                 (sym->attr.result && sym != sym->result)))
3977         {
3978           sym->attr.referenced = 1;
3979           gfc_get_symbol_decl (sym);
3980         }
3981
3982       /* Check for dependencies in the array specification and string
3983         length, adding the necessary declarations to the function.  We
3984         mark the symbol now, as well as in traverse_ns, to prevent
3985         getting stuck in a circular dependency.  */
3986       sym->mark = 1;
3987
3988       /* We do not want the middle-end to warn about unused parameters
3989          as this was already done above.  */
3990       if (sym->attr.dummy && sym->backend_decl != NULL_TREE)
3991           TREE_NO_WARNING(sym->backend_decl) = 1;
3992     }
3993   else if (sym->attr.flavor == FL_PARAMETER)
3994     {
3995       if (warn_unused_parameter
3996            && !sym->attr.referenced
3997            && !sym->attr.use_assoc)
3998         gfc_warning ("Unused parameter '%s' declared at %L", sym->name,
3999                      &sym->declared_at);
4000     }
4001   else if (sym->attr.flavor == FL_PROCEDURE)
4002     {
4003       /* TODO: move to the appropriate place in resolve.c.  */
4004       if (warn_return_type
4005           && sym->attr.function
4006           && sym->result
4007           && sym != sym->result
4008           && !sym->result->attr.referenced
4009           && !sym->attr.use_assoc
4010           && sym->attr.if_source != IFSRC_IFBODY)
4011         {
4012           gfc_warning ("Return value '%s' of function '%s' declared at "
4013                        "%L not set", sym->result->name, sym->name,
4014                         &sym->result->declared_at);
4015
4016           /* Prevents "Unused variable" warning for RESULT variables.  */
4017           sym->result->mark = 1;
4018         }
4019     }
4020
4021   if (sym->attr.dummy == 1)
4022     {
4023       /* Modify the tree type for scalar character dummy arguments of bind(c)
4024          procedures if they are passed by value.  The tree type for them will
4025          be promoted to INTEGER_TYPE for the middle end, which appears to be
4026          what C would do with characters passed by-value.  The value attribute
4027          implies the dummy is a scalar.  */
4028       if (sym->attr.value == 1 && sym->backend_decl != NULL
4029           && sym->ts.type == BT_CHARACTER && sym->ts.is_c_interop
4030           && sym->ns->proc_name != NULL && sym->ns->proc_name->attr.is_bind_c)
4031         gfc_conv_scalar_char_value (sym, NULL, NULL);
4032     }
4033
4034   /* Make sure we convert the types of the derived types from iso_c_binding
4035      into (void *).  */
4036   if (sym->attr.flavor != FL_PROCEDURE && sym->attr.is_iso_c
4037       && sym->ts.type == BT_DERIVED)
4038     sym->backend_decl = gfc_typenode_for_spec (&(sym->ts));
4039 }
4040
4041 static void
4042 generate_local_vars (gfc_namespace * ns)
4043 {
4044   gfc_traverse_ns (ns, generate_local_decl);
4045 }
4046
4047
4048 /* Generate a switch statement to jump to the correct entry point.  Also
4049    creates the label decls for the entry points.  */
4050
4051 static tree
4052 gfc_trans_entry_master_switch (gfc_entry_list * el)
4053 {
4054   stmtblock_t block;
4055   tree label;
4056   tree tmp;
4057   tree val;
4058
4059   gfc_init_block (&block);
4060   for (; el; el = el->next)
4061     {
4062       /* Add the case label.  */
4063       label = gfc_build_label_decl (NULL_TREE);
4064       val = build_int_cst (gfc_array_index_type, el->id);
4065       tmp = build3_v (CASE_LABEL_EXPR, val, NULL_TREE, label);
4066       gfc_add_expr_to_block (&block, tmp);
4067
4068       /* And jump to the actual entry point.  */
4069       label = gfc_build_label_decl (NULL_TREE);
4070       tmp = build1_v (GOTO_EXPR, label);
4071       gfc_add_expr_to_block (&block, tmp);
4072
4073       /* Save the label decl.  */
4074       el->label = label;
4075     }
4076   tmp = gfc_finish_block (&block);
4077   /* The first argument selects the entry point.  */
4078   val = DECL_ARGUMENTS (current_function_decl);
4079   tmp = build3_v (SWITCH_EXPR, val, tmp, NULL_TREE);
4080   return tmp;
4081 }
4082
4083
4084 /* Add code to string lengths of actual arguments passed to a function against
4085    the expected lengths of the dummy arguments.  */
4086
4087 static void
4088 add_argument_checking (stmtblock_t *block, gfc_symbol *sym)
4089 {
4090   gfc_formal_arglist *formal;
4091
4092   for (formal = sym->formal; formal; formal = formal->next)
4093     if (formal->sym && formal->sym->ts.type == BT_CHARACTER)
4094       {
4095         enum tree_code comparison;
4096         tree cond;
4097         tree argname;
4098         gfc_symbol *fsym;
4099         gfc_charlen *cl;
4100         const char *message;
4101
4102         fsym = formal->sym;
4103         cl = fsym->ts.u.cl;
4104
4105         gcc_assert (cl);
4106         gcc_assert (cl->passed_length != NULL_TREE);
4107         gcc_assert (cl->backend_decl != NULL_TREE);
4108
4109         /* For POINTER, ALLOCATABLE and assumed-shape dummy arguments, the
4110            string lengths must match exactly.  Otherwise, it is only required
4111            that the actual string length is *at least* the expected one.
4112            Sequence association allows for a mismatch of the string length
4113            if the actual argument is (part of) an array, but only if the
4114            dummy argument is an array. (See "Sequence association" in
4115            Section 12.4.1.4 for F95 and 12.4.1.5 for F2003.)  */
4116         if (fsym->attr.pointer || fsym->attr.allocatable
4117             || (fsym->as && fsym->as->type == AS_ASSUMED_SHAPE))
4118           {
4119             comparison = NE_EXPR;
4120             message = _("Actual string length does not match the declared one"
4121                         " for dummy argument '%s' (%ld/%ld)");
4122           }
4123         else if (fsym->as && fsym->as->rank != 0)
4124           continue;
4125         else
4126           {
4127             comparison = LT_EXPR;
4128             message = _("Actual string length is shorter than the declared one"
4129                         " for dummy argument '%s' (%ld/%ld)");
4130           }
4131
4132         /* Build the condition.  For optional arguments, an actual length
4133            of 0 is also acceptable if the associated string is NULL, which
4134            means the argument was not passed.  */
4135         cond = fold_build2_loc (input_location, comparison, boolean_type_node,
4136                                 cl->passed_length, cl->backend_decl);
4137         if (fsym->attr.optional)
4138           {
4139             tree not_absent;
4140             tree not_0length;
4141             tree absent_failed;
4142
4143             not_0length = fold_build2_loc (input_location, NE_EXPR,
4144                                            boolean_type_node,
4145                                            cl->passed_length,
4146                                            build_zero_cst (gfc_charlen_type_node));
4147             /* The symbol needs to be referenced for gfc_get_symbol_decl.  */
4148             fsym->attr.referenced = 1;
4149             not_absent = gfc_conv_expr_present (fsym);
4150
4151             absent_failed = fold_build2_loc (input_location, TRUTH_OR_EXPR,
4152                                              boolean_type_node, not_0length,
4153                                              not_absent);
4154
4155             cond = fold_build2_loc (input_location, TRUTH_AND_EXPR,
4156                                     boolean_type_node, cond, absent_failed);
4157           }
4158
4159         /* Build the runtime check.  */
4160         argname = gfc_build_cstring_const (fsym->name);
4161         argname = gfc_build_addr_expr (pchar_type_node, argname);
4162         gfc_trans_runtime_check (true, false, cond, block, &fsym->declared_at,
4163                                  message, argname,
4164                                  fold_convert (long_integer_type_node,
4165                                                cl->passed_length),
4166                                  fold_convert (long_integer_type_node,
4167                                                cl->backend_decl));
4168       }
4169 }
4170
4171
4172 static void
4173 create_main_function (tree fndecl)
4174 {
4175   tree old_context;
4176   tree ftn_main;
4177   tree tmp, decl, result_decl, argc, argv, typelist, arglist;
4178   stmtblock_t body;
4179
4180   old_context = current_function_decl;
4181
4182   if (old_context)
4183     {
4184       push_function_context ();
4185       saved_parent_function_decls = saved_function_decls;
4186       saved_function_decls = NULL_TREE;
4187     }
4188
4189   /* main() function must be declared with global scope.  */
4190   gcc_assert (current_function_decl == NULL_TREE);
4191
4192   /* Declare the function.  */
4193   tmp =  build_function_type_list (integer_type_node, integer_type_node,
4194                                    build_pointer_type (pchar_type_node),
4195                                    NULL_TREE);
4196   main_identifier_node = get_identifier ("main");
4197   ftn_main = build_decl (input_location, FUNCTION_DECL,
4198                          main_identifier_node, tmp);
4199   DECL_EXTERNAL (ftn_main) = 0;
4200   TREE_PUBLIC (ftn_main) = 1;
4201   TREE_STATIC (ftn_main) = 1;
4202   DECL_ATTRIBUTES (ftn_main)
4203       = tree_cons (get_identifier("externally_visible"), NULL_TREE, NULL_TREE);
4204
4205   /* Setup the result declaration (for "return 0").  */
4206   result_decl = build_decl (input_location,
4207                             RESULT_DECL, NULL_TREE, integer_type_node);
4208   DECL_ARTIFICIAL (result_decl) = 1;
4209   DECL_IGNORED_P (result_decl) = 1;
4210   DECL_CONTEXT (result_decl) = ftn_main;
4211   DECL_RESULT (ftn_main) = result_decl;
4212
4213   pushdecl (ftn_main);
4214
4215   /* Get the arguments.  */
4216
4217   arglist = NULL_TREE;
4218   typelist = TYPE_ARG_TYPES (TREE_TYPE (ftn_main));
4219
4220   tmp = TREE_VALUE (typelist);
4221   argc = build_decl (input_location, PARM_DECL, get_identifier ("argc"), tmp);
4222   DECL_CONTEXT (argc) = ftn_main;
4223   DECL_ARG_TYPE (argc) = TREE_VALUE (typelist);
4224   TREE_READONLY (argc) = 1;
4225   gfc_finish_decl (argc);
4226   arglist = chainon (arglist, argc);
4227
4228   typelist = TREE_CHAIN (typelist);
4229   tmp = TREE_VALUE (typelist);
4230   argv = build_decl (input_location, PARM_DECL, get_identifier ("argv"), tmp);
4231   DECL_CONTEXT (argv) = ftn_main;
4232   DECL_ARG_TYPE (argv) = TREE_VALUE (typelist);
4233   TREE_READONLY (argv) = 1;
4234   DECL_BY_REFERENCE (argv) = 1;
4235   gfc_finish_decl (argv);
4236   arglist = chainon (arglist, argv);
4237
4238   DECL_ARGUMENTS (ftn_main) = arglist;
4239   current_function_decl = ftn_main;
4240   announce_function (ftn_main);
4241
4242   rest_of_decl_compilation (ftn_main, 1, 0);
4243   make_decl_rtl (ftn_main);
4244   init_function_start (ftn_main);
4245   pushlevel (0);
4246
4247   gfc_init_block (&body);
4248
4249   /* Call some libgfortran initialization routines, call then MAIN__(). */
4250
4251   /* Call _gfortran_set_args (argc, argv).  */
4252   TREE_USED (argc) = 1;
4253   TREE_USED (argv) = 1;
4254   tmp = build_call_expr_loc (input_location,
4255                          gfor_fndecl_set_args, 2, argc, argv);
4256   gfc_add_expr_to_block (&body, tmp);
4257
4258   /* Add a call to set_options to set up the runtime library Fortran
4259      language standard parameters.  */
4260   {
4261     tree array_type, array, var;
4262     VEC(constructor_elt,gc) *v = NULL;
4263
4264     /* Passing a new option to the library requires four modifications:
4265      + add it to the tree_cons list below
4266           + change the array size in the call to build_array_type
4267           + change the first argument to the library call
4268             gfor_fndecl_set_options
4269           + modify the library (runtime/compile_options.c)!  */
4270
4271     CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
4272                             build_int_cst (integer_type_node,
4273                                            gfc_option.warn_std));
4274     CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
4275                             build_int_cst (integer_type_node,
4276                                            gfc_option.allow_std));
4277     CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
4278                             build_int_cst (integer_type_node, pedantic));
4279     CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
4280                             build_int_cst (integer_type_node,
4281                                            gfc_option.flag_dump_core));
4282     CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
4283                             build_int_cst (integer_type_node,
4284                                            gfc_option.flag_backtrace));
4285     CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
4286                             build_int_cst (integer_type_node,
4287                                            gfc_option.flag_sign_zero));
4288     CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
4289                             build_int_cst (integer_type_node,
4290                                            (gfc_option.rtcheck
4291                                             & GFC_RTCHECK_BOUNDS)));
4292     CONSTRUCTOR_APPEND_ELT (v, NULL_TREE,
4293                             build_int_cst (integer_type_node,
4294                                            gfc_option.flag_range_check));
4295
4296     array_type = build_array_type (integer_type_node,
4297                        build_index_type (build_int_cst (NULL_TREE, 7)));
4298     array = build_constructor (array_type, v);
4299     TREE_CONSTANT (array) = 1;
4300     TREE_STATIC (array) = 1;
4301
4302     /* Create a static variable to hold the jump table.  */
4303     var = gfc_create_var (array_type, "options");
4304     TREE_CONSTANT (var) = 1;
4305     TREE_STATIC (var) = 1;
4306     TREE_READONLY (var) = 1;
4307     DECL_INITIAL (var) = array;
4308     var = gfc_build_addr_expr (build_pointer_type (integer_type_node), var);
4309
4310     tmp = build_call_expr_loc (input_location,
4311                            gfor_fndecl_set_options, 2,
4312                            build_int_cst (integer_type_node, 8), var);
4313     gfc_add_expr_to_block (&body, tmp);
4314   }
4315
4316   /* If -ffpe-trap option was provided, add a call to set_fpe so that
4317      the library will raise a FPE when needed.  */
4318   if (gfc_option.fpe != 0)
4319     {
4320       tmp = build_call_expr_loc (input_location,
4321                              gfor_fndecl_set_fpe, 1,
4322                              build_int_cst (integer_type_node,
4323                                             gfc_option.fpe));
4324       gfc_add_expr_to_block (&body, tmp);
4325     }
4326
4327   /* If this is the main program and an -fconvert option was provided,
4328      add a call to set_convert.  */
4329
4330   if (gfc_option.convert != GFC_CONVERT_NATIVE)
4331     {
4332       tmp = build_call_expr_loc (input_location,
4333                              gfor_fndecl_set_convert, 1,
4334                              build_int_cst (integer_type_node,
4335                                             gfc_option.convert));
4336       gfc_add_expr_to_block (&body, tmp);
4337     }
4338
4339   /* If this is the main program and an -frecord-marker option was provided,
4340      add a call to set_record_marker.  */
4341
4342   if (gfc_option.record_marker != 0)
4343     {
4344       tmp = build_call_expr_loc (input_location,
4345                              gfor_fndecl_set_record_marker, 1,
4346                              build_int_cst (integer_type_node,
4347                                             gfc_option.record_marker));
4348       gfc_add_expr_to_block (&body, tmp);
4349     }
4350
4351   if (gfc_option.max_subrecord_length != 0)
4352     {
4353       tmp = build_call_expr_loc (input_location,
4354                              gfor_fndecl_set_max_subrecord_length, 1,
4355                              build_int_cst (integer_type_node,
4356                                             gfc_option.max_subrecord_length));
4357       gfc_add_expr_to_block (&body, tmp);
4358     }
4359
4360   /* Call MAIN__().  */
4361   tmp = build_call_expr_loc (input_location,
4362                          fndecl, 0);
4363   gfc_add_expr_to_block (&body, tmp);
4364
4365   /* Mark MAIN__ as used.  */
4366   TREE_USED (fndecl) = 1;
4367
4368   /* "return 0".  */
4369   tmp = fold_build2_loc (input_location, MODIFY_EXPR, integer_type_node,
4370                          DECL_RESULT (ftn_main),
4371                          build_int_cst (integer_type_node, 0));
4372   tmp = build1_v (RETURN_EXPR, tmp);
4373   gfc_add_expr_to_block (&body, tmp);
4374
4375
4376   DECL_SAVED_TREE (ftn_main) = gfc_finish_block (&body);
4377   decl = getdecls ();
4378
4379   /* Finish off this function and send it for code generation.  */
4380   poplevel (1, 0, 1);
4381   BLOCK_SUPERCONTEXT (DECL_INITIAL (ftn_main)) = ftn_main;
4382
4383   DECL_SAVED_TREE (ftn_main)
4384     = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (ftn_main),
4385                 DECL_INITIAL (ftn_main));
4386
4387   /* Output the GENERIC tree.  */
4388   dump_function (TDI_original, ftn_main);
4389
4390   cgraph_finalize_function (ftn_main, true);
4391
4392   if (old_context)
4393     {
4394       pop_function_context ();
4395       saved_function_decls = saved_parent_function_decls;
4396     }
4397   current_function_decl = old_context;
4398 }
4399
4400
4401 /* Get the result expression for a procedure.  */
4402
4403 static tree
4404 get_proc_result (gfc_symbol* sym)
4405 {
4406   if (sym->attr.subroutine || sym == sym->result)
4407     {
4408       if (current_fake_result_decl != NULL)
4409         return TREE_VALUE (current_fake_result_decl);
4410
4411       return NULL_TREE;
4412     }
4413
4414   return sym->result->backend_decl;
4415 }
4416
4417
4418 /* Generate an appropriate return-statement for a procedure.  */
4419
4420 tree
4421 gfc_generate_return (void)
4422 {
4423   gfc_symbol* sym;
4424   tree result;
4425   tree fndecl;
4426
4427   sym = current_procedure_symbol;
4428   fndecl = sym->backend_decl;
4429
4430   if (TREE_TYPE (DECL_RESULT (fndecl)) == void_type_node)
4431     result = NULL_TREE;
4432   else
4433     {
4434       result = get_proc_result (sym);
4435
4436       /* Set the return value to the dummy result variable.  The
4437          types may be different for scalar default REAL functions
4438          with -ff2c, therefore we have to convert.  */
4439       if (result != NULL_TREE)
4440         {
4441           result = convert (TREE_TYPE (DECL_RESULT (fndecl)), result);
4442           result = fold_build2_loc (input_location, MODIFY_EXPR,
4443                                     TREE_TYPE (result), DECL_RESULT (fndecl),
4444                                     result);
4445         }
4446     }
4447
4448   return build1_v (RETURN_EXPR, result);
4449 }
4450
4451
4452 /* Generate code for a function.  */
4453
4454 void
4455 gfc_generate_function_code (gfc_namespace * ns)
4456 {
4457   tree fndecl;
4458   tree old_context;
4459   tree decl;
4460   tree tmp;
4461   stmtblock_t init, cleanup;
4462   stmtblock_t body;
4463   gfc_wrapped_block try_block;
4464   tree recurcheckvar = NULL_TREE;
4465   gfc_symbol *sym;
4466   gfc_symbol *previous_procedure_symbol;
4467   int rank;
4468   bool is_recursive;
4469
4470   sym = ns->proc_name;
4471   previous_procedure_symbol = current_procedure_symbol;
4472   current_procedure_symbol = sym;
4473
4474   /* Check that the frontend isn't still using this.  */
4475   gcc_assert (sym->tlink == NULL);
4476   sym->tlink = sym;
4477
4478   /* Create the declaration for functions with global scope.  */
4479   if (!sym->backend_decl)
4480     gfc_create_function_decl (ns, false);
4481
4482   fndecl = sym->backend_decl;
4483   old_context = current_function_decl;
4484
4485   if (old_context)
4486     {
4487       push_function_context ();
4488       saved_parent_function_decls = saved_function_decls;
4489       saved_function_decls = NULL_TREE;
4490     }
4491
4492   trans_function_start (sym);
4493
4494   gfc_init_block (&init);
4495
4496   if (ns->entries && ns->proc_name->ts.type == BT_CHARACTER)
4497     {
4498       /* Copy length backend_decls to all entry point result
4499          symbols.  */
4500       gfc_entry_list *el;
4501       tree backend_decl;
4502
4503       gfc_conv_const_charlen (ns->proc_name->ts.u.cl);
4504       backend_decl = ns->proc_name->result->ts.u.cl->backend_decl;
4505       for (el = ns->entries; el; el = el->next)
4506         el->sym->result->ts.u.cl->backend_decl = backend_decl;
4507     }
4508
4509   /* Translate COMMON blocks.  */
4510   gfc_trans_common (ns);
4511
4512   /* Null the parent fake result declaration if this namespace is
4513      a module function or an external procedures.  */
4514   if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
4515         || ns->parent == NULL)
4516     parent_fake_result_decl = NULL_TREE;
4517
4518   gfc_generate_contained_functions (ns);
4519
4520   nonlocal_dummy_decls = NULL;
4521   nonlocal_dummy_decl_pset = NULL;
4522
4523   generate_local_vars (ns);
4524
4525   /* Keep the parent fake result declaration in module functions
4526      or external procedures.  */
4527   if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
4528         || ns->parent == NULL)
4529     current_fake_result_decl = parent_fake_result_decl;
4530   else
4531     current_fake_result_decl = NULL_TREE;
4532
4533   is_recursive = sym->attr.recursive
4534                  || (sym->attr.entry_master
4535                      && sym->ns->entries->sym->attr.recursive);
4536   if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION)
4537         && !is_recursive
4538         && !gfc_option.flag_recursive)
4539     {
4540       char * msg;
4541
4542       asprintf (&msg, "Recursive call to nonrecursive procedure '%s'",
4543                 sym->name);
4544       recurcheckvar = gfc_create_var (boolean_type_node, "is_recursive");
4545       TREE_STATIC (recurcheckvar) = 1;
4546       DECL_INITIAL (recurcheckvar) = boolean_false_node;
4547       gfc_add_expr_to_block (&init, recurcheckvar);
4548       gfc_trans_runtime_check (true, false, recurcheckvar, &init,
4549                                &sym->declared_at, msg);
4550       gfc_add_modify (&init, recurcheckvar, boolean_true_node);
4551       gfc_free (msg);
4552     }
4553
4554   /* Now generate the code for the body of this function.  */
4555   gfc_init_block (&body);
4556
4557   if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node
4558         && sym->attr.subroutine)
4559     {
4560       tree alternate_return;
4561       alternate_return = gfc_get_fake_result_decl (sym, 0);
4562       gfc_add_modify (&body, alternate_return, integer_zero_node);
4563     }
4564
4565   if (ns->entries)
4566     {
4567       /* Jump to the correct entry point.  */
4568       tmp = gfc_trans_entry_master_switch (ns->entries);
4569       gfc_add_expr_to_block (&body, tmp);
4570     }
4571
4572   /* If bounds-checking is enabled, generate code to check passed in actual
4573      arguments against the expected dummy argument attributes (e.g. string
4574      lengths).  */
4575   if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) && !sym->attr.is_bind_c)
4576     add_argument_checking (&body, sym);
4577
4578   tmp = gfc_trans_code (ns->code);
4579   gfc_add_expr_to_block (&body, tmp);
4580
4581   if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node)
4582     {
4583       tree result = get_proc_result (sym);
4584
4585       if (result != NULL_TREE
4586             && sym->attr.function
4587             && !sym->attr.pointer)
4588         {
4589           if (sym->ts.type == BT_DERIVED
4590               && sym->ts.u.derived->attr.alloc_comp)
4591             {
4592               rank = sym->as ? sym->as->rank : 0;
4593               tmp = gfc_nullify_alloc_comp (sym->ts.u.derived, result, rank);
4594               gfc_add_expr_to_block (&init, tmp);
4595             }
4596           else if (sym->attr.allocatable && sym->attr.dimension == 0)
4597             gfc_add_modify (&init, result, fold_convert (TREE_TYPE (result),
4598                                                          null_pointer_node));
4599         }
4600
4601       if (result == NULL_TREE)
4602         {
4603           /* TODO: move to the appropriate place in resolve.c.  */
4604           if (warn_return_type && !sym->attr.referenced && sym == sym->result)
4605             gfc_warning ("Return value of function '%s' at %L not set",
4606                          sym->name, &sym->declared_at);
4607
4608           TREE_NO_WARNING(sym->backend_decl) = 1;
4609         }
4610       else
4611         gfc_add_expr_to_block (&body, gfc_generate_return ());
4612     }
4613
4614   gfc_init_block (&cleanup);
4615
4616   /* Reset recursion-check variable.  */
4617   if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION)
4618          && !is_recursive
4619          && !gfc_option.gfc_flag_openmp
4620          && recurcheckvar != NULL_TREE)
4621     {
4622       gfc_add_modify (&cleanup, recurcheckvar, boolean_false_node);
4623       recurcheckvar = NULL;
4624     }
4625
4626   /* Finish the function body and add init and cleanup code.  */
4627   tmp = gfc_finish_block (&body);
4628   gfc_start_wrapped_block (&try_block, tmp);
4629   /* Add code to create and cleanup arrays.  */
4630   gfc_trans_deferred_vars (sym, &try_block);
4631   gfc_add_init_cleanup (&try_block, gfc_finish_block (&init),
4632                         gfc_finish_block (&cleanup));
4633
4634   /* Add all the decls we created during processing.  */
4635   decl = saved_function_decls;
4636   while (decl)
4637     {
4638       tree next;
4639
4640       next = DECL_CHAIN (decl);
4641       DECL_CHAIN (decl) = NULL_TREE;
4642       pushdecl (decl);
4643       decl = next;
4644     }
4645   saved_function_decls = NULL_TREE;
4646
4647   DECL_SAVED_TREE (fndecl) = gfc_finish_wrapped_block (&try_block);
4648   decl = getdecls ();
4649
4650   /* Finish off this function and send it for code generation.  */
4651   poplevel (1, 0, 1);
4652   BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
4653
4654   DECL_SAVED_TREE (fndecl)
4655     = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (fndecl),
4656                 DECL_INITIAL (fndecl));
4657
4658   if (nonlocal_dummy_decls)
4659     {
4660       BLOCK_VARS (DECL_INITIAL (fndecl))
4661         = chainon (BLOCK_VARS (DECL_INITIAL (fndecl)), nonlocal_dummy_decls);
4662       pointer_set_destroy (nonlocal_dummy_decl_pset);
4663       nonlocal_dummy_decls = NULL;
4664       nonlocal_dummy_decl_pset = NULL;
4665     }
4666
4667   /* Output the GENERIC tree.  */
4668   dump_function (TDI_original, fndecl);
4669
4670   /* Store the end of the function, so that we get good line number
4671      info for the epilogue.  */
4672   cfun->function_end_locus = input_location;
4673
4674   /* We're leaving the context of this function, so zap cfun.
4675      It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
4676      tree_rest_of_compilation.  */
4677   set_cfun (NULL);
4678
4679   if (old_context)
4680     {
4681       pop_function_context ();
4682       saved_function_decls = saved_parent_function_decls;
4683     }
4684   current_function_decl = old_context;
4685
4686   if (decl_function_context (fndecl))
4687     /* Register this function with cgraph just far enough to get it
4688        added to our parent's nested function list.  */
4689     (void) cgraph_node (fndecl);
4690   else
4691     cgraph_finalize_function (fndecl, true);
4692
4693   gfc_trans_use_stmts (ns);
4694   gfc_traverse_ns (ns, gfc_emit_parameter_debug_info);
4695
4696   if (sym->attr.is_main_program)
4697     create_main_function (fndecl);
4698
4699   current_procedure_symbol = previous_procedure_symbol;
4700 }
4701
4702
4703 void
4704 gfc_generate_constructors (void)
4705 {
4706   gcc_assert (gfc_static_ctors == NULL_TREE);
4707 #if 0
4708   tree fnname;
4709   tree type;
4710   tree fndecl;
4711   tree decl;
4712   tree tmp;
4713
4714   if (gfc_static_ctors == NULL_TREE)
4715     return;
4716
4717   fnname = get_file_function_name ("I");
4718   type = build_function_type_list (void_type_node, NULL_TREE);
4719
4720   fndecl = build_decl (input_location,
4721                        FUNCTION_DECL, fnname, type);
4722   TREE_PUBLIC (fndecl) = 1;
4723
4724   decl = build_decl (input_location,
4725                      RESULT_DECL, NULL_TREE, void_type_node);
4726   DECL_ARTIFICIAL (decl) = 1;
4727   DECL_IGNORED_P (decl) = 1;
4728   DECL_CONTEXT (decl) = fndecl;
4729   DECL_RESULT (fndecl) = decl;
4730
4731   pushdecl (fndecl);
4732
4733   current_function_decl = fndecl;
4734
4735   rest_of_decl_compilation (fndecl, 1, 0);
4736
4737   make_decl_rtl (fndecl);
4738
4739   init_function_start (fndecl);
4740
4741   pushlevel (0);
4742
4743   for (; gfc_static_ctors; gfc_static_ctors = TREE_CHAIN (gfc_static_ctors))
4744     {
4745       tmp = build_call_expr_loc (input_location,
4746                              TREE_VALUE (gfc_static_ctors), 0);
4747       DECL_SAVED_TREE (fndecl) = build_stmt (input_location, EXPR_STMT, tmp);
4748     }
4749
4750   decl = getdecls ();
4751   poplevel (1, 0, 1);
4752
4753   BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
4754   DECL_SAVED_TREE (fndecl)
4755     = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (fndecl),
4756                 DECL_INITIAL (fndecl));
4757
4758   free_after_parsing (cfun);
4759   free_after_compilation (cfun);
4760
4761   tree_rest_of_compilation (fndecl);
4762
4763   current_function_decl = NULL_TREE;
4764 #endif
4765 }
4766
4767 /* Translates a BLOCK DATA program unit. This means emitting the
4768    commons contained therein plus their initializations. We also emit
4769    a globally visible symbol to make sure that each BLOCK DATA program
4770    unit remains unique.  */
4771
4772 void
4773 gfc_generate_block_data (gfc_namespace * ns)
4774 {
4775   tree decl;
4776   tree id;
4777
4778   /* Tell the backend the source location of the block data.  */
4779   if (ns->proc_name)
4780     gfc_set_backend_locus (&ns->proc_name->declared_at);
4781   else
4782     gfc_set_backend_locus (&gfc_current_locus);
4783
4784   /* Process the DATA statements.  */
4785   gfc_trans_common (ns);
4786
4787   /* Create a global symbol with the mane of the block data.  This is to
4788      generate linker errors if the same name is used twice.  It is never
4789      really used.  */
4790   if (ns->proc_name)
4791     id = gfc_sym_mangled_function_id (ns->proc_name);
4792   else
4793     id = get_identifier ("__BLOCK_DATA__");
4794
4795   decl = build_decl (input_location,
4796                      VAR_DECL, id, gfc_array_index_type);
4797   TREE_PUBLIC (decl) = 1;
4798   TREE_STATIC (decl) = 1;
4799   DECL_IGNORED_P (decl) = 1;
4800
4801   pushdecl (decl);
4802   rest_of_decl_compilation (decl, 1, 0);
4803 }
4804
4805
4806 /* Process the local variables of a BLOCK construct.  */
4807
4808 void
4809 gfc_process_block_locals (gfc_namespace* ns)
4810 {
4811   tree decl;
4812
4813   gcc_assert (saved_local_decls == NULL_TREE);
4814   generate_local_vars (ns);
4815
4816   decl = saved_local_decls;
4817   while (decl)
4818     {
4819       tree next;
4820
4821       next = DECL_CHAIN (decl);
4822       DECL_CHAIN (decl) = NULL_TREE;
4823       pushdecl (decl);
4824       decl = next;
4825     }
4826   saved_local_decls = NULL_TREE;
4827 }
4828
4829
4830 #include "gt-fortran-trans-decl.h"