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