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