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