gcc/fortran/trans-decl.c

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