gcc/fortran/trans-decl.c

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