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