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