gcc/fortran/trans-decl.c

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