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