gcc/fortran/trans-decl.c

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