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