gcc/fortran/trans-decl.c

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