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