gcc/fortran/trans-decl.c

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