gcc/fortran/trans-decl.c

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