gcc/fortran/trans-decl.c

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