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 (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) = TREE_STATIC (decl);
1109       DECL_ARTIFICIAL (span) = 1;
1110       DECL_INITIAL (span) = build_int_cst (gfc_array_index_type, 0);
1111
1112       GFC_DECL_SPAN (decl) = span;
1113       GFC_TYPE_ARRAY_SPAN (TREE_TYPE (decl)) = span;
1114     }
1115
1116   sym->backend_decl = decl;
1117
1118   if (sym->attr.assign)
1119     gfc_add_assign_aux_vars (sym);
1120
1121   if (TREE_STATIC (decl) && !sym->attr.use_assoc)
1122     {
1123       /* Add static initializer.  */
1124       DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
1125           TREE_TYPE (decl), sym->attr.dimension,
1126           sym->attr.pointer || sym->attr.allocatable);
1127     }
1128
1129   return decl;
1130 }
1131
1132
1133 /* Substitute a temporary variable in place of the real one.  */
1134
1135 void
1136 gfc_shadow_sym (gfc_symbol * sym, tree decl, gfc_saved_var * save)
1137 {
1138   save->attr = sym->attr;
1139   save->decl = sym->backend_decl;
1140
1141   gfc_clear_attr (&sym->attr);
1142   sym->attr.referenced = 1;
1143   sym->attr.flavor = FL_VARIABLE;
1144
1145   sym->backend_decl = decl;
1146 }
1147
1148
1149 /* Restore the original variable.  */
1150
1151 void
1152 gfc_restore_sym (gfc_symbol * sym, gfc_saved_var * save)
1153 {
1154   sym->attr = save->attr;
1155   sym->backend_decl = save->decl;
1156 }
1157
1158
1159 /* Declare a procedure pointer.  */
1160
1161 static tree
1162 get_proc_pointer_decl (gfc_symbol *sym)
1163 {
1164   tree decl;
1165
1166   decl = sym->backend_decl;
1167   if (decl)
1168     return decl;
1169
1170   decl = build_decl (VAR_DECL, get_identifier (sym->name),
1171                      build_pointer_type (gfc_get_function_type (sym)));
1172
1173   if ((sym->ns->proc_name
1174       && sym->ns->proc_name->backend_decl == current_function_decl)
1175       || sym->attr.contained)
1176     gfc_add_decl_to_function (decl);
1177   else
1178     gfc_add_decl_to_parent_function (decl);
1179
1180   sym->backend_decl = decl;
1181
1182   if (!sym->attr.use_assoc
1183         && (sym->attr.save != SAVE_NONE || sym->attr.data
1184               || (sym->value && sym->ns->proc_name->attr.is_main_program)))
1185     TREE_STATIC (decl) = 1;
1186
1187   if (TREE_STATIC (decl) && sym->value)
1188     {
1189       /* Add static initializer.  */
1190       DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
1191           TREE_TYPE (decl), sym->attr.dimension, sym->attr.proc_pointer);
1192     }
1193
1194   return decl;
1195 }
1196
1197
1198 /* Get a basic decl for an external function.  */
1199
1200 tree
1201 gfc_get_extern_function_decl (gfc_symbol * sym)
1202 {
1203   tree type;
1204   tree fndecl;
1205   gfc_expr e;
1206   gfc_intrinsic_sym *isym;
1207   gfc_expr argexpr;
1208   char s[GFC_MAX_SYMBOL_LEN + 23]; /* "_gfortran_f2c_specific" and '\0'.  */
1209   tree name;
1210   tree mangled_name;
1211
1212   if (sym->backend_decl)
1213     return sym->backend_decl;
1214
1215   /* We should never be creating external decls for alternate entry points.
1216      The procedure may be an alternate entry point, but we don't want/need
1217      to know that.  */
1218   gcc_assert (!(sym->attr.entry || sym->attr.entry_master));
1219
1220   if (sym->attr.proc_pointer)
1221     return get_proc_pointer_decl (sym);
1222
1223   if (sym->attr.intrinsic)
1224     {
1225       /* Call the resolution function to get the actual name.  This is
1226          a nasty hack which relies on the resolution functions only looking
1227          at the first argument.  We pass NULL for the second argument
1228          otherwise things like AINT get confused.  */
1229       isym = gfc_find_function (sym->name);
1230       gcc_assert (isym->resolve.f0 != NULL);
1231
1232       memset (&e, 0, sizeof (e));
1233       e.expr_type = EXPR_FUNCTION;
1234
1235       memset (&argexpr, 0, sizeof (argexpr));
1236       gcc_assert (isym->formal);
1237       argexpr.ts = isym->formal->ts;
1238
1239       if (isym->formal->next == NULL)
1240         isym->resolve.f1 (&e, &argexpr);
1241       else
1242         {
1243           if (isym->formal->next->next == NULL)
1244             isym->resolve.f2 (&e, &argexpr, NULL);
1245           else
1246             {
1247               if (isym->formal->next->next->next == NULL)
1248                 isym->resolve.f3 (&e, &argexpr, NULL, NULL);
1249               else
1250                 {
1251                   /* All specific intrinsics take less than 5 arguments.  */
1252                   gcc_assert (isym->formal->next->next->next->next == NULL);
1253                   isym->resolve.f4 (&e, &argexpr, NULL, NULL, NULL);
1254                 }
1255             }
1256         }
1257
1258       if (gfc_option.flag_f2c
1259           && ((e.ts.type == BT_REAL && e.ts.kind == gfc_default_real_kind)
1260               || e.ts.type == BT_COMPLEX))
1261         {
1262           /* Specific which needs a different implementation if f2c
1263              calling conventions are used.  */
1264           sprintf (s, "_gfortran_f2c_specific%s", e.value.function.name);
1265         }
1266       else
1267         sprintf (s, "_gfortran_specific%s", e.value.function.name);
1268
1269       name = get_identifier (s);
1270       mangled_name = name;
1271     }
1272   else
1273     {
1274       name = gfc_sym_identifier (sym);
1275       mangled_name = gfc_sym_mangled_function_id (sym);
1276     }
1277
1278   type = gfc_get_function_type (sym);
1279   fndecl = build_decl (FUNCTION_DECL, name, type);
1280
1281   SET_DECL_ASSEMBLER_NAME (fndecl, mangled_name);
1282   /* If the return type is a pointer, avoid alias issues by setting
1283      DECL_IS_MALLOC to nonzero. This means that the function should be
1284      treated as if it were a malloc, meaning it returns a pointer that
1285      is not an alias.  */
1286   if (POINTER_TYPE_P (type))
1287     DECL_IS_MALLOC (fndecl) = 1;
1288
1289   /* Set the context of this decl.  */
1290   if (0 && sym->ns && sym->ns->proc_name)
1291     {
1292       /* TODO: Add external decls to the appropriate scope.  */
1293       DECL_CONTEXT (fndecl) = sym->ns->proc_name->backend_decl;
1294     }
1295   else
1296     {
1297       /* Global declaration, e.g. intrinsic subroutine.  */
1298       DECL_CONTEXT (fndecl) = NULL_TREE;
1299     }
1300
1301   DECL_EXTERNAL (fndecl) = 1;
1302
1303   /* This specifies if a function is globally addressable, i.e. it is
1304      the opposite of declaring static in C.  */
1305   TREE_PUBLIC (fndecl) = 1;
1306
1307   /* Set attributes for PURE functions. A call to PURE function in the
1308      Fortran 95 sense is both pure and without side effects in the C
1309      sense.  */
1310   if (sym->attr.pure || sym->attr.elemental)
1311     {
1312       if (sym->attr.function && !gfc_return_by_reference (sym))
1313         DECL_PURE_P (fndecl) = 1;
1314       /* TODO: check if pure SUBROUTINEs don't have INTENT(OUT)
1315          parameters and don't use alternate returns (is this
1316          allowed?). In that case, calls to them are meaningless, and
1317          can be optimized away. See also in build_function_decl().  */
1318       TREE_SIDE_EFFECTS (fndecl) = 0;
1319     }
1320
1321   /* Mark non-returning functions.  */
1322   if (sym->attr.noreturn)
1323       TREE_THIS_VOLATILE(fndecl) = 1;
1324
1325   sym->backend_decl = fndecl;
1326
1327   if (DECL_CONTEXT (fndecl) == NULL_TREE)
1328     pushdecl_top_level (fndecl);
1329
1330   return fndecl;
1331 }
1332
1333
1334 /* Create a declaration for a procedure.  For external functions (in the C
1335    sense) use gfc_get_extern_function_decl.  HAS_ENTRIES is true if this is
1336    a master function with alternate entry points.  */
1337
1338 static void
1339 build_function_decl (gfc_symbol * sym)
1340 {
1341   tree fndecl, type;
1342   symbol_attribute attr;
1343   tree result_decl;
1344   gfc_formal_arglist *f;
1345
1346   gcc_assert (!sym->backend_decl);
1347   gcc_assert (!sym->attr.external);
1348
1349   /* Set the line and filename.  sym->declared_at seems to point to the
1350      last statement for subroutines, but it'll do for now.  */
1351   gfc_set_backend_locus (&sym->declared_at);
1352
1353   /* Allow only one nesting level.  Allow public declarations.  */
1354   gcc_assert (current_function_decl == NULL_TREE
1355               || DECL_CONTEXT (current_function_decl) == NULL_TREE
1356               || TREE_CODE (DECL_CONTEXT (current_function_decl))
1357                  == NAMESPACE_DECL);
1358
1359   type = gfc_get_function_type (sym);
1360   fndecl = build_decl (FUNCTION_DECL, gfc_sym_identifier (sym), type);
1361
1362   /* Perform name mangling if this is a top level or module procedure.  */
1363   if (current_function_decl == NULL_TREE)
1364     SET_DECL_ASSEMBLER_NAME (fndecl, gfc_sym_mangled_function_id (sym));
1365
1366   /* Figure out the return type of the declared function, and build a
1367      RESULT_DECL for it.  If this is a subroutine with alternate
1368      returns, build a RESULT_DECL for it.  */
1369   attr = sym->attr;
1370
1371   result_decl = NULL_TREE;
1372   /* TODO: Shouldn't this just be TREE_TYPE (TREE_TYPE (fndecl)).  */
1373   if (attr.function)
1374     {
1375       if (gfc_return_by_reference (sym))
1376         type = void_type_node;
1377       else
1378         {
1379           if (sym->result != sym)
1380             result_decl = gfc_sym_identifier (sym->result);
1381
1382           type = TREE_TYPE (TREE_TYPE (fndecl));
1383         }
1384     }
1385   else
1386     {
1387       /* Look for alternate return placeholders.  */
1388       int has_alternate_returns = 0;
1389       for (f = sym->formal; f; f = f->next)
1390         {
1391           if (f->sym == NULL)
1392             {
1393               has_alternate_returns = 1;
1394               break;
1395             }
1396         }
1397
1398       if (has_alternate_returns)
1399         type = integer_type_node;
1400       else
1401         type = void_type_node;
1402     }
1403
1404   result_decl = build_decl (RESULT_DECL, result_decl, type);
1405   DECL_ARTIFICIAL (result_decl) = 1;
1406   DECL_IGNORED_P (result_decl) = 1;
1407   DECL_CONTEXT (result_decl) = fndecl;
1408   DECL_RESULT (fndecl) = result_decl;
1409
1410   /* Don't call layout_decl for a RESULT_DECL.
1411      layout_decl (result_decl, 0);  */
1412
1413   /* If the return type is a pointer, avoid alias issues by setting
1414      DECL_IS_MALLOC to nonzero. This means that the function should be
1415      treated as if it were a malloc, meaning it returns a pointer that
1416      is not an alias.  */
1417   if (POINTER_TYPE_P (type))
1418     DECL_IS_MALLOC (fndecl) = 1;
1419
1420   /* Set up all attributes for the function.  */
1421   DECL_CONTEXT (fndecl) = current_function_decl;
1422   DECL_EXTERNAL (fndecl) = 0;
1423
1424   /* This specifies if a function is globally visible, i.e. it is
1425      the opposite of declaring static in C.  */
1426   if (DECL_CONTEXT (fndecl) == NULL_TREE
1427       && !sym->attr.entry_master)
1428     TREE_PUBLIC (fndecl) = 1;
1429
1430   /* TREE_STATIC means the function body is defined here.  */
1431   TREE_STATIC (fndecl) = 1;
1432
1433   /* Set attributes for PURE functions. A call to a PURE function in the
1434      Fortran 95 sense is both pure and without side effects in the C
1435      sense.  */
1436   if (attr.pure || attr.elemental)
1437     {
1438       /* TODO: check if a pure SUBROUTINE has no INTENT(OUT) arguments
1439          including an alternate return. In that case it can also be
1440          marked as PURE. See also in gfc_get_extern_function_decl().  */
1441       if (attr.function && !gfc_return_by_reference (sym))
1442         DECL_PURE_P (fndecl) = 1;
1443       TREE_SIDE_EFFECTS (fndecl) = 0;
1444     }
1445
1446   /* For -fwhole-program to work well, the main program needs to have the
1447      "externally_visible" attribute.  */
1448   if (attr.is_main_program)
1449     DECL_ATTRIBUTES (fndecl)
1450       = tree_cons (get_identifier("externally_visible"), NULL_TREE, NULL_TREE);
1451
1452   /* Layout the function declaration and put it in the binding level
1453      of the current function.  */
1454   pushdecl (fndecl);
1455
1456   sym->backend_decl = fndecl;
1457 }
1458
1459
1460 /* Create the DECL_ARGUMENTS for a procedure.  */
1461
1462 static void
1463 create_function_arglist (gfc_symbol * sym)
1464 {
1465   tree fndecl;
1466   gfc_formal_arglist *f;
1467   tree typelist, hidden_typelist;
1468   tree arglist, hidden_arglist;
1469   tree type;
1470   tree parm;
1471
1472   fndecl = sym->backend_decl;
1473
1474   /* Build formal argument list. Make sure that their TREE_CONTEXT is
1475      the new FUNCTION_DECL node.  */
1476   arglist = NULL_TREE;
1477   hidden_arglist = NULL_TREE;
1478   typelist = TYPE_ARG_TYPES (TREE_TYPE (fndecl));
1479
1480   if (sym->attr.entry_master)
1481     {
1482       type = TREE_VALUE (typelist);
1483       parm = build_decl (PARM_DECL, get_identifier ("__entry"), type);
1484
1485       DECL_CONTEXT (parm) = fndecl;
1486       DECL_ARG_TYPE (parm) = type;
1487       TREE_READONLY (parm) = 1;
1488       gfc_finish_decl (parm);
1489       DECL_ARTIFICIAL (parm) = 1;
1490
1491       arglist = chainon (arglist, parm);
1492       typelist = TREE_CHAIN (typelist);
1493     }
1494
1495   if (gfc_return_by_reference (sym))
1496     {
1497       tree type = TREE_VALUE (typelist), length = NULL;
1498
1499       if (sym->ts.type == BT_CHARACTER)
1500         {
1501           /* Length of character result.  */
1502           tree len_type = TREE_VALUE (TREE_CHAIN (typelist));
1503           gcc_assert (len_type == gfc_charlen_type_node);
1504
1505           length = build_decl (PARM_DECL,
1506                                get_identifier (".__result"),
1507                                len_type);
1508           if (!sym->ts.cl->length)
1509             {
1510               sym->ts.cl->backend_decl = length;
1511               TREE_USED (length) = 1;
1512             }
1513           gcc_assert (TREE_CODE (length) == PARM_DECL);
1514           DECL_CONTEXT (length) = fndecl;
1515           DECL_ARG_TYPE (length) = len_type;
1516           TREE_READONLY (length) = 1;
1517           DECL_ARTIFICIAL (length) = 1;
1518           gfc_finish_decl (length);
1519           if (sym->ts.cl->backend_decl == NULL
1520               || sym->ts.cl->backend_decl == length)
1521             {
1522               gfc_symbol *arg;
1523               tree backend_decl;
1524
1525               if (sym->ts.cl->backend_decl == NULL)
1526                 {
1527                   tree len = build_decl (VAR_DECL,
1528                                          get_identifier ("..__result"),
1529                                          gfc_charlen_type_node);
1530                   DECL_ARTIFICIAL (len) = 1;
1531                   TREE_USED (len) = 1;
1532                   sym->ts.cl->backend_decl = len;
1533                 }
1534
1535               /* Make sure PARM_DECL type doesn't point to incomplete type.  */
1536               arg = sym->result ? sym->result : sym;
1537               backend_decl = arg->backend_decl;
1538               /* Temporary clear it, so that gfc_sym_type creates complete
1539                  type.  */
1540               arg->backend_decl = NULL;
1541               type = gfc_sym_type (arg);
1542               arg->backend_decl = backend_decl;
1543               type = build_reference_type (type);
1544             }
1545         }
1546
1547       parm = build_decl (PARM_DECL, get_identifier ("__result"), type);
1548
1549       DECL_CONTEXT (parm) = fndecl;
1550       DECL_ARG_TYPE (parm) = TREE_VALUE (typelist);
1551       TREE_READONLY (parm) = 1;
1552       DECL_ARTIFICIAL (parm) = 1;
1553       gfc_finish_decl (parm);
1554
1555       arglist = chainon (arglist, parm);
1556       typelist = TREE_CHAIN (typelist);
1557
1558       if (sym->ts.type == BT_CHARACTER)
1559         {
1560           gfc_allocate_lang_decl (parm);
1561           arglist = chainon (arglist, length);
1562           typelist = TREE_CHAIN (typelist);
1563         }
1564     }
1565
1566   hidden_typelist = typelist;
1567   for (f = sym->formal; f; f = f->next)
1568     if (f->sym != NULL) /* Ignore alternate returns.  */
1569       hidden_typelist = TREE_CHAIN (hidden_typelist);
1570
1571   for (f = sym->formal; f; f = f->next)
1572     {
1573       char name[GFC_MAX_SYMBOL_LEN + 2];
1574
1575       /* Ignore alternate returns.  */
1576       if (f->sym == NULL)
1577         continue;
1578
1579       type = TREE_VALUE (typelist);
1580
1581       if (f->sym->ts.type == BT_CHARACTER)
1582         {
1583           tree len_type = TREE_VALUE (hidden_typelist);
1584           tree length = NULL_TREE;
1585           gcc_assert (len_type == gfc_charlen_type_node);
1586
1587           strcpy (&name[1], f->sym->name);
1588           name[0] = '_';
1589           length = build_decl (PARM_DECL, get_identifier (name), len_type);
1590
1591           hidden_arglist = chainon (hidden_arglist, length);
1592           DECL_CONTEXT (length) = fndecl;
1593           DECL_ARTIFICIAL (length) = 1;
1594           DECL_ARG_TYPE (length) = len_type;
1595           TREE_READONLY (length) = 1;
1596           gfc_finish_decl (length);
1597
1598           /* TODO: Check string lengths when -fbounds-check.  */
1599
1600           /* Use the passed value for assumed length variables.  */
1601           if (!f->sym->ts.cl->length)
1602             {
1603               TREE_USED (length) = 1;
1604               gcc_assert (!f->sym->ts.cl->backend_decl);
1605               f->sym->ts.cl->backend_decl = length;
1606             }
1607
1608           hidden_typelist = TREE_CHAIN (hidden_typelist);
1609
1610           if (f->sym->ts.cl->backend_decl == NULL
1611               || f->sym->ts.cl->backend_decl == length)
1612             {
1613               if (f->sym->ts.cl->backend_decl == NULL)
1614                 gfc_create_string_length (f->sym);
1615
1616               /* Make sure PARM_DECL type doesn't point to incomplete type.  */
1617               if (f->sym->attr.flavor == FL_PROCEDURE)
1618                 type = build_pointer_type (gfc_get_function_type (f->sym));
1619               else
1620                 type = gfc_sym_type (f->sym);
1621             }
1622         }
1623
1624       /* For non-constant length array arguments, make sure they use
1625          a different type node from TYPE_ARG_TYPES type.  */
1626       if (f->sym->attr.dimension
1627           && type == TREE_VALUE (typelist)
1628           && TREE_CODE (type) == POINTER_TYPE
1629           && GFC_ARRAY_TYPE_P (type)
1630           && f->sym->as->type != AS_ASSUMED_SIZE
1631           && ! COMPLETE_TYPE_P (TREE_TYPE (type)))
1632         {
1633           if (f->sym->attr.flavor == FL_PROCEDURE)
1634             type = build_pointer_type (gfc_get_function_type (f->sym));
1635           else
1636             type = gfc_sym_type (f->sym);
1637         }
1638
1639       if (f->sym->attr.proc_pointer)
1640         type = build_pointer_type (type);
1641
1642       /* Build the argument declaration.  */
1643       parm = build_decl (PARM_DECL, gfc_sym_identifier (f->sym), type);
1644
1645       /* Fill in arg stuff.  */
1646       DECL_CONTEXT (parm) = fndecl;
1647       DECL_ARG_TYPE (parm) = TREE_VALUE (typelist);
1648       /* All implementation args are read-only.  */
1649       TREE_READONLY (parm) = 1;
1650       if (POINTER_TYPE_P (type)
1651           && (!f->sym->attr.proc_pointer
1652               && f->sym->attr.flavor != FL_PROCEDURE))
1653         DECL_BY_REFERENCE (parm) = 1;
1654
1655       gfc_finish_decl (parm);
1656
1657       f->sym->backend_decl = parm;
1658
1659       arglist = chainon (arglist, parm);
1660       typelist = TREE_CHAIN (typelist);
1661     }
1662
1663   /* Add the hidden string length parameters, unless the procedure
1664      is bind(C).  */
1665   if (!sym->attr.is_bind_c)
1666     arglist = chainon (arglist, hidden_arglist);
1667
1668   gcc_assert (hidden_typelist == NULL_TREE
1669               || TREE_VALUE (hidden_typelist) == void_type_node);
1670   DECL_ARGUMENTS (fndecl) = arglist;
1671 }
1672
1673 /* Convert FNDECL's code to GIMPLE and handle any nested functions.  */
1674
1675 static void
1676 gfc_gimplify_function (tree fndecl)
1677 {
1678   struct cgraph_node *cgn;
1679
1680   gimplify_function_tree (fndecl);
1681   dump_function (TDI_generic, fndecl);
1682
1683   /* Generate errors for structured block violations.  */
1684   /* ??? Could be done as part of resolve_labels.  */
1685   if (flag_openmp)
1686     diagnose_omp_structured_block_errors (fndecl);
1687
1688   /* Convert all nested functions to GIMPLE now.  We do things in this order
1689      so that items like VLA sizes are expanded properly in the context of the
1690      correct function.  */
1691   cgn = cgraph_node (fndecl);
1692   for (cgn = cgn->nested; cgn; cgn = cgn->next_nested)
1693     gfc_gimplify_function (cgn->decl);
1694 }
1695
1696
1697 /* Do the setup necessary before generating the body of a function.  */
1698
1699 static void
1700 trans_function_start (gfc_symbol * sym)
1701 {
1702   tree fndecl;
1703
1704   fndecl = sym->backend_decl;
1705
1706   /* Let GCC know the current scope is this function.  */
1707   current_function_decl = fndecl;
1708
1709   /* Let the world know what we're about to do.  */
1710   announce_function (fndecl);
1711
1712   if (DECL_CONTEXT (fndecl) == NULL_TREE)
1713     {
1714       /* Create RTL for function declaration.  */
1715       rest_of_decl_compilation (fndecl, 1, 0);
1716     }
1717
1718   /* Create RTL for function definition.  */
1719   make_decl_rtl (fndecl);
1720
1721   init_function_start (fndecl);
1722
1723   /* Even though we're inside a function body, we still don't want to
1724      call expand_expr to calculate the size of a variable-sized array.
1725      We haven't necessarily assigned RTL to all variables yet, so it's
1726      not safe to try to expand expressions involving them.  */
1727   cfun->dont_save_pending_sizes_p = 1;
1728
1729   /* function.c requires a push at the start of the function.  */
1730   pushlevel (0);
1731 }
1732
1733 /* Create thunks for alternate entry points.  */
1734
1735 static void
1736 build_entry_thunks (gfc_namespace * ns)
1737 {
1738   gfc_formal_arglist *formal;
1739   gfc_formal_arglist *thunk_formal;
1740   gfc_entry_list *el;
1741   gfc_symbol *thunk_sym;
1742   stmtblock_t body;
1743   tree thunk_fndecl;
1744   tree args;
1745   tree string_args;
1746   tree tmp;
1747   locus old_loc;
1748
1749   /* This should always be a toplevel function.  */
1750   gcc_assert (current_function_decl == NULL_TREE);
1751
1752   gfc_get_backend_locus (&old_loc);
1753   for (el = ns->entries; el; el = el->next)
1754     {
1755       thunk_sym = el->sym;
1756
1757       build_function_decl (thunk_sym);
1758       create_function_arglist (thunk_sym);
1759
1760       trans_function_start (thunk_sym);
1761
1762       thunk_fndecl = thunk_sym->backend_decl;
1763
1764       gfc_init_block (&body);
1765
1766       /* Pass extra parameter identifying this entry point.  */
1767       tmp = build_int_cst (gfc_array_index_type, el->id);
1768       args = tree_cons (NULL_TREE, tmp, NULL_TREE);
1769       string_args = NULL_TREE;
1770
1771       if (thunk_sym->attr.function)
1772         {
1773           if (gfc_return_by_reference (ns->proc_name))
1774             {
1775               tree ref = DECL_ARGUMENTS (current_function_decl);
1776               args = tree_cons (NULL_TREE, ref, args);
1777               if (ns->proc_name->ts.type == BT_CHARACTER)
1778                 args = tree_cons (NULL_TREE, TREE_CHAIN (ref),
1779                                   args);
1780             }
1781         }
1782
1783       for (formal = ns->proc_name->formal; formal; formal = formal->next)
1784         {
1785           /* Ignore alternate returns.  */
1786           if (formal->sym == NULL)
1787             continue;
1788
1789           /* We don't have a clever way of identifying arguments, so resort to
1790              a brute-force search.  */
1791           for (thunk_formal = thunk_sym->formal;
1792                thunk_formal;
1793                thunk_formal = thunk_formal->next)
1794             {
1795               if (thunk_formal->sym == formal->sym)
1796                 break;
1797             }
1798
1799           if (thunk_formal)
1800             {
1801               /* Pass the argument.  */
1802               DECL_ARTIFICIAL (thunk_formal->sym->backend_decl) = 1;
1803               args = tree_cons (NULL_TREE, thunk_formal->sym->backend_decl,
1804                                 args);
1805               if (formal->sym->ts.type == BT_CHARACTER)
1806                 {
1807                   tmp = thunk_formal->sym->ts.cl->backend_decl;
1808                   string_args = tree_cons (NULL_TREE, tmp, string_args);
1809                 }
1810             }
1811           else
1812             {
1813               /* Pass NULL for a missing argument.  */
1814               args = tree_cons (NULL_TREE, null_pointer_node, args);
1815               if (formal->sym->ts.type == BT_CHARACTER)
1816                 {
1817                   tmp = build_int_cst (gfc_charlen_type_node, 0);
1818                   string_args = tree_cons (NULL_TREE, tmp, string_args);
1819                 }
1820             }
1821         }
1822
1823       /* Call the master function.  */
1824       args = nreverse (args);
1825       args = chainon (args, nreverse (string_args));
1826       tmp = ns->proc_name->backend_decl;
1827       tmp = build_function_call_expr (tmp, args);
1828       if (ns->proc_name->attr.mixed_entry_master)
1829         {
1830           tree union_decl, field;
1831           tree master_type = TREE_TYPE (ns->proc_name->backend_decl);
1832
1833           union_decl = build_decl (VAR_DECL, get_identifier ("__result"),
1834                                    TREE_TYPE (master_type));
1835           DECL_ARTIFICIAL (union_decl) = 1;
1836           DECL_EXTERNAL (union_decl) = 0;
1837           TREE_PUBLIC (union_decl) = 0;
1838           TREE_USED (union_decl) = 1;
1839           layout_decl (union_decl, 0);
1840           pushdecl (union_decl);
1841
1842           DECL_CONTEXT (union_decl) = current_function_decl;
1843           tmp = fold_build2 (MODIFY_EXPR, TREE_TYPE (union_decl),
1844                              union_decl, tmp);
1845           gfc_add_expr_to_block (&body, tmp);
1846
1847           for (field = TYPE_FIELDS (TREE_TYPE (union_decl));
1848                field; field = TREE_CHAIN (field))
1849             if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
1850                 thunk_sym->result->name) == 0)
1851               break;
1852           gcc_assert (field != NULL_TREE);
1853           tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
1854                              union_decl, field, NULL_TREE);
1855           tmp = fold_build2 (MODIFY_EXPR,
1856                              TREE_TYPE (DECL_RESULT (current_function_decl)),
1857                              DECL_RESULT (current_function_decl), tmp);
1858           tmp = build1_v (RETURN_EXPR, tmp);
1859         }
1860       else if (TREE_TYPE (DECL_RESULT (current_function_decl))
1861                != void_type_node)
1862         {
1863           tmp = fold_build2 (MODIFY_EXPR,
1864                              TREE_TYPE (DECL_RESULT (current_function_decl)),
1865                              DECL_RESULT (current_function_decl), tmp);
1866           tmp = build1_v (RETURN_EXPR, tmp);
1867         }
1868       gfc_add_expr_to_block (&body, tmp);
1869
1870       /* Finish off this function and send it for code generation.  */
1871       DECL_SAVED_TREE (thunk_fndecl) = gfc_finish_block (&body);
1872       tmp = getdecls ();
1873       poplevel (1, 0, 1);
1874       BLOCK_SUPERCONTEXT (DECL_INITIAL (thunk_fndecl)) = thunk_fndecl;
1875       DECL_SAVED_TREE (thunk_fndecl)
1876         = build3_v (BIND_EXPR, tmp, DECL_SAVED_TREE (thunk_fndecl),
1877                     DECL_INITIAL (thunk_fndecl));
1878
1879       /* Output the GENERIC tree.  */
1880       dump_function (TDI_original, thunk_fndecl);
1881
1882       /* Store the end of the function, so that we get good line number
1883          info for the epilogue.  */
1884       cfun->function_end_locus = input_location;
1885
1886       /* We're leaving the context of this function, so zap cfun.
1887          It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
1888          tree_rest_of_compilation.  */
1889       set_cfun (NULL);
1890
1891       current_function_decl = NULL_TREE;
1892
1893       gfc_gimplify_function (thunk_fndecl);
1894       cgraph_finalize_function (thunk_fndecl, false);
1895
1896       /* We share the symbols in the formal argument list with other entry
1897          points and the master function.  Clear them so that they are
1898          recreated for each function.  */
1899       for (formal = thunk_sym->formal; formal; formal = formal->next)
1900         if (formal->sym != NULL)  /* Ignore alternate returns.  */
1901           {
1902             formal->sym->backend_decl = NULL_TREE;
1903             if (formal->sym->ts.type == BT_CHARACTER)
1904               formal->sym->ts.cl->backend_decl = NULL_TREE;
1905           }
1906
1907       if (thunk_sym->attr.function)
1908         {
1909           if (thunk_sym->ts.type == BT_CHARACTER)
1910             thunk_sym->ts.cl->backend_decl = NULL_TREE;
1911           if (thunk_sym->result->ts.type == BT_CHARACTER)
1912             thunk_sym->result->ts.cl->backend_decl = NULL_TREE;
1913         }
1914     }
1915
1916   gfc_set_backend_locus (&old_loc);
1917 }
1918
1919
1920 /* Create a decl for a function, and create any thunks for alternate entry
1921    points.  */
1922
1923 void
1924 gfc_create_function_decl (gfc_namespace * ns)
1925 {
1926   /* Create a declaration for the master function.  */
1927   build_function_decl (ns->proc_name);
1928
1929   /* Compile the entry thunks.  */
1930   if (ns->entries)
1931     build_entry_thunks (ns);
1932
1933   /* Now create the read argument list.  */
1934   create_function_arglist (ns->proc_name);
1935 }
1936
1937 /* Return the decl used to hold the function return value.  If
1938    parent_flag is set, the context is the parent_scope.  */
1939
1940 tree
1941 gfc_get_fake_result_decl (gfc_symbol * sym, int parent_flag)
1942 {
1943   tree decl;
1944   tree length;
1945   tree this_fake_result_decl;
1946   tree this_function_decl;
1947
1948   char name[GFC_MAX_SYMBOL_LEN + 10];
1949
1950   if (parent_flag)
1951     {
1952       this_fake_result_decl = parent_fake_result_decl;
1953       this_function_decl = DECL_CONTEXT (current_function_decl);
1954     }
1955   else
1956     {
1957       this_fake_result_decl = current_fake_result_decl;
1958       this_function_decl = current_function_decl;
1959     }
1960
1961   if (sym
1962       && sym->ns->proc_name->backend_decl == this_function_decl
1963       && sym->ns->proc_name->attr.entry_master
1964       && sym != sym->ns->proc_name)
1965     {
1966       tree t = NULL, var;
1967       if (this_fake_result_decl != NULL)
1968         for (t = TREE_CHAIN (this_fake_result_decl); t; t = TREE_CHAIN (t))
1969           if (strcmp (IDENTIFIER_POINTER (TREE_PURPOSE (t)), sym->name) == 0)
1970             break;
1971       if (t)
1972         return TREE_VALUE (t);
1973       decl = gfc_get_fake_result_decl (sym->ns->proc_name, parent_flag);
1974
1975       if (parent_flag)
1976         this_fake_result_decl = parent_fake_result_decl;
1977       else
1978         this_fake_result_decl = current_fake_result_decl;
1979
1980       if (decl && sym->ns->proc_name->attr.mixed_entry_master)
1981         {
1982           tree field;
1983
1984           for (field = TYPE_FIELDS (TREE_TYPE (decl));
1985                field; field = TREE_CHAIN (field))
1986             if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
1987                 sym->name) == 0)
1988               break;
1989
1990           gcc_assert (field != NULL_TREE);
1991           decl = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
1992                               decl, field, NULL_TREE);
1993         }
1994
1995       var = create_tmp_var_raw (TREE_TYPE (decl), sym->name);
1996       if (parent_flag)
1997         gfc_add_decl_to_parent_function (var);
1998       else
1999         gfc_add_decl_to_function (var);
2000
2001       SET_DECL_VALUE_EXPR (var, decl);
2002       DECL_HAS_VALUE_EXPR_P (var) = 1;
2003       GFC_DECL_RESULT (var) = 1;
2004
2005       TREE_CHAIN (this_fake_result_decl)
2006           = tree_cons (get_identifier (sym->name), var,
2007                        TREE_CHAIN (this_fake_result_decl));
2008       return var;
2009     }
2010
2011   if (this_fake_result_decl != NULL_TREE)
2012     return TREE_VALUE (this_fake_result_decl);
2013
2014   /* Only when gfc_get_fake_result_decl is called by gfc_trans_return,
2015      sym is NULL.  */
2016   if (!sym)
2017     return NULL_TREE;
2018
2019   if (sym->ts.type == BT_CHARACTER)
2020     {
2021       if (sym->ts.cl->backend_decl == NULL_TREE)
2022         length = gfc_create_string_length (sym);
2023       else
2024         length = sym->ts.cl->backend_decl;
2025       if (TREE_CODE (length) == VAR_DECL
2026           && DECL_CONTEXT (length) == NULL_TREE)
2027         gfc_add_decl_to_function (length);
2028     }
2029
2030   if (gfc_return_by_reference (sym))
2031     {
2032       decl = DECL_ARGUMENTS (this_function_decl);
2033
2034       if (sym->ns->proc_name->backend_decl == this_function_decl
2035           && sym->ns->proc_name->attr.entry_master)
2036         decl = TREE_CHAIN (decl);
2037
2038       TREE_USED (decl) = 1;
2039       if (sym->as)
2040         decl = gfc_build_dummy_array_decl (sym, decl);
2041     }
2042   else
2043     {
2044       sprintf (name, "__result_%.20s",
2045                IDENTIFIER_POINTER (DECL_NAME (this_function_decl)));
2046
2047       if (!sym->attr.mixed_entry_master && sym->attr.function)
2048         decl = build_decl (VAR_DECL, get_identifier (name),
2049                            gfc_sym_type (sym));
2050       else
2051         decl = build_decl (VAR_DECL, get_identifier (name),
2052                            TREE_TYPE (TREE_TYPE (this_function_decl)));
2053       DECL_ARTIFICIAL (decl) = 1;
2054       DECL_EXTERNAL (decl) = 0;
2055       TREE_PUBLIC (decl) = 0;
2056       TREE_USED (decl) = 1;
2057       GFC_DECL_RESULT (decl) = 1;
2058       TREE_ADDRESSABLE (decl) = 1;
2059
2060       layout_decl (decl, 0);
2061
2062       if (parent_flag)
2063         gfc_add_decl_to_parent_function (decl);
2064       else
2065         gfc_add_decl_to_function (decl);
2066     }
2067
2068   if (parent_flag)
2069     parent_fake_result_decl = build_tree_list (NULL, decl);
2070   else
2071     current_fake_result_decl = build_tree_list (NULL, decl);
2072
2073   return decl;
2074 }
2075
2076
2077 /* Builds a function decl.  The remaining parameters are the types of the
2078    function arguments.  Negative nargs indicates a varargs function.  */
2079
2080 tree
2081 gfc_build_library_function_decl (tree name, tree rettype, int nargs, ...)
2082 {
2083   tree arglist;
2084   tree argtype;
2085   tree fntype;
2086   tree fndecl;
2087   va_list p;
2088   int n;
2089
2090   /* Library functions must be declared with global scope.  */
2091   gcc_assert (current_function_decl == NULL_TREE);
2092
2093   va_start (p, nargs);
2094
2095
2096   /* Create a list of the argument types.  */
2097   for (arglist = NULL_TREE, n = abs (nargs); n > 0; n--)
2098     {
2099       argtype = va_arg (p, tree);
2100       arglist = gfc_chainon_list (arglist, argtype);
2101     }
2102
2103   if (nargs >= 0)
2104     {
2105       /* Terminate the list.  */
2106       arglist = gfc_chainon_list (arglist, void_type_node);
2107     }
2108
2109   /* Build the function type and decl.  */
2110   fntype = build_function_type (rettype, arglist);
2111   fndecl = build_decl (FUNCTION_DECL, name, fntype);
2112
2113   /* Mark this decl as external.  */
2114   DECL_EXTERNAL (fndecl) = 1;
2115   TREE_PUBLIC (fndecl) = 1;
2116
2117   va_end (p);
2118
2119   pushdecl (fndecl);
2120
2121   rest_of_decl_compilation (fndecl, 1, 0);
2122
2123   return fndecl;
2124 }
2125
2126 static void
2127 gfc_build_intrinsic_function_decls (void)
2128 {
2129   tree gfc_int4_type_node = gfc_get_int_type (4);
2130   tree gfc_int8_type_node = gfc_get_int_type (8);
2131   tree gfc_int16_type_node = gfc_get_int_type (16);
2132   tree gfc_logical4_type_node = gfc_get_logical_type (4);
2133   tree pchar1_type_node = gfc_get_pchar_type (1);
2134   tree pchar4_type_node = gfc_get_pchar_type (4);
2135
2136   /* String functions.  */
2137   gfor_fndecl_compare_string =
2138     gfc_build_library_function_decl (get_identifier (PREFIX("compare_string")),
2139                                      integer_type_node, 4,
2140                                      gfc_charlen_type_node, pchar1_type_node,
2141                                      gfc_charlen_type_node, pchar1_type_node);
2142
2143   gfor_fndecl_concat_string =
2144     gfc_build_library_function_decl (get_identifier (PREFIX("concat_string")),
2145                                      void_type_node, 6,
2146                                      gfc_charlen_type_node, pchar1_type_node,
2147                                      gfc_charlen_type_node, pchar1_type_node,
2148                                      gfc_charlen_type_node, pchar1_type_node);
2149
2150   gfor_fndecl_string_len_trim =
2151     gfc_build_library_function_decl (get_identifier (PREFIX("string_len_trim")),
2152                                      gfc_int4_type_node, 2,
2153                                      gfc_charlen_type_node, pchar1_type_node);
2154
2155   gfor_fndecl_string_index =
2156     gfc_build_library_function_decl (get_identifier (PREFIX("string_index")),
2157                                      gfc_int4_type_node, 5,
2158                                      gfc_charlen_type_node, pchar1_type_node,
2159                                      gfc_charlen_type_node, pchar1_type_node,
2160                                      gfc_logical4_type_node);
2161
2162   gfor_fndecl_string_scan =
2163     gfc_build_library_function_decl (get_identifier (PREFIX("string_scan")),
2164                                      gfc_int4_type_node, 5,
2165                                      gfc_charlen_type_node, pchar1_type_node,
2166                                      gfc_charlen_type_node, pchar1_type_node,
2167                                      gfc_logical4_type_node);
2168
2169   gfor_fndecl_string_verify =
2170     gfc_build_library_function_decl (get_identifier (PREFIX("string_verify")),
2171                                      gfc_int4_type_node, 5,
2172                                      gfc_charlen_type_node, pchar1_type_node,
2173                                      gfc_charlen_type_node, pchar1_type_node,
2174                                      gfc_logical4_type_node);
2175
2176   gfor_fndecl_string_trim =
2177     gfc_build_library_function_decl (get_identifier (PREFIX("string_trim")),
2178                                      void_type_node, 4,
2179                                      build_pointer_type (gfc_charlen_type_node),
2180                                      build_pointer_type (pchar1_type_node),
2181                                      gfc_charlen_type_node, pchar1_type_node);
2182
2183   gfor_fndecl_string_minmax =
2184     gfc_build_library_function_decl (get_identifier (PREFIX("string_minmax")),
2185                                      void_type_node, -4,
2186                                      build_pointer_type (gfc_charlen_type_node),
2187                                      build_pointer_type (pchar1_type_node),
2188                                      integer_type_node, integer_type_node);
2189
2190   gfor_fndecl_adjustl =
2191     gfc_build_library_function_decl (get_identifier (PREFIX("adjustl")),
2192                                      void_type_node, 3, pchar1_type_node,
2193                                      gfc_charlen_type_node, pchar1_type_node);
2194
2195   gfor_fndecl_adjustr =
2196     gfc_build_library_function_decl (get_identifier (PREFIX("adjustr")),
2197                                      void_type_node, 3, pchar1_type_node,
2198                                      gfc_charlen_type_node, pchar1_type_node);
2199
2200   gfor_fndecl_select_string =
2201     gfc_build_library_function_decl (get_identifier (PREFIX("select_string")),
2202                                      integer_type_node, 4, pvoid_type_node,
2203                                      integer_type_node, pchar1_type_node,
2204                                      gfc_charlen_type_node);
2205
2206   gfor_fndecl_compare_string_char4 =
2207     gfc_build_library_function_decl (get_identifier
2208                                         (PREFIX("compare_string_char4")),
2209                                      integer_type_node, 4,
2210                                      gfc_charlen_type_node, pchar4_type_node,
2211                                      gfc_charlen_type_node, pchar4_type_node);
2212
2213   gfor_fndecl_concat_string_char4 =
2214     gfc_build_library_function_decl (get_identifier
2215                                         (PREFIX("concat_string_char4")),
2216                                      void_type_node, 6,
2217                                      gfc_charlen_type_node, pchar4_type_node,
2218                                      gfc_charlen_type_node, pchar4_type_node,
2219                                      gfc_charlen_type_node, pchar4_type_node);
2220
2221   gfor_fndecl_string_len_trim_char4 =
2222     gfc_build_library_function_decl (get_identifier
2223                                         (PREFIX("string_len_trim_char4")),
2224                                      gfc_charlen_type_node, 2,
2225                                      gfc_charlen_type_node, pchar4_type_node);
2226
2227   gfor_fndecl_string_index_char4 =
2228     gfc_build_library_function_decl (get_identifier
2229                                         (PREFIX("string_index_char4")),
2230                                      gfc_charlen_type_node, 5,
2231                                      gfc_charlen_type_node, pchar4_type_node,
2232                                      gfc_charlen_type_node, pchar4_type_node,
2233                                      gfc_logical4_type_node);
2234
2235   gfor_fndecl_string_scan_char4 =
2236     gfc_build_library_function_decl (get_identifier
2237                                         (PREFIX("string_scan_char4")),
2238                                      gfc_charlen_type_node, 5,
2239                                      gfc_charlen_type_node, pchar4_type_node,
2240                                      gfc_charlen_type_node, pchar4_type_node,
2241                                      gfc_logical4_type_node);
2242
2243   gfor_fndecl_string_verify_char4 =
2244     gfc_build_library_function_decl (get_identifier
2245                                         (PREFIX("string_verify_char4")),
2246                                      gfc_charlen_type_node, 5,
2247                                      gfc_charlen_type_node, pchar4_type_node,
2248                                      gfc_charlen_type_node, pchar4_type_node,
2249                                      gfc_logical4_type_node);
2250
2251   gfor_fndecl_string_trim_char4 =
2252     gfc_build_library_function_decl (get_identifier
2253                                         (PREFIX("string_trim_char4")),
2254                                      void_type_node, 4,
2255                                      build_pointer_type (gfc_charlen_type_node),
2256                                      build_pointer_type (pchar4_type_node),
2257                                      gfc_charlen_type_node, pchar4_type_node);
2258
2259   gfor_fndecl_string_minmax_char4 =
2260     gfc_build_library_function_decl (get_identifier
2261                                         (PREFIX("string_minmax_char4")),
2262                                      void_type_node, -4,
2263                                      build_pointer_type (gfc_charlen_type_node),
2264                                      build_pointer_type (pchar4_type_node),
2265                                      integer_type_node, integer_type_node);
2266
2267   gfor_fndecl_adjustl_char4 =
2268     gfc_build_library_function_decl (get_identifier (PREFIX("adjustl_char4")),
2269                                      void_type_node, 3, pchar4_type_node,
2270                                      gfc_charlen_type_node, pchar4_type_node);
2271
2272   gfor_fndecl_adjustr_char4 =
2273     gfc_build_library_function_decl (get_identifier (PREFIX("adjustr_char4")),
2274                                      void_type_node, 3, pchar4_type_node,
2275                                      gfc_charlen_type_node, pchar4_type_node);
2276
2277   gfor_fndecl_select_string_char4 =
2278     gfc_build_library_function_decl (get_identifier
2279                                         (PREFIX("select_string_char4")),
2280                                      integer_type_node, 4, pvoid_type_node,
2281                                      integer_type_node, pvoid_type_node,
2282                                      gfc_charlen_type_node);
2283
2284
2285   /* Conversion between character kinds.  */
2286
2287   gfor_fndecl_convert_char1_to_char4 =
2288     gfc_build_library_function_decl (get_identifier
2289                                         (PREFIX("convert_char1_to_char4")),
2290                                      void_type_node, 3,
2291                                      build_pointer_type (pchar4_type_node),
2292                                      gfc_charlen_type_node, pchar1_type_node);
2293
2294   gfor_fndecl_convert_char4_to_char1 =
2295     gfc_build_library_function_decl (get_identifier
2296                                         (PREFIX("convert_char4_to_char1")),
2297                                      void_type_node, 3,
2298                                      build_pointer_type (pchar1_type_node),
2299                                      gfc_charlen_type_node, pchar4_type_node);
2300
2301   /* Misc. functions.  */
2302
2303   gfor_fndecl_ttynam =
2304     gfc_build_library_function_decl (get_identifier (PREFIX("ttynam")),
2305                                      void_type_node,
2306                                      3,
2307                                      pchar_type_node,
2308                                      gfc_charlen_type_node,
2309                                      integer_type_node);
2310
2311   gfor_fndecl_fdate =
2312     gfc_build_library_function_decl (get_identifier (PREFIX("fdate")),
2313                                      void_type_node,
2314                                      2,
2315                                      pchar_type_node,
2316                                      gfc_charlen_type_node);
2317
2318   gfor_fndecl_ctime =
2319     gfc_build_library_function_decl (get_identifier (PREFIX("ctime")),
2320                                      void_type_node,
2321                                      3,
2322                                      pchar_type_node,
2323                                      gfc_charlen_type_node,
2324                                      gfc_int8_type_node);
2325
2326   gfor_fndecl_sc_kind =
2327     gfc_build_library_function_decl (get_identifier
2328                                         (PREFIX("selected_char_kind")),
2329                                      gfc_int4_type_node, 2,
2330                                      gfc_charlen_type_node, pchar_type_node);
2331
2332   gfor_fndecl_si_kind =
2333     gfc_build_library_function_decl (get_identifier
2334                                         (PREFIX("selected_int_kind")),
2335                                      gfc_int4_type_node, 1, pvoid_type_node);
2336
2337   gfor_fndecl_sr_kind =
2338     gfc_build_library_function_decl (get_identifier
2339                                         (PREFIX("selected_real_kind")),
2340                                      gfc_int4_type_node, 2,
2341                                      pvoid_type_node, pvoid_type_node);
2342
2343   /* Power functions.  */
2344   {
2345     tree ctype, rtype, itype, jtype;
2346     int rkind, ikind, jkind;
2347 #define NIKINDS 3
2348 #define NRKINDS 4
2349     static int ikinds[NIKINDS] = {4, 8, 16};
2350     static int rkinds[NRKINDS] = {4, 8, 10, 16};
2351     char name[PREFIX_LEN + 12]; /* _gfortran_pow_?n_?n */
2352
2353     for (ikind=0; ikind < NIKINDS; ikind++)
2354       {
2355         itype = gfc_get_int_type (ikinds[ikind]);
2356
2357         for (jkind=0; jkind < NIKINDS; jkind++)
2358           {
2359             jtype = gfc_get_int_type (ikinds[jkind]);
2360             if (itype && jtype)
2361               {
2362                 sprintf(name, PREFIX("pow_i%d_i%d"), ikinds[ikind],
2363                         ikinds[jkind]);
2364                 gfor_fndecl_math_powi[jkind][ikind].integer =
2365                   gfc_build_library_function_decl (get_identifier (name),
2366                     jtype, 2, jtype, itype);
2367                 TREE_READONLY (gfor_fndecl_math_powi[jkind][ikind].integer) = 1;
2368               }
2369           }
2370
2371         for (rkind = 0; rkind < NRKINDS; rkind ++)
2372           {
2373             rtype = gfc_get_real_type (rkinds[rkind]);
2374             if (rtype && itype)
2375               {
2376                 sprintf(name, PREFIX("pow_r%d_i%d"), rkinds[rkind],
2377                         ikinds[ikind]);
2378                 gfor_fndecl_math_powi[rkind][ikind].real =
2379                   gfc_build_library_function_decl (get_identifier (name),
2380                     rtype, 2, rtype, itype);
2381                 TREE_READONLY (gfor_fndecl_math_powi[rkind][ikind].real) = 1;
2382               }
2383
2384             ctype = gfc_get_complex_type (rkinds[rkind]);
2385             if (ctype && itype)
2386               {
2387                 sprintf(name, PREFIX("pow_c%d_i%d"), rkinds[rkind],
2388                         ikinds[ikind]);
2389                 gfor_fndecl_math_powi[rkind][ikind].cmplx =
2390                   gfc_build_library_function_decl (get_identifier (name),
2391                     ctype, 2,ctype, itype);
2392                 TREE_READONLY (gfor_fndecl_math_powi[rkind][ikind].cmplx) = 1;
2393               }
2394           }
2395       }
2396 #undef NIKINDS
2397 #undef NRKINDS
2398   }
2399
2400   gfor_fndecl_math_ishftc4 =
2401     gfc_build_library_function_decl (get_identifier (PREFIX("ishftc4")),
2402                                      gfc_int4_type_node,
2403                                      3, gfc_int4_type_node,
2404                                      gfc_int4_type_node, gfc_int4_type_node);
2405   gfor_fndecl_math_ishftc8 =
2406     gfc_build_library_function_decl (get_identifier (PREFIX("ishftc8")),
2407                                      gfc_int8_type_node,
2408                                      3, gfc_int8_type_node,
2409                                      gfc_int4_type_node, gfc_int4_type_node);
2410   if (gfc_int16_type_node)
2411     gfor_fndecl_math_ishftc16 =
2412       gfc_build_library_function_decl (get_identifier (PREFIX("ishftc16")),
2413                                        gfc_int16_type_node, 3,
2414                                        gfc_int16_type_node,
2415                                        gfc_int4_type_node,
2416                                        gfc_int4_type_node);
2417
2418   /* BLAS functions.  */
2419   {
2420     tree pint = build_pointer_type (integer_type_node);
2421     tree ps = build_pointer_type (gfc_get_real_type (gfc_default_real_kind));
2422     tree pd = build_pointer_type (gfc_get_real_type (gfc_default_double_kind));
2423     tree pc = build_pointer_type (gfc_get_complex_type (gfc_default_real_kind));
2424     tree pz = build_pointer_type
2425                 (gfc_get_complex_type (gfc_default_double_kind));
2426
2427     gfor_fndecl_sgemm = gfc_build_library_function_decl
2428                           (get_identifier
2429                              (gfc_option.flag_underscoring ? "sgemm_"
2430                                                            : "sgemm"),
2431                            void_type_node, 15, pchar_type_node,
2432                            pchar_type_node, pint, pint, pint, ps, ps, pint,
2433                            ps, pint, ps, ps, pint, integer_type_node,
2434                            integer_type_node);
2435     gfor_fndecl_dgemm = gfc_build_library_function_decl
2436                           (get_identifier
2437                              (gfc_option.flag_underscoring ? "dgemm_"
2438                                                            : "dgemm"),
2439                            void_type_node, 15, pchar_type_node,
2440                            pchar_type_node, pint, pint, pint, pd, pd, pint,
2441                            pd, pint, pd, pd, pint, integer_type_node,
2442                            integer_type_node);
2443     gfor_fndecl_cgemm = gfc_build_library_function_decl
2444                           (get_identifier
2445                              (gfc_option.flag_underscoring ? "cgemm_"
2446                                                            : "cgemm"),
2447                            void_type_node, 15, pchar_type_node,
2448                            pchar_type_node, pint, pint, pint, pc, pc, pint,
2449                            pc, pint, pc, pc, pint, integer_type_node,
2450                            integer_type_node);
2451     gfor_fndecl_zgemm = gfc_build_library_function_decl
2452                           (get_identifier
2453                              (gfc_option.flag_underscoring ? "zgemm_"
2454                                                            : "zgemm"),
2455                            void_type_node, 15, pchar_type_node,
2456                            pchar_type_node, pint, pint, pint, pz, pz, pint,
2457                            pz, pint, pz, pz, pint, integer_type_node,
2458                            integer_type_node);
2459   }
2460
2461   /* Other functions.  */
2462   gfor_fndecl_size0 =
2463     gfc_build_library_function_decl (get_identifier (PREFIX("size0")),
2464                                      gfc_array_index_type,
2465                                      1, pvoid_type_node);
2466   gfor_fndecl_size1 =
2467     gfc_build_library_function_decl (get_identifier (PREFIX("size1")),
2468                                      gfc_array_index_type,
2469                                      2, pvoid_type_node,
2470                                      gfc_array_index_type);
2471
2472   gfor_fndecl_iargc =
2473     gfc_build_library_function_decl (get_identifier (PREFIX ("iargc")),
2474                                      gfc_int4_type_node,
2475                                      0);
2476 }
2477
2478
2479 /* Make prototypes for runtime library functions.  */
2480
2481 void
2482 gfc_build_builtin_function_decls (void)
2483 {
2484   tree gfc_int4_type_node = gfc_get_int_type (4);
2485
2486   gfor_fndecl_stop_numeric =
2487     gfc_build_library_function_decl (get_identifier (PREFIX("stop_numeric")),
2488                                      void_type_node, 1, gfc_int4_type_node);
2489   /* Stop doesn't return.  */
2490   TREE_THIS_VOLATILE (gfor_fndecl_stop_numeric) = 1;
2491
2492   gfor_fndecl_stop_string =
2493     gfc_build_library_function_decl (get_identifier (PREFIX("stop_string")),
2494                                      void_type_node, 2, pchar_type_node,
2495                                      gfc_int4_type_node);
2496   /* Stop doesn't return.  */
2497   TREE_THIS_VOLATILE (gfor_fndecl_stop_string) = 1;
2498
2499   gfor_fndecl_pause_numeric =
2500     gfc_build_library_function_decl (get_identifier (PREFIX("pause_numeric")),
2501                                      void_type_node, 1, gfc_int4_type_node);
2502
2503   gfor_fndecl_pause_string =
2504     gfc_build_library_function_decl (get_identifier (PREFIX("pause_string")),
2505                                      void_type_node, 2, pchar_type_node,
2506                                      gfc_int4_type_node);
2507
2508   gfor_fndecl_runtime_error =
2509     gfc_build_library_function_decl (get_identifier (PREFIX("runtime_error")),
2510                                      void_type_node, -1, pchar_type_node);
2511   /* The runtime_error function does not return.  */
2512   TREE_THIS_VOLATILE (gfor_fndecl_runtime_error) = 1;
2513
2514   gfor_fndecl_runtime_error_at =
2515     gfc_build_library_function_decl (get_identifier (PREFIX("runtime_error_at")),
2516                                      void_type_node, -2, pchar_type_node,
2517                                      pchar_type_node);
2518   /* The runtime_error_at function does not return.  */
2519   TREE_THIS_VOLATILE (gfor_fndecl_runtime_error_at) = 1;
2520
2521   gfor_fndecl_runtime_warning_at =
2522     gfc_build_library_function_decl (get_identifier (PREFIX("runtime_warning_at")),
2523                                      void_type_node, -2, pchar_type_node,
2524                                      pchar_type_node);
2525   gfor_fndecl_generate_error =
2526     gfc_build_library_function_decl (get_identifier (PREFIX("generate_error")),
2527                                      void_type_node, 3, pvoid_type_node,
2528                                      integer_type_node, pchar_type_node);
2529
2530   gfor_fndecl_os_error =
2531     gfc_build_library_function_decl (get_identifier (PREFIX("os_error")),
2532                                      void_type_node, 1, pchar_type_node);
2533   /* The runtime_error function does not return.  */
2534   TREE_THIS_VOLATILE (gfor_fndecl_os_error) = 1;
2535
2536   gfor_fndecl_set_fpe =
2537     gfc_build_library_function_decl (get_identifier (PREFIX("set_fpe")),
2538                                     void_type_node, 1, integer_type_node);
2539
2540   /* Keep the array dimension in sync with the call, later in this file.  */
2541   gfor_fndecl_set_options =
2542     gfc_build_library_function_decl (get_identifier (PREFIX("set_options")),
2543                                     void_type_node, 2, integer_type_node,
2544                                     pvoid_type_node);
2545
2546   gfor_fndecl_set_convert =
2547     gfc_build_library_function_decl (get_identifier (PREFIX("set_convert")),
2548                                      void_type_node, 1, integer_type_node);
2549
2550   gfor_fndecl_set_record_marker =
2551     gfc_build_library_function_decl (get_identifier (PREFIX("set_record_marker")),
2552                                      void_type_node, 1, integer_type_node);
2553
2554   gfor_fndecl_set_max_subrecord_length =
2555     gfc_build_library_function_decl (get_identifier (PREFIX("set_max_subrecord_length")),
2556                                      void_type_node, 1, integer_type_node);
2557
2558   gfor_fndecl_in_pack = gfc_build_library_function_decl (
2559         get_identifier (PREFIX("internal_pack")),
2560         pvoid_type_node, 1, pvoid_type_node);
2561
2562   gfor_fndecl_in_unpack = gfc_build_library_function_decl (
2563         get_identifier (PREFIX("internal_unpack")),
2564         void_type_node, 2, pvoid_type_node, pvoid_type_node);
2565
2566   gfor_fndecl_associated =
2567     gfc_build_library_function_decl (
2568                                      get_identifier (PREFIX("associated")),
2569                                      integer_type_node, 2, ppvoid_type_node,
2570                                      ppvoid_type_node);
2571
2572   gfc_build_intrinsic_function_decls ();
2573   gfc_build_intrinsic_lib_fndecls ();
2574   gfc_build_io_library_fndecls ();
2575 }
2576
2577
2578 /* Evaluate the length of dummy character variables.  */
2579
2580 static tree
2581 gfc_trans_dummy_character (gfc_symbol *sym, gfc_charlen *cl, tree fnbody)
2582 {
2583   stmtblock_t body;
2584
2585   gfc_finish_decl (cl->backend_decl);
2586
2587   gfc_start_block (&body);
2588
2589   /* Evaluate the string length expression.  */
2590   gfc_conv_string_length (cl, NULL, &body);
2591
2592   gfc_trans_vla_type_sizes (sym, &body);
2593
2594   gfc_add_expr_to_block (&body, fnbody);
2595   return gfc_finish_block (&body);
2596 }
2597
2598
2599 /* Allocate and cleanup an automatic character variable.  */
2600
2601 static tree
2602 gfc_trans_auto_character_variable (gfc_symbol * sym, tree fnbody)
2603 {
2604   stmtblock_t body;
2605   tree decl;
2606   tree tmp;
2607
2608   gcc_assert (sym->backend_decl);
2609   gcc_assert (sym->ts.cl && sym->ts.cl->length);
2610
2611   gfc_start_block (&body);
2612
2613   /* Evaluate the string length expression.  */
2614   gfc_conv_string_length (sym->ts.cl, NULL, &body);
2615
2616   gfc_trans_vla_type_sizes (sym, &body);
2617
2618   decl = sym->backend_decl;
2619
2620   /* Emit a DECL_EXPR for this variable, which will cause the
2621      gimplifier to allocate storage, and all that good stuff.  */
2622   tmp = fold_build1 (DECL_EXPR, TREE_TYPE (decl), decl);
2623   gfc_add_expr_to_block (&body, tmp);
2624
2625   gfc_add_expr_to_block (&body, fnbody);
2626   return gfc_finish_block (&body);
2627 }
2628
2629 /* Set the initial value of ASSIGN statement auxiliary variable explicitly.  */
2630
2631 static tree
2632 gfc_trans_assign_aux_var (gfc_symbol * sym, tree fnbody)
2633 {
2634   stmtblock_t body;
2635
2636   gcc_assert (sym->backend_decl);
2637   gfc_start_block (&body);
2638
2639   /* Set the initial value to length. See the comments in
2640      function gfc_add_assign_aux_vars in this file.  */
2641   gfc_add_modify (&body, GFC_DECL_STRING_LEN (sym->backend_decl),
2642                        build_int_cst (NULL_TREE, -2));
2643
2644   gfc_add_expr_to_block (&body, fnbody);
2645   return gfc_finish_block (&body);
2646 }
2647
2648 static void
2649 gfc_trans_vla_one_sizepos (tree *tp, stmtblock_t *body)
2650 {
2651   tree t = *tp, var, val;
2652
2653   if (t == NULL || t == error_mark_node)
2654     return;
2655   if (TREE_CONSTANT (t) || DECL_P (t))
2656     return;
2657
2658   if (TREE_CODE (t) == SAVE_EXPR)
2659     {
2660       if (SAVE_EXPR_RESOLVED_P (t))
2661         {
2662           *tp = TREE_OPERAND (t, 0);
2663           return;
2664         }
2665       val = TREE_OPERAND (t, 0);
2666     }
2667   else
2668     val = t;
2669
2670   var = gfc_create_var_np (TREE_TYPE (t), NULL);
2671   gfc_add_decl_to_function (var);
2672   gfc_add_modify (body, var, val);
2673   if (TREE_CODE (t) == SAVE_EXPR)
2674     TREE_OPERAND (t, 0) = var;
2675   *tp = var;
2676 }
2677
2678 static void
2679 gfc_trans_vla_type_sizes_1 (tree type, stmtblock_t *body)
2680 {
2681   tree t;
2682
2683   if (type == NULL || type == error_mark_node)
2684     return;
2685
2686   type = TYPE_MAIN_VARIANT (type);
2687
2688   if (TREE_CODE (type) == INTEGER_TYPE)
2689     {
2690       gfc_trans_vla_one_sizepos (&TYPE_MIN_VALUE (type), body);
2691       gfc_trans_vla_one_sizepos (&TYPE_MAX_VALUE (type), body);
2692
2693       for (t = TYPE_NEXT_VARIANT (type); t; t = TYPE_NEXT_VARIANT (t))
2694         {
2695           TYPE_MIN_VALUE (t) = TYPE_MIN_VALUE (type);
2696           TYPE_MAX_VALUE (t) = TYPE_MAX_VALUE (type);
2697         }
2698     }
2699   else if (TREE_CODE (type) == ARRAY_TYPE)
2700     {
2701       gfc_trans_vla_type_sizes_1 (TREE_TYPE (type), body);
2702       gfc_trans_vla_type_sizes_1 (TYPE_DOMAIN (type), body);
2703       gfc_trans_vla_one_sizepos (&TYPE_SIZE (type), body);
2704       gfc_trans_vla_one_sizepos (&TYPE_SIZE_UNIT (type), body);
2705
2706       for (t = TYPE_NEXT_VARIANT (type); t; t = TYPE_NEXT_VARIANT (t))
2707         {
2708           TYPE_SIZE (t) = TYPE_SIZE (type);
2709           TYPE_SIZE_UNIT (t) = TYPE_SIZE_UNIT (type);
2710         }
2711     }
2712 }
2713
2714 /* Make sure all type sizes and array domains are either constant,
2715    or variable or parameter decls.  This is a simplified variant
2716    of gimplify_type_sizes, but we can't use it here, as none of the
2717    variables in the expressions have been gimplified yet.
2718    As type sizes and domains for various variable length arrays
2719    contain VAR_DECLs that are only initialized at gfc_trans_deferred_vars
2720    time, without this routine gimplify_type_sizes in the middle-end
2721    could result in the type sizes being gimplified earlier than where
2722    those variables are initialized.  */
2723
2724 void
2725 gfc_trans_vla_type_sizes (gfc_symbol *sym, stmtblock_t *body)
2726 {
2727   tree type = TREE_TYPE (sym->backend_decl);
2728
2729   if (TREE_CODE (type) == FUNCTION_TYPE
2730       && (sym->attr.function || sym->attr.result || sym->attr.entry))
2731     {
2732       if (! current_fake_result_decl)
2733         return;
2734
2735       type = TREE_TYPE (TREE_VALUE (current_fake_result_decl));
2736     }
2737
2738   while (POINTER_TYPE_P (type))
2739     type = TREE_TYPE (type);
2740
2741   if (GFC_DESCRIPTOR_TYPE_P (type))
2742     {
2743       tree etype = GFC_TYPE_ARRAY_DATAPTR_TYPE (type);
2744
2745       while (POINTER_TYPE_P (etype))
2746         etype = TREE_TYPE (etype);
2747
2748       gfc_trans_vla_type_sizes_1 (etype, body);
2749     }
2750
2751   gfc_trans_vla_type_sizes_1 (type, body);
2752 }
2753
2754
2755 /* Initialize a derived type by building an lvalue from the symbol
2756    and using trans_assignment to do the work.  */
2757 tree
2758 gfc_init_default_dt (gfc_symbol * sym, tree body)
2759 {
2760   stmtblock_t fnblock;
2761   gfc_expr *e;
2762   tree tmp;
2763   tree present;
2764
2765   gfc_init_block (&fnblock);
2766   gcc_assert (!sym->attr.allocatable);
2767   gfc_set_sym_referenced (sym);
2768   e = gfc_lval_expr_from_sym (sym);
2769   tmp = gfc_trans_assignment (e, sym->value, false);
2770   if (sym->attr.dummy)
2771     {
2772       present = gfc_conv_expr_present (sym);
2773       tmp = build3 (COND_EXPR, TREE_TYPE (tmp), present,
2774                     tmp, build_empty_stmt ());
2775     }
2776   gfc_add_expr_to_block (&fnblock, tmp);
2777   gfc_free_expr (e);
2778   if (body)
2779     gfc_add_expr_to_block (&fnblock, body);
2780   return gfc_finish_block (&fnblock);
2781 }
2782
2783
2784 /* Initialize INTENT(OUT) derived type dummies.  As well as giving
2785    them their default initializer, if they do not have allocatable
2786    components, they have their allocatable components deallocated. */
2787
2788 static tree
2789 init_intent_out_dt (gfc_symbol * proc_sym, tree body)
2790 {
2791   stmtblock_t fnblock;
2792   gfc_formal_arglist *f;
2793   tree tmp;
2794   tree present;
2795
2796   gfc_init_block (&fnblock);
2797   for (f = proc_sym->formal; f; f = f->next)
2798     if (f->sym && f->sym->attr.intent == INTENT_OUT
2799           && f->sym->ts.type == BT_DERIVED)
2800       {
2801         if (f->sym->ts.derived->attr.alloc_comp)
2802           {
2803             tmp = gfc_deallocate_alloc_comp (f->sym->ts.derived,
2804                                              f->sym->backend_decl,
2805                                              f->sym->as ? f->sym->as->rank : 0);
2806
2807             present = gfc_conv_expr_present (f->sym);
2808             tmp = build3 (COND_EXPR, TREE_TYPE (tmp), present,
2809                           tmp, build_empty_stmt ());
2810
2811             gfc_add_expr_to_block (&fnblock, tmp);
2812           }
2813
2814         if (!f->sym->ts.derived->attr.alloc_comp
2815               && f->sym->value)
2816           body = gfc_init_default_dt (f->sym, body);
2817       }
2818
2819   gfc_add_expr_to_block (&fnblock, body);
2820   return gfc_finish_block (&fnblock);
2821 }
2822
2823
2824 /* Generate function entry and exit code, and add it to the function body.
2825    This includes:
2826     Allocation and initialization of array variables.
2827     Allocation of character string variables.
2828     Initialization and possibly repacking of dummy arrays.
2829     Initialization of ASSIGN statement auxiliary variable.  */
2830
2831 static tree
2832 gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
2833 {
2834   locus loc;
2835   gfc_symbol *sym;
2836   gfc_formal_arglist *f;
2837   stmtblock_t body;
2838   bool seen_trans_deferred_array = false;
2839
2840   /* Deal with implicit return variables.  Explicit return variables will
2841      already have been added.  */
2842   if (gfc_return_by_reference (proc_sym) && proc_sym->result == proc_sym)
2843     {
2844       if (!current_fake_result_decl)
2845         {
2846           gfc_entry_list *el = NULL;
2847           if (proc_sym->attr.entry_master)
2848             {
2849               for (el = proc_sym->ns->entries; el; el = el->next)
2850                 if (el->sym != el->sym->result)
2851                   break;
2852             }
2853           /* TODO: move to the appropriate place in resolve.c.  */
2854           if (warn_return_type && el == NULL)
2855             gfc_warning ("Return value of function '%s' at %L not set",
2856                          proc_sym->name, &proc_sym->declared_at);
2857         }
2858       else if (proc_sym->as)
2859         {
2860           tree result = TREE_VALUE (current_fake_result_decl);
2861           fnbody = gfc_trans_dummy_array_bias (proc_sym, result, fnbody);
2862
2863           /* An automatic character length, pointer array result.  */
2864           if (proc_sym->ts.type == BT_CHARACTER
2865                 && TREE_CODE (proc_sym->ts.cl->backend_decl) == VAR_DECL)
2866             fnbody = gfc_trans_dummy_character (proc_sym, proc_sym->ts.cl,
2867                                                 fnbody);
2868         }
2869       else if (proc_sym->ts.type == BT_CHARACTER)
2870         {
2871           if (TREE_CODE (proc_sym->ts.cl->backend_decl) == VAR_DECL)
2872             fnbody = gfc_trans_dummy_character (proc_sym, proc_sym->ts.cl,
2873                                                 fnbody);
2874         }
2875       else
2876         gcc_assert (gfc_option.flag_f2c
2877                     && proc_sym->ts.type == BT_COMPLEX);
2878     }
2879
2880   /* Initialize the INTENT(OUT) derived type dummy arguments.  This
2881      should be done here so that the offsets and lbounds of arrays
2882      are available.  */
2883   fnbody = init_intent_out_dt (proc_sym, fnbody);
2884
2885   for (sym = proc_sym->tlink; sym != proc_sym; sym = sym->tlink)
2886     {
2887       bool sym_has_alloc_comp = (sym->ts.type == BT_DERIVED)
2888                                    && sym->ts.derived->attr.alloc_comp;
2889       if (sym->attr.dimension)
2890         {
2891           switch (sym->as->type)
2892             {
2893             case AS_EXPLICIT:
2894               if (sym->attr.dummy || sym->attr.result)
2895                 fnbody =
2896                   gfc_trans_dummy_array_bias (sym, sym->backend_decl, fnbody);
2897               else if (sym->attr.pointer || sym->attr.allocatable)
2898                 {
2899                   if (TREE_STATIC (sym->backend_decl))
2900                     gfc_trans_static_array_pointer (sym);
2901                   else
2902                     {
2903                       seen_trans_deferred_array = true;
2904                       fnbody = gfc_trans_deferred_array (sym, fnbody);
2905                     }
2906                 }
2907               else
2908                 {
2909                   if (sym_has_alloc_comp)
2910                     {
2911                       seen_trans_deferred_array = true;
2912                       fnbody = gfc_trans_deferred_array (sym, fnbody);
2913                     }
2914                   else if (sym->ts.type == BT_DERIVED
2915                              && sym->value
2916                              && !sym->attr.data
2917                              && sym->attr.save == SAVE_NONE)
2918                     fnbody = gfc_init_default_dt (sym, fnbody);
2919
2920                   gfc_get_backend_locus (&loc);
2921                   gfc_set_backend_locus (&sym->declared_at);
2922                   fnbody = gfc_trans_auto_array_allocation (sym->backend_decl,
2923                       sym, fnbody);
2924                   gfc_set_backend_locus (&loc);
2925                 }
2926               break;
2927
2928             case AS_ASSUMED_SIZE:
2929               /* Must be a dummy parameter.  */
2930               gcc_assert (sym->attr.dummy);
2931
2932               /* We should always pass assumed size arrays the g77 way.  */
2933               fnbody = gfc_trans_g77_array (sym, fnbody);
2934               break;
2935
2936             case AS_ASSUMED_SHAPE:
2937               /* Must be a dummy parameter.  */
2938               gcc_assert (sym->attr.dummy);
2939
2940               fnbody = gfc_trans_dummy_array_bias (sym, sym->backend_decl,
2941                                                    fnbody);
2942               break;
2943
2944             case AS_DEFERRED:
2945               seen_trans_deferred_array = true;
2946               fnbody = gfc_trans_deferred_array (sym, fnbody);
2947               break;
2948
2949             default:
2950               gcc_unreachable ();
2951             }
2952           if (sym_has_alloc_comp && !seen_trans_deferred_array)
2953             fnbody = gfc_trans_deferred_array (sym, fnbody);
2954         }
2955       else if (sym_has_alloc_comp)
2956         fnbody = gfc_trans_deferred_array (sym, fnbody);
2957       else if (sym->ts.type == BT_CHARACTER)
2958         {
2959           gfc_get_backend_locus (&loc);
2960           gfc_set_backend_locus (&sym->declared_at);
2961           if (sym->attr.dummy || sym->attr.result)
2962             fnbody = gfc_trans_dummy_character (sym, sym->ts.cl, fnbody);
2963           else
2964             fnbody = gfc_trans_auto_character_variable (sym, fnbody);
2965           gfc_set_backend_locus (&loc);
2966         }
2967       else if (sym->attr.assign)
2968         {
2969           gfc_get_backend_locus (&loc);
2970           gfc_set_backend_locus (&sym->declared_at);
2971           fnbody = gfc_trans_assign_aux_var (sym, fnbody);
2972           gfc_set_backend_locus (&loc);
2973         }
2974       else if (sym->ts.type == BT_DERIVED
2975                  && sym->value
2976                  && !sym->attr.data
2977                  && sym->attr.save == SAVE_NONE)
2978         fnbody = gfc_init_default_dt (sym, fnbody);
2979       else
2980         gcc_unreachable ();
2981     }
2982
2983   gfc_init_block (&body);
2984
2985   for (f = proc_sym->formal; f; f = f->next)
2986     {
2987       if (f->sym && f->sym->tlink == NULL && f->sym->ts.type == BT_CHARACTER)
2988         {
2989           gcc_assert (f->sym->ts.cl->backend_decl != NULL);
2990           if (TREE_CODE (f->sym->ts.cl->backend_decl) == PARM_DECL)
2991             gfc_trans_vla_type_sizes (f->sym, &body);
2992         }
2993     }
2994
2995   if (gfc_return_by_reference (proc_sym) && proc_sym->ts.type == BT_CHARACTER
2996       && current_fake_result_decl != NULL)
2997     {
2998       gcc_assert (proc_sym->ts.cl->backend_decl != NULL);
2999       if (TREE_CODE (proc_sym->ts.cl->backend_decl) == PARM_DECL)
3000         gfc_trans_vla_type_sizes (proc_sym, &body);
3001     }
3002
3003   gfc_add_expr_to_block (&body, fnbody);
3004   return gfc_finish_block (&body);
3005 }
3006
3007 static GTY ((param_is (struct module_htab_entry))) htab_t module_htab;
3008
3009 /* Hash and equality functions for module_htab.  */
3010
3011 static hashval_t
3012 module_htab_do_hash (const void *x)
3013 {
3014   return htab_hash_string (((const struct module_htab_entry *)x)->name);
3015 }
3016
3017 static int
3018 module_htab_eq (const void *x1, const void *x2)
3019 {
3020   return strcmp ((((const struct module_htab_entry *)x1)->name),
3021                  (const char *)x2) == 0;
3022 }
3023
3024 /* Hash and equality functions for module_htab's decls.  */
3025
3026 static hashval_t
3027 module_htab_decls_hash (const void *x)
3028 {
3029   const_tree t = (const_tree) x;
3030   const_tree n = DECL_NAME (t);
3031   if (n == NULL_TREE)
3032     n = TYPE_NAME (TREE_TYPE (t));
3033   return htab_hash_string (IDENTIFIER_POINTER (n));
3034 }
3035
3036 static int
3037 module_htab_decls_eq (const void *x1, const void *x2)
3038 {
3039   const_tree t1 = (const_tree) x1;
3040   const_tree n1 = DECL_NAME (t1);
3041   if (n1 == NULL_TREE)
3042     n1 = TYPE_NAME (TREE_TYPE (t1));
3043   return strcmp (IDENTIFIER_POINTER (n1), (const char *) x2) == 0;
3044 }
3045
3046 struct module_htab_entry *
3047 gfc_find_module (const char *name)
3048 {
3049   void **slot;
3050
3051   if (! module_htab)
3052     module_htab = htab_create_ggc (10, module_htab_do_hash,
3053                                    module_htab_eq, NULL);
3054
3055   slot = htab_find_slot_with_hash (module_htab, name,
3056                                    htab_hash_string (name), INSERT);
3057   if (*slot == NULL)
3058     {
3059       struct module_htab_entry *entry = GGC_CNEW (struct module_htab_entry);
3060
3061       entry->name = gfc_get_string (name);
3062       entry->decls = htab_create_ggc (10, module_htab_decls_hash,
3063                                       module_htab_decls_eq, NULL);
3064       *slot = (void *) entry;
3065     }
3066   return (struct module_htab_entry *) *slot;
3067 }
3068
3069 void
3070 gfc_module_add_decl (struct module_htab_entry *entry, tree decl)
3071 {
3072   void **slot;
3073   const char *name;
3074
3075   if (DECL_NAME (decl))
3076     name = IDENTIFIER_POINTER (DECL_NAME (decl));
3077   else
3078     {
3079       gcc_assert (TREE_CODE (decl) == TYPE_DECL);
3080       name = IDENTIFIER_POINTER (TYPE_NAME (TREE_TYPE (decl)));
3081     }
3082   slot = htab_find_slot_with_hash (entry->decls, name,
3083                                    htab_hash_string (name), INSERT);
3084   if (*slot == NULL)
3085     *slot = (void *) decl;
3086 }
3087
3088 static struct module_htab_entry *cur_module;
3089
3090 /* Output an initialized decl for a module variable.  */
3091
3092 static void
3093 gfc_create_module_variable (gfc_symbol * sym)
3094 {
3095   tree decl;
3096
3097   /* Module functions with alternate entries are dealt with later and
3098      would get caught by the next condition.  */
3099   if (sym->attr.entry)
3100     return;
3101
3102   /* Make sure we convert the types of the derived types from iso_c_binding
3103      into (void *).  */
3104   if (sym->attr.flavor != FL_PROCEDURE && sym->attr.is_iso_c
3105       && sym->ts.type == BT_DERIVED)
3106     sym->backend_decl = gfc_typenode_for_spec (&(sym->ts));
3107
3108   if (sym->attr.flavor == FL_DERIVED
3109       && sym->backend_decl
3110       && TREE_CODE (sym->backend_decl) == RECORD_TYPE)
3111     {
3112       decl = sym->backend_decl;
3113       gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
3114       gcc_assert (TYPE_CONTEXT (decl) == NULL_TREE
3115                   || TYPE_CONTEXT (decl) == sym->ns->proc_name->backend_decl);
3116       gcc_assert (DECL_CONTEXT (TYPE_STUB_DECL (decl)) == NULL_TREE
3117                   || DECL_CONTEXT (TYPE_STUB_DECL (decl))
3118                      == sym->ns->proc_name->backend_decl);
3119       TYPE_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
3120       DECL_CONTEXT (TYPE_STUB_DECL (decl)) = sym->ns->proc_name->backend_decl;
3121       gfc_module_add_decl (cur_module, TYPE_STUB_DECL (decl));
3122     }
3123
3124   /* Only output variables and array valued, or derived type,
3125      parameters.  */
3126   if (sym->attr.flavor != FL_VARIABLE
3127         && !(sym->attr.flavor == FL_PARAMETER
3128                && (sym->attr.dimension || sym->ts.type == BT_DERIVED)))
3129     return;
3130
3131   if ((sym->attr.in_common || sym->attr.in_equivalence) && sym->backend_decl)
3132     {
3133       decl = sym->backend_decl;
3134       gcc_assert (DECL_CONTEXT (decl) == NULL_TREE);
3135       gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
3136       DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
3137       gfc_module_add_decl (cur_module, decl);
3138     }
3139
3140   /* Don't generate variables from other modules. Variables from
3141      COMMONs will already have been generated.  */
3142   if (sym->attr.use_assoc || sym->attr.in_common)
3143     return;
3144
3145   /* Equivalenced variables arrive here after creation.  */
3146   if (sym->backend_decl
3147       && (sym->equiv_built || sym->attr.in_equivalence))
3148     return;
3149
3150   if (sym->backend_decl)
3151     internal_error ("backend decl for module variable %s already exists",
3152                     sym->name);
3153
3154   /* We always want module variables to be created.  */
3155   sym->attr.referenced = 1;
3156   /* Create the decl.  */
3157   decl = gfc_get_symbol_decl (sym);
3158
3159   /* Create the variable.  */
3160   pushdecl (decl);
3161   gcc_assert (DECL_CONTEXT (decl) == NULL_TREE);
3162   gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
3163   DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
3164   rest_of_decl_compilation (decl, 1, 0);
3165   gfc_module_add_decl (cur_module, decl);
3166
3167   /* Also add length of strings.  */
3168   if (sym->ts.type == BT_CHARACTER)
3169     {
3170       tree length;
3171
3172       length = sym->ts.cl->backend_decl;
3173       if (!INTEGER_CST_P (length))
3174         {
3175           pushdecl (length);
3176           rest_of_decl_compilation (length, 1, 0);
3177         }
3178     }
3179 }
3180
3181 /* Emit debug information for USE statements.  */
3182
3183 static void
3184 gfc_trans_use_stmts (gfc_namespace * ns)
3185 {
3186   gfc_use_list *use_stmt;
3187   for (use_stmt = ns->use_stmts; use_stmt; use_stmt = use_stmt->next)
3188     {
3189       struct module_htab_entry *entry
3190         = gfc_find_module (use_stmt->module_name);
3191       gfc_use_rename *rent;
3192
3193       if (entry->namespace_decl == NULL)
3194         {
3195           entry->namespace_decl
3196             = build_decl (NAMESPACE_DECL,
3197                           get_identifier (use_stmt->module_name),
3198                           void_type_node);
3199           DECL_EXTERNAL (entry->namespace_decl) = 1;
3200         }
3201       gfc_set_backend_locus (&use_stmt->where);
3202       if (!use_stmt->only_flag)
3203         (*debug_hooks->imported_module_or_decl) (entry->namespace_decl,
3204                                                  NULL_TREE,
3205                                                  ns->proc_name->backend_decl,
3206                                                  false);
3207       for (rent = use_stmt->rename; rent; rent = rent->next)
3208         {
3209           tree decl, local_name;
3210           void **slot;
3211
3212           if (rent->op != INTRINSIC_NONE)
3213             continue;
3214
3215           slot = htab_find_slot_with_hash (entry->decls, rent->use_name,
3216                                            htab_hash_string (rent->use_name),
3217                                            INSERT);
3218           if (*slot == NULL)
3219             {
3220               gfc_symtree *st;
3221
3222               st = gfc_find_symtree (ns->sym_root,
3223                                      rent->local_name[0]
3224                                      ? rent->local_name : rent->use_name);
3225               gcc_assert (st && st->n.sym->attr.use_assoc);
3226               if (st->n.sym->backend_decl
3227                   && DECL_P (st->n.sym->backend_decl)
3228                   && st->n.sym->module
3229                   && strcmp (st->n.sym->module, use_stmt->module_name) == 0)
3230                 {
3231                   gcc_assert (DECL_EXTERNAL (entry->namespace_decl)
3232                               || (TREE_CODE (st->n.sym->backend_decl)
3233                                   != VAR_DECL));
3234                   decl = copy_node (st->n.sym->backend_decl);
3235                   DECL_CONTEXT (decl) = entry->namespace_decl;
3236                   DECL_EXTERNAL (decl) = 1;
3237                   DECL_IGNORED_P (decl) = 0;
3238                   DECL_INITIAL (decl) = NULL_TREE;
3239                 }
3240               else
3241                 {
3242                   *slot = error_mark_node;
3243                   htab_clear_slot (entry->decls, slot);
3244                   continue;
3245                 }
3246               *slot = decl;
3247             }
3248           decl = (tree) *slot;
3249           if (rent->local_name[0])
3250             local_name = get_identifier (rent->local_name);
3251           else
3252             local_name = NULL_TREE;
3253           gfc_set_backend_locus (&rent->where);
3254           (*debug_hooks->imported_module_or_decl) (decl, local_name,
3255                                                    ns->proc_name->backend_decl,
3256                                                    !use_stmt->only_flag);
3257         }
3258     }
3259 }
3260
3261
3262 /* Return true if expr is a constant initializer that gfc_conv_initializer
3263    will handle.  */
3264
3265 static bool
3266 check_constant_initializer (gfc_expr *expr, gfc_typespec *ts, bool array,
3267                             bool pointer)
3268 {
3269   gfc_constructor *c;
3270   gfc_component *cm;
3271
3272   if (pointer)
3273     return true;
3274   else if (array)
3275     {
3276       if (expr->expr_type == EXPR_CONSTANT || expr->expr_type == EXPR_NULL)
3277         return true;
3278       else if (expr->expr_type == EXPR_STRUCTURE)
3279         return check_constant_initializer (expr, ts, false, false);
3280       else if (expr->expr_type != EXPR_ARRAY)
3281         return false;
3282       for (c = expr->value.constructor; c; c = c->next)
3283         {
3284           if (c->iterator)
3285             return false;
3286           if (c->expr->expr_type == EXPR_STRUCTURE)
3287             {
3288               if (!check_constant_initializer (c->expr, ts, false, false))
3289                 return false;
3290             }
3291           else if (c->expr->expr_type != EXPR_CONSTANT)
3292             return false;
3293         }
3294       return true;
3295     }
3296   else switch (ts->type)
3297     {
3298     case BT_DERIVED:
3299       if (expr->expr_type != EXPR_STRUCTURE)
3300         return false;
3301       cm = expr->ts.derived->components;
3302       for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
3303         {
3304           if (!c->expr || cm->attr.allocatable)
3305             continue;
3306           if (!check_constant_initializer (c->expr, &cm->ts,
3307                                            cm->attr.dimension,
3308                                            cm->attr.pointer))
3309             return false;
3310         }
3311       return true;
3312     default:
3313       return expr->expr_type == EXPR_CONSTANT;
3314     }
3315 }
3316
3317 /* Emit debug info for parameters and unreferenced variables with
3318    initializers.  */
3319
3320 static void
3321 gfc_emit_parameter_debug_info (gfc_symbol *sym)
3322 {
3323   tree decl;
3324
3325   if (sym->attr.flavor != FL_PARAMETER
3326       && (sym->attr.flavor != FL_VARIABLE || sym->attr.referenced))
3327     return;
3328
3329   if (sym->backend_decl != NULL
3330       || sym->value == NULL
3331       || sym->attr.use_assoc
3332       || sym->attr.dummy
3333       || sym->attr.result
3334       || sym->attr.function
3335       || sym->attr.intrinsic
3336       || sym->attr.pointer
3337       || sym->attr.allocatable
3338       || sym->attr.cray_pointee
3339       || sym->attr.threadprivate
3340       || sym->attr.is_bind_c
3341       || sym->attr.subref_array_pointer
3342       || sym->attr.assign)
3343     return;
3344
3345   if (sym->ts.type == BT_CHARACTER)
3346     {
3347       gfc_conv_const_charlen (sym->ts.cl);
3348       if (sym->ts.cl->backend_decl == NULL
3349           || TREE_CODE (sym->ts.cl->backend_decl) != INTEGER_CST)
3350         return;
3351     }
3352   else if (sym->ts.type == BT_DERIVED && sym->ts.derived->attr.alloc_comp)
3353     return;
3354
3355   if (sym->as)
3356     {
3357       int n;
3358
3359       if (sym->as->type != AS_EXPLICIT)
3360         return;
3361       for (n = 0; n < sym->as->rank; n++)
3362         if (sym->as->lower[n]->expr_type != EXPR_CONSTANT
3363             || sym->as->upper[n] == NULL
3364             || sym->as->upper[n]->expr_type != EXPR_CONSTANT)
3365           return;
3366     }
3367
3368   if (!check_constant_initializer (sym->value, &sym->ts,
3369                                    sym->attr.dimension, false))
3370     return;
3371
3372   /* Create the decl for the variable or constant.  */
3373   decl = build_decl (sym->attr.flavor == FL_PARAMETER ? CONST_DECL : VAR_DECL,
3374                      gfc_sym_identifier (sym), gfc_sym_type (sym));
3375   if (sym->attr.flavor == FL_PARAMETER)
3376     TREE_READONLY (decl) = 1;
3377   gfc_set_decl_location (decl, &sym->declared_at);
3378   if (sym->attr.dimension)
3379     GFC_DECL_PACKED_ARRAY (decl) = 1;
3380   DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
3381   TREE_STATIC (decl) = 1;
3382   TREE_USED (decl) = 1;
3383   if (DECL_CONTEXT (decl) && TREE_CODE (DECL_CONTEXT (decl)) == NAMESPACE_DECL)
3384     TREE_PUBLIC (decl) = 1;
3385   DECL_INITIAL (decl)
3386     = gfc_conv_initializer (sym->value, &sym->ts, TREE_TYPE (decl),
3387                             sym->attr.dimension, 0);
3388   debug_hooks->global_decl (decl);
3389 }
3390
3391 /* Generate all the required code for module variables.  */
3392
3393 void
3394 gfc_generate_module_vars (gfc_namespace * ns)
3395 {
3396   module_namespace = ns;
3397   cur_module = gfc_find_module (ns->proc_name->name);
3398
3399   /* Check if the frontend left the namespace in a reasonable state.  */
3400   gcc_assert (ns->proc_name && !ns->proc_name->tlink);
3401
3402   /* Generate COMMON blocks.  */
3403   gfc_trans_common (ns);
3404
3405   /* Create decls for all the module variables.  */
3406   gfc_traverse_ns (ns, gfc_create_module_variable);
3407
3408   cur_module = NULL;
3409
3410   gfc_trans_use_stmts (ns);
3411   gfc_traverse_ns (ns, gfc_emit_parameter_debug_info);
3412 }
3413
3414
3415 static void
3416 gfc_generate_contained_functions (gfc_namespace * parent)
3417 {
3418   gfc_namespace *ns;
3419
3420   /* We create all the prototypes before generating any code.  */
3421   for (ns = parent->contained; ns; ns = ns->sibling)
3422     {
3423       /* Skip namespaces from used modules.  */
3424       if (ns->parent != parent)
3425         continue;
3426
3427       gfc_create_function_decl (ns);
3428     }
3429
3430   for (ns = parent->contained; ns; ns = ns->sibling)
3431     {
3432       /* Skip namespaces from used modules.  */
3433       if (ns->parent != parent)
3434         continue;
3435
3436       gfc_generate_function_code (ns);
3437     }
3438 }
3439
3440
3441 /* Drill down through expressions for the array specification bounds and
3442    character length calling generate_local_decl for all those variables
3443    that have not already been declared.  */
3444
3445 static void
3446 generate_local_decl (gfc_symbol *);
3447
3448 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced.  */
3449
3450 static bool
3451 expr_decls (gfc_expr *e, gfc_symbol *sym,
3452             int *f ATTRIBUTE_UNUSED)
3453 {
3454   if (e->expr_type != EXPR_VARIABLE
3455             || sym == e->symtree->n.sym
3456             || e->symtree->n.sym->mark
3457             || e->symtree->n.sym->ns != sym->ns)
3458         return false;
3459
3460   generate_local_decl (e->symtree->n.sym);
3461   return false;
3462 }
3463
3464 static void
3465 generate_expr_decls (gfc_symbol *sym, gfc_expr *e)
3466 {
3467   gfc_traverse_expr (e, sym, expr_decls, 0);
3468 }
3469
3470
3471 /* Check for dependencies in the character length and array spec.  */
3472
3473 static void
3474 generate_dependency_declarations (gfc_symbol *sym)
3475 {
3476   int i;
3477
3478   if (sym->ts.type == BT_CHARACTER
3479       && sym->ts.cl
3480       && sym->ts.cl->length
3481       && sym->ts.cl->length->expr_type != EXPR_CONSTANT)
3482     generate_expr_decls (sym, sym->ts.cl->length);
3483
3484   if (sym->as && sym->as->rank)
3485     {
3486       for (i = 0; i < sym->as->rank; i++)
3487         {
3488           generate_expr_decls (sym, sym->as->lower[i]);
3489           generate_expr_decls (sym, sym->as->upper[i]);
3490         }
3491     }
3492 }
3493
3494
3495 /* Generate decls for all local variables.  We do this to ensure correct
3496    handling of expressions which only appear in the specification of
3497    other functions.  */
3498
3499 static void
3500 generate_local_decl (gfc_symbol * sym)
3501 {
3502   if (sym->attr.flavor == FL_VARIABLE)
3503     {
3504       if (!sym->attr.dummy && !sym->ns->proc_name->attr.entry_master)
3505         generate_dependency_declarations (sym);
3506
3507       if (sym->attr.referenced)
3508         gfc_get_symbol_decl (sym);
3509       /* INTENT(out) dummy arguments are likely meant to be set.  */
3510       else if (warn_unused_variable
3511                && sym->attr.dummy
3512                && sym->attr.intent == INTENT_OUT)
3513         gfc_warning ("Dummy argument '%s' at %L was declared INTENT(OUT) but was not set",
3514                      sym->name, &sym->declared_at);
3515       /* Specific warning for unused dummy arguments. */
3516       else if (warn_unused_variable && sym->attr.dummy)
3517         gfc_warning ("Unused dummy argument '%s' at %L", sym->name,
3518                      &sym->declared_at);
3519       /* Warn for unused variables, but not if they're inside a common
3520          block or are use-associated.  */
3521       else if (warn_unused_variable
3522                && !(sym->attr.in_common || sym->attr.use_assoc || sym->mark))
3523         gfc_warning ("Unused variable '%s' declared at %L", sym->name,
3524                      &sym->declared_at);
3525
3526       /* For variable length CHARACTER parameters, the PARM_DECL already
3527          references the length variable, so force gfc_get_symbol_decl
3528          even when not referenced.  If optimize > 0, it will be optimized
3529          away anyway.  But do this only after emitting -Wunused-parameter
3530          warning if requested.  */
3531       if (sym->attr.dummy && !sym->attr.referenced
3532             && sym->ts.type == BT_CHARACTER
3533             && sym->ts.cl->backend_decl != NULL
3534             && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
3535         {
3536           sym->attr.referenced = 1;
3537           gfc_get_symbol_decl (sym);
3538         }
3539
3540       /* INTENT(out) dummy arguments with allocatable components are reset
3541          by default and need to be set referenced to generate the code for
3542          automatic lengths.  */
3543       if (sym->attr.dummy && !sym->attr.referenced
3544             && sym->ts.type == BT_DERIVED
3545             && sym->ts.derived->attr.alloc_comp
3546             && sym->attr.intent == INTENT_OUT)
3547         {
3548           sym->attr.referenced = 1;
3549           gfc_get_symbol_decl (sym);
3550         }
3551
3552
3553       /* Check for dependencies in the array specification and string
3554         length, adding the necessary declarations to the function.  We
3555         mark the symbol now, as well as in traverse_ns, to prevent
3556         getting stuck in a circular dependency.  */
3557       sym->mark = 1;
3558
3559       /* We do not want the middle-end to warn about unused parameters
3560          as this was already done above.  */
3561       if (sym->attr.dummy && sym->backend_decl != NULL_TREE)
3562           TREE_NO_WARNING(sym->backend_decl) = 1;
3563     }
3564   else if (sym->attr.flavor == FL_PARAMETER)
3565     {
3566       if (warn_unused_parameter
3567            && !sym->attr.referenced
3568            && !sym->attr.use_assoc)
3569         gfc_warning ("Unused parameter '%s' declared at %L", sym->name,
3570                      &sym->declared_at);
3571     }
3572   else if (sym->attr.flavor == FL_PROCEDURE)
3573     {
3574       /* TODO: move to the appropriate place in resolve.c.  */
3575       if (warn_return_type
3576           && sym->attr.function
3577           && sym->result
3578           && sym != sym->result
3579           && !sym->result->attr.referenced
3580           && !sym->attr.use_assoc
3581           && sym->attr.if_source != IFSRC_IFBODY)
3582         {
3583           gfc_warning ("Return value '%s' of function '%s' declared at "
3584                        "%L not set", sym->result->name, sym->name,
3585                         &sym->result->declared_at);
3586
3587           /* Prevents "Unused variable" warning for RESULT variables.  */
3588           sym->result->mark = 1;
3589         }
3590     }
3591
3592   if (sym->attr.dummy == 1)
3593     {
3594       /* Modify the tree type for scalar character dummy arguments of bind(c)
3595          procedures if they are passed by value.  The tree type for them will
3596          be promoted to INTEGER_TYPE for the middle end, which appears to be
3597          what C would do with characters passed by-value.  The value attribute
3598          implies the dummy is a scalar.  */
3599       if (sym->attr.value == 1 && sym->backend_decl != NULL
3600           && sym->ts.type == BT_CHARACTER && sym->ts.is_c_interop
3601           && sym->ns->proc_name != NULL && sym->ns->proc_name->attr.is_bind_c)
3602         gfc_conv_scalar_char_value (sym, NULL, NULL);
3603     }
3604
3605   /* Make sure we convert the types of the derived types from iso_c_binding
3606      into (void *).  */
3607   if (sym->attr.flavor != FL_PROCEDURE && sym->attr.is_iso_c
3608       && sym->ts.type == BT_DERIVED)
3609     sym->backend_decl = gfc_typenode_for_spec (&(sym->ts));
3610 }
3611
3612 static void
3613 generate_local_vars (gfc_namespace * ns)
3614 {
3615   gfc_traverse_ns (ns, generate_local_decl);
3616 }
3617
3618
3619 /* Generate a switch statement to jump to the correct entry point.  Also
3620    creates the label decls for the entry points.  */
3621
3622 static tree
3623 gfc_trans_entry_master_switch (gfc_entry_list * el)
3624 {
3625   stmtblock_t block;
3626   tree label;
3627   tree tmp;
3628   tree val;
3629
3630   gfc_init_block (&block);
3631   for (; el; el = el->next)
3632     {
3633       /* Add the case label.  */
3634       label = gfc_build_label_decl (NULL_TREE);
3635       val = build_int_cst (gfc_array_index_type, el->id);
3636       tmp = build3_v (CASE_LABEL_EXPR, val, NULL_TREE, label);
3637       gfc_add_expr_to_block (&block, tmp);
3638
3639       /* And jump to the actual entry point.  */
3640       label = gfc_build_label_decl (NULL_TREE);
3641       tmp = build1_v (GOTO_EXPR, label);
3642       gfc_add_expr_to_block (&block, tmp);
3643
3644       /* Save the label decl.  */
3645       el->label = label;
3646     }
3647   tmp = gfc_finish_block (&block);
3648   /* The first argument selects the entry point.  */
3649   val = DECL_ARGUMENTS (current_function_decl);
3650   tmp = build3_v (SWITCH_EXPR, val, tmp, NULL_TREE);
3651   return tmp;
3652 }
3653
3654
3655 /* Generate code for a function.  */
3656
3657 void
3658 gfc_generate_function_code (gfc_namespace * ns)
3659 {
3660   tree fndecl;
3661   tree old_context;
3662   tree decl;
3663   tree tmp;
3664   tree tmp2;
3665   stmtblock_t block;
3666   stmtblock_t body;
3667   tree result;
3668   gfc_symbol *sym;
3669   int rank;
3670
3671   sym = ns->proc_name;
3672
3673   /* Check that the frontend isn't still using this.  */
3674   gcc_assert (sym->tlink == NULL);
3675   sym->tlink = sym;
3676
3677   /* Create the declaration for functions with global scope.  */
3678   if (!sym->backend_decl)
3679     gfc_create_function_decl (ns);
3680
3681   fndecl = sym->backend_decl;
3682   old_context = current_function_decl;
3683
3684   if (old_context)
3685     {
3686       push_function_context ();
3687       saved_parent_function_decls = saved_function_decls;
3688       saved_function_decls = NULL_TREE;
3689     }
3690
3691   trans_function_start (sym);
3692
3693   gfc_init_block (&block);
3694
3695   if (ns->entries && ns->proc_name->ts.type == BT_CHARACTER)
3696     {
3697       /* Copy length backend_decls to all entry point result
3698          symbols.  */
3699       gfc_entry_list *el;
3700       tree backend_decl;
3701
3702       gfc_conv_const_charlen (ns->proc_name->ts.cl);
3703       backend_decl = ns->proc_name->result->ts.cl->backend_decl;
3704       for (el = ns->entries; el; el = el->next)
3705         el->sym->result->ts.cl->backend_decl = backend_decl;
3706     }
3707
3708   /* Translate COMMON blocks.  */
3709   gfc_trans_common (ns);
3710
3711   /* Null the parent fake result declaration if this namespace is
3712      a module function or an external procedures.  */
3713   if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
3714         || ns->parent == NULL)
3715     parent_fake_result_decl = NULL_TREE;
3716
3717   gfc_generate_contained_functions (ns);
3718
3719   generate_local_vars (ns);
3720
3721   /* Keep the parent fake result declaration in module functions
3722      or external procedures.  */
3723   if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
3724         || ns->parent == NULL)
3725     current_fake_result_decl = parent_fake_result_decl;
3726   else
3727     current_fake_result_decl = NULL_TREE;
3728
3729   current_function_return_label = NULL;
3730
3731   /* Now generate the code for the body of this function.  */
3732   gfc_init_block (&body);
3733
3734   /* If this is the main program, add a call to set_options to set up the
3735      runtime library Fortran language standard parameters.  */
3736   if (sym->attr.is_main_program)
3737     {
3738       tree array_type, array, var;
3739
3740       /* Passing a new option to the library requires four modifications:
3741            + add it to the tree_cons list below
3742            + change the array size in the call to build_array_type
3743            + change the first argument to the library call
3744              gfor_fndecl_set_options
3745            + modify the library (runtime/compile_options.c)!  */
3746       array = tree_cons (NULL_TREE,
3747                          build_int_cst (integer_type_node,
3748                                         gfc_option.warn_std), NULL_TREE);
3749       array = tree_cons (NULL_TREE,
3750                          build_int_cst (integer_type_node,
3751                                         gfc_option.allow_std), array);
3752       array = tree_cons (NULL_TREE,
3753                          build_int_cst (integer_type_node, pedantic), array);
3754       array = tree_cons (NULL_TREE,
3755                          build_int_cst (integer_type_node,
3756                                         gfc_option.flag_dump_core), array);
3757       array = tree_cons (NULL_TREE,
3758                          build_int_cst (integer_type_node,
3759                                         gfc_option.flag_backtrace), array);
3760       array = tree_cons (NULL_TREE,
3761                          build_int_cst (integer_type_node,
3762                                         gfc_option.flag_sign_zero), array);
3763
3764       array = tree_cons (NULL_TREE,
3765                          build_int_cst (integer_type_node,
3766                                         flag_bounds_check), array);
3767
3768       array = tree_cons (NULL_TREE,
3769                          build_int_cst (integer_type_node,
3770                                         gfc_option.flag_range_check), array);
3771
3772       array_type = build_array_type (integer_type_node,
3773                                      build_index_type (build_int_cst (NULL_TREE,
3774                                                                       7)));
3775       array = build_constructor_from_list (array_type, nreverse (array));
3776       TREE_CONSTANT (array) = 1;
3777       TREE_STATIC (array) = 1;
3778
3779       /* Create a static variable to hold the jump table.  */
3780       var = gfc_create_var (array_type, "options");
3781       TREE_CONSTANT (var) = 1;
3782       TREE_STATIC (var) = 1;
3783       TREE_READONLY (var) = 1;
3784       DECL_INITIAL (var) = array;
3785       var = gfc_build_addr_expr (pvoid_type_node, var);
3786
3787       tmp = build_call_expr (gfor_fndecl_set_options, 2,
3788                              build_int_cst (integer_type_node, 8), var);
3789       gfc_add_expr_to_block (&body, tmp);
3790     }
3791
3792   /* If this is the main program and a -ffpe-trap option was provided,
3793      add a call to set_fpe so that the library will raise a FPE when
3794      needed.  */
3795   if (sym->attr.is_main_program && gfc_option.fpe != 0)
3796     {
3797       tmp = build_call_expr (gfor_fndecl_set_fpe, 1,
3798                              build_int_cst (integer_type_node,
3799                                             gfc_option.fpe));
3800       gfc_add_expr_to_block (&body, tmp);
3801     }
3802
3803   /* If this is the main program and an -fconvert option was provided,
3804      add a call to set_convert.  */
3805
3806   if (sym->attr.is_main_program && gfc_option.convert != GFC_CONVERT_NATIVE)
3807     {
3808       tmp = build_call_expr (gfor_fndecl_set_convert, 1,
3809                              build_int_cst (integer_type_node,
3810                                             gfc_option.convert));
3811       gfc_add_expr_to_block (&body, tmp);
3812     }
3813
3814   /* If this is the main program and an -frecord-marker option was provided,
3815      add a call to set_record_marker.  */
3816
3817   if (sym->attr.is_main_program && gfc_option.record_marker != 0)
3818     {
3819       tmp = build_call_expr (gfor_fndecl_set_record_marker, 1,
3820                              build_int_cst (integer_type_node,
3821                                             gfc_option.record_marker));
3822       gfc_add_expr_to_block (&body, tmp);
3823     }
3824
3825   if (sym->attr.is_main_program && gfc_option.max_subrecord_length != 0)
3826     {
3827       tmp = build_call_expr (gfor_fndecl_set_max_subrecord_length,
3828                              1,
3829                              build_int_cst (integer_type_node,
3830                                             gfc_option.max_subrecord_length));
3831       gfc_add_expr_to_block (&body, tmp);
3832     }
3833
3834   if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node
3835       && sym->attr.subroutine)
3836     {
3837       tree alternate_return;
3838       alternate_return = gfc_get_fake_result_decl (sym, 0);
3839       gfc_add_modify (&body, alternate_return, integer_zero_node);
3840     }
3841
3842   if (ns->entries)
3843     {
3844       /* Jump to the correct entry point.  */
3845       tmp = gfc_trans_entry_master_switch (ns->entries);
3846       gfc_add_expr_to_block (&body, tmp);
3847     }
3848
3849   tmp = gfc_trans_code (ns->code);
3850   gfc_add_expr_to_block (&body, tmp);
3851
3852   /* Add a return label if needed.  */
3853   if (current_function_return_label)
3854     {
3855       tmp = build1_v (LABEL_EXPR, current_function_return_label);
3856       gfc_add_expr_to_block (&body, tmp);
3857     }
3858
3859   tmp = gfc_finish_block (&body);
3860   /* Add code to create and cleanup arrays.  */
3861   tmp = gfc_trans_deferred_vars (sym, tmp);
3862
3863   if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node)
3864     {
3865       if (sym->attr.subroutine || sym == sym->result)
3866         {
3867           if (current_fake_result_decl != NULL)
3868             result = TREE_VALUE (current_fake_result_decl);
3869           else
3870             result = NULL_TREE;
3871           current_fake_result_decl = NULL_TREE;
3872         }
3873       else
3874         result = sym->result->backend_decl;
3875
3876       if (result != NULL_TREE && sym->attr.function
3877             && sym->ts.type == BT_DERIVED
3878             && sym->ts.derived->attr.alloc_comp
3879             && !sym->attr.pointer)
3880         {
3881           rank = sym->as ? sym->as->rank : 0;
3882           tmp2 = gfc_nullify_alloc_comp (sym->ts.derived, result, rank);
3883           gfc_add_expr_to_block (&block, tmp2);
3884         }
3885
3886       gfc_add_expr_to_block (&block, tmp);
3887
3888       if (result == NULL_TREE)
3889         {
3890           /* TODO: move to the appropriate place in resolve.c.  */
3891           if (warn_return_type && !sym->attr.referenced && sym == sym->result)
3892             gfc_warning ("Return value of function '%s' at %L not set",
3893                          sym->name, &sym->declared_at);
3894
3895           TREE_NO_WARNING(sym->backend_decl) = 1;
3896         }
3897       else
3898         {
3899           /* Set the return value to the dummy result variable.  The
3900              types may be different for scalar default REAL functions
3901              with -ff2c, therefore we have to convert.  */
3902           tmp = convert (TREE_TYPE (DECL_RESULT (fndecl)), result);
3903           tmp = fold_build2 (MODIFY_EXPR, TREE_TYPE (tmp),
3904                              DECL_RESULT (fndecl), tmp);
3905           tmp = build1_v (RETURN_EXPR, tmp);
3906           gfc_add_expr_to_block (&block, tmp);
3907         }
3908     }
3909   else
3910     gfc_add_expr_to_block (&block, tmp);
3911
3912
3913   /* Add all the decls we created during processing.  */
3914   decl = saved_function_decls;
3915   while (decl)
3916     {
3917       tree next;
3918
3919       next = TREE_CHAIN (decl);
3920       TREE_CHAIN (decl) = NULL_TREE;
3921       pushdecl (decl);
3922       decl = next;
3923     }
3924   saved_function_decls = NULL_TREE;
3925
3926   DECL_SAVED_TREE (fndecl) = gfc_finish_block (&block);
3927   decl = getdecls ();
3928
3929   /* Finish off this function and send it for code generation.  */
3930   poplevel (1, 0, 1);
3931   BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
3932
3933   DECL_SAVED_TREE (fndecl)
3934     = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (fndecl),
3935                 DECL_INITIAL (fndecl));
3936
3937   /* Output the GENERIC tree.  */
3938   dump_function (TDI_original, fndecl);
3939
3940   /* Store the end of the function, so that we get good line number
3941      info for the epilogue.  */
3942   cfun->function_end_locus = input_location;
3943
3944   /* We're leaving the context of this function, so zap cfun.
3945      It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
3946      tree_rest_of_compilation.  */
3947   set_cfun (NULL);
3948
3949   if (old_context)
3950     {
3951       pop_function_context ();
3952       saved_function_decls = saved_parent_function_decls;
3953     }
3954   current_function_decl = old_context;
3955
3956   if (decl_function_context (fndecl))
3957     /* Register this function with cgraph just far enough to get it
3958        added to our parent's nested function list.  */
3959     (void) cgraph_node (fndecl);
3960   else
3961     {
3962       gfc_gimplify_function (fndecl);
3963       cgraph_finalize_function (fndecl, false);
3964     }
3965
3966   gfc_trans_use_stmts (ns);
3967   gfc_traverse_ns (ns, gfc_emit_parameter_debug_info);
3968 }
3969
3970 void
3971 gfc_generate_constructors (void)
3972 {
3973   gcc_assert (gfc_static_ctors == NULL_TREE);
3974 #if 0
3975   tree fnname;
3976   tree type;
3977   tree fndecl;
3978   tree decl;
3979   tree tmp;
3980
3981   if (gfc_static_ctors == NULL_TREE)
3982     return;
3983
3984   fnname = get_file_function_name ("I");
3985   type = build_function_type (void_type_node,
3986                               gfc_chainon_list (NULL_TREE, void_type_node));
3987
3988   fndecl = build_decl (FUNCTION_DECL, fnname, type);
3989   TREE_PUBLIC (fndecl) = 1;
3990
3991   decl = build_decl (RESULT_DECL, NULL_TREE, void_type_node);
3992   DECL_ARTIFICIAL (decl) = 1;
3993   DECL_IGNORED_P (decl) = 1;
3994   DECL_CONTEXT (decl) = fndecl;
3995   DECL_RESULT (fndecl) = decl;
3996
3997   pushdecl (fndecl);
3998
3999   current_function_decl = fndecl;
4000
4001   rest_of_decl_compilation (fndecl, 1, 0);
4002
4003   make_decl_rtl (fndecl);
4004
4005   init_function_start (fndecl);
4006
4007   pushlevel (0);
4008
4009   for (; gfc_static_ctors; gfc_static_ctors = TREE_CHAIN (gfc_static_ctors))
4010     {
4011       tmp = build_call_expr (TREE_VALUE (gfc_static_ctors), 0);
4012       DECL_SAVED_TREE (fndecl) = build_stmt (EXPR_STMT, tmp);
4013     }
4014
4015   decl = getdecls ();
4016   poplevel (1, 0, 1);
4017
4018   BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
4019   DECL_SAVED_TREE (fndecl)
4020     = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (fndecl),
4021                 DECL_INITIAL (fndecl));
4022
4023   free_after_parsing (cfun);
4024   free_after_compilation (cfun);
4025
4026   tree_rest_of_compilation (fndecl);
4027
4028   current_function_decl = NULL_TREE;
4029 #endif
4030 }
4031
4032 /* Translates a BLOCK DATA program unit. This means emitting the
4033    commons contained therein plus their initializations. We also emit
4034    a globally visible symbol to make sure that each BLOCK DATA program
4035    unit remains unique.  */
4036
4037 void
4038 gfc_generate_block_data (gfc_namespace * ns)
4039 {
4040   tree decl;
4041   tree id;
4042
4043   /* Tell the backend the source location of the block data.  */
4044   if (ns->proc_name)
4045     gfc_set_backend_locus (&ns->proc_name->declared_at);
4046   else
4047     gfc_set_backend_locus (&gfc_current_locus);
4048
4049   /* Process the DATA statements.  */
4050   gfc_trans_common (ns);
4051
4052   /* Create a global symbol with the mane of the block data.  This is to
4053      generate linker errors if the same name is used twice.  It is never
4054      really used.  */
4055   if (ns->proc_name)
4056     id = gfc_sym_mangled_function_id (ns->proc_name);
4057   else
4058     id = get_identifier ("__BLOCK_DATA__");
4059
4060   decl = build_decl (VAR_DECL, id, gfc_array_index_type);
4061   TREE_PUBLIC (decl) = 1;
4062   TREE_STATIC (decl) = 1;
4063   DECL_IGNORED_P (decl) = 1;
4064
4065   pushdecl (decl);
4066   rest_of_decl_compilation (decl, 1, 0);
4067 }
4068
4069
4070 #include "gt-fortran-trans-decl.h"