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, unless the procedure
1539      is bind(C).  */
1540   if (!sym->attr.is_bind_c)
1541     arglist = chainon (arglist, hidden_arglist);
1542
1543   gcc_assert (hidden_typelist == NULL_TREE
1544               || TREE_VALUE (hidden_typelist) == void_type_node);
1545   DECL_ARGUMENTS (fndecl) = arglist;
1546 }
1547
1548 /* Convert FNDECL's code to GIMPLE and handle any nested functions.  */
1549
1550 static void
1551 gfc_gimplify_function (tree fndecl)
1552 {
1553   struct cgraph_node *cgn;
1554
1555   gimplify_function_tree (fndecl);
1556   dump_function (TDI_generic, fndecl);
1557
1558   /* Generate errors for structured block violations.  */
1559   /* ??? Could be done as part of resolve_labels.  */
1560   if (flag_openmp)
1561     diagnose_omp_structured_block_errors (fndecl);
1562
1563   /* Convert all nested functions to GIMPLE now.  We do things in this order
1564      so that items like VLA sizes are expanded properly in the context of the
1565      correct function.  */
1566   cgn = cgraph_node (fndecl);
1567   for (cgn = cgn->nested; cgn; cgn = cgn->next_nested)
1568     gfc_gimplify_function (cgn->decl);
1569 }
1570
1571
1572 /* Do the setup necessary before generating the body of a function.  */
1573
1574 static void
1575 trans_function_start (gfc_symbol * sym)
1576 {
1577   tree fndecl;
1578
1579   fndecl = sym->backend_decl;
1580
1581   /* Let GCC know the current scope is this function.  */
1582   current_function_decl = fndecl;
1583
1584   /* Let the world know what we're about to do.  */
1585   announce_function (fndecl);
1586
1587   if (DECL_CONTEXT (fndecl) == NULL_TREE)
1588     {
1589       /* Create RTL for function declaration.  */
1590       rest_of_decl_compilation (fndecl, 1, 0);
1591     }
1592
1593   /* Create RTL for function definition.  */
1594   make_decl_rtl (fndecl);
1595
1596   init_function_start (fndecl);
1597
1598   /* Even though we're inside a function body, we still don't want to
1599      call expand_expr to calculate the size of a variable-sized array.
1600      We haven't necessarily assigned RTL to all variables yet, so it's
1601      not safe to try to expand expressions involving them.  */
1602   cfun->x_dont_save_pending_sizes_p = 1;
1603
1604   /* function.c requires a push at the start of the function.  */
1605   pushlevel (0);
1606 }
1607
1608 /* Create thunks for alternate entry points.  */
1609
1610 static void
1611 build_entry_thunks (gfc_namespace * ns)
1612 {
1613   gfc_formal_arglist *formal;
1614   gfc_formal_arglist *thunk_formal;
1615   gfc_entry_list *el;
1616   gfc_symbol *thunk_sym;
1617   stmtblock_t body;
1618   tree thunk_fndecl;
1619   tree args;
1620   tree string_args;
1621   tree tmp;
1622   locus old_loc;
1623
1624   /* This should always be a toplevel function.  */
1625   gcc_assert (current_function_decl == NULL_TREE);
1626
1627   gfc_get_backend_locus (&old_loc);
1628   for (el = ns->entries; el; el = el->next)
1629     {
1630       thunk_sym = el->sym;
1631
1632       build_function_decl (thunk_sym);
1633       create_function_arglist (thunk_sym);
1634
1635       trans_function_start (thunk_sym);
1636
1637       thunk_fndecl = thunk_sym->backend_decl;
1638
1639       gfc_start_block (&body);
1640
1641       /* Pass extra parameter identifying this entry point.  */
1642       tmp = build_int_cst (gfc_array_index_type, el->id);
1643       args = tree_cons (NULL_TREE, tmp, NULL_TREE);
1644       string_args = NULL_TREE;
1645
1646       if (thunk_sym->attr.function)
1647         {
1648           if (gfc_return_by_reference (ns->proc_name))
1649             {
1650               tree ref = DECL_ARGUMENTS (current_function_decl);
1651               args = tree_cons (NULL_TREE, ref, args);
1652               if (ns->proc_name->ts.type == BT_CHARACTER)
1653                 args = tree_cons (NULL_TREE, TREE_CHAIN (ref),
1654                                   args);
1655             }
1656         }
1657
1658       for (formal = ns->proc_name->formal; formal; formal = formal->next)
1659         {
1660           /* Ignore alternate returns.  */
1661           if (formal->sym == NULL)
1662             continue;
1663
1664           /* We don't have a clever way of identifying arguments, so resort to
1665              a brute-force search.  */
1666           for (thunk_formal = thunk_sym->formal;
1667                thunk_formal;
1668                thunk_formal = thunk_formal->next)
1669             {
1670               if (thunk_formal->sym == formal->sym)
1671                 break;
1672             }
1673
1674           if (thunk_formal)
1675             {
1676               /* Pass the argument.  */
1677               DECL_ARTIFICIAL (thunk_formal->sym->backend_decl) = 1;
1678               args = tree_cons (NULL_TREE, thunk_formal->sym->backend_decl,
1679                                 args);
1680               if (formal->sym->ts.type == BT_CHARACTER)
1681                 {
1682                   tmp = thunk_formal->sym->ts.cl->backend_decl;
1683                   string_args = tree_cons (NULL_TREE, tmp, string_args);
1684                 }
1685             }
1686           else
1687             {
1688               /* Pass NULL for a missing argument.  */
1689               args = tree_cons (NULL_TREE, null_pointer_node, args);
1690               if (formal->sym->ts.type == BT_CHARACTER)
1691                 {
1692                   tmp = build_int_cst (gfc_charlen_type_node, 0);
1693                   string_args = tree_cons (NULL_TREE, tmp, string_args);
1694                 }
1695             }
1696         }
1697
1698       /* Call the master function.  */
1699       args = nreverse (args);
1700       args = chainon (args, nreverse (string_args));
1701       tmp = ns->proc_name->backend_decl;
1702       tmp = build_function_call_expr (tmp, args);
1703       if (ns->proc_name->attr.mixed_entry_master)
1704         {
1705           tree union_decl, field;
1706           tree master_type = TREE_TYPE (ns->proc_name->backend_decl);
1707
1708           union_decl = build_decl (VAR_DECL, get_identifier ("__result"),
1709                                    TREE_TYPE (master_type));
1710           DECL_ARTIFICIAL (union_decl) = 1;
1711           DECL_EXTERNAL (union_decl) = 0;
1712           TREE_PUBLIC (union_decl) = 0;
1713           TREE_USED (union_decl) = 1;
1714           layout_decl (union_decl, 0);
1715           pushdecl (union_decl);
1716
1717           DECL_CONTEXT (union_decl) = current_function_decl;
1718           tmp = build2 (MODIFY_EXPR,
1719                         TREE_TYPE (union_decl),
1720                         union_decl, tmp);
1721           gfc_add_expr_to_block (&body, tmp);
1722
1723           for (field = TYPE_FIELDS (TREE_TYPE (union_decl));
1724                field; field = TREE_CHAIN (field))
1725             if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
1726                 thunk_sym->result->name) == 0)
1727               break;
1728           gcc_assert (field != NULL_TREE);
1729           tmp = build3 (COMPONENT_REF, TREE_TYPE (field), union_decl, field,
1730                         NULL_TREE);
1731           tmp = build2 (MODIFY_EXPR,
1732                         TREE_TYPE (DECL_RESULT (current_function_decl)),
1733                         DECL_RESULT (current_function_decl), tmp);
1734           tmp = build1_v (RETURN_EXPR, tmp);
1735         }
1736       else if (TREE_TYPE (DECL_RESULT (current_function_decl))
1737                != void_type_node)
1738         {
1739           tmp = build2 (MODIFY_EXPR,
1740                         TREE_TYPE (DECL_RESULT (current_function_decl)),
1741                         DECL_RESULT (current_function_decl), tmp);
1742           tmp = build1_v (RETURN_EXPR, tmp);
1743         }
1744       gfc_add_expr_to_block (&body, tmp);
1745
1746       /* Finish off this function and send it for code generation.  */
1747       DECL_SAVED_TREE (thunk_fndecl) = gfc_finish_block (&body);
1748       poplevel (1, 0, 1);
1749       BLOCK_SUPERCONTEXT (DECL_INITIAL (thunk_fndecl)) = thunk_fndecl;
1750
1751       /* Output the GENERIC tree.  */
1752       dump_function (TDI_original, thunk_fndecl);
1753
1754       /* Store the end of the function, so that we get good line number
1755          info for the epilogue.  */
1756       cfun->function_end_locus = input_location;
1757
1758       /* We're leaving the context of this function, so zap cfun.
1759          It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
1760          tree_rest_of_compilation.  */
1761       set_cfun (NULL);
1762
1763       current_function_decl = NULL_TREE;
1764
1765       gfc_gimplify_function (thunk_fndecl);
1766       cgraph_finalize_function (thunk_fndecl, false);
1767
1768       /* We share the symbols in the formal argument list with other entry
1769          points and the master function.  Clear them so that they are
1770          recreated for each function.  */
1771       for (formal = thunk_sym->formal; formal; formal = formal->next)
1772         if (formal->sym != NULL)  /* Ignore alternate returns.  */
1773           {
1774             formal->sym->backend_decl = NULL_TREE;
1775             if (formal->sym->ts.type == BT_CHARACTER)
1776               formal->sym->ts.cl->backend_decl = NULL_TREE;
1777           }
1778
1779       if (thunk_sym->attr.function)
1780         {
1781           if (thunk_sym->ts.type == BT_CHARACTER)
1782             thunk_sym->ts.cl->backend_decl = NULL_TREE;
1783           if (thunk_sym->result->ts.type == BT_CHARACTER)
1784             thunk_sym->result->ts.cl->backend_decl = NULL_TREE;
1785         }
1786     }
1787
1788   gfc_set_backend_locus (&old_loc);
1789 }
1790
1791
1792 /* Create a decl for a function, and create any thunks for alternate entry
1793    points.  */
1794
1795 void
1796 gfc_create_function_decl (gfc_namespace * ns)
1797 {
1798   /* Create a declaration for the master function.  */
1799   build_function_decl (ns->proc_name);
1800
1801   /* Compile the entry thunks.  */
1802   if (ns->entries)
1803     build_entry_thunks (ns);
1804
1805   /* Now create the read argument list.  */
1806   create_function_arglist (ns->proc_name);
1807 }
1808
1809 /* Return the decl used to hold the function return value.  If
1810    parent_flag is set, the context is the parent_scope.  */
1811
1812 tree
1813 gfc_get_fake_result_decl (gfc_symbol * sym, int parent_flag)
1814 {
1815   tree decl;
1816   tree length;
1817   tree this_fake_result_decl;
1818   tree this_function_decl;
1819
1820   char name[GFC_MAX_SYMBOL_LEN + 10];
1821
1822   if (parent_flag)
1823     {
1824       this_fake_result_decl = parent_fake_result_decl;
1825       this_function_decl = DECL_CONTEXT (current_function_decl);
1826     }
1827   else
1828     {
1829       this_fake_result_decl = current_fake_result_decl;
1830       this_function_decl = current_function_decl;
1831     }
1832
1833   if (sym
1834       && sym->ns->proc_name->backend_decl == this_function_decl
1835       && sym->ns->proc_name->attr.entry_master
1836       && sym != sym->ns->proc_name)
1837     {
1838       tree t = NULL, var;
1839       if (this_fake_result_decl != NULL)
1840         for (t = TREE_CHAIN (this_fake_result_decl); t; t = TREE_CHAIN (t))
1841           if (strcmp (IDENTIFIER_POINTER (TREE_PURPOSE (t)), sym->name) == 0)
1842             break;
1843       if (t)
1844         return TREE_VALUE (t);
1845       decl = gfc_get_fake_result_decl (sym->ns->proc_name, parent_flag);
1846
1847       if (parent_flag)
1848         this_fake_result_decl = parent_fake_result_decl;
1849       else
1850         this_fake_result_decl = current_fake_result_decl;
1851
1852       if (decl && sym->ns->proc_name->attr.mixed_entry_master)
1853         {
1854           tree field;
1855
1856           for (field = TYPE_FIELDS (TREE_TYPE (decl));
1857                field; field = TREE_CHAIN (field))
1858             if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
1859                 sym->name) == 0)
1860               break;
1861
1862           gcc_assert (field != NULL_TREE);
1863           decl = build3 (COMPONENT_REF, TREE_TYPE (field), decl, field,
1864                          NULL_TREE);
1865         }
1866
1867       var = create_tmp_var_raw (TREE_TYPE (decl), sym->name);
1868       if (parent_flag)
1869         gfc_add_decl_to_parent_function (var);
1870       else
1871         gfc_add_decl_to_function (var);
1872
1873       SET_DECL_VALUE_EXPR (var, decl);
1874       DECL_HAS_VALUE_EXPR_P (var) = 1;
1875       GFC_DECL_RESULT (var) = 1;
1876
1877       TREE_CHAIN (this_fake_result_decl)
1878           = tree_cons (get_identifier (sym->name), var,
1879                        TREE_CHAIN (this_fake_result_decl));
1880       return var;
1881     }
1882
1883   if (this_fake_result_decl != NULL_TREE)
1884     return TREE_VALUE (this_fake_result_decl);
1885
1886   /* Only when gfc_get_fake_result_decl is called by gfc_trans_return,
1887      sym is NULL.  */
1888   if (!sym)
1889     return NULL_TREE;
1890
1891   if (sym->ts.type == BT_CHARACTER)
1892     {
1893       if (sym->ts.cl->backend_decl == NULL_TREE)
1894         length = gfc_create_string_length (sym);
1895       else
1896         length = sym->ts.cl->backend_decl;
1897       if (TREE_CODE (length) == VAR_DECL
1898           && DECL_CONTEXT (length) == NULL_TREE)
1899         gfc_add_decl_to_function (length);
1900     }
1901
1902   if (gfc_return_by_reference (sym))
1903     {
1904       decl = DECL_ARGUMENTS (this_function_decl);
1905
1906       if (sym->ns->proc_name->backend_decl == this_function_decl
1907           && sym->ns->proc_name->attr.entry_master)
1908         decl = TREE_CHAIN (decl);
1909
1910       TREE_USED (decl) = 1;
1911       if (sym->as)
1912         decl = gfc_build_dummy_array_decl (sym, decl);
1913     }
1914   else
1915     {
1916       sprintf (name, "__result_%.20s",
1917                IDENTIFIER_POINTER (DECL_NAME (this_function_decl)));
1918
1919       if (!sym->attr.mixed_entry_master && sym->attr.function)
1920         decl = build_decl (VAR_DECL, get_identifier (name),
1921                            gfc_sym_type (sym));
1922       else
1923         decl = build_decl (VAR_DECL, get_identifier (name),
1924                            TREE_TYPE (TREE_TYPE (this_function_decl)));
1925       DECL_ARTIFICIAL (decl) = 1;
1926       DECL_EXTERNAL (decl) = 0;
1927       TREE_PUBLIC (decl) = 0;
1928       TREE_USED (decl) = 1;
1929       GFC_DECL_RESULT (decl) = 1;
1930       TREE_ADDRESSABLE (decl) = 1;
1931
1932       layout_decl (decl, 0);
1933
1934       if (parent_flag)
1935         gfc_add_decl_to_parent_function (decl);
1936       else
1937         gfc_add_decl_to_function (decl);
1938     }
1939
1940   if (parent_flag)
1941     parent_fake_result_decl = build_tree_list (NULL, decl);
1942   else
1943     current_fake_result_decl = build_tree_list (NULL, decl);
1944
1945   return decl;
1946 }
1947
1948
1949 /* Builds a function decl.  The remaining parameters are the types of the
1950    function arguments.  Negative nargs indicates a varargs function.  */
1951
1952 tree
1953 gfc_build_library_function_decl (tree name, tree rettype, int nargs, ...)
1954 {
1955   tree arglist;
1956   tree argtype;
1957   tree fntype;
1958   tree fndecl;
1959   va_list p;
1960   int n;
1961
1962   /* Library functions must be declared with global scope.  */
1963   gcc_assert (current_function_decl == NULL_TREE);
1964
1965   va_start (p, nargs);
1966
1967
1968   /* Create a list of the argument types.  */
1969   for (arglist = NULL_TREE, n = abs (nargs); n > 0; n--)
1970     {
1971       argtype = va_arg (p, tree);
1972       arglist = gfc_chainon_list (arglist, argtype);
1973     }
1974
1975   if (nargs >= 0)
1976     {
1977       /* Terminate the list.  */
1978       arglist = gfc_chainon_list (arglist, void_type_node);
1979     }
1980
1981   /* Build the function type and decl.  */
1982   fntype = build_function_type (rettype, arglist);
1983   fndecl = build_decl (FUNCTION_DECL, name, fntype);
1984
1985   /* Mark this decl as external.  */
1986   DECL_EXTERNAL (fndecl) = 1;
1987   TREE_PUBLIC (fndecl) = 1;
1988
1989   va_end (p);
1990
1991   pushdecl (fndecl);
1992
1993   rest_of_decl_compilation (fndecl, 1, 0);
1994
1995   return fndecl;
1996 }
1997
1998 static void
1999 gfc_build_intrinsic_function_decls (void)
2000 {
2001   tree gfc_int4_type_node = gfc_get_int_type (4);
2002   tree gfc_int8_type_node = gfc_get_int_type (8);
2003   tree gfc_int16_type_node = gfc_get_int_type (16);
2004   tree gfc_logical4_type_node = gfc_get_logical_type (4);
2005   tree gfc_real4_type_node = gfc_get_real_type (4);
2006   tree gfc_real8_type_node = gfc_get_real_type (8);
2007   tree gfc_real10_type_node = gfc_get_real_type (10);
2008   tree gfc_real16_type_node = gfc_get_real_type (16);
2009   tree gfc_complex4_type_node = gfc_get_complex_type (4);
2010   tree gfc_complex8_type_node = gfc_get_complex_type (8);
2011   tree gfc_complex10_type_node = gfc_get_complex_type (10);
2012   tree gfc_complex16_type_node = gfc_get_complex_type (16);
2013
2014   /* String functions.  */
2015   gfor_fndecl_compare_string =
2016     gfc_build_library_function_decl (get_identifier (PREFIX("compare_string")),
2017                                      integer_type_node, 4,
2018                                      gfc_charlen_type_node, pchar_type_node,
2019                                      gfc_charlen_type_node, pchar_type_node);
2020
2021   gfor_fndecl_concat_string =
2022     gfc_build_library_function_decl (get_identifier (PREFIX("concat_string")),
2023                                      void_type_node,
2024                                      6,
2025                                      gfc_charlen_type_node, pchar_type_node,
2026                                      gfc_charlen_type_node, pchar_type_node,
2027                                      gfc_charlen_type_node, pchar_type_node);
2028
2029   gfor_fndecl_string_len_trim =
2030     gfc_build_library_function_decl (get_identifier (PREFIX("string_len_trim")),
2031                                      gfc_int4_type_node,
2032                                      2, gfc_charlen_type_node,
2033                                      pchar_type_node);
2034
2035   gfor_fndecl_string_index =
2036     gfc_build_library_function_decl (get_identifier (PREFIX("string_index")),
2037                                      gfc_int4_type_node,
2038                                      5, gfc_charlen_type_node, pchar_type_node,
2039                                      gfc_charlen_type_node, pchar_type_node,
2040                                      gfc_logical4_type_node);
2041
2042   gfor_fndecl_string_scan =
2043     gfc_build_library_function_decl (get_identifier (PREFIX("string_scan")),
2044                                      gfc_int4_type_node,
2045                                      5, gfc_charlen_type_node, pchar_type_node,
2046                                      gfc_charlen_type_node, pchar_type_node,
2047                                      gfc_logical4_type_node);
2048
2049   gfor_fndecl_string_verify =
2050     gfc_build_library_function_decl (get_identifier (PREFIX("string_verify")),
2051                                      gfc_int4_type_node,
2052                                      5, gfc_charlen_type_node, pchar_type_node,
2053                                      gfc_charlen_type_node, pchar_type_node,
2054                                      gfc_logical4_type_node);
2055
2056   gfor_fndecl_string_trim =
2057     gfc_build_library_function_decl (get_identifier (PREFIX("string_trim")),
2058                                      void_type_node,
2059                                      4,
2060                                      build_pointer_type (gfc_charlen_type_node),
2061                                      ppvoid_type_node,
2062                                      gfc_charlen_type_node,
2063                                      pchar_type_node);
2064
2065   gfor_fndecl_string_minmax =
2066     gfc_build_library_function_decl (get_identifier (PREFIX("string_minmax")),
2067                                      void_type_node, -4,
2068                                      build_pointer_type (gfc_charlen_type_node),
2069                                      ppvoid_type_node, integer_type_node,
2070                                      integer_type_node);
2071
2072   gfor_fndecl_ttynam =
2073     gfc_build_library_function_decl (get_identifier (PREFIX("ttynam")),
2074                                      void_type_node,
2075                                      3,
2076                                      pchar_type_node,
2077                                      gfc_charlen_type_node,
2078                                      integer_type_node);
2079
2080   gfor_fndecl_fdate =
2081     gfc_build_library_function_decl (get_identifier (PREFIX("fdate")),
2082                                      void_type_node,
2083                                      2,
2084                                      pchar_type_node,
2085                                      gfc_charlen_type_node);
2086
2087   gfor_fndecl_ctime =
2088     gfc_build_library_function_decl (get_identifier (PREFIX("ctime")),
2089                                      void_type_node,
2090                                      3,
2091                                      pchar_type_node,
2092                                      gfc_charlen_type_node,
2093                                      gfc_int8_type_node);
2094
2095   gfor_fndecl_adjustl =
2096     gfc_build_library_function_decl (get_identifier (PREFIX("adjustl")),
2097                                      void_type_node,
2098                                      3,
2099                                      pchar_type_node,
2100                                      gfc_charlen_type_node, pchar_type_node);
2101
2102   gfor_fndecl_adjustr =
2103     gfc_build_library_function_decl (get_identifier (PREFIX("adjustr")),
2104                                      void_type_node,
2105                                      3,
2106                                      pchar_type_node,
2107                                      gfc_charlen_type_node, pchar_type_node);
2108
2109   gfor_fndecl_si_kind =
2110     gfc_build_library_function_decl (get_identifier
2111                                         (PREFIX("selected_int_kind")),
2112                                      gfc_int4_type_node,
2113                                      1,
2114                                      pvoid_type_node);
2115
2116   gfor_fndecl_sr_kind =
2117     gfc_build_library_function_decl (get_identifier
2118                                         (PREFIX("selected_real_kind")),
2119                                      gfc_int4_type_node,
2120                                      2, pvoid_type_node,
2121                                      pvoid_type_node);
2122
2123   /* Power functions.  */
2124   {
2125     tree ctype, rtype, itype, jtype;
2126     int rkind, ikind, jkind;
2127 #define NIKINDS 3
2128 #define NRKINDS 4
2129     static int ikinds[NIKINDS] = {4, 8, 16};
2130     static int rkinds[NRKINDS] = {4, 8, 10, 16};
2131     char name[PREFIX_LEN + 12]; /* _gfortran_pow_?n_?n */
2132
2133     for (ikind=0; ikind < NIKINDS; ikind++)
2134       {
2135         itype = gfc_get_int_type (ikinds[ikind]);
2136
2137         for (jkind=0; jkind < NIKINDS; jkind++)
2138           {
2139             jtype = gfc_get_int_type (ikinds[jkind]);
2140             if (itype && jtype)
2141               {
2142                 sprintf(name, PREFIX("pow_i%d_i%d"), ikinds[ikind],
2143                         ikinds[jkind]);
2144                 gfor_fndecl_math_powi[jkind][ikind].integer =
2145                   gfc_build_library_function_decl (get_identifier (name),
2146                     jtype, 2, jtype, itype);
2147                 TREE_READONLY (gfor_fndecl_math_powi[jkind][ikind].integer) = 1;
2148               }
2149           }
2150
2151         for (rkind = 0; rkind < NRKINDS; rkind ++)
2152           {
2153             rtype = gfc_get_real_type (rkinds[rkind]);
2154             if (rtype && itype)
2155               {
2156                 sprintf(name, PREFIX("pow_r%d_i%d"), rkinds[rkind],
2157                         ikinds[ikind]);
2158                 gfor_fndecl_math_powi[rkind][ikind].real =
2159                   gfc_build_library_function_decl (get_identifier (name),
2160                     rtype, 2, rtype, itype);
2161                 TREE_READONLY (gfor_fndecl_math_powi[rkind][ikind].real) = 1;
2162               }
2163
2164             ctype = gfc_get_complex_type (rkinds[rkind]);
2165             if (ctype && itype)
2166               {
2167                 sprintf(name, PREFIX("pow_c%d_i%d"), rkinds[rkind],
2168                         ikinds[ikind]);
2169                 gfor_fndecl_math_powi[rkind][ikind].cmplx =
2170                   gfc_build_library_function_decl (get_identifier (name),
2171                     ctype, 2,ctype, itype);
2172                 TREE_READONLY (gfor_fndecl_math_powi[rkind][ikind].cmplx) = 1;
2173               }
2174           }
2175       }
2176 #undef NIKINDS
2177 #undef NRKINDS
2178   }
2179
2180   gfor_fndecl_math_cpowf =
2181     gfc_build_library_function_decl (get_identifier ("cpowf"),
2182                                      gfc_complex4_type_node,
2183                                      1, gfc_complex4_type_node);
2184   gfor_fndecl_math_cpow =
2185     gfc_build_library_function_decl (get_identifier ("cpow"),
2186                                      gfc_complex8_type_node,
2187                                      1, gfc_complex8_type_node);
2188   if (gfc_complex10_type_node)
2189     gfor_fndecl_math_cpowl10 =
2190       gfc_build_library_function_decl (get_identifier ("cpowl"),
2191                                        gfc_complex10_type_node, 1,
2192                                        gfc_complex10_type_node);
2193   if (gfc_complex16_type_node)
2194     gfor_fndecl_math_cpowl16 =
2195       gfc_build_library_function_decl (get_identifier ("cpowl"),
2196                                        gfc_complex16_type_node, 1,
2197                                        gfc_complex16_type_node);
2198
2199   gfor_fndecl_math_ishftc4 =
2200     gfc_build_library_function_decl (get_identifier (PREFIX("ishftc4")),
2201                                      gfc_int4_type_node,
2202                                      3, gfc_int4_type_node,
2203                                      gfc_int4_type_node, gfc_int4_type_node);
2204   gfor_fndecl_math_ishftc8 =
2205     gfc_build_library_function_decl (get_identifier (PREFIX("ishftc8")),
2206                                      gfc_int8_type_node,
2207                                      3, gfc_int8_type_node,
2208                                      gfc_int4_type_node, gfc_int4_type_node);
2209   if (gfc_int16_type_node)
2210     gfor_fndecl_math_ishftc16 =
2211       gfc_build_library_function_decl (get_identifier (PREFIX("ishftc16")),
2212                                        gfc_int16_type_node, 3,
2213                                        gfc_int16_type_node,
2214                                        gfc_int4_type_node,
2215                                        gfc_int4_type_node);
2216
2217   gfor_fndecl_math_exponent4 =
2218     gfc_build_library_function_decl (get_identifier (PREFIX("exponent_r4")),
2219                                      gfc_int4_type_node,
2220                                      1, gfc_real4_type_node);
2221   gfor_fndecl_math_exponent8 =
2222     gfc_build_library_function_decl (get_identifier (PREFIX("exponent_r8")),
2223                                      gfc_int4_type_node,
2224                                      1, gfc_real8_type_node);
2225   if (gfc_real10_type_node)
2226     gfor_fndecl_math_exponent10 =
2227       gfc_build_library_function_decl (get_identifier (PREFIX("exponent_r10")),
2228                                        gfc_int4_type_node, 1,
2229                                        gfc_real10_type_node);
2230   if (gfc_real16_type_node)
2231     gfor_fndecl_math_exponent16 =
2232       gfc_build_library_function_decl (get_identifier (PREFIX("exponent_r16")),
2233                                        gfc_int4_type_node, 1,
2234                                        gfc_real16_type_node);
2235
2236   /* BLAS functions.  */
2237   {
2238     tree pint = build_pointer_type (integer_type_node);
2239     tree ps = build_pointer_type (gfc_get_real_type (gfc_default_real_kind));
2240     tree pd = build_pointer_type (gfc_get_real_type (gfc_default_double_kind));
2241     tree pc = build_pointer_type (gfc_get_complex_type (gfc_default_real_kind));
2242     tree pz = build_pointer_type
2243                 (gfc_get_complex_type (gfc_default_double_kind));
2244
2245     gfor_fndecl_sgemm = gfc_build_library_function_decl
2246                           (get_identifier
2247                              (gfc_option.flag_underscoring ? "sgemm_"
2248                                                            : "sgemm"),
2249                            void_type_node, 15, pchar_type_node,
2250                            pchar_type_node, pint, pint, pint, ps, ps, pint,
2251                            ps, pint, ps, ps, pint, integer_type_node,
2252                            integer_type_node);
2253     gfor_fndecl_dgemm = gfc_build_library_function_decl
2254                           (get_identifier
2255                              (gfc_option.flag_underscoring ? "dgemm_"
2256                                                            : "dgemm"),
2257                            void_type_node, 15, pchar_type_node,
2258                            pchar_type_node, pint, pint, pint, pd, pd, pint,
2259                            pd, pint, pd, pd, pint, integer_type_node,
2260                            integer_type_node);
2261     gfor_fndecl_cgemm = gfc_build_library_function_decl
2262                           (get_identifier
2263                              (gfc_option.flag_underscoring ? "cgemm_"
2264                                                            : "cgemm"),
2265                            void_type_node, 15, pchar_type_node,
2266                            pchar_type_node, pint, pint, pint, pc, pc, pint,
2267                            pc, pint, pc, pc, pint, integer_type_node,
2268                            integer_type_node);
2269     gfor_fndecl_zgemm = gfc_build_library_function_decl
2270                           (get_identifier
2271                              (gfc_option.flag_underscoring ? "zgemm_"
2272                                                            : "zgemm"),
2273                            void_type_node, 15, pchar_type_node,
2274                            pchar_type_node, pint, pint, pint, pz, pz, pint,
2275                            pz, pint, pz, pz, pint, integer_type_node,
2276                            integer_type_node);
2277   }
2278
2279   /* Other functions.  */
2280   gfor_fndecl_size0 =
2281     gfc_build_library_function_decl (get_identifier (PREFIX("size0")),
2282                                      gfc_array_index_type,
2283                                      1, pvoid_type_node);
2284   gfor_fndecl_size1 =
2285     gfc_build_library_function_decl (get_identifier (PREFIX("size1")),
2286                                      gfc_array_index_type,
2287                                      2, pvoid_type_node,
2288                                      gfc_array_index_type);
2289
2290   gfor_fndecl_iargc =
2291     gfc_build_library_function_decl (get_identifier (PREFIX ("iargc")),
2292                                      gfc_int4_type_node,
2293                                      0);
2294 }
2295
2296
2297 /* Make prototypes for runtime library functions.  */
2298
2299 void
2300 gfc_build_builtin_function_decls (void)
2301 {
2302   tree gfc_int4_type_node = gfc_get_int_type (4);
2303
2304   gfor_fndecl_stop_numeric =
2305     gfc_build_library_function_decl (get_identifier (PREFIX("stop_numeric")),
2306                                      void_type_node, 1, gfc_int4_type_node);
2307   /* Stop doesn't return.  */
2308   TREE_THIS_VOLATILE (gfor_fndecl_stop_numeric) = 1;
2309
2310   gfor_fndecl_stop_string =
2311     gfc_build_library_function_decl (get_identifier (PREFIX("stop_string")),
2312                                      void_type_node, 2, pchar_type_node,
2313                                      gfc_int4_type_node);
2314   /* Stop doesn't return.  */
2315   TREE_THIS_VOLATILE (gfor_fndecl_stop_string) = 1;
2316
2317   gfor_fndecl_pause_numeric =
2318     gfc_build_library_function_decl (get_identifier (PREFIX("pause_numeric")),
2319                                      void_type_node, 1, gfc_int4_type_node);
2320
2321   gfor_fndecl_pause_string =
2322     gfc_build_library_function_decl (get_identifier (PREFIX("pause_string")),
2323                                      void_type_node, 2, pchar_type_node,
2324                                      gfc_int4_type_node);
2325
2326   gfor_fndecl_select_string =
2327     gfc_build_library_function_decl (get_identifier (PREFIX("select_string")),
2328                                      integer_type_node, 0);
2329
2330   gfor_fndecl_runtime_error =
2331     gfc_build_library_function_decl (get_identifier (PREFIX("runtime_error")),
2332                                      void_type_node, -1, pchar_type_node);
2333   /* The runtime_error function does not return.  */
2334   TREE_THIS_VOLATILE (gfor_fndecl_runtime_error) = 1;
2335
2336   gfor_fndecl_runtime_error_at =
2337     gfc_build_library_function_decl (get_identifier (PREFIX("runtime_error_at")),
2338                                      void_type_node, -2, pchar_type_node,
2339                                      pchar_type_node);
2340   /* The runtime_error_at function does not return.  */
2341   TREE_THIS_VOLATILE (gfor_fndecl_runtime_error_at) = 1;
2342
2343   gfor_fndecl_generate_error =
2344     gfc_build_library_function_decl (get_identifier (PREFIX("generate_error")),
2345                                      void_type_node, 3, pvoid_type_node,
2346                                      integer_type_node, pchar_type_node);
2347
2348   gfor_fndecl_os_error =
2349     gfc_build_library_function_decl (get_identifier (PREFIX("os_error")),
2350                                      void_type_node, 1, pchar_type_node);
2351   /* The runtime_error function does not return.  */
2352   TREE_THIS_VOLATILE (gfor_fndecl_os_error) = 1;
2353
2354   gfor_fndecl_set_fpe =
2355     gfc_build_library_function_decl (get_identifier (PREFIX("set_fpe")),
2356                                     void_type_node, 1, integer_type_node);
2357
2358   /* Keep the array dimension in sync with the call, later in this file.  */
2359   gfor_fndecl_set_options =
2360     gfc_build_library_function_decl (get_identifier (PREFIX("set_options")),
2361                                     void_type_node, 2, integer_type_node,
2362                                     pvoid_type_node);
2363
2364   gfor_fndecl_set_convert =
2365     gfc_build_library_function_decl (get_identifier (PREFIX("set_convert")),
2366                                      void_type_node, 1, integer_type_node);
2367
2368   gfor_fndecl_set_record_marker =
2369     gfc_build_library_function_decl (get_identifier (PREFIX("set_record_marker")),
2370                                      void_type_node, 1, integer_type_node);
2371
2372   gfor_fndecl_set_max_subrecord_length =
2373     gfc_build_library_function_decl (get_identifier (PREFIX("set_max_subrecord_length")),
2374                                      void_type_node, 1, integer_type_node);
2375
2376   gfor_fndecl_in_pack = gfc_build_library_function_decl (
2377         get_identifier (PREFIX("internal_pack")),
2378         pvoid_type_node, 1, pvoid_type_node);
2379
2380   gfor_fndecl_in_unpack = gfc_build_library_function_decl (
2381         get_identifier (PREFIX("internal_unpack")),
2382         pvoid_type_node, 1, pvoid_type_node);
2383
2384   gfor_fndecl_associated =
2385     gfc_build_library_function_decl (
2386                                      get_identifier (PREFIX("associated")),
2387                                      integer_type_node, 2, ppvoid_type_node,
2388                                      ppvoid_type_node);
2389
2390   gfc_build_intrinsic_function_decls ();
2391   gfc_build_intrinsic_lib_fndecls ();
2392   gfc_build_io_library_fndecls ();
2393 }
2394
2395
2396 /* Evaluate the length of dummy character variables.  */
2397
2398 static tree
2399 gfc_trans_dummy_character (gfc_symbol *sym, gfc_charlen *cl, tree fnbody)
2400 {
2401   stmtblock_t body;
2402
2403   gfc_finish_decl (cl->backend_decl);
2404
2405   gfc_start_block (&body);
2406
2407   /* Evaluate the string length expression.  */
2408   gfc_conv_string_length (cl, &body);
2409
2410   gfc_trans_vla_type_sizes (sym, &body);
2411
2412   gfc_add_expr_to_block (&body, fnbody);
2413   return gfc_finish_block (&body);
2414 }
2415
2416
2417 /* Allocate and cleanup an automatic character variable.  */
2418
2419 static tree
2420 gfc_trans_auto_character_variable (gfc_symbol * sym, tree fnbody)
2421 {
2422   stmtblock_t body;
2423   tree decl;
2424   tree tmp;
2425
2426   gcc_assert (sym->backend_decl);
2427   gcc_assert (sym->ts.cl && sym->ts.cl->length);
2428
2429   gfc_start_block (&body);
2430
2431   /* Evaluate the string length expression.  */
2432   gfc_conv_string_length (sym->ts.cl, &body);
2433
2434   gfc_trans_vla_type_sizes (sym, &body);
2435
2436   decl = sym->backend_decl;
2437
2438   /* Emit a DECL_EXPR for this variable, which will cause the
2439      gimplifier to allocate storage, and all that good stuff.  */
2440   tmp = build1 (DECL_EXPR, TREE_TYPE (decl), decl);
2441   gfc_add_expr_to_block (&body, tmp);
2442
2443   gfc_add_expr_to_block (&body, fnbody);
2444   return gfc_finish_block (&body);
2445 }
2446
2447 /* Set the initial value of ASSIGN statement auxiliary variable explicitly.  */
2448
2449 static tree
2450 gfc_trans_assign_aux_var (gfc_symbol * sym, tree fnbody)
2451 {
2452   stmtblock_t body;
2453
2454   gcc_assert (sym->backend_decl);
2455   gfc_start_block (&body);
2456
2457   /* Set the initial value to length. See the comments in
2458      function gfc_add_assign_aux_vars in this file.  */
2459   gfc_add_modify_expr (&body, GFC_DECL_STRING_LEN (sym->backend_decl),
2460                        build_int_cst (NULL_TREE, -2));
2461
2462   gfc_add_expr_to_block (&body, fnbody);
2463   return gfc_finish_block (&body);
2464 }
2465
2466 static void
2467 gfc_trans_vla_one_sizepos (tree *tp, stmtblock_t *body)
2468 {
2469   tree t = *tp, var, val;
2470
2471   if (t == NULL || t == error_mark_node)
2472     return;
2473   if (TREE_CONSTANT (t) || DECL_P (t))
2474     return;
2475
2476   if (TREE_CODE (t) == SAVE_EXPR)
2477     {
2478       if (SAVE_EXPR_RESOLVED_P (t))
2479         {
2480           *tp = TREE_OPERAND (t, 0);
2481           return;
2482         }
2483       val = TREE_OPERAND (t, 0);
2484     }
2485   else
2486     val = t;
2487
2488   var = gfc_create_var_np (TREE_TYPE (t), NULL);
2489   gfc_add_decl_to_function (var);
2490   gfc_add_modify_expr (body, var, val);
2491   if (TREE_CODE (t) == SAVE_EXPR)
2492     TREE_OPERAND (t, 0) = var;
2493   *tp = var;
2494 }
2495
2496 static void
2497 gfc_trans_vla_type_sizes_1 (tree type, stmtblock_t *body)
2498 {
2499   tree t;
2500
2501   if (type == NULL || type == error_mark_node)
2502     return;
2503
2504   type = TYPE_MAIN_VARIANT (type);
2505
2506   if (TREE_CODE (type) == INTEGER_TYPE)
2507     {
2508       gfc_trans_vla_one_sizepos (&TYPE_MIN_VALUE (type), body);
2509       gfc_trans_vla_one_sizepos (&TYPE_MAX_VALUE (type), body);
2510
2511       for (t = TYPE_NEXT_VARIANT (type); t; t = TYPE_NEXT_VARIANT (t))
2512         {
2513           TYPE_MIN_VALUE (t) = TYPE_MIN_VALUE (type);
2514           TYPE_MAX_VALUE (t) = TYPE_MAX_VALUE (type);
2515         }
2516     }
2517   else if (TREE_CODE (type) == ARRAY_TYPE)
2518     {
2519       gfc_trans_vla_type_sizes_1 (TREE_TYPE (type), body);
2520       gfc_trans_vla_type_sizes_1 (TYPE_DOMAIN (type), body);
2521       gfc_trans_vla_one_sizepos (&TYPE_SIZE (type), body);
2522       gfc_trans_vla_one_sizepos (&TYPE_SIZE_UNIT (type), body);
2523
2524       for (t = TYPE_NEXT_VARIANT (type); t; t = TYPE_NEXT_VARIANT (t))
2525         {
2526           TYPE_SIZE (t) = TYPE_SIZE (type);
2527           TYPE_SIZE_UNIT (t) = TYPE_SIZE_UNIT (type);
2528         }
2529     }
2530 }
2531
2532 /* Make sure all type sizes and array domains are either constant,
2533    or variable or parameter decls.  This is a simplified variant
2534    of gimplify_type_sizes, but we can't use it here, as none of the
2535    variables in the expressions have been gimplified yet.
2536    As type sizes and domains for various variable length arrays
2537    contain VAR_DECLs that are only initialized at gfc_trans_deferred_vars
2538    time, without this routine gimplify_type_sizes in the middle-end
2539    could result in the type sizes being gimplified earlier than where
2540    those variables are initialized.  */
2541
2542 void
2543 gfc_trans_vla_type_sizes (gfc_symbol *sym, stmtblock_t *body)
2544 {
2545   tree type = TREE_TYPE (sym->backend_decl);
2546
2547   if (TREE_CODE (type) == FUNCTION_TYPE
2548       && (sym->attr.function || sym->attr.result || sym->attr.entry))
2549     {
2550       if (! current_fake_result_decl)
2551         return;
2552
2553       type = TREE_TYPE (TREE_VALUE (current_fake_result_decl));
2554     }
2555
2556   while (POINTER_TYPE_P (type))
2557     type = TREE_TYPE (type);
2558
2559   if (GFC_DESCRIPTOR_TYPE_P (type))
2560     {
2561       tree etype = GFC_TYPE_ARRAY_DATAPTR_TYPE (type);
2562
2563       while (POINTER_TYPE_P (etype))
2564         etype = TREE_TYPE (etype);
2565
2566       gfc_trans_vla_type_sizes_1 (etype, body);
2567     }
2568
2569   gfc_trans_vla_type_sizes_1 (type, body);
2570 }
2571
2572
2573 /* Initialize INTENT(OUT) derived type dummies.  */
2574 static tree
2575 init_intent_out_dt (gfc_symbol * proc_sym, tree body)
2576 {
2577   stmtblock_t fnblock;
2578   gfc_formal_arglist *f;
2579   gfc_expr *tmpe;
2580   tree tmp;
2581   tree present;
2582
2583   gfc_init_block (&fnblock);
2584
2585   for (f = proc_sym->formal; f; f = f->next)
2586     {
2587       if (f->sym && f->sym->attr.intent == INTENT_OUT
2588             && f->sym->ts.type == BT_DERIVED
2589             && !f->sym->ts.derived->attr.alloc_comp
2590             && f->sym->value)
2591         {
2592           gcc_assert (!f->sym->attr.allocatable);
2593           gfc_set_sym_referenced (f->sym);
2594           tmpe = gfc_lval_expr_from_sym (f->sym);
2595           tmp = gfc_trans_assignment (tmpe, f->sym->value, false);
2596
2597           present = gfc_conv_expr_present (f->sym);
2598           tmp = build3 (COND_EXPR, TREE_TYPE (tmp), present,
2599                         tmp, build_empty_stmt ());
2600           gfc_add_expr_to_block (&fnblock, tmp);
2601           gfc_free_expr (tmpe);
2602         }
2603     }
2604
2605   gfc_add_expr_to_block (&fnblock, body);
2606   return gfc_finish_block (&fnblock);
2607 }
2608
2609
2610
2611 /* Generate function entry and exit code, and add it to the function body.
2612    This includes:
2613     Allocation and initialization of array variables.
2614     Allocation of character string variables.
2615     Initialization and possibly repacking of dummy arrays.
2616     Initialization of ASSIGN statement auxiliary variable.  */
2617
2618 static tree
2619 gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
2620 {
2621   locus loc;
2622   gfc_symbol *sym;
2623   gfc_formal_arglist *f;
2624   stmtblock_t body;
2625   bool seen_trans_deferred_array = false;
2626
2627   /* Deal with implicit return variables.  Explicit return variables will
2628      already have been added.  */
2629   if (gfc_return_by_reference (proc_sym) && proc_sym->result == proc_sym)
2630     {
2631       if (!current_fake_result_decl)
2632         {
2633           gfc_entry_list *el = NULL;
2634           if (proc_sym->attr.entry_master)
2635             {
2636               for (el = proc_sym->ns->entries; el; el = el->next)
2637                 if (el->sym != el->sym->result)
2638                   break;
2639             }
2640           if (el == NULL)
2641             warning (0, "Function does not return a value");
2642         }
2643       else if (proc_sym->as)
2644         {
2645           tree result = TREE_VALUE (current_fake_result_decl);
2646           fnbody = gfc_trans_dummy_array_bias (proc_sym, result, fnbody);
2647
2648           /* An automatic character length, pointer array result.  */
2649           if (proc_sym->ts.type == BT_CHARACTER
2650                 && TREE_CODE (proc_sym->ts.cl->backend_decl) == VAR_DECL)
2651             fnbody = gfc_trans_dummy_character (proc_sym, proc_sym->ts.cl,
2652                                                 fnbody);
2653         }
2654       else if (proc_sym->ts.type == BT_CHARACTER)
2655         {
2656           if (TREE_CODE (proc_sym->ts.cl->backend_decl) == VAR_DECL)
2657             fnbody = gfc_trans_dummy_character (proc_sym, proc_sym->ts.cl,
2658                                                 fnbody);
2659         }
2660       else
2661         gcc_assert (gfc_option.flag_f2c
2662                     && proc_sym->ts.type == BT_COMPLEX);
2663     }
2664
2665   /* Initialize the INTENT(OUT) derived type dummy arguments.  This
2666      should be done here so that the offsets and lbounds of arrays
2667      are available.  */
2668   fnbody = init_intent_out_dt (proc_sym, fnbody);
2669
2670   for (sym = proc_sym->tlink; sym != proc_sym; sym = sym->tlink)
2671     {
2672       bool sym_has_alloc_comp = (sym->ts.type == BT_DERIVED)
2673                                    && sym->ts.derived->attr.alloc_comp;
2674       if (sym->attr.dimension)
2675         {
2676           switch (sym->as->type)
2677             {
2678             case AS_EXPLICIT:
2679               if (sym->attr.dummy || sym->attr.result)
2680                 fnbody =
2681                   gfc_trans_dummy_array_bias (sym, sym->backend_decl, fnbody);
2682               else if (sym->attr.pointer || sym->attr.allocatable)
2683                 {
2684                   if (TREE_STATIC (sym->backend_decl))
2685                     gfc_trans_static_array_pointer (sym);
2686                   else
2687                     {
2688                       seen_trans_deferred_array = true;
2689                       fnbody = gfc_trans_deferred_array (sym, fnbody);
2690                     }
2691                 }
2692               else
2693                 {
2694                   if (sym_has_alloc_comp)
2695                     {
2696                       seen_trans_deferred_array = true;
2697                       fnbody = gfc_trans_deferred_array (sym, fnbody);
2698                     }
2699
2700                   gfc_get_backend_locus (&loc);
2701                   gfc_set_backend_locus (&sym->declared_at);
2702                   fnbody = gfc_trans_auto_array_allocation (sym->backend_decl,
2703                       sym, fnbody);
2704                   gfc_set_backend_locus (&loc);
2705                 }
2706               break;
2707
2708             case AS_ASSUMED_SIZE:
2709               /* Must be a dummy parameter.  */
2710               gcc_assert (sym->attr.dummy);
2711
2712               /* We should always pass assumed size arrays the g77 way.  */
2713               fnbody = gfc_trans_g77_array (sym, fnbody);
2714               break;
2715
2716             case AS_ASSUMED_SHAPE:
2717               /* Must be a dummy parameter.  */
2718               gcc_assert (sym->attr.dummy);
2719
2720               fnbody = gfc_trans_dummy_array_bias (sym, sym->backend_decl,
2721                                                    fnbody);
2722               break;
2723
2724             case AS_DEFERRED:
2725               seen_trans_deferred_array = true;
2726               fnbody = gfc_trans_deferred_array (sym, fnbody);
2727               break;
2728
2729             default:
2730               gcc_unreachable ();
2731             }
2732           if (sym_has_alloc_comp && !seen_trans_deferred_array)
2733             fnbody = gfc_trans_deferred_array (sym, fnbody);
2734         }
2735       else if (sym_has_alloc_comp)
2736         fnbody = gfc_trans_deferred_array (sym, fnbody);
2737       else if (sym->ts.type == BT_CHARACTER)
2738         {
2739           gfc_get_backend_locus (&loc);
2740           gfc_set_backend_locus (&sym->declared_at);
2741           if (sym->attr.dummy || sym->attr.result)
2742             fnbody = gfc_trans_dummy_character (sym, sym->ts.cl, fnbody);
2743           else
2744             fnbody = gfc_trans_auto_character_variable (sym, fnbody);
2745           gfc_set_backend_locus (&loc);
2746         }
2747       else if (sym->attr.assign)
2748         {
2749           gfc_get_backend_locus (&loc);
2750           gfc_set_backend_locus (&sym->declared_at);
2751           fnbody = gfc_trans_assign_aux_var (sym, fnbody);
2752           gfc_set_backend_locus (&loc);
2753         }
2754       else
2755         gcc_unreachable ();
2756     }
2757
2758   gfc_init_block (&body);
2759
2760   for (f = proc_sym->formal; f; f = f->next)
2761     {
2762       if (f->sym && f->sym->tlink == NULL && f->sym->ts.type == BT_CHARACTER)
2763         {
2764           gcc_assert (f->sym->ts.cl->backend_decl != NULL);
2765           if (TREE_CODE (f->sym->ts.cl->backend_decl) == PARM_DECL)
2766             gfc_trans_vla_type_sizes (f->sym, &body);
2767         }
2768     }
2769
2770   if (gfc_return_by_reference (proc_sym) && proc_sym->ts.type == BT_CHARACTER
2771       && current_fake_result_decl != NULL)
2772     {
2773       gcc_assert (proc_sym->ts.cl->backend_decl != NULL);
2774       if (TREE_CODE (proc_sym->ts.cl->backend_decl) == PARM_DECL)
2775         gfc_trans_vla_type_sizes (proc_sym, &body);
2776     }
2777
2778   gfc_add_expr_to_block (&body, fnbody);
2779   return gfc_finish_block (&body);
2780 }
2781
2782
2783 /* Output an initialized decl for a module variable.  */
2784
2785 static void
2786 gfc_create_module_variable (gfc_symbol * sym)
2787 {
2788   tree decl;
2789
2790   /* Module functions with alternate entries are dealt with later and
2791      would get caught by the next condition.  */
2792   if (sym->attr.entry)
2793     return;
2794
2795   /* Make sure we convert the types of the derived types from iso_c_binding
2796      into (void *).  */
2797   if (sym->attr.flavor != FL_PROCEDURE && sym->attr.is_iso_c
2798       && sym->ts.type == BT_DERIVED)
2799     sym->backend_decl = gfc_typenode_for_spec (&(sym->ts));
2800
2801   /* Only output variables and array valued, or derived type,
2802      parameters.  */
2803   if (sym->attr.flavor != FL_VARIABLE
2804         && !(sym->attr.flavor == FL_PARAMETER
2805                && (sym->attr.dimension || sym->ts.type == BT_DERIVED)))
2806     return;
2807
2808   /* Don't generate variables from other modules. Variables from
2809      COMMONs will already have been generated.  */
2810   if (sym->attr.use_assoc || sym->attr.in_common)
2811     return;
2812
2813   /* Equivalenced variables arrive here after creation.  */
2814   if (sym->backend_decl
2815         && (sym->equiv_built || sym->attr.in_equivalence))
2816       return;
2817
2818   if (sym->backend_decl)
2819     internal_error ("backend decl for module variable %s already exists",
2820                     sym->name);
2821
2822   /* We always want module variables to be created.  */
2823   sym->attr.referenced = 1;
2824   /* Create the decl.  */
2825   decl = gfc_get_symbol_decl (sym);
2826
2827   /* Create the variable.  */
2828   pushdecl (decl);
2829   rest_of_decl_compilation (decl, 1, 0);
2830
2831   /* Also add length of strings.  */
2832   if (sym->ts.type == BT_CHARACTER)
2833     {
2834       tree length;
2835
2836       length = sym->ts.cl->backend_decl;
2837       if (!INTEGER_CST_P (length))
2838         {
2839           pushdecl (length);
2840           rest_of_decl_compilation (length, 1, 0);
2841         }
2842     }
2843 }
2844
2845
2846 /* Generate all the required code for module variables.  */
2847
2848 void
2849 gfc_generate_module_vars (gfc_namespace * ns)
2850 {
2851   module_namespace = ns;
2852
2853   /* Check if the frontend left the namespace in a reasonable state.  */
2854   gcc_assert (ns->proc_name && !ns->proc_name->tlink);
2855
2856   /* Generate COMMON blocks.  */
2857   gfc_trans_common (ns);
2858
2859   /* Create decls for all the module variables.  */
2860   gfc_traverse_ns (ns, gfc_create_module_variable);
2861 }
2862
2863 static void
2864 gfc_generate_contained_functions (gfc_namespace * parent)
2865 {
2866   gfc_namespace *ns;
2867
2868   /* We create all the prototypes before generating any code.  */
2869   for (ns = parent->contained; ns; ns = ns->sibling)
2870     {
2871       /* Skip namespaces from used modules.  */
2872       if (ns->parent != parent)
2873         continue;
2874
2875       gfc_create_function_decl (ns);
2876     }
2877
2878   for (ns = parent->contained; ns; ns = ns->sibling)
2879     {
2880       /* Skip namespaces from used modules.  */
2881       if (ns->parent != parent)
2882         continue;
2883
2884       gfc_generate_function_code (ns);
2885     }
2886 }
2887
2888
2889 /* Drill down through expressions for the array specification bounds and
2890    character length calling generate_local_decl for all those variables
2891    that have not already been declared.  */
2892
2893 static void
2894 generate_local_decl (gfc_symbol *);
2895
2896 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced.  */
2897
2898 static bool
2899 expr_decls (gfc_expr *e, gfc_symbol *sym,
2900             int *f ATTRIBUTE_UNUSED)
2901 {
2902   if (e->expr_type != EXPR_VARIABLE
2903             || sym == e->symtree->n.sym
2904             || e->symtree->n.sym->mark
2905             || e->symtree->n.sym->ns != sym->ns)
2906         return false;
2907
2908   generate_local_decl (e->symtree->n.sym);
2909   return false;
2910 }
2911
2912 static void
2913 generate_expr_decls (gfc_symbol *sym, gfc_expr *e)
2914 {
2915   gfc_traverse_expr (e, sym, expr_decls, 0);
2916 }
2917
2918
2919 /* Check for dependencies in the character length and array spec.  */
2920
2921 static void
2922 generate_dependency_declarations (gfc_symbol *sym)
2923 {
2924   int i;
2925
2926   if (sym->ts.type == BT_CHARACTER
2927       && sym->ts.cl
2928       && sym->ts.cl->length
2929       && sym->ts.cl->length->expr_type != EXPR_CONSTANT)
2930     generate_expr_decls (sym, sym->ts.cl->length);
2931
2932   if (sym->as && sym->as->rank)
2933     {
2934       for (i = 0; i < sym->as->rank; i++)
2935         {
2936           generate_expr_decls (sym, sym->as->lower[i]);
2937           generate_expr_decls (sym, sym->as->upper[i]);
2938         }
2939     }
2940 }
2941
2942
2943 /* Generate decls for all local variables.  We do this to ensure correct
2944    handling of expressions which only appear in the specification of
2945    other functions.  */
2946
2947 static void
2948 generate_local_decl (gfc_symbol * sym)
2949 {
2950   if (sym->attr.flavor == FL_VARIABLE)
2951     {
2952       /* Check for dependencies in the array specification and string
2953         length, adding the necessary declarations to the function.  We
2954         mark the symbol now, as well as in traverse_ns, to prevent
2955         getting stuck in a circular dependency.  */
2956       sym->mark = 1;
2957       if (!sym->attr.dummy && !sym->ns->proc_name->attr.entry_master)
2958         generate_dependency_declarations (sym);
2959
2960       if (sym->attr.referenced)
2961         gfc_get_symbol_decl (sym);
2962       /* INTENT(out) dummy arguments are likely meant to be set.  */
2963       else if (warn_unused_variable
2964                && sym->attr.dummy
2965                && sym->attr.intent == INTENT_OUT)
2966         gfc_warning ("Dummy argument '%s' at %L was declared INTENT(OUT) but was not set",
2967                      sym->name, &sym->declared_at);
2968       /* Specific warning for unused dummy arguments. */
2969       else if (warn_unused_variable && sym->attr.dummy)
2970         gfc_warning ("Unused dummy argument '%s' at %L", sym->name,
2971                      &sym->declared_at);
2972       /* Warn for unused variables, but not if they're inside a common
2973          block or are use-associated.  */
2974       else if (warn_unused_variable
2975                && !(sym->attr.in_common || sym->attr.use_assoc))
2976         gfc_warning ("Unused variable '%s' declared at %L", sym->name,
2977                      &sym->declared_at);
2978       /* For variable length CHARACTER parameters, the PARM_DECL already
2979          references the length variable, so force gfc_get_symbol_decl
2980          even when not referenced.  If optimize > 0, it will be optimized
2981          away anyway.  But do this only after emitting -Wunused-parameter
2982          warning if requested.  */
2983       if (sym->attr.dummy && ! sym->attr.referenced
2984           && sym->ts.type == BT_CHARACTER
2985           && sym->ts.cl->backend_decl != NULL
2986           && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
2987         {
2988           sym->attr.referenced = 1;
2989           gfc_get_symbol_decl (sym);
2990         }
2991
2992       /* We do not want the middle-end to warn about unused parameters
2993          as this was already done above.  */
2994       if (sym->attr.dummy && sym->backend_decl != NULL_TREE)
2995           TREE_NO_WARNING(sym->backend_decl) = 1;
2996     }
2997   else if (sym->attr.flavor == FL_PARAMETER)
2998     {
2999       if (warn_unused_parameter
3000            && !sym->attr.referenced
3001            && !sym->attr.use_assoc)
3002         gfc_warning ("Unused parameter '%s' declared at %L", sym->name,
3003                      &sym->declared_at);
3004     }
3005
3006   if (sym->attr.dummy == 1)
3007     {
3008       /* Modify the tree type for scalar character dummy arguments of bind(c)
3009          procedures if they are passed by value.  The tree type for them will
3010          be promoted to INTEGER_TYPE for the middle end, which appears to be
3011          what C would do with characters passed by-value.  The value attribute
3012          implies the dummy is a scalar.  */
3013       if (sym->attr.value == 1 && sym->backend_decl != NULL
3014           && sym->ts.type == BT_CHARACTER && sym->ts.is_c_interop
3015           && sym->ns->proc_name != NULL && sym->ns->proc_name->attr.is_bind_c)
3016         gfc_conv_scalar_char_value (sym, NULL, NULL);
3017     }
3018
3019   /* Make sure we convert the types of the derived types from iso_c_binding
3020      into (void *).  */
3021   if (sym->attr.flavor != FL_PROCEDURE && sym->attr.is_iso_c
3022       && sym->ts.type == BT_DERIVED)
3023     sym->backend_decl = gfc_typenode_for_spec (&(sym->ts));
3024 }
3025
3026 static void
3027 generate_local_vars (gfc_namespace * ns)
3028 {
3029   gfc_traverse_ns (ns, generate_local_decl);
3030 }
3031
3032
3033 /* Generate a switch statement to jump to the correct entry point.  Also
3034    creates the label decls for the entry points.  */
3035
3036 static tree
3037 gfc_trans_entry_master_switch (gfc_entry_list * el)
3038 {
3039   stmtblock_t block;
3040   tree label;
3041   tree tmp;
3042   tree val;
3043
3044   gfc_init_block (&block);
3045   for (; el; el = el->next)
3046     {
3047       /* Add the case label.  */
3048       label = gfc_build_label_decl (NULL_TREE);
3049       val = build_int_cst (gfc_array_index_type, el->id);
3050       tmp = build3_v (CASE_LABEL_EXPR, val, NULL_TREE, label);
3051       gfc_add_expr_to_block (&block, tmp);
3052
3053       /* And jump to the actual entry point.  */
3054       label = gfc_build_label_decl (NULL_TREE);
3055       tmp = build1_v (GOTO_EXPR, label);
3056       gfc_add_expr_to_block (&block, tmp);
3057
3058       /* Save the label decl.  */
3059       el->label = label;
3060     }
3061   tmp = gfc_finish_block (&block);
3062   /* The first argument selects the entry point.  */
3063   val = DECL_ARGUMENTS (current_function_decl);
3064   tmp = build3_v (SWITCH_EXPR, val, tmp, NULL_TREE);
3065   return tmp;
3066 }
3067
3068
3069 /* Generate code for a function.  */
3070
3071 void
3072 gfc_generate_function_code (gfc_namespace * ns)
3073 {
3074   tree fndecl;
3075   tree old_context;
3076   tree decl;
3077   tree tmp;
3078   tree tmp2;
3079   stmtblock_t block;
3080   stmtblock_t body;
3081   tree result;
3082   gfc_symbol *sym;
3083   int rank;
3084
3085   sym = ns->proc_name;
3086
3087   /* Check that the frontend isn't still using this.  */
3088   gcc_assert (sym->tlink == NULL);
3089   sym->tlink = sym;
3090
3091   /* Create the declaration for functions with global scope.  */
3092   if (!sym->backend_decl)
3093     gfc_create_function_decl (ns);
3094
3095   fndecl = sym->backend_decl;
3096   old_context = current_function_decl;
3097
3098   if (old_context)
3099     {
3100       push_function_context ();
3101       saved_parent_function_decls = saved_function_decls;
3102       saved_function_decls = NULL_TREE;
3103     }
3104
3105   trans_function_start (sym);
3106
3107   gfc_start_block (&block);
3108
3109   if (ns->entries && ns->proc_name->ts.type == BT_CHARACTER)
3110     {
3111       /* Copy length backend_decls to all entry point result
3112          symbols.  */
3113       gfc_entry_list *el;
3114       tree backend_decl;
3115
3116       gfc_conv_const_charlen (ns->proc_name->ts.cl);
3117       backend_decl = ns->proc_name->result->ts.cl->backend_decl;
3118       for (el = ns->entries; el; el = el->next)
3119         el->sym->result->ts.cl->backend_decl = backend_decl;
3120     }
3121
3122   /* Translate COMMON blocks.  */
3123   gfc_trans_common (ns);
3124
3125   /* Null the parent fake result declaration if this namespace is
3126      a module function or an external procedures.  */
3127   if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
3128         || ns->parent == NULL)
3129     parent_fake_result_decl = NULL_TREE;
3130
3131   gfc_generate_contained_functions (ns);
3132
3133   generate_local_vars (ns);
3134
3135   /* Keep the parent fake result declaration in module functions
3136      or external procedures.  */
3137   if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
3138         || ns->parent == NULL)
3139     current_fake_result_decl = parent_fake_result_decl;
3140   else
3141     current_fake_result_decl = NULL_TREE;
3142
3143   current_function_return_label = NULL;
3144
3145   /* Now generate the code for the body of this function.  */
3146   gfc_init_block (&body);
3147
3148   /* If this is the main program, add a call to set_options to set up the
3149      runtime library Fortran language standard parameters.  */
3150   if (sym->attr.is_main_program)
3151     {
3152       tree array_type, array, var;
3153
3154       /* Passing a new option to the library requires four modifications:
3155            + add it to the tree_cons list below
3156            + change the array size in the call to build_array_type
3157            + change the first argument to the library call
3158              gfor_fndecl_set_options
3159            + modify the library (runtime/compile_options.c)!  */
3160       array = tree_cons (NULL_TREE,
3161                          build_int_cst (integer_type_node,
3162                                         gfc_option.warn_std), NULL_TREE);
3163       array = tree_cons (NULL_TREE,
3164                          build_int_cst (integer_type_node,
3165                                         gfc_option.allow_std), array);
3166       array = tree_cons (NULL_TREE,
3167                          build_int_cst (integer_type_node, pedantic), array);
3168       array = tree_cons (NULL_TREE,
3169                          build_int_cst (integer_type_node,
3170                                         gfc_option.flag_dump_core), array);
3171       array = tree_cons (NULL_TREE,
3172                          build_int_cst (integer_type_node,
3173                                         gfc_option.flag_backtrace), array);
3174       array = tree_cons (NULL_TREE,
3175                          build_int_cst (integer_type_node,
3176                                         gfc_option.flag_sign_zero), array);
3177
3178       array = tree_cons (NULL_TREE,
3179                          build_int_cst (integer_type_node,
3180                                         flag_bounds_check), array);
3181
3182       array_type = build_array_type (integer_type_node,
3183                                      build_index_type (build_int_cst (NULL_TREE,
3184                                                                       6)));
3185       array = build_constructor_from_list (array_type, nreverse (array));
3186       TREE_CONSTANT (array) = 1;
3187       TREE_INVARIANT (array) = 1;
3188       TREE_STATIC (array) = 1;
3189
3190       /* Create a static variable to hold the jump table.  */
3191       var = gfc_create_var (array_type, "options");
3192       TREE_CONSTANT (var) = 1;
3193       TREE_INVARIANT (var) = 1;
3194       TREE_STATIC (var) = 1;
3195       TREE_READONLY (var) = 1;
3196       DECL_INITIAL (var) = array;
3197       var = gfc_build_addr_expr (pvoid_type_node, var);
3198
3199       tmp = build_call_expr (gfor_fndecl_set_options, 2,
3200                              build_int_cst (integer_type_node, 7), var);
3201       gfc_add_expr_to_block (&body, tmp);
3202     }
3203
3204   /* If this is the main program and a -ffpe-trap option was provided,
3205      add a call to set_fpe so that the library will raise a FPE when
3206      needed.  */
3207   if (sym->attr.is_main_program && gfc_option.fpe != 0)
3208     {
3209       tmp = build_call_expr (gfor_fndecl_set_fpe, 1,
3210                              build_int_cst (integer_type_node,
3211                                             gfc_option.fpe));
3212       gfc_add_expr_to_block (&body, tmp);
3213     }
3214
3215   /* If this is the main program and an -fconvert option was provided,
3216      add a call to set_convert.  */
3217
3218   if (sym->attr.is_main_program && gfc_option.convert != GFC_CONVERT_NATIVE)
3219     {
3220       tmp = build_call_expr (gfor_fndecl_set_convert, 1,
3221                              build_int_cst (integer_type_node,
3222                                             gfc_option.convert));
3223       gfc_add_expr_to_block (&body, tmp);
3224     }
3225
3226   /* If this is the main program and an -frecord-marker option was provided,
3227      add a call to set_record_marker.  */
3228
3229   if (sym->attr.is_main_program && gfc_option.record_marker != 0)
3230     {
3231       tmp = build_call_expr (gfor_fndecl_set_record_marker, 1,
3232                              build_int_cst (integer_type_node,
3233                                             gfc_option.record_marker));
3234       gfc_add_expr_to_block (&body, tmp);
3235     }
3236
3237   if (sym->attr.is_main_program && gfc_option.max_subrecord_length != 0)
3238     {
3239       tmp = build_call_expr (gfor_fndecl_set_max_subrecord_length,
3240                              1,
3241                              build_int_cst (integer_type_node,
3242                                             gfc_option.max_subrecord_length));
3243       gfc_add_expr_to_block (&body, tmp);
3244     }
3245
3246   if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node
3247       && sym->attr.subroutine)
3248     {
3249       tree alternate_return;
3250       alternate_return = gfc_get_fake_result_decl (sym, 0);
3251       gfc_add_modify_expr (&body, alternate_return, integer_zero_node);
3252     }
3253
3254   if (ns->entries)
3255     {
3256       /* Jump to the correct entry point.  */
3257       tmp = gfc_trans_entry_master_switch (ns->entries);
3258       gfc_add_expr_to_block (&body, tmp);
3259     }
3260
3261   tmp = gfc_trans_code (ns->code);
3262   gfc_add_expr_to_block (&body, tmp);
3263
3264   /* Add a return label if needed.  */
3265   if (current_function_return_label)
3266     {
3267       tmp = build1_v (LABEL_EXPR, current_function_return_label);
3268       gfc_add_expr_to_block (&body, tmp);
3269     }
3270
3271   tmp = gfc_finish_block (&body);
3272   /* Add code to create and cleanup arrays.  */
3273   tmp = gfc_trans_deferred_vars (sym, tmp);
3274
3275   if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node)
3276     {
3277       if (sym->attr.subroutine || sym == sym->result)
3278         {
3279           if (current_fake_result_decl != NULL)
3280             result = TREE_VALUE (current_fake_result_decl);
3281           else
3282             result = NULL_TREE;
3283           current_fake_result_decl = NULL_TREE;
3284         }
3285       else
3286         result = sym->result->backend_decl;
3287
3288       if (result != NULL_TREE && sym->attr.function
3289             && sym->ts.type == BT_DERIVED
3290             && sym->ts.derived->attr.alloc_comp
3291             && !sym->attr.pointer)
3292         {
3293           rank = sym->as ? sym->as->rank : 0;
3294           tmp2 = gfc_nullify_alloc_comp (sym->ts.derived, result, rank);
3295           gfc_add_expr_to_block (&block, tmp2);
3296         }
3297
3298      gfc_add_expr_to_block (&block, tmp);
3299
3300      if (result == NULL_TREE)
3301         warning (0, "Function return value not set");
3302       else
3303         {
3304           /* Set the return value to the dummy result variable.  The
3305              types may be different for scalar default REAL functions
3306              with -ff2c, therefore we have to convert.  */
3307           tmp = convert (TREE_TYPE (DECL_RESULT (fndecl)), result);
3308           tmp = build2 (MODIFY_EXPR, TREE_TYPE (tmp),
3309                         DECL_RESULT (fndecl), tmp);
3310           tmp = build1_v (RETURN_EXPR, tmp);
3311           gfc_add_expr_to_block (&block, tmp);
3312         }
3313     }
3314   else
3315     gfc_add_expr_to_block (&block, tmp);
3316
3317
3318   /* Add all the decls we created during processing.  */
3319   decl = saved_function_decls;
3320   while (decl)
3321     {
3322       tree next;
3323
3324       next = TREE_CHAIN (decl);
3325       TREE_CHAIN (decl) = NULL_TREE;
3326       pushdecl (decl);
3327       decl = next;
3328     }
3329   saved_function_decls = NULL_TREE;
3330
3331   DECL_SAVED_TREE (fndecl) = gfc_finish_block (&block);
3332
3333   /* Finish off this function and send it for code generation.  */
3334   poplevel (1, 0, 1);
3335   BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
3336
3337   /* Output the GENERIC tree.  */
3338   dump_function (TDI_original, fndecl);
3339
3340   /* Store the end of the function, so that we get good line number
3341      info for the epilogue.  */
3342   cfun->function_end_locus = input_location;
3343
3344   /* We're leaving the context of this function, so zap cfun.
3345      It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
3346      tree_rest_of_compilation.  */
3347   set_cfun (NULL);
3348
3349   if (old_context)
3350     {
3351       pop_function_context ();
3352       saved_function_decls = saved_parent_function_decls;
3353     }
3354   current_function_decl = old_context;
3355
3356   if (decl_function_context (fndecl))
3357     /* Register this function with cgraph just far enough to get it
3358        added to our parent's nested function list.  */
3359     (void) cgraph_node (fndecl);
3360   else
3361     {
3362       gfc_gimplify_function (fndecl);
3363       cgraph_finalize_function (fndecl, false);
3364     }
3365 }
3366
3367 void
3368 gfc_generate_constructors (void)
3369 {
3370   gcc_assert (gfc_static_ctors == NULL_TREE);
3371 #if 0
3372   tree fnname;
3373   tree type;
3374   tree fndecl;
3375   tree decl;
3376   tree tmp;
3377
3378   if (gfc_static_ctors == NULL_TREE)
3379     return;
3380
3381   fnname = get_file_function_name ("I");
3382   type = build_function_type (void_type_node,
3383                               gfc_chainon_list (NULL_TREE, void_type_node));
3384
3385   fndecl = build_decl (FUNCTION_DECL, fnname, type);
3386   TREE_PUBLIC (fndecl) = 1;
3387
3388   decl = build_decl (RESULT_DECL, NULL_TREE, void_type_node);
3389   DECL_ARTIFICIAL (decl) = 1;
3390   DECL_IGNORED_P (decl) = 1;
3391   DECL_CONTEXT (decl) = fndecl;
3392   DECL_RESULT (fndecl) = decl;
3393
3394   pushdecl (fndecl);
3395
3396   current_function_decl = fndecl;
3397
3398   rest_of_decl_compilation (fndecl, 1, 0);
3399
3400   make_decl_rtl (fndecl);
3401
3402   init_function_start (fndecl);
3403
3404   pushlevel (0);
3405
3406   for (; gfc_static_ctors; gfc_static_ctors = TREE_CHAIN (gfc_static_ctors))
3407     {
3408       tmp = build_call_expr (TREE_VALUE (gfc_static_ctors), 0);
3409       DECL_SAVED_TREE (fndecl) = build_stmt (EXPR_STMT, tmp);
3410     }
3411
3412   poplevel (1, 0, 1);
3413
3414   BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
3415
3416   free_after_parsing (cfun);
3417   free_after_compilation (cfun);
3418
3419   tree_rest_of_compilation (fndecl);
3420
3421   current_function_decl = NULL_TREE;
3422 #endif
3423 }
3424
3425 /* Translates a BLOCK DATA program unit. This means emitting the
3426    commons contained therein plus their initializations. We also emit
3427    a globally visible symbol to make sure that each BLOCK DATA program
3428    unit remains unique.  */
3429
3430 void
3431 gfc_generate_block_data (gfc_namespace * ns)
3432 {
3433   tree decl;
3434   tree id;
3435
3436   /* Tell the backend the source location of the block data.  */
3437   if (ns->proc_name)
3438     gfc_set_backend_locus (&ns->proc_name->declared_at);
3439   else
3440     gfc_set_backend_locus (&gfc_current_locus);
3441
3442   /* Process the DATA statements.  */
3443   gfc_trans_common (ns);
3444
3445   /* Create a global symbol with the mane of the block data.  This is to
3446      generate linker errors if the same name is used twice.  It is never
3447      really used.  */
3448   if (ns->proc_name)
3449     id = gfc_sym_mangled_function_id (ns->proc_name);
3450   else
3451     id = get_identifier ("__BLOCK_DATA__");
3452
3453   decl = build_decl (VAR_DECL, id, gfc_array_index_type);
3454   TREE_PUBLIC (decl) = 1;
3455   TREE_STATIC (decl) = 1;
3456
3457   pushdecl (decl);
3458   rest_of_decl_compilation (decl, 1, 0);
3459 }
3460
3461
3462 #include "gt-fortran-trans-decl.h"