gcc/fortran/trans-decl.c

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