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