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 tree
2321 gfc_build_library_function_decl (tree name, tree rettype, int nargs, ...)
2322 {
2323   tree arglist;
2324   tree argtype;
2325   tree fntype;
2326   tree fndecl;
2327   va_list p;
2328   int n;
2329
2330   /* Library functions must be declared with global scope.  */
2331   gcc_assert (current_function_decl == NULL_TREE);
2332
2333   va_start (p, nargs);
2334
2335
2336   /* Create a list of the argument types.  */
2337   for (arglist = NULL_TREE, n = abs (nargs); n > 0; n--)
2338     {
2339       argtype = va_arg (p, tree);
2340       arglist = gfc_chainon_list (arglist, argtype);
2341     }
2342
2343   if (nargs >= 0)
2344     {
2345       /* Terminate the list.  */
2346       arglist = gfc_chainon_list (arglist, void_type_node);
2347     }
2348
2349   /* Build the function type and decl.  */
2350   fntype = build_function_type (rettype, arglist);
2351   fndecl = build_decl (input_location,
2352                        FUNCTION_DECL, name, fntype);
2353
2354   /* Mark this decl as external.  */
2355   DECL_EXTERNAL (fndecl) = 1;
2356   TREE_PUBLIC (fndecl) = 1;
2357
2358   va_end (p);
2359
2360   pushdecl (fndecl);
2361
2362   rest_of_decl_compilation (fndecl, 1, 0);
2363
2364   return fndecl;
2365 }
2366
2367 static void
2368 gfc_build_intrinsic_function_decls (void)
2369 {
2370   tree gfc_int4_type_node = gfc_get_int_type (4);
2371   tree gfc_int8_type_node = gfc_get_int_type (8);
2372   tree gfc_int16_type_node = gfc_get_int_type (16);
2373   tree gfc_logical4_type_node = gfc_get_logical_type (4);
2374   tree pchar1_type_node = gfc_get_pchar_type (1);
2375   tree pchar4_type_node = gfc_get_pchar_type (4);
2376
2377   /* String functions.  */
2378   gfor_fndecl_compare_string =
2379     gfc_build_library_function_decl (get_identifier (PREFIX("compare_string")),
2380                                      integer_type_node, 4,
2381                                      gfc_charlen_type_node, pchar1_type_node,
2382                                      gfc_charlen_type_node, pchar1_type_node);
2383
2384   gfor_fndecl_concat_string =
2385     gfc_build_library_function_decl (get_identifier (PREFIX("concat_string")),
2386                                      void_type_node, 6,
2387                                      gfc_charlen_type_node, pchar1_type_node,
2388                                      gfc_charlen_type_node, pchar1_type_node,
2389                                      gfc_charlen_type_node, pchar1_type_node);
2390
2391   gfor_fndecl_string_len_trim =
2392     gfc_build_library_function_decl (get_identifier (PREFIX("string_len_trim")),
2393                                      gfc_int4_type_node, 2,
2394                                      gfc_charlen_type_node, pchar1_type_node);
2395
2396   gfor_fndecl_string_index =
2397     gfc_build_library_function_decl (get_identifier (PREFIX("string_index")),
2398                                      gfc_int4_type_node, 5,
2399                                      gfc_charlen_type_node, pchar1_type_node,
2400                                      gfc_charlen_type_node, pchar1_type_node,
2401                                      gfc_logical4_type_node);
2402
2403   gfor_fndecl_string_scan =
2404     gfc_build_library_function_decl (get_identifier (PREFIX("string_scan")),
2405                                      gfc_int4_type_node, 5,
2406                                      gfc_charlen_type_node, pchar1_type_node,
2407                                      gfc_charlen_type_node, pchar1_type_node,
2408                                      gfc_logical4_type_node);
2409
2410   gfor_fndecl_string_verify =
2411     gfc_build_library_function_decl (get_identifier (PREFIX("string_verify")),
2412                                      gfc_int4_type_node, 5,
2413                                      gfc_charlen_type_node, pchar1_type_node,
2414                                      gfc_charlen_type_node, pchar1_type_node,
2415                                      gfc_logical4_type_node);
2416
2417   gfor_fndecl_string_trim =
2418     gfc_build_library_function_decl (get_identifier (PREFIX("string_trim")),
2419                                      void_type_node, 4,
2420                                      build_pointer_type (gfc_charlen_type_node),
2421                                      build_pointer_type (pchar1_type_node),
2422                                      gfc_charlen_type_node, pchar1_type_node);
2423
2424   gfor_fndecl_string_minmax =
2425     gfc_build_library_function_decl (get_identifier (PREFIX("string_minmax")),
2426                                      void_type_node, -4,
2427                                      build_pointer_type (gfc_charlen_type_node),
2428                                      build_pointer_type (pchar1_type_node),
2429                                      integer_type_node, integer_type_node);
2430
2431   gfor_fndecl_adjustl =
2432     gfc_build_library_function_decl (get_identifier (PREFIX("adjustl")),
2433                                      void_type_node, 3, pchar1_type_node,
2434                                      gfc_charlen_type_node, pchar1_type_node);
2435
2436   gfor_fndecl_adjustr =
2437     gfc_build_library_function_decl (get_identifier (PREFIX("adjustr")),
2438                                      void_type_node, 3, pchar1_type_node,
2439                                      gfc_charlen_type_node, pchar1_type_node);
2440
2441   gfor_fndecl_select_string =
2442     gfc_build_library_function_decl (get_identifier (PREFIX("select_string")),
2443                                      integer_type_node, 4, pvoid_type_node,
2444                                      integer_type_node, pchar1_type_node,
2445                                      gfc_charlen_type_node);
2446
2447   gfor_fndecl_compare_string_char4 =
2448     gfc_build_library_function_decl (get_identifier
2449                                         (PREFIX("compare_string_char4")),
2450                                      integer_type_node, 4,
2451                                      gfc_charlen_type_node, pchar4_type_node,
2452                                      gfc_charlen_type_node, pchar4_type_node);
2453
2454   gfor_fndecl_concat_string_char4 =
2455     gfc_build_library_function_decl (get_identifier
2456                                         (PREFIX("concat_string_char4")),
2457                                      void_type_node, 6,
2458                                      gfc_charlen_type_node, pchar4_type_node,
2459                                      gfc_charlen_type_node, pchar4_type_node,
2460                                      gfc_charlen_type_node, pchar4_type_node);
2461
2462   gfor_fndecl_string_len_trim_char4 =
2463     gfc_build_library_function_decl (get_identifier
2464                                         (PREFIX("string_len_trim_char4")),
2465                                      gfc_charlen_type_node, 2,
2466                                      gfc_charlen_type_node, pchar4_type_node);
2467
2468   gfor_fndecl_string_index_char4 =
2469     gfc_build_library_function_decl (get_identifier
2470                                         (PREFIX("string_index_char4")),
2471                                      gfc_charlen_type_node, 5,
2472                                      gfc_charlen_type_node, pchar4_type_node,
2473                                      gfc_charlen_type_node, pchar4_type_node,
2474                                      gfc_logical4_type_node);
2475
2476   gfor_fndecl_string_scan_char4 =
2477     gfc_build_library_function_decl (get_identifier
2478                                         (PREFIX("string_scan_char4")),
2479                                      gfc_charlen_type_node, 5,
2480                                      gfc_charlen_type_node, pchar4_type_node,
2481                                      gfc_charlen_type_node, pchar4_type_node,
2482                                      gfc_logical4_type_node);
2483
2484   gfor_fndecl_string_verify_char4 =
2485     gfc_build_library_function_decl (get_identifier
2486                                         (PREFIX("string_verify_char4")),
2487                                      gfc_charlen_type_node, 5,
2488                                      gfc_charlen_type_node, pchar4_type_node,
2489                                      gfc_charlen_type_node, pchar4_type_node,
2490                                      gfc_logical4_type_node);
2491
2492   gfor_fndecl_string_trim_char4 =
2493     gfc_build_library_function_decl (get_identifier
2494                                         (PREFIX("string_trim_char4")),
2495                                      void_type_node, 4,
2496                                      build_pointer_type (gfc_charlen_type_node),
2497                                      build_pointer_type (pchar4_type_node),
2498                                      gfc_charlen_type_node, pchar4_type_node);
2499
2500   gfor_fndecl_string_minmax_char4 =
2501     gfc_build_library_function_decl (get_identifier
2502                                         (PREFIX("string_minmax_char4")),
2503                                      void_type_node, -4,
2504                                      build_pointer_type (gfc_charlen_type_node),
2505                                      build_pointer_type (pchar4_type_node),
2506                                      integer_type_node, integer_type_node);
2507
2508   gfor_fndecl_adjustl_char4 =
2509     gfc_build_library_function_decl (get_identifier (PREFIX("adjustl_char4")),
2510                                      void_type_node, 3, pchar4_type_node,
2511                                      gfc_charlen_type_node, pchar4_type_node);
2512
2513   gfor_fndecl_adjustr_char4 =
2514     gfc_build_library_function_decl (get_identifier (PREFIX("adjustr_char4")),
2515                                      void_type_node, 3, pchar4_type_node,
2516                                      gfc_charlen_type_node, pchar4_type_node);
2517
2518   gfor_fndecl_select_string_char4 =
2519     gfc_build_library_function_decl (get_identifier
2520                                         (PREFIX("select_string_char4")),
2521                                      integer_type_node, 4, pvoid_type_node,
2522                                      integer_type_node, pvoid_type_node,
2523                                      gfc_charlen_type_node);
2524
2525
2526   /* Conversion between character kinds.  */
2527
2528   gfor_fndecl_convert_char1_to_char4 =
2529     gfc_build_library_function_decl (get_identifier
2530                                         (PREFIX("convert_char1_to_char4")),
2531                                      void_type_node, 3,
2532                                      build_pointer_type (pchar4_type_node),
2533                                      gfc_charlen_type_node, pchar1_type_node);
2534
2535   gfor_fndecl_convert_char4_to_char1 =
2536     gfc_build_library_function_decl (get_identifier
2537                                         (PREFIX("convert_char4_to_char1")),
2538                                      void_type_node, 3,
2539                                      build_pointer_type (pchar1_type_node),
2540                                      gfc_charlen_type_node, pchar4_type_node);
2541
2542   /* Misc. functions.  */
2543
2544   gfor_fndecl_ttynam =
2545     gfc_build_library_function_decl (get_identifier (PREFIX("ttynam")),
2546                                      void_type_node,
2547                                      3,
2548                                      pchar_type_node,
2549                                      gfc_charlen_type_node,
2550                                      integer_type_node);
2551
2552   gfor_fndecl_fdate =
2553     gfc_build_library_function_decl (get_identifier (PREFIX("fdate")),
2554                                      void_type_node,
2555                                      2,
2556                                      pchar_type_node,
2557                                      gfc_charlen_type_node);
2558
2559   gfor_fndecl_ctime =
2560     gfc_build_library_function_decl (get_identifier (PREFIX("ctime")),
2561                                      void_type_node,
2562                                      3,
2563                                      pchar_type_node,
2564                                      gfc_charlen_type_node,
2565                                      gfc_int8_type_node);
2566
2567   gfor_fndecl_sc_kind =
2568     gfc_build_library_function_decl (get_identifier
2569                                         (PREFIX("selected_char_kind")),
2570                                      gfc_int4_type_node, 2,
2571                                      gfc_charlen_type_node, pchar_type_node);
2572
2573   gfor_fndecl_si_kind =
2574     gfc_build_library_function_decl (get_identifier
2575                                         (PREFIX("selected_int_kind")),
2576                                      gfc_int4_type_node, 1, pvoid_type_node);
2577
2578   gfor_fndecl_sr_kind =
2579     gfc_build_library_function_decl (get_identifier
2580                                         (PREFIX("selected_real_kind")),
2581                                      gfc_int4_type_node, 2,
2582                                      pvoid_type_node, pvoid_type_node);
2583
2584   /* Power functions.  */
2585   {
2586     tree ctype, rtype, itype, jtype;
2587     int rkind, ikind, jkind;
2588 #define NIKINDS 3
2589 #define NRKINDS 4
2590     static int ikinds[NIKINDS] = {4, 8, 16};
2591     static int rkinds[NRKINDS] = {4, 8, 10, 16};
2592     char name[PREFIX_LEN + 12]; /* _gfortran_pow_?n_?n */
2593
2594     for (ikind=0; ikind < NIKINDS; ikind++)
2595       {
2596         itype = gfc_get_int_type (ikinds[ikind]);
2597
2598         for (jkind=0; jkind < NIKINDS; jkind++)
2599           {
2600             jtype = gfc_get_int_type (ikinds[jkind]);
2601             if (itype && jtype)
2602               {
2603                 sprintf(name, PREFIX("pow_i%d_i%d"), ikinds[ikind],
2604                         ikinds[jkind]);
2605                 gfor_fndecl_math_powi[jkind][ikind].integer =
2606                   gfc_build_library_function_decl (get_identifier (name),
2607                     jtype, 2, jtype, itype);
2608                 TREE_READONLY (gfor_fndecl_math_powi[jkind][ikind].integer) = 1;
2609               }
2610           }
2611
2612         for (rkind = 0; rkind < NRKINDS; rkind ++)
2613           {
2614             rtype = gfc_get_real_type (rkinds[rkind]);
2615             if (rtype && itype)
2616               {
2617                 sprintf(name, PREFIX("pow_r%d_i%d"), rkinds[rkind],
2618                         ikinds[ikind]);
2619                 gfor_fndecl_math_powi[rkind][ikind].real =
2620                   gfc_build_library_function_decl (get_identifier (name),
2621                     rtype, 2, rtype, itype);
2622                 TREE_READONLY (gfor_fndecl_math_powi[rkind][ikind].real) = 1;
2623               }
2624
2625             ctype = gfc_get_complex_type (rkinds[rkind]);
2626             if (ctype && itype)
2627               {
2628                 sprintf(name, PREFIX("pow_c%d_i%d"), rkinds[rkind],
2629                         ikinds[ikind]);
2630                 gfor_fndecl_math_powi[rkind][ikind].cmplx =
2631                   gfc_build_library_function_decl (get_identifier (name),
2632                     ctype, 2,ctype, itype);
2633                 TREE_READONLY (gfor_fndecl_math_powi[rkind][ikind].cmplx) = 1;
2634               }
2635           }
2636       }
2637 #undef NIKINDS
2638 #undef NRKINDS
2639   }
2640
2641   gfor_fndecl_math_ishftc4 =
2642     gfc_build_library_function_decl (get_identifier (PREFIX("ishftc4")),
2643                                      gfc_int4_type_node,
2644                                      3, gfc_int4_type_node,
2645                                      gfc_int4_type_node, gfc_int4_type_node);
2646   gfor_fndecl_math_ishftc8 =
2647     gfc_build_library_function_decl (get_identifier (PREFIX("ishftc8")),
2648                                      gfc_int8_type_node,
2649                                      3, gfc_int8_type_node,
2650                                      gfc_int4_type_node, gfc_int4_type_node);
2651   if (gfc_int16_type_node)
2652     gfor_fndecl_math_ishftc16 =
2653       gfc_build_library_function_decl (get_identifier (PREFIX("ishftc16")),
2654                                        gfc_int16_type_node, 3,
2655                                        gfc_int16_type_node,
2656                                        gfc_int4_type_node,
2657                                        gfc_int4_type_node);
2658
2659   /* BLAS functions.  */
2660   {
2661     tree pint = build_pointer_type (integer_type_node);
2662     tree ps = build_pointer_type (gfc_get_real_type (gfc_default_real_kind));
2663     tree pd = build_pointer_type (gfc_get_real_type (gfc_default_double_kind));
2664     tree pc = build_pointer_type (gfc_get_complex_type (gfc_default_real_kind));
2665     tree pz = build_pointer_type
2666                 (gfc_get_complex_type (gfc_default_double_kind));
2667
2668     gfor_fndecl_sgemm = gfc_build_library_function_decl
2669                           (get_identifier
2670                              (gfc_option.flag_underscoring ? "sgemm_"
2671                                                            : "sgemm"),
2672                            void_type_node, 15, pchar_type_node,
2673                            pchar_type_node, pint, pint, pint, ps, ps, pint,
2674                            ps, pint, ps, ps, pint, integer_type_node,
2675                            integer_type_node);
2676     gfor_fndecl_dgemm = gfc_build_library_function_decl
2677                           (get_identifier
2678                              (gfc_option.flag_underscoring ? "dgemm_"
2679                                                            : "dgemm"),
2680                            void_type_node, 15, pchar_type_node,
2681                            pchar_type_node, pint, pint, pint, pd, pd, pint,
2682                            pd, pint, pd, pd, pint, integer_type_node,
2683                            integer_type_node);
2684     gfor_fndecl_cgemm = gfc_build_library_function_decl
2685                           (get_identifier
2686                              (gfc_option.flag_underscoring ? "cgemm_"
2687                                                            : "cgemm"),
2688                            void_type_node, 15, pchar_type_node,
2689                            pchar_type_node, pint, pint, pint, pc, pc, pint,
2690                            pc, pint, pc, pc, pint, integer_type_node,
2691                            integer_type_node);
2692     gfor_fndecl_zgemm = gfc_build_library_function_decl
2693                           (get_identifier
2694                              (gfc_option.flag_underscoring ? "zgemm_"
2695                                                            : "zgemm"),
2696                            void_type_node, 15, pchar_type_node,
2697                            pchar_type_node, pint, pint, pint, pz, pz, pint,
2698                            pz, pint, pz, pz, pint, integer_type_node,
2699                            integer_type_node);
2700   }
2701
2702   /* Other functions.  */
2703   gfor_fndecl_size0 =
2704     gfc_build_library_function_decl (get_identifier (PREFIX("size0")),
2705                                      gfc_array_index_type,
2706                                      1, pvoid_type_node);
2707   gfor_fndecl_size1 =
2708     gfc_build_library_function_decl (get_identifier (PREFIX("size1")),
2709                                      gfc_array_index_type,
2710                                      2, pvoid_type_node,
2711                                      gfc_array_index_type);
2712
2713   gfor_fndecl_iargc =
2714     gfc_build_library_function_decl (get_identifier (PREFIX ("iargc")),
2715                                      gfc_int4_type_node,
2716                                      0);
2717
2718   if (gfc_type_for_size (128, true))
2719     {
2720       tree uint128 = gfc_type_for_size (128, true);
2721
2722       gfor_fndecl_clz128 =
2723         gfc_build_library_function_decl (get_identifier (PREFIX ("clz128")),
2724                                          integer_type_node, 1, uint128);
2725
2726       gfor_fndecl_ctz128 =
2727         gfc_build_library_function_decl (get_identifier (PREFIX ("ctz128")),
2728                                          integer_type_node, 1, uint128);
2729     }
2730 }
2731
2732
2733 /* Make prototypes for runtime library functions.  */
2734
2735 void
2736 gfc_build_builtin_function_decls (void)
2737 {
2738   tree gfc_int4_type_node = gfc_get_int_type (4);
2739
2740   gfor_fndecl_stop_numeric =
2741     gfc_build_library_function_decl (get_identifier (PREFIX("stop_numeric")),
2742                                      void_type_node, 1, gfc_int4_type_node);
2743   /* Stop doesn't return.  */
2744   TREE_THIS_VOLATILE (gfor_fndecl_stop_numeric) = 1;
2745
2746   gfor_fndecl_stop_string =
2747     gfc_build_library_function_decl (get_identifier (PREFIX("stop_string")),
2748                                      void_type_node, 2, pchar_type_node,
2749                                      gfc_int4_type_node);
2750   /* Stop doesn't return.  */
2751   TREE_THIS_VOLATILE (gfor_fndecl_stop_string) = 1;
2752
2753   gfor_fndecl_error_stop_string =
2754     gfc_build_library_function_decl (get_identifier (PREFIX("error_stop_string")),
2755                                      void_type_node, 2, pchar_type_node,
2756                                      gfc_int4_type_node);
2757   /* ERROR STOP doesn't return.  */
2758   TREE_THIS_VOLATILE (gfor_fndecl_error_stop_string) = 1;
2759
2760   gfor_fndecl_pause_numeric =
2761     gfc_build_library_function_decl (get_identifier (PREFIX("pause_numeric")),
2762                                      void_type_node, 1, gfc_int4_type_node);
2763
2764   gfor_fndecl_pause_string =
2765     gfc_build_library_function_decl (get_identifier (PREFIX("pause_string")),
2766                                      void_type_node, 2, pchar_type_node,
2767                                      gfc_int4_type_node);
2768
2769   gfor_fndecl_runtime_error =
2770     gfc_build_library_function_decl (get_identifier (PREFIX("runtime_error")),
2771                                      void_type_node, -1, pchar_type_node);
2772   /* The runtime_error function does not return.  */
2773   TREE_THIS_VOLATILE (gfor_fndecl_runtime_error) = 1;
2774
2775   gfor_fndecl_runtime_error_at =
2776     gfc_build_library_function_decl (get_identifier (PREFIX("runtime_error_at")),
2777                                      void_type_node, -2, pchar_type_node,
2778                                      pchar_type_node);
2779   /* The runtime_error_at function does not return.  */
2780   TREE_THIS_VOLATILE (gfor_fndecl_runtime_error_at) = 1;
2781
2782   gfor_fndecl_runtime_warning_at =
2783     gfc_build_library_function_decl (get_identifier (PREFIX("runtime_warning_at")),
2784                                      void_type_node, -2, pchar_type_node,
2785                                      pchar_type_node);
2786   gfor_fndecl_generate_error =
2787     gfc_build_library_function_decl (get_identifier (PREFIX("generate_error")),
2788                                      void_type_node, 3, pvoid_type_node,
2789                                      integer_type_node, pchar_type_node);
2790
2791   gfor_fndecl_os_error =
2792     gfc_build_library_function_decl (get_identifier (PREFIX("os_error")),
2793                                      void_type_node, 1, pchar_type_node);
2794   /* The runtime_error function does not return.  */
2795   TREE_THIS_VOLATILE (gfor_fndecl_os_error) = 1;
2796
2797   gfor_fndecl_set_args =
2798     gfc_build_library_function_decl (get_identifier (PREFIX("set_args")),
2799                                      void_type_node, 2, integer_type_node,
2800                                      build_pointer_type (pchar_type_node));
2801
2802   gfor_fndecl_set_fpe =
2803     gfc_build_library_function_decl (get_identifier (PREFIX("set_fpe")),
2804                                     void_type_node, 1, integer_type_node);
2805
2806   /* Keep the array dimension in sync with the call, later in this file.  */
2807   gfor_fndecl_set_options =
2808     gfc_build_library_function_decl (get_identifier (PREFIX("set_options")),
2809                                     void_type_node, 2, integer_type_node,
2810                                     build_pointer_type (integer_type_node));
2811
2812   gfor_fndecl_set_convert =
2813     gfc_build_library_function_decl (get_identifier (PREFIX("set_convert")),
2814                                      void_type_node, 1, integer_type_node);
2815
2816   gfor_fndecl_set_record_marker =
2817     gfc_build_library_function_decl (get_identifier (PREFIX("set_record_marker")),
2818                                      void_type_node, 1, integer_type_node);
2819
2820   gfor_fndecl_set_max_subrecord_length =
2821     gfc_build_library_function_decl (get_identifier (PREFIX("set_max_subrecord_length")),
2822                                      void_type_node, 1, integer_type_node);
2823
2824   gfor_fndecl_in_pack = gfc_build_library_function_decl (
2825         get_identifier (PREFIX("internal_pack")),
2826         pvoid_type_node, 1, pvoid_type_node);
2827
2828   gfor_fndecl_in_unpack = gfc_build_library_function_decl (
2829         get_identifier (PREFIX("internal_unpack")),
2830         void_type_node, 2, pvoid_type_node, pvoid_type_node);
2831
2832   gfor_fndecl_associated =
2833     gfc_build_library_function_decl (
2834                                      get_identifier (PREFIX("associated")),
2835                                      integer_type_node, 2, ppvoid_type_node,
2836                                      ppvoid_type_node);
2837
2838   gfc_build_intrinsic_function_decls ();
2839   gfc_build_intrinsic_lib_fndecls ();
2840   gfc_build_io_library_fndecls ();
2841 }
2842
2843
2844 /* Evaluate the length of dummy character variables.  */
2845
2846 static tree
2847 gfc_trans_dummy_character (gfc_symbol *sym, gfc_charlen *cl, tree fnbody)
2848 {
2849   stmtblock_t body;
2850
2851   gfc_finish_decl (cl->backend_decl);
2852
2853   gfc_start_block (&body);
2854
2855   /* Evaluate the string length expression.  */
2856   gfc_conv_string_length (cl, NULL, &body);
2857
2858   gfc_trans_vla_type_sizes (sym, &body);
2859
2860   gfc_add_expr_to_block (&body, fnbody);
2861   return gfc_finish_block (&body);
2862 }
2863
2864
2865 /* Allocate and cleanup an automatic character variable.  */
2866
2867 static tree
2868 gfc_trans_auto_character_variable (gfc_symbol * sym, tree fnbody)
2869 {
2870   stmtblock_t body;
2871   tree decl;
2872   tree tmp;
2873
2874   gcc_assert (sym->backend_decl);
2875   gcc_assert (sym->ts.u.cl && sym->ts.u.cl->length);
2876
2877   gfc_start_block (&body);
2878
2879   /* Evaluate the string length expression.  */
2880   gfc_conv_string_length (sym->ts.u.cl, NULL, &body);
2881
2882   gfc_trans_vla_type_sizes (sym, &body);
2883
2884   decl = sym->backend_decl;
2885
2886   /* Emit a DECL_EXPR for this variable, which will cause the
2887      gimplifier to allocate storage, and all that good stuff.  */
2888   tmp = fold_build1 (DECL_EXPR, TREE_TYPE (decl), decl);
2889   gfc_add_expr_to_block (&body, tmp);
2890
2891   gfc_add_expr_to_block (&body, fnbody);
2892   return gfc_finish_block (&body);
2893 }
2894
2895 /* Set the initial value of ASSIGN statement auxiliary variable explicitly.  */
2896
2897 static tree
2898 gfc_trans_assign_aux_var (gfc_symbol * sym, tree fnbody)
2899 {
2900   stmtblock_t body;
2901
2902   gcc_assert (sym->backend_decl);
2903   gfc_start_block (&body);
2904
2905   /* Set the initial value to length. See the comments in
2906      function gfc_add_assign_aux_vars in this file.  */
2907   gfc_add_modify (&body, GFC_DECL_STRING_LEN (sym->backend_decl),
2908                        build_int_cst (NULL_TREE, -2));
2909
2910   gfc_add_expr_to_block (&body, fnbody);
2911   return gfc_finish_block (&body);
2912 }
2913
2914 static void
2915 gfc_trans_vla_one_sizepos (tree *tp, stmtblock_t *body)
2916 {
2917   tree t = *tp, var, val;
2918
2919   if (t == NULL || t == error_mark_node)
2920     return;
2921   if (TREE_CONSTANT (t) || DECL_P (t))
2922     return;
2923
2924   if (TREE_CODE (t) == SAVE_EXPR)
2925     {
2926       if (SAVE_EXPR_RESOLVED_P (t))
2927         {
2928           *tp = TREE_OPERAND (t, 0);
2929           return;
2930         }
2931       val = TREE_OPERAND (t, 0);
2932     }
2933   else
2934     val = t;
2935
2936   var = gfc_create_var_np (TREE_TYPE (t), NULL);
2937   gfc_add_decl_to_function (var);
2938   gfc_add_modify (body, var, val);
2939   if (TREE_CODE (t) == SAVE_EXPR)
2940     TREE_OPERAND (t, 0) = var;
2941   *tp = var;
2942 }
2943
2944 static void
2945 gfc_trans_vla_type_sizes_1 (tree type, stmtblock_t *body)
2946 {
2947   tree t;
2948
2949   if (type == NULL || type == error_mark_node)
2950     return;
2951
2952   type = TYPE_MAIN_VARIANT (type);
2953
2954   if (TREE_CODE (type) == INTEGER_TYPE)
2955     {
2956       gfc_trans_vla_one_sizepos (&TYPE_MIN_VALUE (type), body);
2957       gfc_trans_vla_one_sizepos (&TYPE_MAX_VALUE (type), body);
2958
2959       for (t = TYPE_NEXT_VARIANT (type); t; t = TYPE_NEXT_VARIANT (t))
2960         {
2961           TYPE_MIN_VALUE (t) = TYPE_MIN_VALUE (type);
2962           TYPE_MAX_VALUE (t) = TYPE_MAX_VALUE (type);
2963         }
2964     }
2965   else if (TREE_CODE (type) == ARRAY_TYPE)
2966     {
2967       gfc_trans_vla_type_sizes_1 (TREE_TYPE (type), body);
2968       gfc_trans_vla_type_sizes_1 (TYPE_DOMAIN (type), body);
2969       gfc_trans_vla_one_sizepos (&TYPE_SIZE (type), body);
2970       gfc_trans_vla_one_sizepos (&TYPE_SIZE_UNIT (type), body);
2971
2972       for (t = TYPE_NEXT_VARIANT (type); t; t = TYPE_NEXT_VARIANT (t))
2973         {
2974           TYPE_SIZE (t) = TYPE_SIZE (type);
2975           TYPE_SIZE_UNIT (t) = TYPE_SIZE_UNIT (type);
2976         }
2977     }
2978 }
2979
2980 /* Make sure all type sizes and array domains are either constant,
2981    or variable or parameter decls.  This is a simplified variant
2982    of gimplify_type_sizes, but we can't use it here, as none of the
2983    variables in the expressions have been gimplified yet.
2984    As type sizes and domains for various variable length arrays
2985    contain VAR_DECLs that are only initialized at gfc_trans_deferred_vars
2986    time, without this routine gimplify_type_sizes in the middle-end
2987    could result in the type sizes being gimplified earlier than where
2988    those variables are initialized.  */
2989
2990 void
2991 gfc_trans_vla_type_sizes (gfc_symbol *sym, stmtblock_t *body)
2992 {
2993   tree type = TREE_TYPE (sym->backend_decl);
2994
2995   if (TREE_CODE (type) == FUNCTION_TYPE
2996       && (sym->attr.function || sym->attr.result || sym->attr.entry))
2997     {
2998       if (! current_fake_result_decl)
2999         return;
3000
3001       type = TREE_TYPE (TREE_VALUE (current_fake_result_decl));
3002     }
3003
3004   while (POINTER_TYPE_P (type))
3005     type = TREE_TYPE (type);
3006
3007   if (GFC_DESCRIPTOR_TYPE_P (type))
3008     {
3009       tree etype = GFC_TYPE_ARRAY_DATAPTR_TYPE (type);
3010
3011       while (POINTER_TYPE_P (etype))
3012         etype = TREE_TYPE (etype);
3013
3014       gfc_trans_vla_type_sizes_1 (etype, body);
3015     }
3016
3017   gfc_trans_vla_type_sizes_1 (type, body);
3018 }
3019
3020
3021 /* Initialize a derived type by building an lvalue from the symbol
3022    and using trans_assignment to do the work. Set dealloc to false
3023    if no deallocation prior the assignment is needed.  */
3024 tree
3025 gfc_init_default_dt (gfc_symbol * sym, tree body, bool dealloc)
3026 {
3027   stmtblock_t fnblock;
3028   gfc_expr *e;
3029   tree tmp;
3030   tree present;
3031
3032   gfc_init_block (&fnblock);
3033   gcc_assert (!sym->attr.allocatable);
3034   gfc_set_sym_referenced (sym);
3035   e = gfc_lval_expr_from_sym (sym);
3036   tmp = gfc_trans_assignment (e, sym->value, false, dealloc);
3037   if (sym->attr.dummy && (sym->attr.optional
3038                           || sym->ns->proc_name->attr.entry_master))
3039     {
3040       present = gfc_conv_expr_present (sym);
3041       tmp = build3 (COND_EXPR, TREE_TYPE (tmp), present,
3042                     tmp, build_empty_stmt (input_location));
3043     }
3044   gfc_add_expr_to_block (&fnblock, tmp);
3045   gfc_free_expr (e);
3046   if (body)
3047     gfc_add_expr_to_block (&fnblock, body);
3048   return gfc_finish_block (&fnblock);
3049 }
3050
3051
3052 /* Initialize INTENT(OUT) derived type dummies.  As well as giving
3053    them their default initializer, if they do not have allocatable
3054    components, they have their allocatable components deallocated. */
3055
3056 static tree
3057 init_intent_out_dt (gfc_symbol * proc_sym, tree body)
3058 {
3059   stmtblock_t fnblock;
3060   gfc_formal_arglist *f;
3061   tree tmp;
3062   tree present;
3063
3064   gfc_init_block (&fnblock);
3065   for (f = proc_sym->formal; f; f = f->next)
3066     if (f->sym && f->sym->attr.intent == INTENT_OUT
3067         && !f->sym->attr.pointer
3068         && f->sym->ts.type == BT_DERIVED)
3069       {
3070         if (f->sym->ts.u.derived->attr.alloc_comp && !f->sym->value)
3071           {
3072             tmp = gfc_deallocate_alloc_comp (f->sym->ts.u.derived,
3073                                              f->sym->backend_decl,
3074                                              f->sym->as ? f->sym->as->rank : 0);
3075
3076             if (f->sym->attr.optional
3077                 || f->sym->ns->proc_name->attr.entry_master)
3078               {
3079                 present = gfc_conv_expr_present (f->sym);
3080                 tmp = build3 (COND_EXPR, TREE_TYPE (tmp), present,
3081                               tmp, build_empty_stmt (input_location));
3082               }
3083
3084             gfc_add_expr_to_block (&fnblock, tmp);
3085           }
3086        else if (f->sym->value)
3087           body = gfc_init_default_dt (f->sym, body, true);
3088       }
3089
3090   gfc_add_expr_to_block (&fnblock, body);
3091   return gfc_finish_block (&fnblock);
3092 }
3093
3094
3095 /* Generate function entry and exit code, and add it to the function body.
3096    This includes:
3097     Allocation and initialization of array variables.
3098     Allocation of character string variables.
3099     Initialization and possibly repacking of dummy arrays.
3100     Initialization of ASSIGN statement auxiliary variable.
3101     Automatic deallocation.  */
3102
3103 tree
3104 gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
3105 {
3106   locus loc;
3107   gfc_symbol *sym;
3108   gfc_formal_arglist *f;
3109   stmtblock_t body;
3110   bool seen_trans_deferred_array = false;
3111
3112   /* Deal with implicit return variables.  Explicit return variables will
3113      already have been added.  */
3114   if (gfc_return_by_reference (proc_sym) && proc_sym->result == proc_sym)
3115     {
3116       if (!current_fake_result_decl)
3117         {
3118           gfc_entry_list *el = NULL;
3119           if (proc_sym->attr.entry_master)
3120             {
3121               for (el = proc_sym->ns->entries; el; el = el->next)
3122                 if (el->sym != el->sym->result)
3123                   break;
3124             }
3125           /* TODO: move to the appropriate place in resolve.c.  */
3126           if (warn_return_type && el == NULL)
3127             gfc_warning ("Return value of function '%s' at %L not set",
3128                          proc_sym->name, &proc_sym->declared_at);
3129         }
3130       else if (proc_sym->as)
3131         {
3132           tree result = TREE_VALUE (current_fake_result_decl);
3133           fnbody = gfc_trans_dummy_array_bias (proc_sym, result, fnbody);
3134
3135           /* An automatic character length, pointer array result.  */
3136           if (proc_sym->ts.type == BT_CHARACTER
3137                 && TREE_CODE (proc_sym->ts.u.cl->backend_decl) == VAR_DECL)
3138             fnbody = gfc_trans_dummy_character (proc_sym, proc_sym->ts.u.cl,
3139                                                 fnbody);
3140         }
3141       else if (proc_sym->ts.type == BT_CHARACTER)
3142         {
3143           if (TREE_CODE (proc_sym->ts.u.cl->backend_decl) == VAR_DECL)
3144             fnbody = gfc_trans_dummy_character (proc_sym, proc_sym->ts.u.cl,
3145                                                 fnbody);
3146         }
3147       else
3148         gcc_assert (gfc_option.flag_f2c
3149                     && proc_sym->ts.type == BT_COMPLEX);
3150     }
3151
3152   /* Initialize the INTENT(OUT) derived type dummy arguments.  This
3153      should be done here so that the offsets and lbounds of arrays
3154      are available.  */
3155   fnbody = init_intent_out_dt (proc_sym, fnbody);
3156
3157   for (sym = proc_sym->tlink; sym != proc_sym; sym = sym->tlink)
3158     {
3159       bool sym_has_alloc_comp = (sym->ts.type == BT_DERIVED)
3160                                    && sym->ts.u.derived->attr.alloc_comp;
3161       if (sym->attr.dimension)
3162         {
3163           switch (sym->as->type)
3164             {
3165             case AS_EXPLICIT:
3166               if (sym->attr.dummy || sym->attr.result)
3167                 fnbody =
3168                   gfc_trans_dummy_array_bias (sym, sym->backend_decl, fnbody);
3169               else if (sym->attr.pointer || sym->attr.allocatable)
3170                 {
3171                   if (TREE_STATIC (sym->backend_decl))
3172                     gfc_trans_static_array_pointer (sym);
3173                   else
3174                     {
3175                       seen_trans_deferred_array = true;
3176                       fnbody = gfc_trans_deferred_array (sym, fnbody);
3177                     }
3178                 }
3179               else
3180                 {
3181                   if (sym_has_alloc_comp)
3182                     {
3183                       seen_trans_deferred_array = true;
3184                       fnbody = gfc_trans_deferred_array (sym, fnbody);
3185                     }
3186                   else if (sym->ts.type == BT_DERIVED
3187                              && sym->value
3188                              && !sym->attr.data
3189                              && sym->attr.save == SAVE_NONE)
3190                     fnbody = gfc_init_default_dt (sym, fnbody, false);
3191
3192                   gfc_get_backend_locus (&loc);
3193                   gfc_set_backend_locus (&sym->declared_at);
3194                   fnbody = gfc_trans_auto_array_allocation (sym->backend_decl,
3195                       sym, fnbody);
3196                   gfc_set_backend_locus (&loc);
3197                 }
3198               break;
3199
3200             case AS_ASSUMED_SIZE:
3201               /* Must be a dummy parameter.  */
3202               gcc_assert (sym->attr.dummy || sym->as->cp_was_assumed);
3203
3204               /* We should always pass assumed size arrays the g77 way.  */
3205               if (sym->attr.dummy)
3206                 fnbody = gfc_trans_g77_array (sym, fnbody);
3207               break;
3208
3209             case AS_ASSUMED_SHAPE:
3210               /* Must be a dummy parameter.  */
3211               gcc_assert (sym->attr.dummy);
3212
3213               fnbody = gfc_trans_dummy_array_bias (sym, sym->backend_decl,
3214                                                    fnbody);
3215               break;
3216
3217             case AS_DEFERRED:
3218               seen_trans_deferred_array = true;
3219               fnbody = gfc_trans_deferred_array (sym, fnbody);
3220               break;
3221
3222             default:
3223               gcc_unreachable ();
3224             }
3225           if (sym_has_alloc_comp && !seen_trans_deferred_array)
3226             fnbody = gfc_trans_deferred_array (sym, fnbody);
3227         }
3228       else if (sym_has_alloc_comp)
3229         fnbody = gfc_trans_deferred_array (sym, fnbody);
3230       else if (sym->attr.allocatable
3231                || (sym->ts.type == BT_CLASS
3232                    && sym->ts.u.derived->components->attr.allocatable))
3233         {
3234           if (!sym->attr.save)
3235             {
3236               /* Nullify and automatic deallocation of allocatable
3237                  scalars.  */
3238               tree tmp;
3239               gfc_expr *e;
3240               gfc_se se;
3241               stmtblock_t block;
3242
3243               e = gfc_lval_expr_from_sym (sym);
3244               if (sym->ts.type == BT_CLASS)
3245                 gfc_add_component_ref (e, "$data");
3246
3247               gfc_init_se (&se, NULL);
3248               se.want_pointer = 1;
3249               gfc_conv_expr (&se, e);
3250               gfc_free_expr (e);
3251
3252               /* Nullify when entering the scope.  */
3253               gfc_start_block (&block);
3254               gfc_add_modify (&block, se.expr,
3255                               fold_convert (TREE_TYPE (se.expr),
3256                                             null_pointer_node));
3257               gfc_add_expr_to_block (&block, fnbody);
3258
3259               /* Deallocate when leaving the scope. Nullifying is not
3260                  needed.  */
3261               tmp = gfc_deallocate_with_status (se.expr, NULL_TREE, true,
3262                                                 NULL);
3263               gfc_add_expr_to_block (&block, tmp);
3264               fnbody = gfc_finish_block (&block);
3265             }
3266         }
3267       else if (sym->ts.type == BT_CHARACTER)
3268         {
3269           gfc_get_backend_locus (&loc);
3270           gfc_set_backend_locus (&sym->declared_at);
3271           if (sym->attr.dummy || sym->attr.result)
3272             fnbody = gfc_trans_dummy_character (sym, sym->ts.u.cl, fnbody);
3273           else
3274             fnbody = gfc_trans_auto_character_variable (sym, fnbody);
3275           gfc_set_backend_locus (&loc);
3276         }
3277       else if (sym->attr.assign)
3278         {
3279           gfc_get_backend_locus (&loc);
3280           gfc_set_backend_locus (&sym->declared_at);
3281           fnbody = gfc_trans_assign_aux_var (sym, fnbody);
3282           gfc_set_backend_locus (&loc);
3283         }
3284       else if (sym->ts.type == BT_DERIVED
3285                  && sym->value
3286                  && !sym->attr.data
3287                  && sym->attr.save == SAVE_NONE)
3288         fnbody = gfc_init_default_dt (sym, fnbody, false);
3289       else
3290         gcc_unreachable ();
3291     }
3292
3293   gfc_init_block (&body);
3294
3295   for (f = proc_sym->formal; f; f = f->next)
3296     {
3297       if (f->sym && f->sym->tlink == NULL && f->sym->ts.type == BT_CHARACTER)
3298         {
3299           gcc_assert (f->sym->ts.u.cl->backend_decl != NULL);
3300           if (TREE_CODE (f->sym->ts.u.cl->backend_decl) == PARM_DECL)
3301             gfc_trans_vla_type_sizes (f->sym, &body);
3302         }
3303     }
3304
3305   if (gfc_return_by_reference (proc_sym) && proc_sym->ts.type == BT_CHARACTER
3306       && current_fake_result_decl != NULL)
3307     {
3308       gcc_assert (proc_sym->ts.u.cl->backend_decl != NULL);
3309       if (TREE_CODE (proc_sym->ts.u.cl->backend_decl) == PARM_DECL)
3310         gfc_trans_vla_type_sizes (proc_sym, &body);
3311     }
3312
3313   gfc_add_expr_to_block (&body, fnbody);
3314   return gfc_finish_block (&body);
3315 }
3316
3317 static GTY ((param_is (struct module_htab_entry))) htab_t module_htab;
3318
3319 /* Hash and equality functions for module_htab.  */
3320
3321 static hashval_t
3322 module_htab_do_hash (const void *x)
3323 {
3324   return htab_hash_string (((const struct module_htab_entry *)x)->name);
3325 }
3326
3327 static int
3328 module_htab_eq (const void *x1, const void *x2)
3329 {
3330   return strcmp ((((const struct module_htab_entry *)x1)->name),
3331                  (const char *)x2) == 0;
3332 }
3333
3334 /* Hash and equality functions for module_htab's decls.  */
3335
3336 static hashval_t
3337 module_htab_decls_hash (const void *x)
3338 {
3339   const_tree t = (const_tree) x;
3340   const_tree n = DECL_NAME (t);
3341   if (n == NULL_TREE)
3342     n = TYPE_NAME (TREE_TYPE (t));
3343   return htab_hash_string (IDENTIFIER_POINTER (n));
3344 }
3345
3346 static int
3347 module_htab_decls_eq (const void *x1, const void *x2)
3348 {
3349   const_tree t1 = (const_tree) x1;
3350   const_tree n1 = DECL_NAME (t1);
3351   if (n1 == NULL_TREE)
3352     n1 = TYPE_NAME (TREE_TYPE (t1));
3353   return strcmp (IDENTIFIER_POINTER (n1), (const char *) x2) == 0;
3354 }
3355
3356 struct module_htab_entry *
3357 gfc_find_module (const char *name)
3358 {
3359   void **slot;
3360
3361   if (! module_htab)
3362     module_htab = htab_create_ggc (10, module_htab_do_hash,
3363                                    module_htab_eq, NULL);
3364
3365   slot = htab_find_slot_with_hash (module_htab, name,
3366                                    htab_hash_string (name), INSERT);
3367   if (*slot == NULL)
3368     {
3369       struct module_htab_entry *entry = GGC_CNEW (struct module_htab_entry);
3370
3371       entry->name = gfc_get_string (name);
3372       entry->decls = htab_create_ggc (10, module_htab_decls_hash,
3373                                       module_htab_decls_eq, NULL);
3374       *slot = (void *) entry;
3375     }
3376   return (struct module_htab_entry *) *slot;
3377 }
3378
3379 void
3380 gfc_module_add_decl (struct module_htab_entry *entry, tree decl)
3381 {
3382   void **slot;
3383   const char *name;
3384
3385   if (DECL_NAME (decl))
3386     name = IDENTIFIER_POINTER (DECL_NAME (decl));
3387   else
3388     {
3389       gcc_assert (TREE_CODE (decl) == TYPE_DECL);
3390       name = IDENTIFIER_POINTER (TYPE_NAME (TREE_TYPE (decl)));
3391     }
3392   slot = htab_find_slot_with_hash (entry->decls, name,
3393                                    htab_hash_string (name), INSERT);
3394   if (*slot == NULL)
3395     *slot = (void *) decl;
3396 }
3397
3398 static struct module_htab_entry *cur_module;
3399
3400 /* Output an initialized decl for a module variable.  */
3401
3402 static void
3403 gfc_create_module_variable (gfc_symbol * sym)
3404 {
3405   tree decl;
3406
3407   /* Module functions with alternate entries are dealt with later and
3408      would get caught by the next condition.  */
3409   if (sym->attr.entry)
3410     return;
3411
3412   /* Make sure we convert the types of the derived types from iso_c_binding
3413      into (void *).  */
3414   if (sym->attr.flavor != FL_PROCEDURE && sym->attr.is_iso_c
3415       && sym->ts.type == BT_DERIVED)
3416     sym->backend_decl = gfc_typenode_for_spec (&(sym->ts));
3417
3418   if (sym->attr.flavor == FL_DERIVED
3419       && sym->backend_decl
3420       && TREE_CODE (sym->backend_decl) == RECORD_TYPE)
3421     {
3422       decl = sym->backend_decl;
3423       gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
3424
3425       /* -fwhole-file mixes up the contexts so these asserts are unnecessary.  */
3426       if (!(gfc_option.flag_whole_file && sym->attr.use_assoc))
3427         {
3428           gcc_assert (TYPE_CONTEXT (decl) == NULL_TREE
3429                       || TYPE_CONTEXT (decl) == sym->ns->proc_name->backend_decl);
3430           gcc_assert (DECL_CONTEXT (TYPE_STUB_DECL (decl)) == NULL_TREE
3431                       || DECL_CONTEXT (TYPE_STUB_DECL (decl))
3432                            == sym->ns->proc_name->backend_decl);
3433         }
3434       TYPE_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
3435       DECL_CONTEXT (TYPE_STUB_DECL (decl)) = sym->ns->proc_name->backend_decl;
3436       gfc_module_add_decl (cur_module, TYPE_STUB_DECL (decl));
3437     }
3438
3439   /* Only output variables, procedure pointers and array valued,
3440      or derived type, parameters.  */
3441   if (sym->attr.flavor != FL_VARIABLE
3442         && !(sym->attr.flavor == FL_PARAMETER
3443                && (sym->attr.dimension || sym->ts.type == BT_DERIVED))
3444         && !(sym->attr.flavor == FL_PROCEDURE && sym->attr.proc_pointer))
3445     return;
3446
3447   if ((sym->attr.in_common || sym->attr.in_equivalence) && sym->backend_decl)
3448     {
3449       decl = sym->backend_decl;
3450       gcc_assert (DECL_CONTEXT (decl) == NULL_TREE);
3451       gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
3452       DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
3453       gfc_module_add_decl (cur_module, decl);
3454     }
3455
3456   /* Don't generate variables from other modules. Variables from
3457      COMMONs will already have been generated.  */
3458   if (sym->attr.use_assoc || sym->attr.in_common)
3459     return;
3460
3461   /* Equivalenced variables arrive here after creation.  */
3462   if (sym->backend_decl
3463       && (sym->equiv_built || sym->attr.in_equivalence))
3464     return;
3465
3466   if (sym->backend_decl && !sym->attr.vtab)
3467     internal_error ("backend decl for module variable %s already exists",
3468                     sym->name);
3469
3470   /* We always want module variables to be created.  */
3471   sym->attr.referenced = 1;
3472   /* Create the decl.  */
3473   decl = gfc_get_symbol_decl (sym);
3474
3475   /* Create the variable.  */
3476   pushdecl (decl);
3477   gcc_assert (DECL_CONTEXT (decl) == NULL_TREE);
3478   gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
3479   DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
3480   rest_of_decl_compilation (decl, 1, 0);
3481   gfc_module_add_decl (cur_module, decl);
3482
3483   /* Also add length of strings.  */
3484   if (sym->ts.type == BT_CHARACTER)
3485     {
3486       tree length;
3487
3488       length = sym->ts.u.cl->backend_decl;
3489       gcc_assert (length || sym->attr.proc_pointer);
3490       if (length && !INTEGER_CST_P (length))
3491         {
3492           pushdecl (length);
3493           rest_of_decl_compilation (length, 1, 0);
3494         }
3495     }
3496 }
3497
3498 /* Emit debug information for USE statements.  */
3499
3500 static void
3501 gfc_trans_use_stmts (gfc_namespace * ns)
3502 {
3503   gfc_use_list *use_stmt;
3504   for (use_stmt = ns->use_stmts; use_stmt; use_stmt = use_stmt->next)
3505     {
3506       struct module_htab_entry *entry
3507         = gfc_find_module (use_stmt->module_name);
3508       gfc_use_rename *rent;
3509
3510       if (entry->namespace_decl == NULL)
3511         {
3512           entry->namespace_decl
3513             = build_decl (input_location,
3514                           NAMESPACE_DECL,
3515                           get_identifier (use_stmt->module_name),
3516                           void_type_node);
3517           DECL_EXTERNAL (entry->namespace_decl) = 1;
3518         }
3519       gfc_set_backend_locus (&use_stmt->where);
3520       if (!use_stmt->only_flag)
3521         (*debug_hooks->imported_module_or_decl) (entry->namespace_decl,
3522                                                  NULL_TREE,
3523                                                  ns->proc_name->backend_decl,
3524                                                  false);
3525       for (rent = use_stmt->rename; rent; rent = rent->next)
3526         {
3527           tree decl, local_name;
3528           void **slot;
3529
3530           if (rent->op != INTRINSIC_NONE)
3531             continue;
3532
3533           slot = htab_find_slot_with_hash (entry->decls, rent->use_name,
3534                                            htab_hash_string (rent->use_name),
3535                                            INSERT);
3536           if (*slot == NULL)
3537             {
3538               gfc_symtree *st;
3539
3540               st = gfc_find_symtree (ns->sym_root,
3541                                      rent->local_name[0]
3542                                      ? rent->local_name : rent->use_name);
3543               gcc_assert (st);
3544
3545               /* Sometimes, generic interfaces wind up being over-ruled by a
3546                  local symbol (see PR41062).  */
3547               if (!st->n.sym->attr.use_assoc)
3548                 continue;
3549
3550               if (st->n.sym->backend_decl
3551                   && DECL_P (st->n.sym->backend_decl)
3552                   && st->n.sym->module
3553                   && strcmp (st->n.sym->module, use_stmt->module_name) == 0)
3554                 {
3555                   gcc_assert (DECL_EXTERNAL (entry->namespace_decl)
3556                               || (TREE_CODE (st->n.sym->backend_decl)
3557                                   != VAR_DECL));
3558                   decl = copy_node (st->n.sym->backend_decl);
3559                   DECL_CONTEXT (decl) = entry->namespace_decl;
3560                   DECL_EXTERNAL (decl) = 1;
3561                   DECL_IGNORED_P (decl) = 0;
3562                   DECL_INITIAL (decl) = NULL_TREE;
3563                 }
3564               else
3565                 {
3566                   *slot = error_mark_node;
3567                   htab_clear_slot (entry->decls, slot);
3568                   continue;
3569                 }
3570               *slot = decl;
3571             }
3572           decl = (tree) *slot;
3573           if (rent->local_name[0])
3574             local_name = get_identifier (rent->local_name);
3575           else
3576             local_name = NULL_TREE;
3577           gfc_set_backend_locus (&rent->where);
3578           (*debug_hooks->imported_module_or_decl) (decl, local_name,
3579                                                    ns->proc_name->backend_decl,
3580                                                    !use_stmt->only_flag);
3581         }
3582     }
3583 }
3584
3585
3586 /* Return true if expr is a constant initializer that gfc_conv_initializer
3587    will handle.  */
3588
3589 static bool
3590 check_constant_initializer (gfc_expr *expr, gfc_typespec *ts, bool array,
3591                             bool pointer)
3592 {
3593   gfc_constructor *c;
3594   gfc_component *cm;
3595
3596   if (pointer)
3597     return true;
3598   else if (array)
3599     {
3600       if (expr->expr_type == EXPR_CONSTANT || expr->expr_type == EXPR_NULL)
3601         return true;
3602       else if (expr->expr_type == EXPR_STRUCTURE)
3603         return check_constant_initializer (expr, ts, false, false);
3604       else if (expr->expr_type != EXPR_ARRAY)
3605         return false;
3606       for (c = gfc_constructor_first (expr->value.constructor);
3607            c; c = gfc_constructor_next (c))
3608         {
3609           if (c->iterator)
3610             return false;
3611           if (c->expr->expr_type == EXPR_STRUCTURE)
3612             {
3613               if (!check_constant_initializer (c->expr, ts, false, false))
3614                 return false;
3615             }
3616           else if (c->expr->expr_type != EXPR_CONSTANT)
3617             return false;
3618         }
3619       return true;
3620     }
3621   else switch (ts->type)
3622     {
3623     case BT_DERIVED:
3624       if (expr->expr_type != EXPR_STRUCTURE)
3625         return false;
3626       cm = expr->ts.u.derived->components;
3627       for (c = gfc_constructor_first (expr->value.constructor);
3628            c; c = gfc_constructor_next (c), cm = cm->next)
3629         {
3630           if (!c->expr || cm->attr.allocatable)
3631             continue;
3632           if (!check_constant_initializer (c->expr, &cm->ts,
3633                                            cm->attr.dimension,
3634                                            cm->attr.pointer))
3635             return false;
3636         }
3637       return true;
3638     default:
3639       return expr->expr_type == EXPR_CONSTANT;
3640     }
3641 }
3642
3643 /* Emit debug info for parameters and unreferenced variables with
3644    initializers.  */
3645
3646 static void
3647 gfc_emit_parameter_debug_info (gfc_symbol *sym)
3648 {
3649   tree decl;
3650
3651   if (sym->attr.flavor != FL_PARAMETER
3652       && (sym->attr.flavor != FL_VARIABLE || sym->attr.referenced))
3653     return;
3654
3655   if (sym->backend_decl != NULL
3656       || sym->value == NULL
3657       || sym->attr.use_assoc
3658       || sym->attr.dummy
3659       || sym->attr.result
3660       || sym->attr.function
3661       || sym->attr.intrinsic
3662       || sym->attr.pointer
3663       || sym->attr.allocatable
3664       || sym->attr.cray_pointee
3665       || sym->attr.threadprivate
3666       || sym->attr.is_bind_c
3667       || sym->attr.subref_array_pointer
3668       || sym->attr.assign)
3669     return;
3670
3671   if (sym->ts.type == BT_CHARACTER)
3672     {
3673       gfc_conv_const_charlen (sym->ts.u.cl);
3674       if (sym->ts.u.cl->backend_decl == NULL
3675           || TREE_CODE (sym->ts.u.cl->backend_decl) != INTEGER_CST)
3676         return;
3677     }
3678   else if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.alloc_comp)
3679     return;
3680
3681   if (sym->as)
3682     {
3683       int n;
3684
3685       if (sym->as->type != AS_EXPLICIT)
3686         return;
3687       for (n = 0; n < sym->as->rank; n++)
3688         if (sym->as->lower[n]->expr_type != EXPR_CONSTANT
3689             || sym->as->upper[n] == NULL
3690             || sym->as->upper[n]->expr_type != EXPR_CONSTANT)
3691           return;
3692     }
3693
3694   if (!check_constant_initializer (sym->value, &sym->ts,
3695                                    sym->attr.dimension, false))
3696     return;
3697
3698   /* Create the decl for the variable or constant.  */
3699   decl = build_decl (input_location,
3700                      sym->attr.flavor == FL_PARAMETER ? CONST_DECL : VAR_DECL,
3701                      gfc_sym_identifier (sym), gfc_sym_type (sym));
3702   if (sym->attr.flavor == FL_PARAMETER)
3703     TREE_READONLY (decl) = 1;
3704   gfc_set_decl_location (decl, &sym->declared_at);
3705   if (sym->attr.dimension)
3706     GFC_DECL_PACKED_ARRAY (decl) = 1;
3707   DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
3708   TREE_STATIC (decl) = 1;
3709   TREE_USED (decl) = 1;
3710   if (DECL_CONTEXT (decl) && TREE_CODE (DECL_CONTEXT (decl)) == NAMESPACE_DECL)
3711     TREE_PUBLIC (decl) = 1;
3712   DECL_INITIAL (decl)
3713     = gfc_conv_initializer (sym->value, &sym->ts, TREE_TYPE (decl),
3714                             sym->attr.dimension, 0);
3715   debug_hooks->global_decl (decl);
3716 }
3717
3718 /* Generate all the required code for module variables.  */
3719
3720 void
3721 gfc_generate_module_vars (gfc_namespace * ns)
3722 {
3723   module_namespace = ns;
3724   cur_module = gfc_find_module (ns->proc_name->name);
3725
3726   /* Check if the frontend left the namespace in a reasonable state.  */
3727   gcc_assert (ns->proc_name && !ns->proc_name->tlink);
3728
3729   /* Generate COMMON blocks.  */
3730   gfc_trans_common (ns);
3731
3732   /* Create decls for all the module variables.  */
3733   gfc_traverse_ns (ns, gfc_create_module_variable);
3734
3735   cur_module = NULL;
3736
3737   gfc_trans_use_stmts (ns);
3738   gfc_traverse_ns (ns, gfc_emit_parameter_debug_info);
3739 }
3740
3741
3742 static void
3743 gfc_generate_contained_functions (gfc_namespace * parent)
3744 {
3745   gfc_namespace *ns;
3746
3747   /* We create all the prototypes before generating any code.  */
3748   for (ns = parent->contained; ns; ns = ns->sibling)
3749     {
3750       /* Skip namespaces from used modules.  */
3751       if (ns->parent != parent)
3752         continue;
3753
3754       gfc_create_function_decl (ns);
3755     }
3756
3757   for (ns = parent->contained; ns; ns = ns->sibling)
3758     {
3759       /* Skip namespaces from used modules.  */
3760       if (ns->parent != parent)
3761         continue;
3762
3763       gfc_generate_function_code (ns);
3764     }
3765 }
3766
3767
3768 /* Drill down through expressions for the array specification bounds and
3769    character length calling generate_local_decl for all those variables
3770    that have not already been declared.  */
3771
3772 static void
3773 generate_local_decl (gfc_symbol *);
3774
3775 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced.  */
3776
3777 static bool
3778 expr_decls (gfc_expr *e, gfc_symbol *sym,
3779             int *f ATTRIBUTE_UNUSED)
3780 {
3781   if (e->expr_type != EXPR_VARIABLE
3782             || sym == e->symtree->n.sym
3783             || e->symtree->n.sym->mark
3784             || e->symtree->n.sym->ns != sym->ns)
3785         return false;
3786
3787   generate_local_decl (e->symtree->n.sym);
3788   return false;
3789 }
3790
3791 static void
3792 generate_expr_decls (gfc_symbol *sym, gfc_expr *e)
3793 {
3794   gfc_traverse_expr (e, sym, expr_decls, 0);
3795 }
3796
3797
3798 /* Check for dependencies in the character length and array spec.  */
3799
3800 static void
3801 generate_dependency_declarations (gfc_symbol *sym)
3802 {
3803   int i;
3804
3805   if (sym->ts.type == BT_CHARACTER
3806       && sym->ts.u.cl
3807       && sym->ts.u.cl->length
3808       && sym->ts.u.cl->length->expr_type != EXPR_CONSTANT)
3809     generate_expr_decls (sym, sym->ts.u.cl->length);
3810
3811   if (sym->as && sym->as->rank)
3812     {
3813       for (i = 0; i < sym->as->rank; i++)
3814         {
3815           generate_expr_decls (sym, sym->as->lower[i]);
3816           generate_expr_decls (sym, sym->as->upper[i]);
3817         }
3818     }
3819 }
3820
3821
3822 /* Generate decls for all local variables.  We do this to ensure correct
3823    handling of expressions which only appear in the specification of
3824    other functions.  */
3825
3826 static void
3827 generate_local_decl (gfc_symbol * sym)
3828 {
3829   if (sym->attr.flavor == FL_VARIABLE)
3830     {
3831       if (!sym->attr.dummy && !sym->ns->proc_name->attr.entry_master)
3832         generate_dependency_declarations (sym);
3833
3834       if (sym->attr.referenced)
3835         gfc_get_symbol_decl (sym);
3836       /* INTENT(out) dummy arguments are likely meant to be set.  */
3837       else if (warn_unused_variable
3838                && sym->attr.dummy
3839                && sym->attr.intent == INTENT_OUT)
3840         {
3841           if (!(sym->ts.type == BT_DERIVED
3842                 && sym->ts.u.derived->components->initializer))
3843             gfc_warning ("Dummy argument '%s' at %L was declared INTENT(OUT) "
3844                          "but was not set",  sym->name, &sym->declared_at);
3845         }
3846       /* Specific warning for unused dummy arguments. */
3847       else if (warn_unused_variable && sym->attr.dummy)
3848         gfc_warning ("Unused dummy argument '%s' at %L", sym->name,
3849                      &sym->declared_at);
3850       /* Warn for unused variables, but not if they're inside a common
3851          block or are use-associated.  */
3852       else if (warn_unused_variable
3853                && !(sym->attr.in_common || sym->attr.use_assoc || sym->mark))
3854         gfc_warning ("Unused variable '%s' declared at %L", sym->name,
3855                      &sym->declared_at);
3856
3857       /* For variable length CHARACTER parameters, the PARM_DECL already
3858          references the length variable, so force gfc_get_symbol_decl
3859          even when not referenced.  If optimize > 0, it will be optimized
3860          away anyway.  But do this only after emitting -Wunused-parameter
3861          warning if requested.  */
3862       if (sym->attr.dummy && !sym->attr.referenced
3863             && sym->ts.type == BT_CHARACTER
3864             && sym->ts.u.cl->backend_decl != NULL
3865             && TREE_CODE (sym->ts.u.cl->backend_decl) == VAR_DECL)
3866         {
3867           sym->attr.referenced = 1;
3868           gfc_get_symbol_decl (sym);
3869         }
3870
3871       /* INTENT(out) dummy arguments and result variables with allocatable
3872          components are reset by default and need to be set referenced to
3873          generate the code for nullification and automatic lengths.  */
3874       if (!sym->attr.referenced
3875             && sym->ts.type == BT_DERIVED
3876             && sym->ts.u.derived->attr.alloc_comp
3877             && !sym->attr.pointer
3878             && ((sym->attr.dummy && sym->attr.intent == INTENT_OUT)
3879                   ||
3880                 (sym->attr.result && sym != sym->result)))
3881         {
3882           sym->attr.referenced = 1;
3883           gfc_get_symbol_decl (sym);
3884         }
3885
3886       /* Check for dependencies in the array specification and string
3887         length, adding the necessary declarations to the function.  We
3888         mark the symbol now, as well as in traverse_ns, to prevent
3889         getting stuck in a circular dependency.  */
3890       sym->mark = 1;
3891
3892       /* We do not want the middle-end to warn about unused parameters
3893          as this was already done above.  */
3894       if (sym->attr.dummy && sym->backend_decl != NULL_TREE)
3895           TREE_NO_WARNING(sym->backend_decl) = 1;
3896     }
3897   else if (sym->attr.flavor == FL_PARAMETER)
3898     {
3899       if (warn_unused_parameter
3900            && !sym->attr.referenced
3901            && !sym->attr.use_assoc)
3902         gfc_warning ("Unused parameter '%s' declared at %L", sym->name,
3903                      &sym->declared_at);
3904     }
3905   else if (sym->attr.flavor == FL_PROCEDURE)
3906     {
3907       /* TODO: move to the appropriate place in resolve.c.  */
3908       if (warn_return_type
3909           && sym->attr.function
3910           && sym->result
3911           && sym != sym->result
3912           && !sym->result->attr.referenced
3913           && !sym->attr.use_assoc
3914           && sym->attr.if_source != IFSRC_IFBODY)
3915         {
3916           gfc_warning ("Return value '%s' of function '%s' declared at "
3917                        "%L not set", sym->result->name, sym->name,
3918                         &sym->result->declared_at);
3919
3920           /* Prevents "Unused variable" warning for RESULT variables.  */
3921           sym->result->mark = 1;
3922         }
3923     }
3924
3925   if (sym->attr.dummy == 1)
3926     {
3927       /* Modify the tree type for scalar character dummy arguments of bind(c)
3928          procedures if they are passed by value.  The tree type for them will
3929          be promoted to INTEGER_TYPE for the middle end, which appears to be
3930          what C would do with characters passed by-value.  The value attribute
3931          implies the dummy is a scalar.  */
3932       if (sym->attr.value == 1 && sym->backend_decl != NULL
3933           && sym->ts.type == BT_CHARACTER && sym->ts.is_c_interop
3934           && sym->ns->proc_name != NULL && sym->ns->proc_name->attr.is_bind_c)
3935         gfc_conv_scalar_char_value (sym, NULL, NULL);
3936     }
3937
3938   /* Make sure we convert the types of the derived types from iso_c_binding
3939      into (void *).  */
3940   if (sym->attr.flavor != FL_PROCEDURE && sym->attr.is_iso_c
3941       && sym->ts.type == BT_DERIVED)
3942     sym->backend_decl = gfc_typenode_for_spec (&(sym->ts));
3943 }
3944
3945 static void
3946 generate_local_vars (gfc_namespace * ns)
3947 {
3948   gfc_traverse_ns (ns, generate_local_decl);
3949 }
3950
3951
3952 /* Generate a switch statement to jump to the correct entry point.  Also
3953    creates the label decls for the entry points.  */
3954
3955 static tree
3956 gfc_trans_entry_master_switch (gfc_entry_list * el)
3957 {
3958   stmtblock_t block;
3959   tree label;
3960   tree tmp;
3961   tree val;
3962
3963   gfc_init_block (&block);
3964   for (; el; el = el->next)
3965     {
3966       /* Add the case label.  */
3967       label = gfc_build_label_decl (NULL_TREE);
3968       val = build_int_cst (gfc_array_index_type, el->id);
3969       tmp = build3_v (CASE_LABEL_EXPR, val, NULL_TREE, label);
3970       gfc_add_expr_to_block (&block, tmp);
3971
3972       /* And jump to the actual entry point.  */
3973       label = gfc_build_label_decl (NULL_TREE);
3974       tmp = build1_v (GOTO_EXPR, label);
3975       gfc_add_expr_to_block (&block, tmp);
3976
3977       /* Save the label decl.  */
3978       el->label = label;
3979     }
3980   tmp = gfc_finish_block (&block);
3981   /* The first argument selects the entry point.  */
3982   val = DECL_ARGUMENTS (current_function_decl);
3983   tmp = build3_v (SWITCH_EXPR, val, tmp, NULL_TREE);
3984   return tmp;
3985 }
3986
3987
3988 /* Add code to string lengths of actual arguments passed to a function against
3989    the expected lengths of the dummy arguments.  */
3990
3991 static void
3992 add_argument_checking (stmtblock_t *block, gfc_symbol *sym)
3993 {
3994   gfc_formal_arglist *formal;
3995
3996   for (formal = sym->formal; formal; formal = formal->next)
3997     if (formal->sym && formal->sym->ts.type == BT_CHARACTER)
3998       {
3999         enum tree_code comparison;
4000         tree cond;
4001         tree argname;
4002         gfc_symbol *fsym;
4003         gfc_charlen *cl;
4004         const char *message;
4005
4006         fsym = formal->sym;
4007         cl = fsym->ts.u.cl;
4008
4009         gcc_assert (cl);
4010         gcc_assert (cl->passed_length != NULL_TREE);
4011         gcc_assert (cl->backend_decl != NULL_TREE);
4012
4013         /* For POINTER, ALLOCATABLE and assumed-shape dummy arguments, the
4014            string lengths must match exactly.  Otherwise, it is only required
4015            that the actual string length is *at least* the expected one.
4016            Sequence association allows for a mismatch of the string length
4017            if the actual argument is (part of) an array, but only if the
4018            dummy argument is an array. (See "Sequence association" in
4019            Section 12.4.1.4 for F95 and 12.4.1.5 for F2003.)  */
4020         if (fsym->attr.pointer || fsym->attr.allocatable
4021             || (fsym->as && fsym->as->type == AS_ASSUMED_SHAPE))
4022           {
4023             comparison = NE_EXPR;
4024             message = _("Actual string length does not match the declared one"
4025                         " for dummy argument '%s' (%ld/%ld)");
4026           }
4027         else if (fsym->as && fsym->as->rank != 0)
4028           continue;
4029         else
4030           {
4031             comparison = LT_EXPR;
4032             message = _("Actual string length is shorter than the declared one"
4033                         " for dummy argument '%s' (%ld/%ld)");
4034           }
4035
4036         /* Build the condition.  For optional arguments, an actual length
4037            of 0 is also acceptable if the associated string is NULL, which
4038            means the argument was not passed.  */
4039         cond = fold_build2 (comparison, boolean_type_node,
4040                             cl->passed_length, cl->backend_decl);
4041         if (fsym->attr.optional)
4042           {
4043             tree not_absent;
4044             tree not_0length;
4045             tree absent_failed;
4046
4047             not_0length = fold_build2 (NE_EXPR, boolean_type_node,
4048                                        cl->passed_length,
4049                                        fold_convert (gfc_charlen_type_node,
4050                                                      integer_zero_node));
4051             /* The symbol needs to be referenced for gfc_get_symbol_decl.  */
4052             fsym->attr.referenced = 1;
4053             not_absent = gfc_conv_expr_present (fsym);
4054
4055             absent_failed = fold_build2 (TRUTH_OR_EXPR, boolean_type_node,
4056                                          not_0length, not_absent);
4057
4058             cond = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
4059                                 cond, absent_failed);
4060           }
4061
4062         /* Build the runtime check.  */
4063         argname = gfc_build_cstring_const (fsym->name);
4064         argname = gfc_build_addr_expr (pchar_type_node, argname);
4065         gfc_trans_runtime_check (true, false, cond, block, &fsym->declared_at,
4066                                  message, argname,
4067                                  fold_convert (long_integer_type_node,
4068                                                cl->passed_length),
4069                                  fold_convert (long_integer_type_node,
4070                                                cl->backend_decl));
4071       }
4072 }
4073
4074
4075 static void
4076 create_main_function (tree fndecl)
4077 {
4078   tree old_context;
4079   tree ftn_main;
4080   tree tmp, decl, result_decl, argc, argv, typelist, arglist;
4081   stmtblock_t body;
4082
4083   old_context = current_function_decl;
4084
4085   if (old_context)
4086     {
4087       push_function_context ();
4088       saved_parent_function_decls = saved_function_decls;
4089       saved_function_decls = NULL_TREE;
4090     }
4091
4092   /* main() function must be declared with global scope.  */
4093   gcc_assert (current_function_decl == NULL_TREE);
4094
4095   /* Declare the function.  */
4096   tmp =  build_function_type_list (integer_type_node, integer_type_node,
4097                                    build_pointer_type (pchar_type_node),
4098                                    NULL_TREE);
4099   main_identifier_node = get_identifier ("main");
4100   ftn_main = build_decl (input_location, FUNCTION_DECL,
4101                          main_identifier_node, tmp);
4102   DECL_EXTERNAL (ftn_main) = 0;
4103   TREE_PUBLIC (ftn_main) = 1;
4104   TREE_STATIC (ftn_main) = 1;
4105   DECL_ATTRIBUTES (ftn_main)
4106       = tree_cons (get_identifier("externally_visible"), NULL_TREE, NULL_TREE);
4107
4108   /* Setup the result declaration (for "return 0").  */
4109   result_decl = build_decl (input_location,
4110                             RESULT_DECL, NULL_TREE, integer_type_node);
4111   DECL_ARTIFICIAL (result_decl) = 1;
4112   DECL_IGNORED_P (result_decl) = 1;
4113   DECL_CONTEXT (result_decl) = ftn_main;
4114   DECL_RESULT (ftn_main) = result_decl;
4115
4116   pushdecl (ftn_main);
4117
4118   /* Get the arguments.  */
4119
4120   arglist = NULL_TREE;
4121   typelist = TYPE_ARG_TYPES (TREE_TYPE (ftn_main));
4122
4123   tmp = TREE_VALUE (typelist);
4124   argc = build_decl (input_location, PARM_DECL, get_identifier ("argc"), tmp);
4125   DECL_CONTEXT (argc) = ftn_main;
4126   DECL_ARG_TYPE (argc) = TREE_VALUE (typelist);
4127   TREE_READONLY (argc) = 1;
4128   gfc_finish_decl (argc);
4129   arglist = chainon (arglist, argc);
4130
4131   typelist = TREE_CHAIN (typelist);
4132   tmp = TREE_VALUE (typelist);
4133   argv = build_decl (input_location, PARM_DECL, get_identifier ("argv"), tmp);
4134   DECL_CONTEXT (argv) = ftn_main;
4135   DECL_ARG_TYPE (argv) = TREE_VALUE (typelist);
4136   TREE_READONLY (argv) = 1;
4137   DECL_BY_REFERENCE (argv) = 1;
4138   gfc_finish_decl (argv);
4139   arglist = chainon (arglist, argv);
4140
4141   DECL_ARGUMENTS (ftn_main) = arglist;
4142   current_function_decl = ftn_main;
4143   announce_function (ftn_main);
4144
4145   rest_of_decl_compilation (ftn_main, 1, 0);
4146   make_decl_rtl (ftn_main);
4147   init_function_start (ftn_main);
4148   pushlevel (0);
4149
4150   gfc_init_block (&body);
4151
4152   /* Call some libgfortran initialization routines, call then MAIN__(). */
4153
4154   /* Call _gfortran_set_args (argc, argv).  */
4155   TREE_USED (argc) = 1;
4156   TREE_USED (argv) = 1;
4157   tmp = build_call_expr_loc (input_location,
4158                          gfor_fndecl_set_args, 2, argc, argv);
4159   gfc_add_expr_to_block (&body, tmp);
4160
4161   /* Add a call to set_options to set up the runtime library Fortran
4162      language standard parameters.  */
4163   {
4164     tree array_type, array, var;
4165
4166     /* Passing a new option to the library requires four modifications:
4167      + add it to the tree_cons list below
4168           + change the array size in the call to build_array_type
4169           + change the first argument to the library call
4170             gfor_fndecl_set_options
4171           + modify the library (runtime/compile_options.c)!  */
4172
4173     array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,
4174                        gfc_option.warn_std), NULL_TREE);
4175     array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,
4176                        gfc_option.allow_std), array);
4177     array = tree_cons (NULL_TREE, build_int_cst (integer_type_node, pedantic),
4178                        array);
4179     array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,
4180                        gfc_option.flag_dump_core), array);
4181     array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,
4182                        gfc_option.flag_backtrace), array);
4183     array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,
4184                        gfc_option.flag_sign_zero), array);
4185
4186     array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,
4187                        (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)), array);
4188
4189     array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,
4190                        gfc_option.flag_range_check), array);
4191
4192     array_type = build_array_type (integer_type_node,
4193                        build_index_type (build_int_cst (NULL_TREE, 7)));
4194     array = build_constructor_from_list (array_type, nreverse (array));
4195     TREE_CONSTANT (array) = 1;
4196     TREE_STATIC (array) = 1;
4197
4198     /* Create a static variable to hold the jump table.  */
4199     var = gfc_create_var (array_type, "options");
4200     TREE_CONSTANT (var) = 1;
4201     TREE_STATIC (var) = 1;
4202     TREE_READONLY (var) = 1;
4203     DECL_INITIAL (var) = array;
4204     var = gfc_build_addr_expr (build_pointer_type (integer_type_node), var);
4205
4206     tmp = build_call_expr_loc (input_location,
4207                            gfor_fndecl_set_options, 2,
4208                            build_int_cst (integer_type_node, 8), var);
4209     gfc_add_expr_to_block (&body, tmp);
4210   }
4211
4212   /* If -ffpe-trap option was provided, add a call to set_fpe so that
4213      the library will raise a FPE when needed.  */
4214   if (gfc_option.fpe != 0)
4215     {
4216       tmp = build_call_expr_loc (input_location,
4217                              gfor_fndecl_set_fpe, 1,
4218                              build_int_cst (integer_type_node,
4219                                             gfc_option.fpe));
4220       gfc_add_expr_to_block (&body, tmp);
4221     }
4222
4223   /* If this is the main program and an -fconvert option was provided,
4224      add a call to set_convert.  */
4225
4226   if (gfc_option.convert != GFC_CONVERT_NATIVE)
4227     {
4228       tmp = build_call_expr_loc (input_location,
4229                              gfor_fndecl_set_convert, 1,
4230                              build_int_cst (integer_type_node,
4231                                             gfc_option.convert));
4232       gfc_add_expr_to_block (&body, tmp);
4233     }
4234
4235   /* If this is the main program and an -frecord-marker option was provided,
4236      add a call to set_record_marker.  */
4237
4238   if (gfc_option.record_marker != 0)
4239     {
4240       tmp = build_call_expr_loc (input_location,
4241                              gfor_fndecl_set_record_marker, 1,
4242                              build_int_cst (integer_type_node,
4243                                             gfc_option.record_marker));
4244       gfc_add_expr_to_block (&body, tmp);
4245     }
4246
4247   if (gfc_option.max_subrecord_length != 0)
4248     {
4249       tmp = build_call_expr_loc (input_location,
4250                              gfor_fndecl_set_max_subrecord_length, 1,
4251                              build_int_cst (integer_type_node,
4252                                             gfc_option.max_subrecord_length));
4253       gfc_add_expr_to_block (&body, tmp);
4254     }
4255
4256   /* Call MAIN__().  */
4257   tmp = build_call_expr_loc (input_location,
4258                          fndecl, 0);
4259   gfc_add_expr_to_block (&body, tmp);
4260
4261   /* Mark MAIN__ as used.  */
4262   TREE_USED (fndecl) = 1;
4263
4264   /* "return 0".  */
4265   tmp = fold_build2 (MODIFY_EXPR, integer_type_node, DECL_RESULT (ftn_main),
4266                      build_int_cst (integer_type_node, 0));
4267   tmp = build1_v (RETURN_EXPR, tmp);
4268   gfc_add_expr_to_block (&body, tmp);
4269
4270
4271   DECL_SAVED_TREE (ftn_main) = gfc_finish_block (&body);
4272   decl = getdecls ();
4273
4274   /* Finish off this function and send it for code generation.  */
4275   poplevel (1, 0, 1);
4276   BLOCK_SUPERCONTEXT (DECL_INITIAL (ftn_main)) = ftn_main;
4277
4278   DECL_SAVED_TREE (ftn_main)
4279     = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (ftn_main),
4280                 DECL_INITIAL (ftn_main));
4281
4282   /* Output the GENERIC tree.  */
4283   dump_function (TDI_original, ftn_main);
4284
4285   cgraph_finalize_function (ftn_main, true);
4286
4287   if (old_context)
4288     {
4289       pop_function_context ();
4290       saved_function_decls = saved_parent_function_decls;
4291     }
4292   current_function_decl = old_context;
4293 }
4294
4295
4296 /* Generate code for a function.  */
4297
4298 void
4299 gfc_generate_function_code (gfc_namespace * ns)
4300 {
4301   tree fndecl;
4302   tree old_context;
4303   tree decl;
4304   tree tmp;
4305   tree tmp2;
4306   stmtblock_t block;
4307   stmtblock_t body;
4308   tree result;
4309   tree recurcheckvar = NULL_TREE;
4310   gfc_symbol *sym;
4311   int rank;
4312   bool is_recursive;
4313
4314   sym = ns->proc_name;
4315
4316   /* Check that the frontend isn't still using this.  */
4317   gcc_assert (sym->tlink == NULL);
4318   sym->tlink = sym;
4319
4320   /* Create the declaration for functions with global scope.  */
4321   if (!sym->backend_decl)
4322     gfc_create_function_decl (ns);
4323
4324   fndecl = sym->backend_decl;
4325   old_context = current_function_decl;
4326
4327   if (old_context)
4328     {
4329       push_function_context ();
4330       saved_parent_function_decls = saved_function_decls;
4331       saved_function_decls = NULL_TREE;
4332     }
4333
4334   trans_function_start (sym);
4335
4336   gfc_init_block (&block);
4337
4338   if (ns->entries && ns->proc_name->ts.type == BT_CHARACTER)
4339     {
4340       /* Copy length backend_decls to all entry point result
4341          symbols.  */
4342       gfc_entry_list *el;
4343       tree backend_decl;
4344
4345       gfc_conv_const_charlen (ns->proc_name->ts.u.cl);
4346       backend_decl = ns->proc_name->result->ts.u.cl->backend_decl;
4347       for (el = ns->entries; el; el = el->next)
4348         el->sym->result->ts.u.cl->backend_decl = backend_decl;
4349     }
4350
4351   /* Translate COMMON blocks.  */
4352   gfc_trans_common (ns);
4353
4354   /* Null the parent fake result declaration if this namespace is
4355      a module function or an external procedures.  */
4356   if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
4357         || ns->parent == NULL)
4358     parent_fake_result_decl = NULL_TREE;
4359
4360   gfc_generate_contained_functions (ns);
4361
4362   nonlocal_dummy_decls = NULL;
4363   nonlocal_dummy_decl_pset = NULL;
4364
4365   generate_local_vars (ns);
4366
4367   /* Keep the parent fake result declaration in module functions
4368      or external procedures.  */
4369   if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
4370         || ns->parent == NULL)
4371     current_fake_result_decl = parent_fake_result_decl;
4372   else
4373     current_fake_result_decl = NULL_TREE;
4374
4375   current_function_return_label = NULL;
4376
4377   /* Now generate the code for the body of this function.  */
4378   gfc_init_block (&body);
4379
4380    is_recursive = sym->attr.recursive
4381                   || (sym->attr.entry_master
4382                       && sym->ns->entries->sym->attr.recursive);
4383    if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION)
4384           && !is_recursive
4385           && !gfc_option.flag_recursive)
4386      {
4387        char * msg;
4388
4389        asprintf (&msg, "Recursive call to nonrecursive procedure '%s'",
4390                  sym->name);
4391        recurcheckvar = gfc_create_var (boolean_type_node, "is_recursive");
4392        TREE_STATIC (recurcheckvar) = 1;
4393        DECL_INITIAL (recurcheckvar) = boolean_false_node;
4394        gfc_add_expr_to_block (&block, recurcheckvar);
4395        gfc_trans_runtime_check (true, false, recurcheckvar, &block,
4396                                 &sym->declared_at, msg);
4397        gfc_add_modify (&block, recurcheckvar, boolean_true_node);
4398        gfc_free (msg);
4399     }
4400
4401   if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node
4402         && sym->attr.subroutine)
4403     {
4404       tree alternate_return;
4405       alternate_return = gfc_get_fake_result_decl (sym, 0);
4406       gfc_add_modify (&body, alternate_return, integer_zero_node);
4407     }
4408
4409   if (ns->entries)
4410     {
4411       /* Jump to the correct entry point.  */
4412       tmp = gfc_trans_entry_master_switch (ns->entries);
4413       gfc_add_expr_to_block (&body, tmp);
4414     }
4415
4416   /* If bounds-checking is enabled, generate code to check passed in actual
4417      arguments against the expected dummy argument attributes (e.g. string
4418      lengths).  */
4419   if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) && !sym->attr.is_bind_c)
4420     add_argument_checking (&body, sym);
4421
4422   tmp = gfc_trans_code (ns->code);
4423   gfc_add_expr_to_block (&body, tmp);
4424
4425   /* Add a return label if needed.  */
4426   if (current_function_return_label)
4427     {
4428       tmp = build1_v (LABEL_EXPR, current_function_return_label);
4429       gfc_add_expr_to_block (&body, tmp);
4430     }
4431
4432   tmp = gfc_finish_block (&body);
4433   /* Add code to create and cleanup arrays.  */
4434   tmp = gfc_trans_deferred_vars (sym, tmp);
4435
4436   if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node)
4437     {
4438       if (sym->attr.subroutine || sym == sym->result)
4439         {
4440           if (current_fake_result_decl != NULL)
4441             result = TREE_VALUE (current_fake_result_decl);
4442           else
4443             result = NULL_TREE;
4444           current_fake_result_decl = NULL_TREE;
4445         }
4446       else
4447         result = sym->result->backend_decl;
4448
4449       if (result != NULL_TREE
4450             && sym->attr.function
4451             && !sym->attr.pointer)
4452         {
4453           if (sym->ts.type == BT_DERIVED
4454               && sym->ts.u.derived->attr.alloc_comp)
4455             {
4456               rank = sym->as ? sym->as->rank : 0;
4457               tmp2 = gfc_nullify_alloc_comp (sym->ts.u.derived, result, rank);
4458               gfc_add_expr_to_block (&block, tmp2);
4459             }
4460           else if (sym->attr.allocatable && sym->attr.dimension == 0)
4461             gfc_add_modify (&block, result, fold_convert (TREE_TYPE (result),
4462                                                           null_pointer_node));
4463         }
4464
4465       gfc_add_expr_to_block (&block, tmp);
4466
4467       /* Reset recursion-check variable.  */
4468       if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION)
4469              && !is_recursive
4470              && !gfc_option.flag_openmp
4471              && recurcheckvar != NULL_TREE)
4472         {
4473           gfc_add_modify (&block, recurcheckvar, boolean_false_node);
4474           recurcheckvar = NULL;
4475         }
4476
4477       if (result == NULL_TREE)
4478         {
4479           /* TODO: move to the appropriate place in resolve.c.  */
4480           if (warn_return_type && !sym->attr.referenced && sym == sym->result)
4481             gfc_warning ("Return value of function '%s' at %L not set",
4482                          sym->name, &sym->declared_at);
4483
4484           TREE_NO_WARNING(sym->backend_decl) = 1;
4485         }
4486       else
4487         {
4488           /* Set the return value to the dummy result variable.  The
4489              types may be different for scalar default REAL functions
4490              with -ff2c, therefore we have to convert.  */
4491           tmp = convert (TREE_TYPE (DECL_RESULT (fndecl)), result);
4492           tmp = fold_build2 (MODIFY_EXPR, TREE_TYPE (tmp),
4493                              DECL_RESULT (fndecl), tmp);
4494           tmp = build1_v (RETURN_EXPR, tmp);
4495           gfc_add_expr_to_block (&block, tmp);
4496         }
4497     }
4498   else
4499     {
4500       gfc_add_expr_to_block (&block, tmp);
4501       /* Reset recursion-check variable.  */
4502       if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION)
4503              && !is_recursive
4504              && !gfc_option.flag_openmp
4505              && recurcheckvar != NULL_TREE)
4506         {
4507           gfc_add_modify (&block, recurcheckvar, boolean_false_node);
4508           recurcheckvar = NULL_TREE;
4509         }
4510     }
4511
4512
4513   /* Add all the decls we created during processing.  */
4514   decl = saved_function_decls;
4515   while (decl)
4516     {
4517       tree next;
4518
4519       next = TREE_CHAIN (decl);
4520       TREE_CHAIN (decl) = NULL_TREE;
4521       pushdecl (decl);
4522       decl = next;
4523     }
4524   saved_function_decls = NULL_TREE;
4525
4526   DECL_SAVED_TREE (fndecl) = gfc_finish_block (&block);
4527   decl = getdecls ();
4528
4529   /* Finish off this function and send it for code generation.  */
4530   poplevel (1, 0, 1);
4531   BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
4532
4533   DECL_SAVED_TREE (fndecl)
4534     = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (fndecl),
4535                 DECL_INITIAL (fndecl));
4536
4537   if (nonlocal_dummy_decls)
4538     {
4539       BLOCK_VARS (DECL_INITIAL (fndecl))
4540         = chainon (BLOCK_VARS (DECL_INITIAL (fndecl)), nonlocal_dummy_decls);
4541       pointer_set_destroy (nonlocal_dummy_decl_pset);
4542       nonlocal_dummy_decls = NULL;
4543       nonlocal_dummy_decl_pset = NULL;
4544     }
4545
4546   /* Output the GENERIC tree.  */
4547   dump_function (TDI_original, fndecl);
4548
4549   /* Store the end of the function, so that we get good line number
4550      info for the epilogue.  */
4551   cfun->function_end_locus = input_location;
4552
4553   /* We're leaving the context of this function, so zap cfun.
4554      It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
4555      tree_rest_of_compilation.  */
4556   set_cfun (NULL);
4557
4558   if (old_context)
4559     {
4560       pop_function_context ();
4561       saved_function_decls = saved_parent_function_decls;
4562     }
4563   current_function_decl = old_context;
4564
4565   if (decl_function_context (fndecl))
4566     /* Register this function with cgraph just far enough to get it
4567        added to our parent's nested function list.  */
4568     (void) cgraph_node (fndecl);
4569   else
4570     cgraph_finalize_function (fndecl, true);
4571
4572   gfc_trans_use_stmts (ns);
4573   gfc_traverse_ns (ns, gfc_emit_parameter_debug_info);
4574
4575   if (sym->attr.is_main_program)
4576     create_main_function (fndecl);
4577 }
4578
4579
4580 void
4581 gfc_generate_constructors (void)
4582 {
4583   gcc_assert (gfc_static_ctors == NULL_TREE);
4584 #if 0
4585   tree fnname;
4586   tree type;
4587   tree fndecl;
4588   tree decl;
4589   tree tmp;
4590
4591   if (gfc_static_ctors == NULL_TREE)
4592     return;
4593
4594   fnname = get_file_function_name ("I");
4595   type = build_function_type (void_type_node,
4596                               gfc_chainon_list (NULL_TREE, void_type_node));
4597
4598   fndecl = build_decl (input_location,
4599                        FUNCTION_DECL, fnname, type);
4600   TREE_PUBLIC (fndecl) = 1;
4601
4602   decl = build_decl (input_location,
4603                      RESULT_DECL, NULL_TREE, void_type_node);
4604   DECL_ARTIFICIAL (decl) = 1;
4605   DECL_IGNORED_P (decl) = 1;
4606   DECL_CONTEXT (decl) = fndecl;
4607   DECL_RESULT (fndecl) = decl;
4608
4609   pushdecl (fndecl);
4610
4611   current_function_decl = fndecl;
4612
4613   rest_of_decl_compilation (fndecl, 1, 0);
4614
4615   make_decl_rtl (fndecl);
4616
4617   init_function_start (fndecl);
4618
4619   pushlevel (0);
4620
4621   for (; gfc_static_ctors; gfc_static_ctors = TREE_CHAIN (gfc_static_ctors))
4622     {
4623       tmp = build_call_expr_loc (input_location,
4624                              TREE_VALUE (gfc_static_ctors), 0);
4625       DECL_SAVED_TREE (fndecl) = build_stmt (input_location, EXPR_STMT, tmp);
4626     }
4627
4628   decl = getdecls ();
4629   poplevel (1, 0, 1);
4630
4631   BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
4632   DECL_SAVED_TREE (fndecl)
4633     = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (fndecl),
4634                 DECL_INITIAL (fndecl));
4635
4636   free_after_parsing (cfun);
4637   free_after_compilation (cfun);
4638
4639   tree_rest_of_compilation (fndecl);
4640
4641   current_function_decl = NULL_TREE;
4642 #endif
4643 }
4644
4645 /* Translates a BLOCK DATA program unit. This means emitting the
4646    commons contained therein plus their initializations. We also emit
4647    a globally visible symbol to make sure that each BLOCK DATA program
4648    unit remains unique.  */
4649
4650 void
4651 gfc_generate_block_data (gfc_namespace * ns)
4652 {
4653   tree decl;
4654   tree id;
4655
4656   /* Tell the backend the source location of the block data.  */
4657   if (ns->proc_name)
4658     gfc_set_backend_locus (&ns->proc_name->declared_at);
4659   else
4660     gfc_set_backend_locus (&gfc_current_locus);
4661
4662   /* Process the DATA statements.  */
4663   gfc_trans_common (ns);
4664
4665   /* Create a global symbol with the mane of the block data.  This is to
4666      generate linker errors if the same name is used twice.  It is never
4667      really used.  */
4668   if (ns->proc_name)
4669     id = gfc_sym_mangled_function_id (ns->proc_name);
4670   else
4671     id = get_identifier ("__BLOCK_DATA__");
4672
4673   decl = build_decl (input_location,
4674                      VAR_DECL, id, gfc_array_index_type);
4675   TREE_PUBLIC (decl) = 1;
4676   TREE_STATIC (decl) = 1;
4677   DECL_IGNORED_P (decl) = 1;
4678
4679   pushdecl (decl);
4680   rest_of_decl_compilation (decl, 1, 0);
4681 }
4682
4683
4684 /* Process the local variables of a BLOCK construct.  */
4685
4686 void
4687 gfc_process_block_locals (gfc_namespace* ns)
4688 {
4689   tree decl;
4690
4691   gcc_assert (saved_local_decls == NULL_TREE);
4692   generate_local_vars (ns);
4693
4694   decl = saved_local_decls;
4695   while (decl)
4696     {
4697       tree next;
4698
4699       next = TREE_CHAIN (decl);
4700       TREE_CHAIN (decl) = NULL_TREE;
4701       pushdecl (decl);
4702       decl = next;
4703     }
4704   saved_local_decls = NULL_TREE;
4705 }
4706
4707
4708 #include "gt-fortran-trans-decl.h"