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