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