gcc/fortran/trans-decl.c

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