gcc/fortran/trans-decl.c

   1 /* Backend function setup
   2    Copyright (C) 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
   3    Contributed by Paul Brook
   4
   5 This file is part of GCC.
   6
   7 GCC is free software; you can redistribute it and/or modify it under
   8 the terms of the GNU General Public License as published by the Free
   9 Software Foundation; either version 2, or (at your option) any later
  10 version.
  11
  12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
  13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
  14 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  15 for more details.
  16
  17 You should have received a copy of the GNU General Public License
  18 along with GCC; see the file COPYING.  If not, write to the Free
  19 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
  20 02110-1301, USA.  */
  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 "target.h"
  34 #include "function.h"
  35 #include "flags.h"
  36 #include "cgraph.h"
  37 #include "gfortran.h"
  38 #include "trans.h"
  39 #include "trans-types.h"
  40 #include "trans-array.h"
  41 #include "trans-const.h"
  42 /* Only for gfc_trans_code.  Shouldn't need to include this.  */
  43 #include "trans-stmt.h"
  44
  45 #define MAX_LABEL_VALUE 99999
  46
  47
  48 /* Holds the result of the function if no result variable specified.  */
  49
  50 static GTY(()) tree current_fake_result_decl;
  51
  52 static GTY(()) tree current_function_return_label;
  53
  54
  55 /* Holds the variable DECLs for the current function.  */
  56
  57 static GTY(()) tree saved_function_decls = NULL_TREE;
  58 static GTY(()) tree saved_parent_function_decls = NULL_TREE;
  59
  60
  61 /* The namespace of the module we're currently generating.  Only used while
  62    outputting decls for module variables.  Do not rely on this being set.  */
  63
  64 static gfc_namespace *module_namespace;
  65
  66
  67 /* List of static constructor functions.  */
  68
  69 tree gfc_static_ctors;
  70
  71
  72 /* Function declarations for builtin library functions.  */
  73
  74 tree gfor_fndecl_internal_malloc;
  75 tree gfor_fndecl_internal_malloc64;
  76 tree gfor_fndecl_internal_realloc;
  77 tree gfor_fndecl_internal_realloc64;
  78 tree gfor_fndecl_internal_free;
  79 tree gfor_fndecl_allocate;
  80 tree gfor_fndecl_allocate64;
  81 tree gfor_fndecl_deallocate;
  82 tree gfor_fndecl_pause_numeric;
  83 tree gfor_fndecl_pause_string;
  84 tree gfor_fndecl_stop_numeric;
  85 tree gfor_fndecl_stop_string;
  86 tree gfor_fndecl_select_string;
  87 tree gfor_fndecl_runtime_error;
  88 tree gfor_fndecl_set_fpe;
  89 tree gfor_fndecl_set_std;
  90 tree gfor_fndecl_ctime;
  91 tree gfor_fndecl_fdate;
  92 tree gfor_fndecl_ttynam;
  93 tree gfor_fndecl_in_pack;
  94 tree gfor_fndecl_in_unpack;
  95 tree gfor_fndecl_associated;
  96
  97
  98 /* Math functions.  Many other math functions are handled in
  99    trans-intrinsic.c.  */
 100
 101 gfc_powdecl_list gfor_fndecl_math_powi[4][3];
 102 tree gfor_fndecl_math_cpowf;
 103 tree gfor_fndecl_math_cpow;
 104 tree gfor_fndecl_math_cpowl10;
 105 tree gfor_fndecl_math_cpowl16;
 106 tree gfor_fndecl_math_ishftc4;
 107 tree gfor_fndecl_math_ishftc8;
 108 tree gfor_fndecl_math_ishftc16;
 109 tree gfor_fndecl_math_exponent4;
 110 tree gfor_fndecl_math_exponent8;
 111 tree gfor_fndecl_math_exponent10;
 112 tree gfor_fndecl_math_exponent16;
 113
 114
 115 /* String functions.  */
 116
 117 tree gfor_fndecl_copy_string;
 118 tree gfor_fndecl_compare_string;
 119 tree gfor_fndecl_concat_string;
 120 tree gfor_fndecl_string_len_trim;
 121 tree gfor_fndecl_string_index;
 122 tree gfor_fndecl_string_scan;
 123 tree gfor_fndecl_string_verify;
 124 tree gfor_fndecl_string_trim;
 125 tree gfor_fndecl_string_repeat;
 126 tree gfor_fndecl_adjustl;
 127 tree gfor_fndecl_adjustr;
 128
 129
 130 /* Other misc. runtime library functions.  */
 131
 132 tree gfor_fndecl_size0;
 133 tree gfor_fndecl_size1;
 134 tree gfor_fndecl_iargc;
 135
 136 /* Intrinsic functions implemented in FORTRAN.  */
 137 tree gfor_fndecl_si_kind;
 138 tree gfor_fndecl_sr_kind;
 139
 140
 141 static void
 142 gfc_add_decl_to_parent_function (tree decl)
 143 {
 144   gcc_assert (decl);
 145   DECL_CONTEXT (decl) = DECL_CONTEXT (current_function_decl);
 146   DECL_NONLOCAL (decl) = 1;
 147   TREE_CHAIN (decl) = saved_parent_function_decls;
 148   saved_parent_function_decls = decl;
 149 }
 150
 151 void
 152 gfc_add_decl_to_function (tree decl)
 153 {
 154   gcc_assert (decl);
 155   TREE_USED (decl) = 1;
 156   DECL_CONTEXT (decl) = current_function_decl;
 157   TREE_CHAIN (decl) = saved_function_decls;
 158   saved_function_decls = decl;
 159 }
 160
 161
 162 /* Build a  backend label declaration.  Set TREE_USED for named labels.
 163    The context of the label is always the current_function_decl.  All
 164    labels are marked artificial.  */
 165
 166 tree
 167 gfc_build_label_decl (tree label_id)
 168 {
 169   /* 2^32 temporaries should be enough.  */
 170   static unsigned int tmp_num = 1;
 171   tree label_decl;
 172   char *label_name;
 173
 174   if (label_id == NULL_TREE)
 175     {
 176       /* Build an internal label name.  */
 177       ASM_FORMAT_PRIVATE_NAME (label_name, "L", tmp_num++);
 178       label_id = get_identifier (label_name);
 179     }
 180   else
 181     label_name = NULL;
 182
 183   /* Build the LABEL_DECL node. Labels have no type.  */
 184   label_decl = build_decl (LABEL_DECL, label_id, void_type_node);
 185   DECL_CONTEXT (label_decl) = current_function_decl;
 186   DECL_MODE (label_decl) = VOIDmode;
 187
 188   /* We always define the label as used, even if the original source
 189      file never references the label.  We don't want all kinds of
 190      spurious warnings for old-style Fortran code with too many
 191      labels.  */
 192   TREE_USED (label_decl) = 1;
 193
 194   DECL_ARTIFICIAL (label_decl) = 1;
 195   return label_decl;
 196 }
 197
 198
 199 /* Returns the return label for the current function.  */
 200
 201 tree
 202 gfc_get_return_label (void)
 203 {
 204   char name[GFC_MAX_SYMBOL_LEN + 10];
 205
 206   if (current_function_return_label)
 207     return current_function_return_label;
 208
 209   sprintf (name, "__return_%s",
 210            IDENTIFIER_POINTER (DECL_NAME (current_function_decl)));
 211
 212   current_function_return_label =
 213     gfc_build_label_decl (get_identifier (name));
 214
 215   DECL_ARTIFICIAL (current_function_return_label) = 1;
 216
 217   return current_function_return_label;
 218 }
 219
 220
 221 /* Set the backend source location of a decl.  */
 222
 223 void
 224 gfc_set_decl_location (tree decl, locus * loc)
 225 {
 226 #ifdef USE_MAPPED_LOCATION
 227   DECL_SOURCE_LOCATION (decl) = loc->lb->location;
 228 #else
 229   DECL_SOURCE_LINE (decl) = loc->lb->linenum;
 230   DECL_SOURCE_FILE (decl) = loc->lb->file->filename;
 231 #endif
 232 }
 233
 234
 235 /* Return the backend label declaration for a given label structure,
 236    or create it if it doesn't exist yet.  */
 237
 238 tree
 239 gfc_get_label_decl (gfc_st_label * lp)
 240 {
 241   if (lp->backend_decl)
 242     return lp->backend_decl;
 243   else
 244     {
 245       char label_name[GFC_MAX_SYMBOL_LEN + 1];
 246       tree label_decl;
 247
 248       /* Validate the label declaration from the front end.  */
 249       gcc_assert (lp != NULL && lp->value <= MAX_LABEL_VALUE);
 250
 251       /* Build a mangled name for the label.  */
 252       sprintf (label_name, "__label_%.6d", lp->value);
 253
 254       /* Build the LABEL_DECL node.  */
 255       label_decl = gfc_build_label_decl (get_identifier (label_name));
 256
 257       /* Tell the debugger where the label came from.  */
 258       if (lp->value <= MAX_LABEL_VALUE) /* An internal label.  */
 259         gfc_set_decl_location (label_decl, &lp->where);
 260       else
 261         DECL_ARTIFICIAL (label_decl) = 1;
 262
 263       /* Store the label in the label list and return the LABEL_DECL.  */
 264       lp->backend_decl = label_decl;
 265       return label_decl;
 266     }
 267 }
 268
 269
 270 /* Convert a gfc_symbol to an identifier of the same name.  */
 271
 272 static tree
 273 gfc_sym_identifier (gfc_symbol * sym)
 274 {
 275   return (get_identifier (sym->name));
 276 }
 277
 278
 279 /* Construct mangled name from symbol name.  */
 280
 281 static tree
 282 gfc_sym_mangled_identifier (gfc_symbol * sym)
 283 {
 284   char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
 285
 286   if (sym->module == NULL)
 287     return gfc_sym_identifier (sym);
 288   else
 289     {
 290       snprintf (name, sizeof name, "__%s__%s", sym->module, sym->name);
 291       return get_identifier (name);
 292     }
 293 }
 294
 295
 296 /* Construct mangled function name from symbol name.  */
 297
 298 static tree
 299 gfc_sym_mangled_function_id (gfc_symbol * sym)
 300 {
 301   int has_underscore;
 302   char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
 303
 304   if (sym->module == NULL || sym->attr.proc == PROC_EXTERNAL
 305       || (sym->module != NULL && sym->attr.if_source == IFSRC_IFBODY))
 306     {
 307       if (strcmp (sym->name, "MAIN__") == 0
 308           || sym->attr.proc == PROC_INTRINSIC)
 309         return get_identifier (sym->name);
 310
 311       if (gfc_option.flag_underscoring)
 312         {
 313           has_underscore = strchr (sym->name, '_') != 0;
 314           if (gfc_option.flag_second_underscore && has_underscore)
 315             snprintf (name, sizeof name, "%s__", sym->name);
 316           else
 317             snprintf (name, sizeof name, "%s_", sym->name);
 318           return get_identifier (name);
 319         }
 320       else
 321         return get_identifier (sym->name);
 322     }
 323   else
 324     {
 325       snprintf (name, sizeof name, "__%s__%s", sym->module, sym->name);
 326       return get_identifier (name);
 327     }
 328 }
 329
 330
 331 /* Returns true if a variable of specified size should go on the stack.  */
 332
 333 int
 334 gfc_can_put_var_on_stack (tree size)
 335 {
 336   unsigned HOST_WIDE_INT low;
 337
 338   if (!INTEGER_CST_P (size))
 339     return 0;
 340
 341   if (gfc_option.flag_max_stack_var_size < 0)
 342     return 1;
 343
 344   if (TREE_INT_CST_HIGH (size) != 0)
 345     return 0;
 346
 347   low = TREE_INT_CST_LOW (size);
 348   if (low > (unsigned HOST_WIDE_INT) gfc_option.flag_max_stack_var_size)
 349     return 0;
 350
 351 /* TODO: Set a per-function stack size limit.  */
 352
 353   return 1;
 354 }
 355
 356
 357 /* gfc_finish_cray_pointee sets DECL_VALUE_EXPR for a Cray pointee to
 358    an expression involving its corresponding pointer.  There are
 359    2 cases; one for variable size arrays, and one for everything else,
 360    because variable-sized arrays require one fewer level of
 361    indirection.  */
 362
 363 static void
 364 gfc_finish_cray_pointee (tree decl, gfc_symbol *sym)
 365 {
 366   tree ptr_decl = gfc_get_symbol_decl (sym->cp_pointer);
 367   tree value;
 368
 369   /* Parameters need to be dereferenced.  */
 370   if (sym->cp_pointer->attr.dummy)
 371     ptr_decl = build_fold_indirect_ref (ptr_decl);
 372
 373   /* Check to see if we're dealing with a variable-sized array.  */
 374   if (sym->attr.dimension
 375       && TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE)
 376     {
 377       /* These decls will be dereferenced later, so we don't dereference
 378          them here.  */
 379       value = convert (TREE_TYPE (decl), ptr_decl);
 380     }
 381   else
 382     {
 383       ptr_decl = convert (build_pointer_type (TREE_TYPE (decl)),
 384                           ptr_decl);
 385       value = build_fold_indirect_ref (ptr_decl);
 386     }
 387
 388   SET_DECL_VALUE_EXPR (decl, value);
 389   DECL_HAS_VALUE_EXPR_P (decl) = 1;
 390   /* This is a fake variable just for debugging purposes.  */
 391   TREE_ASM_WRITTEN (decl) = 1;
 392 }
 393
 394
 395 /* Finish processing of a declaration and install its initial value.  */
 396
 397 static void
 398 gfc_finish_decl (tree decl, tree init)
 399 {
 400   if (TREE_CODE (decl) == PARM_DECL)
 401     gcc_assert (init == NULL_TREE);
 402   /* Remember that PARM_DECL doesn't have a DECL_INITIAL field per se
 403      -- it overlaps DECL_ARG_TYPE.  */
 404   else if (init == NULL_TREE)
 405     gcc_assert (DECL_INITIAL (decl) == NULL_TREE);
 406   else
 407     gcc_assert (DECL_INITIAL (decl) == error_mark_node);
 408
 409   if (init != NULL_TREE)
 410     {
 411       if (TREE_CODE (decl) != TYPE_DECL)
 412         DECL_INITIAL (decl) = init;
 413       else
 414         {
 415           /* typedef foo = bar; store the type of bar as the type of foo.  */
 416           TREE_TYPE (decl) = TREE_TYPE (init);
 417           DECL_INITIAL (decl) = init = 0;
 418         }
 419     }
 420
 421   if (TREE_CODE (decl) == VAR_DECL)
 422     {
 423       if (DECL_SIZE (decl) == NULL_TREE
 424           && TYPE_SIZE (TREE_TYPE (decl)) != NULL_TREE)
 425         layout_decl (decl, 0);
 426
 427       /* A static variable with an incomplete type is an error if it is
 428          initialized. Also if it is not file scope. Otherwise, let it
 429          through, but if it is not `extern' then it may cause an error
 430          message later.  */
 431       /* An automatic variable with an incomplete type is an error.  */
 432       if (DECL_SIZE (decl) == NULL_TREE
 433           && (TREE_STATIC (decl) ? (DECL_INITIAL (decl) != 0
 434                                     || DECL_CONTEXT (decl) != 0)
 435                                  : !DECL_EXTERNAL (decl)))
 436         {
 437           gfc_fatal_error ("storage size not known");
 438         }
 439
 440       if ((DECL_EXTERNAL (decl) || TREE_STATIC (decl))
 441           && (DECL_SIZE (decl) != 0)
 442           && (TREE_CODE (DECL_SIZE (decl)) != INTEGER_CST))
 443         {
 444           gfc_fatal_error ("storage size not constant");
 445         }
 446     }
 447
 448 }
 449
 450
 451 /* Apply symbol attributes to a variable, and add it to the function scope.  */
 452
 453 static void
 454 gfc_finish_var_decl (tree decl, gfc_symbol * sym)
 455 {
 456   /* TREE_ADDRESSABLE means the address of this variable is actually needed.
 457      This is the equivalent of the TARGET variables.
 458      We also need to set this if the variable is passed by reference in a
 459      CALL statement.  */
 460
 461   /* Set DECL_VALUE_EXPR for Cray Pointees.  */
 462   if (sym->attr.cray_pointee)
 463     gfc_finish_cray_pointee (decl, sym);
 464
 465   if (sym->attr.target)
 466     TREE_ADDRESSABLE (decl) = 1;
 467   /* If it wasn't used we wouldn't be getting it.  */
 468   TREE_USED (decl) = 1;
 469
 470   /* Chain this decl to the pending declarations.  Don't do pushdecl()
 471      because this would add them to the current scope rather than the
 472      function scope.  */
 473   if (current_function_decl != NULL_TREE)
 474     {
 475       if (sym->ns->proc_name->backend_decl == current_function_decl
 476           || sym->result == sym)
 477         gfc_add_decl_to_function (decl);
 478       else
 479         gfc_add_decl_to_parent_function (decl);
 480     }
 481
 482   if (sym->attr.cray_pointee)
 483     return;
 484
 485   /* If a variable is USE associated, it's always external.  */
 486   if (sym->attr.use_assoc)
 487     {
 488       DECL_EXTERNAL (decl) = 1;
 489       TREE_PUBLIC (decl) = 1;
 490     }
 491   else if (sym->module && !sym->attr.result && !sym->attr.dummy)
 492     {
 493       /* TODO: Don't set sym->module for result or dummy variables.  */
 494       gcc_assert (current_function_decl == NULL_TREE || sym->result == sym);
 495       /* This is the declaration of a module variable.  */
 496       TREE_PUBLIC (decl) = 1;
 497       TREE_STATIC (decl) = 1;
 498     }
 499
 500   if ((sym->attr.save || sym->attr.data || sym->value)
 501       && !sym->attr.use_assoc)
 502     TREE_STATIC (decl) = 1;
 503
 504   /* Keep variables larger than max-stack-var-size off stack.  */
 505   if (!sym->ns->proc_name->attr.recursive
 506       && INTEGER_CST_P (DECL_SIZE_UNIT (decl))
 507       && !gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl)))
 508     TREE_STATIC (decl) = 1;
 509 }
 510
 511
 512 /* Allocate the lang-specific part of a decl.  */
 513
 514 void
 515 gfc_allocate_lang_decl (tree decl)
 516 {
 517   DECL_LANG_SPECIFIC (decl) = (struct lang_decl *)
 518     ggc_alloc_cleared (sizeof (struct lang_decl));
 519 }
 520
 521 /* Remember a symbol to generate initialization/cleanup code at function
 522    entry/exit.  */
 523
 524 static void
 525 gfc_defer_symbol_init (gfc_symbol * sym)
 526 {
 527   gfc_symbol *p;
 528   gfc_symbol *last;
 529   gfc_symbol *head;
 530
 531   /* Don't add a symbol twice.  */
 532   if (sym->tlink)
 533     return;
 534
 535   last = head = sym->ns->proc_name;
 536   p = last->tlink;
 537
 538   /* Make sure that setup code for dummy variables which are used in the
 539      setup of other variables is generated first.  */
 540   if (sym->attr.dummy)
 541     {
 542       /* Find the first dummy arg seen after us, or the first non-dummy arg.
 543          This is a circular list, so don't go past the head.  */
 544       while (p != head
 545              && (!p->attr.dummy || p->dummy_order > sym->dummy_order))
 546         {
 547           last = p;
 548           p = p->tlink;
 549         }
 550     }
 551   /* Insert in between last and p.  */
 552   last->tlink = sym;
 553   sym->tlink = p;
 554 }
 555
 556
 557 /* Create an array index type variable with function scope.  */
 558
 559 static tree
 560 create_index_var (const char * pfx, int nest)
 561 {
 562   tree decl;
 563
 564   decl = gfc_create_var_np (gfc_array_index_type, pfx);
 565   if (nest)
 566     gfc_add_decl_to_parent_function (decl);
 567   else
 568     gfc_add_decl_to_function (decl);
 569   return decl;
 570 }
 571
 572
 573 /* Create variables to hold all the non-constant bits of info for a
 574    descriptorless array.  Remember these in the lang-specific part of the
 575    type.  */
 576
 577 static void
 578 gfc_build_qualified_array (tree decl, gfc_symbol * sym)
 579 {
 580   tree type;
 581   int dim;
 582   int nest;
 583
 584   type = TREE_TYPE (decl);
 585
 586   /* We just use the descriptor, if there is one.  */
 587   if (GFC_DESCRIPTOR_TYPE_P (type))
 588     return;
 589
 590   gcc_assert (GFC_ARRAY_TYPE_P (type));
 591   nest = (sym->ns->proc_name->backend_decl != current_function_decl)
 592          && !sym->attr.contained;
 593
 594   for (dim = 0; dim < GFC_TYPE_ARRAY_RANK (type); dim++)
 595     {
 596       if (GFC_TYPE_ARRAY_LBOUND (type, dim) == NULL_TREE)
 597         GFC_TYPE_ARRAY_LBOUND (type, dim) = create_index_var ("lbound", nest);
 598       /* Don't try to use the unknown bound for assumed shape arrays.  */
 599       if (GFC_TYPE_ARRAY_UBOUND (type, dim) == NULL_TREE
 600           && (sym->as->type != AS_ASSUMED_SIZE
 601               || dim < GFC_TYPE_ARRAY_RANK (type) - 1))
 602         GFC_TYPE_ARRAY_UBOUND (type, dim) = create_index_var ("ubound", nest);
 603
 604       if (GFC_TYPE_ARRAY_STRIDE (type, dim) == NULL_TREE)
 605         GFC_TYPE_ARRAY_STRIDE (type, dim) = create_index_var ("stride", nest);
 606     }
 607   if (GFC_TYPE_ARRAY_OFFSET (type) == NULL_TREE)
 608     {
 609       GFC_TYPE_ARRAY_OFFSET (type) = gfc_create_var_np (gfc_array_index_type,
 610                                                         "offset");
 611       if (nest)
 612         gfc_add_decl_to_parent_function (GFC_TYPE_ARRAY_OFFSET (type));
 613       else
 614         gfc_add_decl_to_function (GFC_TYPE_ARRAY_OFFSET (type));
 615     }
 616 }
 617
 618
 619 /* For some dummy arguments we don't use the actual argument directly.
 620    Instead we create a local decl and use that.  This allows us to perform
 621    initialization, and construct full type information.  */
 622
 623 static tree
 624 gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy)
 625 {
 626   tree decl;
 627   tree type;
 628   gfc_array_spec *as;
 629   char *name;
 630   int packed;
 631   int n;
 632   bool known_size;
 633
 634   if (sym->attr.pointer || sym->attr.allocatable)
 635     return dummy;
 636
 637   /* Add to list of variables if not a fake result variable.  */
 638   if (sym->attr.result || sym->attr.dummy)
 639     gfc_defer_symbol_init (sym);
 640
 641   type = TREE_TYPE (dummy);
 642   gcc_assert (TREE_CODE (dummy) == PARM_DECL
 643           && POINTER_TYPE_P (type));
 644
 645   /* Do we know the element size?  */
 646   known_size = sym->ts.type != BT_CHARACTER
 647           || INTEGER_CST_P (sym->ts.cl->backend_decl);
 648
 649   if (known_size && !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type)))
 650     {
 651       /* For descriptorless arrays with known element size the actual
 652          argument is sufficient.  */
 653       gcc_assert (GFC_ARRAY_TYPE_P (type));
 654       gfc_build_qualified_array (dummy, sym);
 655       return dummy;
 656     }
 657
 658   type = TREE_TYPE (type);
 659   if (GFC_DESCRIPTOR_TYPE_P (type))
 660     {
 661       /* Create a decriptorless array pointer.  */
 662       as = sym->as;
 663       packed = 0;
 664       if (!gfc_option.flag_repack_arrays)
 665         {
 666           if (as->type == AS_ASSUMED_SIZE)
 667             packed = 2;
 668         }
 669       else
 670         {
 671           if (as->type == AS_EXPLICIT)
 672             {
 673               packed = 2;
 674               for (n = 0; n < as->rank; n++)
 675                 {
 676                   if (!(as->upper[n]
 677                         && as->lower[n]
 678                         && as->upper[n]->expr_type == EXPR_CONSTANT
 679                         && as->lower[n]->expr_type == EXPR_CONSTANT))
 680                     packed = 1;
 681                 }
 682             }
 683           else
 684             packed = 1;
 685         }
 686
 687       type = gfc_typenode_for_spec (&sym->ts);
 688       type = gfc_get_nodesc_array_type (type, sym->as, packed);
 689     }
 690   else
 691     {
 692       /* We now have an expression for the element size, so create a fully
 693          qualified type.  Reset sym->backend decl or this will just return the
 694          old type.  */
 695       sym->backend_decl = NULL_TREE;
 696       type = gfc_sym_type (sym);
 697       packed = 2;
 698     }
 699
 700   ASM_FORMAT_PRIVATE_NAME (name, IDENTIFIER_POINTER (DECL_NAME (dummy)), 0);
 701   decl = build_decl (VAR_DECL, get_identifier (name), type);
 702
 703   DECL_ARTIFICIAL (decl) = 1;
 704   TREE_PUBLIC (decl) = 0;
 705   TREE_STATIC (decl) = 0;
 706   DECL_EXTERNAL (decl) = 0;
 707
 708   /* We should never get deferred shape arrays here.  We used to because of
 709      frontend bugs.  */
 710   gcc_assert (sym->as->type != AS_DEFERRED);
 711
 712   switch (packed)
 713     {
 714     case 1:
 715       GFC_DECL_PARTIAL_PACKED_ARRAY (decl) = 1;
 716       break;
 717
 718     case 2:
 719       GFC_DECL_PACKED_ARRAY (decl) = 1;
 720       break;
 721     }
 722
 723   gfc_build_qualified_array (decl, sym);
 724
 725   if (DECL_LANG_SPECIFIC (dummy))
 726     DECL_LANG_SPECIFIC (decl) = DECL_LANG_SPECIFIC (dummy);
 727   else
 728     gfc_allocate_lang_decl (decl);
 729
 730   GFC_DECL_SAVED_DESCRIPTOR (decl) = dummy;
 731
 732   if (sym->ns->proc_name->backend_decl == current_function_decl
 733       || sym->attr.contained)
 734     gfc_add_decl_to_function (decl);
 735   else
 736     gfc_add_decl_to_parent_function (decl);
 737
 738   return decl;
 739 }
 740
 741
 742 /* Return a constant or a variable to use as a string length.  Does not
 743    add the decl to the current scope.  */
 744
 745 static tree
 746 gfc_create_string_length (gfc_symbol * sym)
 747 {
 748   tree length;
 749
 750   gcc_assert (sym->ts.cl);
 751   gfc_conv_const_charlen (sym->ts.cl);
 752
 753   if (sym->ts.cl->backend_decl == NULL_TREE)
 754     {
 755       char name[GFC_MAX_MANGLED_SYMBOL_LEN + 2];
 756
 757       /* Also prefix the mangled name.  */
 758       strcpy (&name[1], sym->name);
 759       name[0] = '.';
 760       length = build_decl (VAR_DECL, get_identifier (name),
 761                            gfc_charlen_type_node);
 762       DECL_ARTIFICIAL (length) = 1;
 763       TREE_USED (length) = 1;
 764       gfc_defer_symbol_init (sym);
 765       sym->ts.cl->backend_decl = length;
 766     }
 767
 768   return sym->ts.cl->backend_decl;
 769 }
 770
 771 /* If a variable is assigned a label, we add another two auxiliary
 772    variables.  */
 773
 774 static void
 775 gfc_add_assign_aux_vars (gfc_symbol * sym)
 776 {
 777   tree addr;
 778   tree length;
 779   tree decl;
 780
 781   gcc_assert (sym->backend_decl);
 782
 783   decl = sym->backend_decl;
 784   gfc_allocate_lang_decl (decl);
 785   GFC_DECL_ASSIGN (decl) = 1;
 786   length = build_decl (VAR_DECL, create_tmp_var_name (sym->name),
 787                        gfc_charlen_type_node);
 788   addr = build_decl (VAR_DECL, create_tmp_var_name (sym->name),
 789                      pvoid_type_node);
 790   gfc_finish_var_decl (length, sym);
 791   gfc_finish_var_decl (addr, sym);
 792   /*  STRING_LENGTH is also used as flag. Less than -1 means that
 793       ASSIGN_ADDR can not be used. Equal -1 means that ASSIGN_ADDR is the
 794       target label's address. Otherwise, value is the length of a format string
 795       and ASSIGN_ADDR is its address.  */
 796   if (TREE_STATIC (length))
 797     DECL_INITIAL (length) = build_int_cst (NULL_TREE, -2);
 798   else
 799     gfc_defer_symbol_init (sym);
 800
 801   GFC_DECL_STRING_LEN (decl) = length;
 802   GFC_DECL_ASSIGN_ADDR (decl) = addr;
 803 }
 804
 805 /* Return the decl for a gfc_symbol, create it if it doesn't already
 806    exist.  */
 807
 808 tree
 809 gfc_get_symbol_decl (gfc_symbol * sym)
 810 {
 811   tree decl;
 812   tree etype = NULL_TREE;
 813   tree length = NULL_TREE;
 814   tree tmp = NULL_TREE;
 815   int byref;
 816
 817   gcc_assert (sym->attr.referenced);
 818
 819   if (sym->ns && sym->ns->proc_name->attr.function)
 820     byref = gfc_return_by_reference (sym->ns->proc_name);
 821   else
 822     byref = 0;
 823
 824   if ((sym->attr.dummy && ! sym->attr.function) || (sym->attr.result && byref))
 825     {
 826       /* Return via extra parameter.  */
 827       if (sym->attr.result && byref
 828           && !sym->backend_decl)
 829         {
 830           sym->backend_decl =
 831             DECL_ARGUMENTS (sym->ns->proc_name->backend_decl);
 832           /* For entry master function skip over the __entry
 833              argument.  */
 834           if (sym->ns->proc_name->attr.entry_master)
 835             sym->backend_decl = TREE_CHAIN (sym->backend_decl);
 836         }
 837
 838       /* Dummy variables should already have been created.  */
 839       gcc_assert (sym->backend_decl);
 840
 841       /* Create a character length variable.  */
 842       if (sym->ts.type == BT_CHARACTER)
 843         {
 844           if (sym->ts.cl->backend_decl == NULL_TREE)
 845             {
 846               length = gfc_create_string_length (sym);
 847               if (TREE_CODE (length) != INTEGER_CST)
 848                 {
 849                   gfc_finish_var_decl (length, sym);
 850                   gfc_defer_symbol_init (sym);
 851                 }
 852             }
 853
 854           /* Set the element size of automatic and assumed character length
 855              length, dummy, pointer arrays.  */
 856           if (sym->attr.pointer && sym->attr.dummy
 857                 && sym->attr.dimension)
 858             {
 859               tmp = build_fold_indirect_ref (sym->backend_decl);
 860               etype = gfc_get_element_type (TREE_TYPE (tmp));
 861               if (TYPE_SIZE_UNIT (etype) == NULL_TREE)
 862                 {
 863                   tmp = TYPE_SIZE_UNIT (gfc_character1_type_node);
 864                   tmp = fold_convert (TREE_TYPE (tmp), sym->ts.cl->backend_decl);
 865                   TYPE_SIZE_UNIT (etype) = tmp;
 866                 }
 867             }
 868         }
 869
 870       /* Use a copy of the descriptor for dummy arrays.  */
 871       if (sym->attr.dimension && !TREE_USED (sym->backend_decl))
 872         {
 873           sym->backend_decl =
 874             gfc_build_dummy_array_decl (sym, sym->backend_decl);
 875         }
 876
 877       TREE_USED (sym->backend_decl) = 1;
 878       if (sym->attr.assign && GFC_DECL_ASSIGN (sym->backend_decl) == 0)
 879         {
 880           gfc_add_assign_aux_vars (sym);
 881         }
 882       return sym->backend_decl;
 883     }
 884
 885   if (sym->backend_decl)
 886     return sym->backend_decl;
 887
 888   /* Catch function declarations.  Only used for actual parameters.  */
 889   if (sym->attr.flavor == FL_PROCEDURE)
 890     {
 891       decl = gfc_get_extern_function_decl (sym);
 892       return decl;
 893     }
 894
 895   if (sym->attr.intrinsic)
 896     internal_error ("intrinsic variable which isn't a procedure");
 897
 898   /* Create string length decl first so that they can be used in the
 899      type declaration.  */
 900   if (sym->ts.type == BT_CHARACTER)
 901     length = gfc_create_string_length (sym);
 902
 903   /* Create the decl for the variable.  */
 904   decl = build_decl (VAR_DECL, gfc_sym_identifier (sym), gfc_sym_type (sym));
 905
 906   gfc_set_decl_location (decl, &sym->declared_at);
 907
 908   /* Symbols from modules should have their assembler names mangled.
 909      This is done here rather than in gfc_finish_var_decl because it
 910      is different for string length variables.  */
 911   if (sym->module)
 912     SET_DECL_ASSEMBLER_NAME (decl, gfc_sym_mangled_identifier (sym));
 913
 914   if (sym->attr.dimension)
 915     {
 916       /* Create variables to hold the non-constant bits of array info.  */
 917       gfc_build_qualified_array (decl, sym);
 918
 919       /* Remember this variable for allocation/cleanup.  */
 920       gfc_defer_symbol_init (sym);
 921
 922       if ((sym->attr.allocatable || !sym->attr.dummy) && !sym->attr.pointer)
 923         GFC_DECL_PACKED_ARRAY (decl) = 1;
 924     }
 925
 926   gfc_finish_var_decl (decl, sym);
 927
 928   if (sym->ts.type == BT_CHARACTER)
 929     {
 930       /* Character variables need special handling.  */
 931       gfc_allocate_lang_decl (decl);
 932
 933       if (TREE_CODE (length) != INTEGER_CST)
 934         {
 935           char name[GFC_MAX_MANGLED_SYMBOL_LEN + 2];
 936
 937           if (sym->module)
 938             {
 939               /* Also prefix the mangled name for symbols from modules.  */
 940               strcpy (&name[1], sym->name);
 941               name[0] = '.';
 942               strcpy (&name[1],
 943                       IDENTIFIER_POINTER (DECL_ASSEMBLER_NAME (length)));
 944               SET_DECL_ASSEMBLER_NAME (decl, get_identifier (name));
 945             }
 946           gfc_finish_var_decl (length, sym);
 947           gcc_assert (!sym->value);
 948         }
 949     }
 950   sym->backend_decl = decl;
 951
 952   if (sym->attr.assign)
 953     {
 954       gfc_add_assign_aux_vars (sym);
 955     }
 956
 957   if (TREE_STATIC (decl) && !sym->attr.use_assoc)
 958     {
 959       /* Add static initializer.  */
 960       DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
 961           TREE_TYPE (decl), sym->attr.dimension,
 962           sym->attr.pointer || sym->attr.allocatable);
 963     }
 964
 965   return decl;
 966 }
 967
 968
 969 /* Substitute a temporary variable in place of the real one.  */
 970
 971 void
 972 gfc_shadow_sym (gfc_symbol * sym, tree decl, gfc_saved_var * save)
 973 {
 974   save->attr = sym->attr;
 975   save->decl = sym->backend_decl;
 976
 977   gfc_clear_attr (&sym->attr);
 978   sym->attr.referenced = 1;
 979   sym->attr.flavor = FL_VARIABLE;
 980
 981   sym->backend_decl = decl;
 982 }
 983
 984
 985 /* Restore the original variable.  */
 986
 987 void
 988 gfc_restore_sym (gfc_symbol * sym, gfc_saved_var * save)
 989 {
 990   sym->attr = save->attr;
 991   sym->backend_decl = save->decl;
 992 }
 993
 994
 995 /* Get a basic decl for an external function.  */
 996
 997 tree
 998 gfc_get_extern_function_decl (gfc_symbol * sym)
 999 {
1000   tree type;
1001   tree fndecl;
1002   gfc_expr e;
1003   gfc_intrinsic_sym *isym;
1004   gfc_expr argexpr;
1005   char s[GFC_MAX_SYMBOL_LEN + 13]; /* "f2c_specific" and '\0'.  */
1006   tree name;
1007   tree mangled_name;
1008
1009   if (sym->backend_decl)
1010     return sym->backend_decl;
1011
1012   /* We should never be creating external decls for alternate entry points.
1013      The procedure may be an alternate entry point, but we don't want/need
1014      to know that.  */
1015   gcc_assert (!(sym->attr.entry || sym->attr.entry_master));
1016
1017   if (sym->attr.intrinsic)
1018     {
1019       /* Call the resolution function to get the actual name.  This is
1020          a nasty hack which relies on the resolution functions only looking
1021          at the first argument.  We pass NULL for the second argument
1022          otherwise things like AINT get confused.  */
1023       isym = gfc_find_function (sym->name);
1024       gcc_assert (isym->resolve.f0 != NULL);
1025
1026       memset (&e, 0, sizeof (e));
1027       e.expr_type = EXPR_FUNCTION;
1028
1029       memset (&argexpr, 0, sizeof (argexpr));
1030       gcc_assert (isym->formal);
1031       argexpr.ts = isym->formal->ts;
1032
1033       if (isym->formal->next == NULL)
1034         isym->resolve.f1 (&e, &argexpr);
1035       else
1036         {
1037           /* All specific intrinsics take one or two arguments.  */
1038           gcc_assert (isym->formal->next->next == NULL);
1039           isym->resolve.f2 (&e, &argexpr, NULL);
1040         }
1041
1042       if (gfc_option.flag_f2c
1043           && ((e.ts.type == BT_REAL && e.ts.kind == gfc_default_real_kind)
1044               || e.ts.type == BT_COMPLEX))
1045         {
1046           /* Specific which needs a different implementation if f2c
1047              calling conventions are used.  */
1048           sprintf (s, "f2c_specific%s", e.value.function.name);
1049         }
1050       else
1051         sprintf (s, "specific%s", e.value.function.name);
1052
1053       name = get_identifier (s);
1054       mangled_name = name;
1055     }
1056   else
1057     {
1058       name = gfc_sym_identifier (sym);
1059       mangled_name = gfc_sym_mangled_function_id (sym);
1060     }
1061
1062   type = gfc_get_function_type (sym);
1063   fndecl = build_decl (FUNCTION_DECL, name, type);
1064
1065   SET_DECL_ASSEMBLER_NAME (fndecl, mangled_name);
1066   /* If the return type is a pointer, avoid alias issues by setting
1067      DECL_IS_MALLOC to nonzero. This means that the function should be
1068      treated as if it were a malloc, meaning it returns a pointer that
1069      is not an alias.  */
1070   if (POINTER_TYPE_P (type))
1071     DECL_IS_MALLOC (fndecl) = 1;
1072
1073   /* Set the context of this decl.  */
1074   if (0 && sym->ns && sym->ns->proc_name)
1075     {
1076       /* TODO: Add external decls to the appropriate scope.  */
1077       DECL_CONTEXT (fndecl) = sym->ns->proc_name->backend_decl;
1078     }
1079   else
1080     {
1081       /* Global declaration, e.g. intrinsic subroutine.  */
1082       DECL_CONTEXT (fndecl) = NULL_TREE;
1083     }
1084
1085   DECL_EXTERNAL (fndecl) = 1;
1086
1087   /* This specifies if a function is globally addressable, i.e. it is
1088      the opposite of declaring static in C.  */
1089   TREE_PUBLIC (fndecl) = 1;
1090
1091   /* Set attributes for PURE functions. A call to PURE function in the
1092      Fortran 95 sense is both pure and without side effects in the C
1093      sense.  */
1094   if (sym->attr.pure || sym->attr.elemental)
1095     {
1096       if (sym->attr.function)
1097         DECL_IS_PURE (fndecl) = 1;
1098       /* TODO: check if pure SUBROUTINEs don't have INTENT(OUT)
1099          parameters and don't use alternate returns (is this
1100          allowed?). In that case, calls to them are meaningless, and
1101          can be optimized away. See also in build_function_decl().  */
1102       TREE_SIDE_EFFECTS (fndecl) = 0;
1103     }
1104
1105   /* Mark non-returning functions.  */
1106   if (sym->attr.noreturn)
1107       TREE_THIS_VOLATILE(fndecl) = 1;
1108
1109   sym->backend_decl = fndecl;
1110
1111   if (DECL_CONTEXT (fndecl) == NULL_TREE)
1112     pushdecl_top_level (fndecl);
1113
1114   return fndecl;
1115 }
1116
1117
1118 /* Create a declaration for a procedure.  For external functions (in the C
1119    sense) use gfc_get_extern_function_decl.  HAS_ENTRIES is true if this is
1120    a master function with alternate entry points.  */
1121
1122 static void
1123 build_function_decl (gfc_symbol * sym)
1124 {
1125   tree fndecl, type;
1126   symbol_attribute attr;
1127   tree result_decl;
1128   gfc_formal_arglist *f;
1129
1130   gcc_assert (!sym->backend_decl);
1131   gcc_assert (!sym->attr.external);
1132
1133   /* Set the line and filename.  sym->declared_at seems to point to the
1134      last statement for subroutines, but it'll do for now.  */
1135   gfc_set_backend_locus (&sym->declared_at);
1136
1137   /* Allow only one nesting level.  Allow public declarations.  */
1138   gcc_assert (current_function_decl == NULL_TREE
1139           || DECL_CONTEXT (current_function_decl) == NULL_TREE);
1140
1141   type = gfc_get_function_type (sym);
1142   fndecl = build_decl (FUNCTION_DECL, gfc_sym_identifier (sym), type);
1143
1144   /* Perform name mangling if this is a top level or module procedure.  */
1145   if (current_function_decl == NULL_TREE)
1146     SET_DECL_ASSEMBLER_NAME (fndecl, gfc_sym_mangled_function_id (sym));
1147
1148   /* Figure out the return type of the declared function, and build a
1149      RESULT_DECL for it.  If this is a subroutine with alternate
1150      returns, build a RESULT_DECL for it.  */
1151   attr = sym->attr;
1152
1153   result_decl = NULL_TREE;
1154   /* TODO: Shouldn't this just be TREE_TYPE (TREE_TYPE (fndecl)).  */
1155   if (attr.function)
1156     {
1157       if (gfc_return_by_reference (sym))
1158         type = void_type_node;
1159       else
1160         {
1161           if (sym->result != sym)
1162             result_decl = gfc_sym_identifier (sym->result);
1163
1164           type = TREE_TYPE (TREE_TYPE (fndecl));
1165         }
1166     }
1167   else
1168     {
1169       /* Look for alternate return placeholders.  */
1170       int has_alternate_returns = 0;
1171       for (f = sym->formal; f; f = f->next)
1172         {
1173           if (f->sym == NULL)
1174             {
1175               has_alternate_returns = 1;
1176               break;
1177             }
1178         }
1179
1180       if (has_alternate_returns)
1181         type = integer_type_node;
1182       else
1183         type = void_type_node;
1184     }
1185
1186   result_decl = build_decl (RESULT_DECL, result_decl, type);
1187   DECL_ARTIFICIAL (result_decl) = 1;
1188   DECL_IGNORED_P (result_decl) = 1;
1189   DECL_CONTEXT (result_decl) = fndecl;
1190   DECL_RESULT (fndecl) = result_decl;
1191
1192   /* Don't call layout_decl for a RESULT_DECL.
1193      layout_decl (result_decl, 0);  */
1194
1195   /* If the return type is a pointer, avoid alias issues by setting
1196      DECL_IS_MALLOC to nonzero. This means that the function should be
1197      treated as if it were a malloc, meaning it returns a pointer that
1198      is not an alias.  */
1199   if (POINTER_TYPE_P (type))
1200     DECL_IS_MALLOC (fndecl) = 1;
1201
1202   /* Set up all attributes for the function.  */
1203   DECL_CONTEXT (fndecl) = current_function_decl;
1204   DECL_EXTERNAL (fndecl) = 0;
1205
1206   /* This specifies if a function is globally visible, i.e. it is
1207      the opposite of declaring static in C.  */
1208   if (DECL_CONTEXT (fndecl) == NULL_TREE
1209       && !sym->attr.entry_master)
1210     TREE_PUBLIC (fndecl) = 1;
1211
1212   /* TREE_STATIC means the function body is defined here.  */
1213   TREE_STATIC (fndecl) = 1;
1214
1215   /* Set attributes for PURE functions. A call to a PURE function in the
1216      Fortran 95 sense is both pure and without side effects in the C
1217      sense.  */
1218   if (attr.pure || attr.elemental)
1219     {
1220       /* TODO: check if a pure SUBROUTINE has no INTENT(OUT) arguments
1221          including a alternate return. In that case it can also be
1222          marked as PURE. See also in gfc_get_extern_function_decl().  */
1223       if (attr.function && !gfc_return_by_reference (sym))
1224         DECL_IS_PURE (fndecl) = 1;
1225       TREE_SIDE_EFFECTS (fndecl) = 0;
1226     }
1227
1228   /* Layout the function declaration and put it in the binding level
1229      of the current function.  */
1230   pushdecl (fndecl);
1231
1232   sym->backend_decl = fndecl;
1233 }
1234
1235
1236 /* Create the DECL_ARGUMENTS for a procedure.  */
1237
1238 static void
1239 create_function_arglist (gfc_symbol * sym)
1240 {
1241   tree fndecl;
1242   gfc_formal_arglist *f;
1243   tree typelist;
1244   tree arglist;
1245   tree length;
1246   tree type;
1247   tree parm;
1248
1249   fndecl = sym->backend_decl;
1250
1251   /* Build formal argument list. Make sure that their TREE_CONTEXT is
1252      the new FUNCTION_DECL node.  */
1253   arglist = NULL_TREE;
1254   typelist = TYPE_ARG_TYPES (TREE_TYPE (fndecl));
1255
1256   if (sym->attr.entry_master)
1257     {
1258       type = TREE_VALUE (typelist);
1259       parm = build_decl (PARM_DECL, get_identifier ("__entry"), type);
1260
1261       DECL_CONTEXT (parm) = fndecl;
1262       DECL_ARG_TYPE (parm) = type;
1263       TREE_READONLY (parm) = 1;
1264       gfc_finish_decl (parm, NULL_TREE);
1265
1266       arglist = chainon (arglist, parm);
1267       typelist = TREE_CHAIN (typelist);
1268     }
1269
1270   if (gfc_return_by_reference (sym))
1271     {
1272       type = TREE_VALUE (typelist);
1273       parm = build_decl (PARM_DECL, get_identifier ("__result"), type);
1274
1275       DECL_CONTEXT (parm) = fndecl;
1276       DECL_ARG_TYPE (parm) = type;
1277       TREE_READONLY (parm) = 1;
1278       DECL_ARTIFICIAL (parm) = 1;
1279       gfc_finish_decl (parm, NULL_TREE);
1280
1281       arglist = chainon (arglist, parm);
1282       typelist = TREE_CHAIN (typelist);
1283
1284       if (sym->ts.type == BT_CHARACTER)
1285         {
1286           gfc_allocate_lang_decl (parm);
1287
1288           /* Length of character result.  */
1289           type = TREE_VALUE (typelist);
1290           gcc_assert (type == gfc_charlen_type_node);
1291
1292           length = build_decl (PARM_DECL,
1293                                get_identifier (".__result"),
1294                                type);
1295           if (!sym->ts.cl->length)
1296             {
1297               sym->ts.cl->backend_decl = length;
1298               TREE_USED (length) = 1;
1299             }
1300           gcc_assert (TREE_CODE (length) == PARM_DECL);
1301           arglist = chainon (arglist, length);
1302           typelist = TREE_CHAIN (typelist);
1303           DECL_CONTEXT (length) = fndecl;
1304           DECL_ARG_TYPE (length) = type;
1305           TREE_READONLY (length) = 1;
1306           DECL_ARTIFICIAL (length) = 1;
1307           gfc_finish_decl (length, NULL_TREE);
1308         }
1309     }
1310
1311   for (f = sym->formal; f; f = f->next)
1312     {
1313       if (f->sym != NULL)       /* ignore alternate returns.  */
1314         {
1315           length = NULL_TREE;
1316
1317           type = TREE_VALUE (typelist);
1318
1319           /* Build a the argument declaration.  */
1320           parm = build_decl (PARM_DECL,
1321                              gfc_sym_identifier (f->sym), type);
1322
1323           /* Fill in arg stuff.  */
1324           DECL_CONTEXT (parm) = fndecl;
1325           DECL_ARG_TYPE (parm) = type;
1326           /* All implementation args are read-only.  */
1327           TREE_READONLY (parm) = 1;
1328
1329           gfc_finish_decl (parm, NULL_TREE);
1330
1331           f->sym->backend_decl = parm;
1332
1333           arglist = chainon (arglist, parm);
1334           typelist = TREE_CHAIN (typelist);
1335         }
1336     }
1337
1338   /* Add the hidden string length parameters.  */
1339   parm = arglist;
1340   for (f = sym->formal; f; f = f->next)
1341     {
1342       char name[GFC_MAX_SYMBOL_LEN + 2];
1343       /* Ignore alternate returns.  */
1344       if (f->sym == NULL)
1345         continue;
1346
1347       if (f->sym->ts.type != BT_CHARACTER)
1348         continue;
1349
1350       parm = f->sym->backend_decl;
1351       type = TREE_VALUE (typelist);
1352       gcc_assert (type == gfc_charlen_type_node);
1353
1354       strcpy (&name[1], f->sym->name);
1355       name[0] = '_';
1356       length = build_decl (PARM_DECL, get_identifier (name), type);
1357
1358       arglist = chainon (arglist, length);
1359       DECL_CONTEXT (length) = fndecl;
1360       DECL_ARTIFICIAL (length) = 1;
1361       DECL_ARG_TYPE (length) = type;
1362       TREE_READONLY (length) = 1;
1363       gfc_finish_decl (length, NULL_TREE);
1364
1365       /* TODO: Check string lengths when -fbounds-check.  */
1366
1367       /* Use the passed value for assumed length variables.  */
1368       if (!f->sym->ts.cl->length)
1369         {
1370           TREE_USED (length) = 1;
1371           if (!f->sym->ts.cl->backend_decl)
1372             f->sym->ts.cl->backend_decl = length;
1373           else
1374             {
1375               /* there is already another variable using this
1376                  gfc_charlen node, build a new one for this variable
1377                  and chain it into the list of gfc_charlens.
1378                  This happens for e.g. in the case
1379                  CHARACTER(*)::c1,c2
1380                  since CHARACTER declarations on the same line share
1381                  the same gfc_charlen node.  */
1382               gfc_charlen *cl;
1383
1384               cl = gfc_get_charlen ();
1385               cl->backend_decl = length;
1386               cl->next = f->sym->ts.cl->next;
1387               f->sym->ts.cl->next = cl;
1388               f->sym->ts.cl = cl;
1389             }
1390         }
1391
1392       parm = TREE_CHAIN (parm);
1393       typelist = TREE_CHAIN (typelist);
1394     }
1395
1396   gcc_assert (TREE_VALUE (typelist) == void_type_node);
1397   DECL_ARGUMENTS (fndecl) = arglist;
1398 }
1399
1400 /* Convert FNDECL's code to GIMPLE and handle any nested functions.  */
1401
1402 static void
1403 gfc_gimplify_function (tree fndecl)
1404 {
1405   struct cgraph_node *cgn;
1406
1407   gimplify_function_tree (fndecl);
1408   dump_function (TDI_generic, fndecl);
1409
1410   /* Convert all nested functions to GIMPLE now.  We do things in this order
1411      so that items like VLA sizes are expanded properly in the context of the
1412      correct function.  */
1413   cgn = cgraph_node (fndecl);
1414   for (cgn = cgn->nested; cgn; cgn = cgn->next_nested)
1415     gfc_gimplify_function (cgn->decl);
1416 }
1417
1418
1419 /* Do the setup necessary before generating the body of a function.  */
1420
1421 static void
1422 trans_function_start (gfc_symbol * sym)
1423 {
1424   tree fndecl;
1425
1426   fndecl = sym->backend_decl;
1427
1428   /* Let GCC know the current scope is this function.  */
1429   current_function_decl = fndecl;
1430
1431   /* Let the world know what we're about to do.  */
1432   announce_function (fndecl);
1433
1434   if (DECL_CONTEXT (fndecl) == NULL_TREE)
1435     {
1436       /* Create RTL for function declaration.  */
1437       rest_of_decl_compilation (fndecl, 1, 0);
1438     }
1439
1440   /* Create RTL for function definition.  */
1441   make_decl_rtl (fndecl);
1442
1443   init_function_start (fndecl);
1444
1445   /* Even though we're inside a function body, we still don't want to
1446      call expand_expr to calculate the size of a variable-sized array.
1447      We haven't necessarily assigned RTL to all variables yet, so it's
1448      not safe to try to expand expressions involving them.  */
1449   cfun->x_dont_save_pending_sizes_p = 1;
1450
1451   /* function.c requires a push at the start of the function.  */
1452   pushlevel (0);
1453 }
1454
1455 /* Create thunks for alternate entry points.  */
1456
1457 static void
1458 build_entry_thunks (gfc_namespace * ns)
1459 {
1460   gfc_formal_arglist *formal;
1461   gfc_formal_arglist *thunk_formal;
1462   gfc_entry_list *el;
1463   gfc_symbol *thunk_sym;
1464   stmtblock_t body;
1465   tree thunk_fndecl;
1466   tree args;
1467   tree string_args;
1468   tree tmp;
1469   locus old_loc;
1470
1471   /* This should always be a toplevel function.  */
1472   gcc_assert (current_function_decl == NULL_TREE);
1473
1474   gfc_get_backend_locus (&old_loc);
1475   for (el = ns->entries; el; el = el->next)
1476     {
1477       thunk_sym = el->sym;
1478
1479       build_function_decl (thunk_sym);
1480       create_function_arglist (thunk_sym);
1481
1482       trans_function_start (thunk_sym);
1483
1484       thunk_fndecl = thunk_sym->backend_decl;
1485
1486       gfc_start_block (&body);
1487
1488       /* Pass extra parameter identifying this entry point.  */
1489       tmp = build_int_cst (gfc_array_index_type, el->id);
1490       args = tree_cons (NULL_TREE, tmp, NULL_TREE);
1491       string_args = NULL_TREE;
1492
1493       if (thunk_sym->attr.function)
1494         {
1495           if (gfc_return_by_reference (ns->proc_name))
1496             {
1497               tree ref = DECL_ARGUMENTS (current_function_decl);
1498               args = tree_cons (NULL_TREE, ref, args);
1499               if (ns->proc_name->ts.type == BT_CHARACTER)
1500                 args = tree_cons (NULL_TREE, TREE_CHAIN (ref),
1501                                   args);
1502             }
1503         }
1504
1505       for (formal = ns->proc_name->formal; formal; formal = formal->next)
1506         {
1507           /* Ignore alternate returns.  */
1508           if (formal->sym == NULL)
1509             continue;
1510
1511           /* We don't have a clever way of identifying arguments, so resort to
1512              a brute-force search.  */
1513           for (thunk_formal = thunk_sym->formal;
1514                thunk_formal;
1515                thunk_formal = thunk_formal->next)
1516             {
1517               if (thunk_formal->sym == formal->sym)
1518                 break;
1519             }
1520
1521           if (thunk_formal)
1522             {
1523               /* Pass the argument.  */
1524               args = tree_cons (NULL_TREE, thunk_formal->sym->backend_decl,
1525                                 args);
1526               if (formal->sym->ts.type == BT_CHARACTER)
1527                 {
1528                   tmp = thunk_formal->sym->ts.cl->backend_decl;
1529                   string_args = tree_cons (NULL_TREE, tmp, string_args);
1530                 }
1531             }
1532           else
1533             {
1534               /* Pass NULL for a missing argument.  */
1535               args = tree_cons (NULL_TREE, null_pointer_node, args);
1536               if (formal->sym->ts.type == BT_CHARACTER)
1537                 {
1538                   tmp = convert (gfc_charlen_type_node, integer_zero_node);
1539                   string_args = tree_cons (NULL_TREE, tmp, string_args);
1540                 }
1541             }
1542         }
1543
1544       /* Call the master function.  */
1545       args = nreverse (args);
1546       args = chainon (args, nreverse (string_args));
1547       tmp = ns->proc_name->backend_decl;
1548       tmp = build_function_call_expr (tmp, args);
1549       if (ns->proc_name->attr.mixed_entry_master)
1550         {
1551           tree union_decl, field;
1552           tree master_type = TREE_TYPE (ns->proc_name->backend_decl);
1553
1554           union_decl = build_decl (VAR_DECL, get_identifier ("__result"),
1555                                    TREE_TYPE (master_type));
1556           DECL_ARTIFICIAL (union_decl) = 1;
1557           DECL_EXTERNAL (union_decl) = 0;
1558           TREE_PUBLIC (union_decl) = 0;
1559           TREE_USED (union_decl) = 1;
1560           layout_decl (union_decl, 0);
1561           pushdecl (union_decl);
1562
1563           DECL_CONTEXT (union_decl) = current_function_decl;
1564           tmp = build2 (MODIFY_EXPR,
1565                         TREE_TYPE (union_decl),
1566                         union_decl, tmp);
1567           gfc_add_expr_to_block (&body, tmp);
1568
1569           for (field = TYPE_FIELDS (TREE_TYPE (union_decl));
1570                field; field = TREE_CHAIN (field))
1571             if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
1572                 thunk_sym->result->name) == 0)
1573               break;
1574           gcc_assert (field != NULL_TREE);
1575           tmp = build3 (COMPONENT_REF, TREE_TYPE (field), union_decl, field,
1576                         NULL_TREE);
1577           tmp = build2 (MODIFY_EXPR,
1578                         TREE_TYPE (DECL_RESULT (current_function_decl)),
1579                         DECL_RESULT (current_function_decl), tmp);
1580           tmp = build1_v (RETURN_EXPR, tmp);
1581         }
1582       else if (TREE_TYPE (DECL_RESULT (current_function_decl))
1583                != void_type_node)
1584         {
1585           tmp = build2 (MODIFY_EXPR,
1586                         TREE_TYPE (DECL_RESULT (current_function_decl)),
1587                         DECL_RESULT (current_function_decl), tmp);
1588           tmp = build1_v (RETURN_EXPR, tmp);
1589         }
1590       gfc_add_expr_to_block (&body, tmp);
1591
1592       /* Finish off this function and send it for code generation.  */
1593       DECL_SAVED_TREE (thunk_fndecl) = gfc_finish_block (&body);
1594       poplevel (1, 0, 1);
1595       BLOCK_SUPERCONTEXT (DECL_INITIAL (thunk_fndecl)) = thunk_fndecl;
1596
1597       /* Output the GENERIC tree.  */
1598       dump_function (TDI_original, thunk_fndecl);
1599
1600       /* Store the end of the function, so that we get good line number
1601          info for the epilogue.  */
1602       cfun->function_end_locus = input_location;
1603
1604       /* We're leaving the context of this function, so zap cfun.
1605          It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
1606          tree_rest_of_compilation.  */
1607       cfun = NULL;
1608
1609       current_function_decl = NULL_TREE;
1610
1611       gfc_gimplify_function (thunk_fndecl);
1612       cgraph_finalize_function (thunk_fndecl, false);
1613
1614       /* We share the symbols in the formal argument list with other entry
1615          points and the master function.  Clear them so that they are
1616          recreated for each function.  */
1617       for (formal = thunk_sym->formal; formal; formal = formal->next)
1618         if (formal->sym != NULL)  /* Ignore alternate returns.  */
1619           {
1620             formal->sym->backend_decl = NULL_TREE;
1621             if (formal->sym->ts.type == BT_CHARACTER)
1622               formal->sym->ts.cl->backend_decl = NULL_TREE;
1623           }
1624
1625       if (thunk_sym->attr.function)
1626         {
1627           if (thunk_sym->ts.type == BT_CHARACTER)
1628             thunk_sym->ts.cl->backend_decl = NULL_TREE;
1629           if (thunk_sym->result->ts.type == BT_CHARACTER)
1630             thunk_sym->result->ts.cl->backend_decl = NULL_TREE;
1631         }
1632     }
1633
1634   gfc_set_backend_locus (&old_loc);
1635 }
1636
1637
1638 /* Create a decl for a function, and create any thunks for alternate entry
1639    points.  */
1640
1641 void
1642 gfc_create_function_decl (gfc_namespace * ns)
1643 {
1644   /* Create a declaration for the master function.  */
1645   build_function_decl (ns->proc_name);
1646
1647   /* Compile the entry thunks.  */
1648   if (ns->entries)
1649     build_entry_thunks (ns);
1650
1651   /* Now create the read argument list.  */
1652   create_function_arglist (ns->proc_name);
1653 }
1654
1655 /* Return the decl used to hold the function return value.  */
1656
1657 tree
1658 gfc_get_fake_result_decl (gfc_symbol * sym)
1659 {
1660   tree decl;
1661   tree length;
1662
1663   char name[GFC_MAX_SYMBOL_LEN + 10];
1664
1665   if (sym
1666       && sym->ns->proc_name->backend_decl == current_function_decl
1667       && sym->ns->proc_name->attr.mixed_entry_master
1668       && sym != sym->ns->proc_name)
1669     {
1670       decl = gfc_get_fake_result_decl (sym->ns->proc_name);
1671       if (decl)
1672         {
1673           tree field;
1674
1675           for (field = TYPE_FIELDS (TREE_TYPE (decl));
1676                field; field = TREE_CHAIN (field))
1677             if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
1678                 sym->name) == 0)
1679               break;
1680
1681           gcc_assert (field != NULL_TREE);
1682           decl = build3 (COMPONENT_REF, TREE_TYPE (field), decl, field,
1683                          NULL_TREE);
1684         }
1685       return decl;
1686     }
1687
1688   if (current_fake_result_decl != NULL_TREE)
1689     return current_fake_result_decl;
1690
1691   /* Only when gfc_get_fake_result_decl is called by gfc_trans_return,
1692      sym is NULL.  */
1693   if (!sym)
1694     return NULL_TREE;
1695
1696   if (sym->ts.type == BT_CHARACTER
1697       && !sym->ts.cl->backend_decl)
1698     {
1699       length = gfc_create_string_length (sym);
1700       gfc_finish_var_decl (length, sym);
1701     }
1702
1703   if (gfc_return_by_reference (sym))
1704     {
1705       decl = DECL_ARGUMENTS (current_function_decl);
1706
1707       if (sym->ns->proc_name->backend_decl == current_function_decl
1708           && sym->ns->proc_name->attr.entry_master)
1709         decl = TREE_CHAIN (decl);
1710
1711       TREE_USED (decl) = 1;
1712       if (sym->as)
1713         decl = gfc_build_dummy_array_decl (sym, decl);
1714     }
1715   else
1716     {
1717       sprintf (name, "__result_%.20s",
1718                IDENTIFIER_POINTER (DECL_NAME (current_function_decl)));
1719
1720       decl = build_decl (VAR_DECL, get_identifier (name),
1721                          TREE_TYPE (TREE_TYPE (current_function_decl)));
1722
1723       DECL_ARTIFICIAL (decl) = 1;
1724       DECL_EXTERNAL (decl) = 0;
1725       TREE_PUBLIC (decl) = 0;
1726       TREE_USED (decl) = 1;
1727
1728       layout_decl (decl, 0);
1729
1730       gfc_add_decl_to_function (decl);
1731     }
1732
1733   current_fake_result_decl = decl;
1734
1735   return decl;
1736 }
1737
1738
1739 /* Builds a function decl.  The remaining parameters are the types of the
1740    function arguments.  Negative nargs indicates a varargs function.  */
1741
1742 tree
1743 gfc_build_library_function_decl (tree name, tree rettype, int nargs, ...)
1744 {
1745   tree arglist;
1746   tree argtype;
1747   tree fntype;
1748   tree fndecl;
1749   va_list p;
1750   int n;
1751
1752   /* Library functions must be declared with global scope.  */
1753   gcc_assert (current_function_decl == NULL_TREE);
1754
1755   va_start (p, nargs);
1756
1757
1758   /* Create a list of the argument types.  */
1759   for (arglist = NULL_TREE, n = abs (nargs); n > 0; n--)
1760     {
1761       argtype = va_arg (p, tree);
1762       arglist = gfc_chainon_list (arglist, argtype);
1763     }
1764
1765   if (nargs >= 0)
1766     {
1767       /* Terminate the list.  */
1768       arglist = gfc_chainon_list (arglist, void_type_node);
1769     }
1770
1771   /* Build the function type and decl.  */
1772   fntype = build_function_type (rettype, arglist);
1773   fndecl = build_decl (FUNCTION_DECL, name, fntype);
1774
1775   /* Mark this decl as external.  */
1776   DECL_EXTERNAL (fndecl) = 1;
1777   TREE_PUBLIC (fndecl) = 1;
1778
1779   va_end (p);
1780
1781   pushdecl (fndecl);
1782
1783   rest_of_decl_compilation (fndecl, 1, 0);
1784
1785   return fndecl;
1786 }
1787
1788 static void
1789 gfc_build_intrinsic_function_decls (void)
1790 {
1791   tree gfc_int4_type_node = gfc_get_int_type (4);
1792   tree gfc_int8_type_node = gfc_get_int_type (8);
1793   tree gfc_int16_type_node = gfc_get_int_type (16);
1794   tree gfc_logical4_type_node = gfc_get_logical_type (4);
1795   tree gfc_real4_type_node = gfc_get_real_type (4);
1796   tree gfc_real8_type_node = gfc_get_real_type (8);
1797   tree gfc_real10_type_node = gfc_get_real_type (10);
1798   tree gfc_real16_type_node = gfc_get_real_type (16);
1799   tree gfc_complex4_type_node = gfc_get_complex_type (4);
1800   tree gfc_complex8_type_node = gfc_get_complex_type (8);
1801   tree gfc_complex10_type_node = gfc_get_complex_type (10);
1802   tree gfc_complex16_type_node = gfc_get_complex_type (16);
1803   tree gfc_c_int_type_node = gfc_get_int_type (gfc_c_int_kind);
1804
1805   /* String functions.  */
1806   gfor_fndecl_copy_string =
1807     gfc_build_library_function_decl (get_identifier (PREFIX("copy_string")),
1808                                      void_type_node,
1809                                      4,
1810                                      gfc_charlen_type_node, pchar_type_node,
1811                                      gfc_charlen_type_node, pchar_type_node);
1812
1813   gfor_fndecl_compare_string =
1814     gfc_build_library_function_decl (get_identifier (PREFIX("compare_string")),
1815                                      gfc_int4_type_node,
1816                                      4,
1817                                      gfc_charlen_type_node, pchar_type_node,
1818                                      gfc_charlen_type_node, pchar_type_node);
1819
1820   gfor_fndecl_concat_string =
1821     gfc_build_library_function_decl (get_identifier (PREFIX("concat_string")),
1822                                      void_type_node,
1823                                      6,
1824                                      gfc_charlen_type_node, pchar_type_node,
1825                                      gfc_charlen_type_node, pchar_type_node,
1826                                      gfc_charlen_type_node, pchar_type_node);
1827
1828   gfor_fndecl_string_len_trim =
1829     gfc_build_library_function_decl (get_identifier (PREFIX("string_len_trim")),
1830                                      gfc_int4_type_node,
1831                                      2, gfc_charlen_type_node,
1832                                      pchar_type_node);
1833
1834   gfor_fndecl_string_index =
1835     gfc_build_library_function_decl (get_identifier (PREFIX("string_index")),
1836                                      gfc_int4_type_node,
1837                                      5, gfc_charlen_type_node, pchar_type_node,
1838                                      gfc_charlen_type_node, pchar_type_node,
1839                                      gfc_logical4_type_node);
1840
1841   gfor_fndecl_string_scan =
1842     gfc_build_library_function_decl (get_identifier (PREFIX("string_scan")),
1843                                      gfc_int4_type_node,
1844                                      5, gfc_charlen_type_node, pchar_type_node,
1845                                      gfc_charlen_type_node, pchar_type_node,
1846                                      gfc_logical4_type_node);
1847
1848   gfor_fndecl_string_verify =
1849     gfc_build_library_function_decl (get_identifier (PREFIX("string_verify")),
1850                                      gfc_int4_type_node,
1851                                      5, gfc_charlen_type_node, pchar_type_node,
1852                                      gfc_charlen_type_node, pchar_type_node,
1853                                      gfc_logical4_type_node);
1854
1855   gfor_fndecl_string_trim =
1856     gfc_build_library_function_decl (get_identifier (PREFIX("string_trim")),
1857                                      void_type_node,
1858                                      4,
1859                                      build_pointer_type (gfc_charlen_type_node),
1860                                      ppvoid_type_node,
1861                                      gfc_charlen_type_node,
1862                                      pchar_type_node);
1863
1864   gfor_fndecl_string_repeat =
1865     gfc_build_library_function_decl (get_identifier (PREFIX("string_repeat")),
1866                                      void_type_node,
1867                                      4,
1868                                      pchar_type_node,
1869                                      gfc_charlen_type_node,
1870                                      pchar_type_node,
1871                                      gfc_int4_type_node);
1872
1873   gfor_fndecl_ttynam =
1874     gfc_build_library_function_decl (get_identifier (PREFIX("ttynam")),
1875                                      void_type_node,
1876                                      3,
1877                                      pchar_type_node,
1878                                      gfc_charlen_type_node,
1879                                      gfc_c_int_type_node);
1880
1881   gfor_fndecl_fdate =
1882     gfc_build_library_function_decl (get_identifier (PREFIX("fdate")),
1883                                      void_type_node,
1884                                      2,
1885                                      pchar_type_node,
1886                                      gfc_charlen_type_node);
1887
1888   gfor_fndecl_ctime =
1889     gfc_build_library_function_decl (get_identifier (PREFIX("ctime")),
1890                                      void_type_node,
1891                                      3,
1892                                      pchar_type_node,
1893                                      gfc_charlen_type_node,
1894                                      gfc_int8_type_node);
1895
1896   gfor_fndecl_adjustl =
1897     gfc_build_library_function_decl (get_identifier (PREFIX("adjustl")),
1898                                      void_type_node,
1899                                      3,
1900                                      pchar_type_node,
1901                                      gfc_charlen_type_node, pchar_type_node);
1902
1903   gfor_fndecl_adjustr =
1904     gfc_build_library_function_decl (get_identifier (PREFIX("adjustr")),
1905                                      void_type_node,
1906                                      3,
1907                                      pchar_type_node,
1908                                      gfc_charlen_type_node, pchar_type_node);
1909
1910   gfor_fndecl_si_kind =
1911     gfc_build_library_function_decl (get_identifier ("selected_int_kind"),
1912                                      gfc_int4_type_node,
1913                                      1,
1914                                      pvoid_type_node);
1915
1916   gfor_fndecl_sr_kind =
1917     gfc_build_library_function_decl (get_identifier ("selected_real_kind"),
1918                                      gfc_int4_type_node,
1919                                      2, pvoid_type_node,
1920                                      pvoid_type_node);
1921
1922   /* Power functions.  */
1923   {
1924     tree ctype, rtype, itype, jtype;
1925     int rkind, ikind, jkind;
1926 #define NIKINDS 3
1927 #define NRKINDS 4
1928     static int ikinds[NIKINDS] = {4, 8, 16};
1929     static int rkinds[NRKINDS] = {4, 8, 10, 16};
1930     char name[PREFIX_LEN + 12]; /* _gfortran_pow_?n_?n */
1931
1932     for (ikind=0; ikind < NIKINDS; ikind++)
1933       {
1934         itype = gfc_get_int_type (ikinds[ikind]);
1935
1936         for (jkind=0; jkind < NIKINDS; jkind++)
1937           {
1938             jtype = gfc_get_int_type (ikinds[jkind]);
1939             if (itype && jtype)
1940               {
1941                 sprintf(name, PREFIX("pow_i%d_i%d"), ikinds[ikind],
1942                         ikinds[jkind]);
1943                 gfor_fndecl_math_powi[jkind][ikind].integer =
1944                   gfc_build_library_function_decl (get_identifier (name),
1945                     jtype, 2, jtype, itype);
1946               }
1947           }
1948
1949         for (rkind = 0; rkind < NRKINDS; rkind ++)
1950           {
1951             rtype = gfc_get_real_type (rkinds[rkind]);
1952             if (rtype && itype)
1953               {
1954                 sprintf(name, PREFIX("pow_r%d_i%d"), rkinds[rkind],
1955                         ikinds[ikind]);
1956                 gfor_fndecl_math_powi[rkind][ikind].real =
1957                   gfc_build_library_function_decl (get_identifier (name),
1958                     rtype, 2, rtype, itype);
1959               }
1960
1961             ctype = gfc_get_complex_type (rkinds[rkind]);
1962             if (ctype && itype)
1963               {
1964                 sprintf(name, PREFIX("pow_c%d_i%d"), rkinds[rkind],
1965                         ikinds[ikind]);
1966                 gfor_fndecl_math_powi[rkind][ikind].cmplx =
1967                   gfc_build_library_function_decl (get_identifier (name),
1968                     ctype, 2,ctype, itype);
1969               }
1970           }
1971       }
1972 #undef NIKINDS
1973 #undef NRKINDS
1974   }
1975
1976   gfor_fndecl_math_cpowf =
1977     gfc_build_library_function_decl (get_identifier ("cpowf"),
1978                                      gfc_complex4_type_node,
1979                                      1, gfc_complex4_type_node);
1980   gfor_fndecl_math_cpow =
1981     gfc_build_library_function_decl (get_identifier ("cpow"),
1982                                      gfc_complex8_type_node,
1983                                      1, gfc_complex8_type_node);
1984   if (gfc_complex10_type_node)
1985     gfor_fndecl_math_cpowl10 =
1986       gfc_build_library_function_decl (get_identifier ("cpowl"),
1987                                        gfc_complex10_type_node, 1,
1988                                        gfc_complex10_type_node);
1989   if (gfc_complex16_type_node)
1990     gfor_fndecl_math_cpowl16 =
1991       gfc_build_library_function_decl (get_identifier ("cpowl"),
1992                                        gfc_complex16_type_node, 1,
1993                                        gfc_complex16_type_node);
1994
1995   gfor_fndecl_math_ishftc4 =
1996     gfc_build_library_function_decl (get_identifier (PREFIX("ishftc4")),
1997                                      gfc_int4_type_node,
1998                                      3, gfc_int4_type_node,
1999                                      gfc_int4_type_node, gfc_int4_type_node);
2000   gfor_fndecl_math_ishftc8 =
2001     gfc_build_library_function_decl (get_identifier (PREFIX("ishftc8")),
2002                                      gfc_int8_type_node,
2003                                      3, gfc_int8_type_node,
2004                                      gfc_int4_type_node, gfc_int4_type_node);
2005   if (gfc_int16_type_node)
2006     gfor_fndecl_math_ishftc16 =
2007       gfc_build_library_function_decl (get_identifier (PREFIX("ishftc16")),
2008                                        gfc_int16_type_node, 3,
2009                                        gfc_int16_type_node,
2010                                        gfc_int4_type_node,
2011                                        gfc_int4_type_node);
2012
2013   gfor_fndecl_math_exponent4 =
2014     gfc_build_library_function_decl (get_identifier (PREFIX("exponent_r4")),
2015                                      gfc_int4_type_node,
2016                                      1, gfc_real4_type_node);
2017   gfor_fndecl_math_exponent8 =
2018     gfc_build_library_function_decl (get_identifier (PREFIX("exponent_r8")),
2019                                      gfc_int4_type_node,
2020                                      1, gfc_real8_type_node);
2021   if (gfc_real10_type_node)
2022     gfor_fndecl_math_exponent10 =
2023       gfc_build_library_function_decl (get_identifier (PREFIX("exponent_r10")),
2024                                        gfc_int4_type_node, 1,
2025                                        gfc_real10_type_node);
2026   if (gfc_real16_type_node)
2027     gfor_fndecl_math_exponent16 =
2028       gfc_build_library_function_decl (get_identifier (PREFIX("exponent_r16")),
2029                                        gfc_int4_type_node, 1,
2030                                        gfc_real16_type_node);
2031
2032   /* Other functions.  */
2033   gfor_fndecl_size0 =
2034     gfc_build_library_function_decl (get_identifier (PREFIX("size0")),
2035                                      gfc_array_index_type,
2036                                      1, pvoid_type_node);
2037   gfor_fndecl_size1 =
2038     gfc_build_library_function_decl (get_identifier (PREFIX("size1")),
2039                                      gfc_array_index_type,
2040                                      2, pvoid_type_node,
2041                                      gfc_array_index_type);
2042
2043   gfor_fndecl_iargc =
2044     gfc_build_library_function_decl (get_identifier (PREFIX ("iargc")),
2045                                      gfc_int4_type_node,
2046                                      0);
2047 }
2048
2049
2050 /* Make prototypes for runtime library functions.  */
2051
2052 void
2053 gfc_build_builtin_function_decls (void)
2054 {
2055   tree gfc_c_int_type_node = gfc_get_int_type (gfc_c_int_kind);
2056   tree gfc_int4_type_node = gfc_get_int_type (4);
2057   tree gfc_int8_type_node = gfc_get_int_type (8);
2058   tree gfc_logical4_type_node = gfc_get_logical_type (4);
2059   tree gfc_pint4_type_node = build_pointer_type (gfc_int4_type_node);
2060
2061   /* Treat these two internal malloc wrappers as malloc.  */
2062   gfor_fndecl_internal_malloc =
2063     gfc_build_library_function_decl (get_identifier (PREFIX("internal_malloc")),
2064                                      pvoid_type_node, 1, gfc_int4_type_node);
2065   DECL_IS_MALLOC (gfor_fndecl_internal_malloc) = 1;
2066
2067   gfor_fndecl_internal_malloc64 =
2068     gfc_build_library_function_decl (get_identifier
2069                                      (PREFIX("internal_malloc64")),
2070                                      pvoid_type_node, 1, gfc_int8_type_node);
2071   DECL_IS_MALLOC (gfor_fndecl_internal_malloc64) = 1;
2072
2073   gfor_fndecl_internal_realloc =
2074     gfc_build_library_function_decl (get_identifier
2075                                      (PREFIX("internal_realloc")),
2076                                      pvoid_type_node, 2, pvoid_type_node,
2077                                      gfc_int4_type_node);
2078
2079   gfor_fndecl_internal_realloc64 =
2080     gfc_build_library_function_decl (get_identifier
2081                                      (PREFIX("internal_realloc64")),
2082                                      pvoid_type_node, 2, pvoid_type_node,
2083                                      gfc_int8_type_node);
2084
2085   gfor_fndecl_internal_free =
2086     gfc_build_library_function_decl (get_identifier (PREFIX("internal_free")),
2087                                      void_type_node, 1, pvoid_type_node);
2088
2089   gfor_fndecl_allocate =
2090     gfc_build_library_function_decl (get_identifier (PREFIX("allocate")),
2091                                      void_type_node, 2, ppvoid_type_node,
2092                                      gfc_int4_type_node);
2093
2094   gfor_fndecl_allocate64 =
2095     gfc_build_library_function_decl (get_identifier (PREFIX("allocate64")),
2096                                      void_type_node, 2, ppvoid_type_node,
2097                                      gfc_int8_type_node);
2098
2099   gfor_fndecl_deallocate =
2100     gfc_build_library_function_decl (get_identifier (PREFIX("deallocate")),
2101                                      void_type_node, 2, ppvoid_type_node,
2102                                      gfc_pint4_type_node);
2103
2104   gfor_fndecl_stop_numeric =
2105     gfc_build_library_function_decl (get_identifier (PREFIX("stop_numeric")),
2106                                      void_type_node, 1, gfc_int4_type_node);
2107
2108   /* Stop doesn't return.  */
2109   TREE_THIS_VOLATILE (gfor_fndecl_stop_numeric) = 1;
2110
2111   gfor_fndecl_stop_string =
2112     gfc_build_library_function_decl (get_identifier (PREFIX("stop_string")),
2113                                      void_type_node, 2, pchar_type_node,
2114                                      gfc_int4_type_node);
2115   /* Stop doesn't return.  */
2116   TREE_THIS_VOLATILE (gfor_fndecl_stop_string) = 1;
2117
2118   gfor_fndecl_pause_numeric =
2119     gfc_build_library_function_decl (get_identifier (PREFIX("pause_numeric")),
2120                                      void_type_node, 1, gfc_int4_type_node);
2121
2122   gfor_fndecl_pause_string =
2123     gfc_build_library_function_decl (get_identifier (PREFIX("pause_string")),
2124                                      void_type_node, 2, pchar_type_node,
2125                                      gfc_int4_type_node);
2126
2127   gfor_fndecl_select_string =
2128     gfc_build_library_function_decl (get_identifier (PREFIX("select_string")),
2129                                      pvoid_type_node, 0);
2130
2131   gfor_fndecl_runtime_error =
2132     gfc_build_library_function_decl (get_identifier (PREFIX("runtime_error")),
2133                                      void_type_node,
2134                                      3,
2135                                      pchar_type_node, pchar_type_node,
2136                                      gfc_int4_type_node);
2137   /* The runtime_error function does not return.  */
2138   TREE_THIS_VOLATILE (gfor_fndecl_runtime_error) = 1;
2139
2140   gfor_fndecl_set_fpe =
2141     gfc_build_library_function_decl (get_identifier (PREFIX("set_fpe")),
2142                                     void_type_node, 1, gfc_c_int_type_node);
2143
2144   gfor_fndecl_set_std =
2145     gfc_build_library_function_decl (get_identifier (PREFIX("set_std")),
2146                                     void_type_node,
2147                                     2,
2148                                     gfc_int4_type_node,
2149                                     gfc_int4_type_node);
2150
2151   gfor_fndecl_in_pack = gfc_build_library_function_decl (
2152         get_identifier (PREFIX("internal_pack")),
2153         pvoid_type_node, 1, pvoid_type_node);
2154
2155   gfor_fndecl_in_unpack = gfc_build_library_function_decl (
2156         get_identifier (PREFIX("internal_unpack")),
2157         pvoid_type_node, 1, pvoid_type_node);
2158
2159   gfor_fndecl_associated =
2160     gfc_build_library_function_decl (
2161                                      get_identifier (PREFIX("associated")),
2162                                      gfc_logical4_type_node,
2163                                      2,
2164                                      ppvoid_type_node,
2165                                      ppvoid_type_node);
2166
2167   gfc_build_intrinsic_function_decls ();
2168   gfc_build_intrinsic_lib_fndecls ();
2169   gfc_build_io_library_fndecls ();
2170 }
2171
2172
2173 /* Evaluate the length of dummy character variables.  */
2174
2175 static tree
2176 gfc_trans_dummy_character (gfc_charlen * cl, tree fnbody)
2177 {
2178   stmtblock_t body;
2179
2180   gfc_finish_decl (cl->backend_decl, NULL_TREE);
2181
2182   gfc_start_block (&body);
2183
2184   /* Evaluate the string length expression.  */
2185   gfc_trans_init_string_length (cl, &body);
2186
2187   gfc_add_expr_to_block (&body, fnbody);
2188   return gfc_finish_block (&body);
2189 }
2190
2191
2192 /* Allocate and cleanup an automatic character variable.  */
2193
2194 static tree
2195 gfc_trans_auto_character_variable (gfc_symbol * sym, tree fnbody)
2196 {
2197   stmtblock_t body;
2198   tree decl;
2199   tree tmp;
2200
2201   gcc_assert (sym->backend_decl);
2202   gcc_assert (sym->ts.cl && sym->ts.cl->length);
2203
2204   gfc_start_block (&body);
2205
2206   /* Evaluate the string length expression.  */
2207   gfc_trans_init_string_length (sym->ts.cl, &body);
2208
2209   decl = sym->backend_decl;
2210
2211   /* Emit a DECL_EXPR for this variable, which will cause the
2212      gimplifier to allocate storage, and all that good stuff.  */
2213   tmp = build1 (DECL_EXPR, TREE_TYPE (decl), decl);
2214   gfc_add_expr_to_block (&body, tmp);
2215
2216   gfc_add_expr_to_block (&body, fnbody);
2217   return gfc_finish_block (&body);
2218 }
2219
2220 /* Set the initial value of ASSIGN statement auxiliary variable explicitly.  */
2221
2222 static tree
2223 gfc_trans_assign_aux_var (gfc_symbol * sym, tree fnbody)
2224 {
2225   stmtblock_t body;
2226
2227   gcc_assert (sym->backend_decl);
2228   gfc_start_block (&body);
2229
2230   /* Set the initial value to length. See the comments in
2231      function gfc_add_assign_aux_vars in this file.  */
2232   gfc_add_modify_expr (&body, GFC_DECL_STRING_LEN (sym->backend_decl),
2233                        build_int_cst (NULL_TREE, -2));
2234
2235   gfc_add_expr_to_block (&body, fnbody);
2236   return gfc_finish_block (&body);
2237 }
2238
2239
2240 /* Generate function entry and exit code, and add it to the function body.
2241    This includes:
2242     Allocation and initialization of array variables.
2243     Allocation of character string variables.
2244     Initialization and possibly repacking of dummy arrays.
2245     Initialization of ASSIGN statement auxiliary variable.  */
2246
2247 static tree
2248 gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
2249 {
2250   locus loc;
2251   gfc_symbol *sym;
2252
2253   /* Deal with implicit return variables.  Explicit return variables will
2254      already have been added.  */
2255   if (gfc_return_by_reference (proc_sym) && proc_sym->result == proc_sym)
2256     {
2257       if (!current_fake_result_decl)
2258         {
2259           gfc_entry_list *el = NULL;
2260           if (proc_sym->attr.entry_master)
2261             {
2262               for (el = proc_sym->ns->entries; el; el = el->next)
2263                 if (el->sym != el->sym->result)
2264                   break;
2265             }
2266           if (el == NULL)
2267             warning (0, "Function does not return a value");
2268         }
2269       else if (proc_sym->as)
2270         {
2271           fnbody = gfc_trans_dummy_array_bias (proc_sym,
2272                                                current_fake_result_decl,
2273                                                fnbody);
2274         }
2275       else if (proc_sym->ts.type == BT_CHARACTER)
2276         {
2277           if (TREE_CODE (proc_sym->ts.cl->backend_decl) == VAR_DECL)
2278             fnbody = gfc_trans_dummy_character (proc_sym->ts.cl, fnbody);
2279         }
2280       else
2281         gcc_assert (gfc_option.flag_f2c
2282                     && proc_sym->ts.type == BT_COMPLEX);
2283     }
2284
2285   for (sym = proc_sym->tlink; sym != proc_sym; sym = sym->tlink)
2286     {
2287       if (sym->attr.dimension)
2288         {
2289           switch (sym->as->type)
2290             {
2291             case AS_EXPLICIT:
2292               if (sym->attr.dummy || sym->attr.result)
2293                 fnbody =
2294                   gfc_trans_dummy_array_bias (sym, sym->backend_decl, fnbody);
2295               else if (sym->attr.pointer || sym->attr.allocatable)
2296                 {
2297                   if (TREE_STATIC (sym->backend_decl))
2298                     gfc_trans_static_array_pointer (sym);
2299                   else
2300                     fnbody = gfc_trans_deferred_array (sym, fnbody);
2301                 }
2302               else
2303                 {
2304                   gfc_get_backend_locus (&loc);
2305                   gfc_set_backend_locus (&sym->declared_at);
2306                   fnbody = gfc_trans_auto_array_allocation (sym->backend_decl,
2307                       sym, fnbody);
2308                   gfc_set_backend_locus (&loc);
2309                 }
2310               break;
2311
2312             case AS_ASSUMED_SIZE:
2313               /* Must be a dummy parameter.  */
2314               gcc_assert (sym->attr.dummy);
2315
2316               /* We should always pass assumed size arrays the g77 way.  */
2317               fnbody = gfc_trans_g77_array (sym, fnbody);
2318               break;
2319
2320             case AS_ASSUMED_SHAPE:
2321               /* Must be a dummy parameter.  */
2322               gcc_assert (sym->attr.dummy);
2323
2324               fnbody = gfc_trans_dummy_array_bias (sym, sym->backend_decl,
2325                                                    fnbody);
2326               break;
2327
2328             case AS_DEFERRED:
2329               fnbody = gfc_trans_deferred_array (sym, fnbody);
2330               break;
2331
2332             default:
2333               gcc_unreachable ();
2334             }
2335         }
2336       else if (sym->ts.type == BT_CHARACTER)
2337         {
2338           gfc_get_backend_locus (&loc);
2339           gfc_set_backend_locus (&sym->declared_at);
2340           if (sym->attr.dummy || sym->attr.result)
2341             fnbody = gfc_trans_dummy_character (sym->ts.cl, fnbody);
2342           else
2343             fnbody = gfc_trans_auto_character_variable (sym, fnbody);
2344           gfc_set_backend_locus (&loc);
2345         }
2346       else if (sym->attr.assign)
2347         {
2348           gfc_get_backend_locus (&loc);
2349           gfc_set_backend_locus (&sym->declared_at);
2350           fnbody = gfc_trans_assign_aux_var (sym, fnbody);
2351           gfc_set_backend_locus (&loc);
2352         }
2353       else
2354         gcc_unreachable ();
2355     }
2356
2357   return fnbody;
2358 }
2359
2360
2361 /* Output an initialized decl for a module variable.  */
2362
2363 static void
2364 gfc_create_module_variable (gfc_symbol * sym)
2365 {
2366   tree decl;
2367
2368   /* Only output symbols from this module.  */
2369   if (sym->ns != module_namespace)
2370     {
2371       /* I don't think this should ever happen.  */
2372       internal_error ("module symbol %s in wrong namespace", sym->name);
2373     }
2374
2375   /* Only output variables and array valued parameters.  */
2376   if (sym->attr.flavor != FL_VARIABLE
2377       && (sym->attr.flavor != FL_PARAMETER || sym->attr.dimension == 0))
2378     return;
2379
2380   /* Don't generate variables from other modules. Variables from
2381      COMMONs will already have been generated.  */
2382   if (sym->attr.use_assoc || sym->attr.in_common)
2383     return;
2384
2385   /* Equivalenced variables arrive here after creation.  */
2386   if (sym->backend_decl
2387         && (sym->equiv_built || sym->attr.in_equivalence))
2388       return;
2389
2390   if (sym->backend_decl)
2391     internal_error ("backend decl for module variable %s already exists",
2392                     sym->name);
2393
2394   /* We always want module variables to be created.  */
2395   sym->attr.referenced = 1;
2396   /* Create the decl.  */
2397   decl = gfc_get_symbol_decl (sym);
2398
2399   /* Create the variable.  */
2400   pushdecl (decl);
2401   rest_of_decl_compilation (decl, 1, 0);
2402
2403   /* Also add length of strings.  */
2404   if (sym->ts.type == BT_CHARACTER)
2405     {
2406       tree length;
2407
2408       length = sym->ts.cl->backend_decl;
2409       if (!INTEGER_CST_P (length))
2410         {
2411           pushdecl (length);
2412           rest_of_decl_compilation (length, 1, 0);
2413         }
2414     }
2415 }
2416
2417
2418 /* Generate all the required code for module variables.  */
2419
2420 void
2421 gfc_generate_module_vars (gfc_namespace * ns)
2422 {
2423   module_namespace = ns;
2424
2425   /* Check if the frontend left the namespace in a reasonable state.  */
2426   gcc_assert (ns->proc_name && !ns->proc_name->tlink);
2427
2428   /* Generate COMMON blocks.  */
2429   gfc_trans_common (ns);
2430
2431   /* Create decls for all the module variables.  */
2432   gfc_traverse_ns (ns, gfc_create_module_variable);
2433 }
2434
2435 static void
2436 gfc_generate_contained_functions (gfc_namespace * parent)
2437 {
2438   gfc_namespace *ns;
2439
2440   /* We create all the prototypes before generating any code.  */
2441   for (ns = parent->contained; ns; ns = ns->sibling)
2442     {
2443       /* Skip namespaces from used modules.  */
2444       if (ns->parent != parent)
2445         continue;
2446
2447       gfc_create_function_decl (ns);
2448     }
2449
2450   for (ns = parent->contained; ns; ns = ns->sibling)
2451     {
2452       /* Skip namespaces from used modules.  */
2453       if (ns->parent != parent)
2454         continue;
2455
2456       gfc_generate_function_code (ns);
2457     }
2458 }
2459
2460
2461 /* Generate decls for all local variables.  We do this to ensure correct
2462    handling of expressions which only appear in the specification of
2463    other functions.  */
2464
2465 static void
2466 generate_local_decl (gfc_symbol * sym)
2467 {
2468   if (sym->attr.flavor == FL_VARIABLE)
2469     {
2470       if (sym->attr.referenced)
2471         gfc_get_symbol_decl (sym);
2472       else if (sym->attr.dummy && warn_unused_parameter)
2473             warning (0, "unused parameter %qs", sym->name);
2474       /* Warn for unused variables, but not if they're inside a common
2475          block or are use-associated.  */
2476       else if (warn_unused_variable
2477                && !(sym->attr.in_common || sym->attr.use_assoc))
2478         warning (0, "unused variable %qs", sym->name);
2479     }
2480 }
2481
2482 static void
2483 generate_local_vars (gfc_namespace * ns)
2484 {
2485   gfc_traverse_ns (ns, generate_local_decl);
2486 }
2487
2488
2489 /* Generate a switch statement to jump to the correct entry point.  Also
2490    creates the label decls for the entry points.  */
2491
2492 static tree
2493 gfc_trans_entry_master_switch (gfc_entry_list * el)
2494 {
2495   stmtblock_t block;
2496   tree label;
2497   tree tmp;
2498   tree val;
2499
2500   gfc_init_block (&block);
2501   for (; el; el = el->next)
2502     {
2503       /* Add the case label.  */
2504       label = gfc_build_label_decl (NULL_TREE);
2505       val = build_int_cst (gfc_array_index_type, el->id);
2506       tmp = build3_v (CASE_LABEL_EXPR, val, NULL_TREE, label);
2507       gfc_add_expr_to_block (&block, tmp);
2508
2509       /* And jump to the actual entry point.  */
2510       label = gfc_build_label_decl (NULL_TREE);
2511       tmp = build1_v (GOTO_EXPR, label);
2512       gfc_add_expr_to_block (&block, tmp);
2513
2514       /* Save the label decl.  */
2515       el->label = label;
2516     }
2517   tmp = gfc_finish_block (&block);
2518   /* The first argument selects the entry point.  */
2519   val = DECL_ARGUMENTS (current_function_decl);
2520   tmp = build3_v (SWITCH_EXPR, val, tmp, NULL_TREE);
2521   return tmp;
2522 }
2523
2524
2525 /* Generate code for a function.  */
2526
2527 void
2528 gfc_generate_function_code (gfc_namespace * ns)
2529 {
2530   tree fndecl;
2531   tree old_context;
2532   tree decl;
2533   tree tmp;
2534   stmtblock_t block;
2535   stmtblock_t body;
2536   tree result;
2537   gfc_symbol *sym;
2538
2539   sym = ns->proc_name;
2540
2541   /* Check that the frontend isn't still using this.  */
2542   gcc_assert (sym->tlink == NULL);
2543   sym->tlink = sym;
2544
2545   /* Create the declaration for functions with global scope.  */
2546   if (!sym->backend_decl)
2547     gfc_create_function_decl (ns);
2548
2549   fndecl = sym->backend_decl;
2550   old_context = current_function_decl;
2551
2552   if (old_context)
2553     {
2554       push_function_context ();
2555       saved_parent_function_decls = saved_function_decls;
2556       saved_function_decls = NULL_TREE;
2557     }
2558
2559   trans_function_start (sym);
2560
2561   /* Will be created as needed.  */
2562   current_fake_result_decl = NULL_TREE;
2563
2564   gfc_start_block (&block);
2565
2566   if (ns->entries && ns->proc_name->ts.type == BT_CHARACTER)
2567     {
2568       /* Copy length backend_decls to all entry point result
2569          symbols.  */
2570       gfc_entry_list *el;
2571       tree backend_decl;
2572
2573       gfc_conv_const_charlen (ns->proc_name->ts.cl);
2574       backend_decl = ns->proc_name->result->ts.cl->backend_decl;
2575       for (el = ns->entries; el; el = el->next)
2576         el->sym->result->ts.cl->backend_decl = backend_decl;
2577     }
2578
2579   /* Translate COMMON blocks.  */
2580   gfc_trans_common (ns);
2581
2582   gfc_generate_contained_functions (ns);
2583
2584   generate_local_vars (ns);
2585
2586   current_function_return_label = NULL;
2587
2588   /* Now generate the code for the body of this function.  */
2589   gfc_init_block (&body);
2590
2591   /* If this is the main program and we compile with -pedantic, add a call
2592      to set_std to set up the runtime library Fortran language standard
2593      parameters.  */
2594   if (sym->attr.is_main_program && pedantic)
2595     {
2596       tree arglist, gfc_int4_type_node;
2597
2598       gfc_int4_type_node = gfc_get_int_type (4);
2599       arglist = gfc_chainon_list (NULL_TREE,
2600                                   build_int_cst (gfc_int4_type_node,
2601                                                  gfc_option.warn_std));
2602       arglist = gfc_chainon_list (arglist,
2603                                   build_int_cst (gfc_int4_type_node,
2604                                                  gfc_option.allow_std));
2605       tmp = build_function_call_expr (gfor_fndecl_set_std, arglist);
2606       gfc_add_expr_to_block (&body, tmp);
2607     }
2608
2609   /* If this is the main program and a -ffpe-trap option was provided,
2610      add a call to set_fpe so that the library will raise a FPE when
2611      needed.  */
2612   if (sym->attr.is_main_program && gfc_option.fpe != 0)
2613     {
2614       tree arglist, gfc_c_int_type_node;
2615
2616       gfc_c_int_type_node = gfc_get_int_type (gfc_c_int_kind);
2617       arglist = gfc_chainon_list (NULL_TREE,
2618                                   build_int_cst (gfc_c_int_type_node,
2619                                                  gfc_option.fpe));
2620       tmp = build_function_call_expr (gfor_fndecl_set_fpe, arglist);
2621       gfc_add_expr_to_block (&body, tmp);
2622     }
2623
2624   if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node
2625       && sym->attr.subroutine)
2626     {
2627       tree alternate_return;
2628       alternate_return = gfc_get_fake_result_decl (sym);
2629       gfc_add_modify_expr (&body, alternate_return, integer_zero_node);
2630     }
2631
2632   if (ns->entries)
2633     {
2634       /* Jump to the correct entry point.  */
2635       tmp = gfc_trans_entry_master_switch (ns->entries);
2636       gfc_add_expr_to_block (&body, tmp);
2637     }
2638
2639   tmp = gfc_trans_code (ns->code);
2640   gfc_add_expr_to_block (&body, tmp);
2641
2642   /* Add a return label if needed.  */
2643   if (current_function_return_label)
2644     {
2645       tmp = build1_v (LABEL_EXPR, current_function_return_label);
2646       gfc_add_expr_to_block (&body, tmp);
2647     }
2648
2649   tmp = gfc_finish_block (&body);
2650   /* Add code to create and cleanup arrays.  */
2651   tmp = gfc_trans_deferred_vars (sym, tmp);
2652   gfc_add_expr_to_block (&block, tmp);
2653
2654   if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node)
2655     {
2656       if (sym->attr.subroutine || sym == sym->result)
2657         {
2658           result = current_fake_result_decl;
2659           current_fake_result_decl = NULL_TREE;
2660         }
2661       else
2662         result = sym->result->backend_decl;
2663
2664       if (result == NULL_TREE)
2665         warning (0, "Function return value not set");
2666       else
2667         {
2668           /* Set the return value to the dummy result variable.  */
2669           tmp = build2 (MODIFY_EXPR, TREE_TYPE (result),
2670                         DECL_RESULT (fndecl), result);
2671           tmp = build1_v (RETURN_EXPR, tmp);
2672           gfc_add_expr_to_block (&block, tmp);
2673         }
2674     }
2675
2676   /* Add all the decls we created during processing.  */
2677   decl = saved_function_decls;
2678   while (decl)
2679     {
2680       tree next;
2681
2682       next = TREE_CHAIN (decl);
2683       TREE_CHAIN (decl) = NULL_TREE;
2684       pushdecl (decl);
2685       decl = next;
2686     }
2687   saved_function_decls = NULL_TREE;
2688
2689   DECL_SAVED_TREE (fndecl) = gfc_finish_block (&block);
2690
2691   /* Finish off this function and send it for code generation.  */
2692   poplevel (1, 0, 1);
2693   BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
2694
2695   /* Output the GENERIC tree.  */
2696   dump_function (TDI_original, fndecl);
2697
2698   /* Store the end of the function, so that we get good line number
2699      info for the epilogue.  */
2700   cfun->function_end_locus = input_location;
2701
2702   /* We're leaving the context of this function, so zap cfun.
2703      It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
2704      tree_rest_of_compilation.  */
2705   cfun = NULL;
2706
2707   if (old_context)
2708     {
2709       pop_function_context ();
2710       saved_function_decls = saved_parent_function_decls;
2711     }
2712   current_function_decl = old_context;
2713
2714   if (decl_function_context (fndecl))
2715     /* Register this function with cgraph just far enough to get it
2716        added to our parent's nested function list.  */
2717     (void) cgraph_node (fndecl);
2718   else
2719     {
2720       gfc_gimplify_function (fndecl);
2721       cgraph_finalize_function (fndecl, false);
2722     }
2723 }
2724
2725 void
2726 gfc_generate_constructors (void)
2727 {
2728   gcc_assert (gfc_static_ctors == NULL_TREE);
2729 #if 0
2730   tree fnname;
2731   tree type;
2732   tree fndecl;
2733   tree decl;
2734   tree tmp;
2735
2736   if (gfc_static_ctors == NULL_TREE)
2737     return;
2738
2739   fnname = get_file_function_name ('I');
2740   type = build_function_type (void_type_node,
2741                               gfc_chainon_list (NULL_TREE, void_type_node));
2742
2743   fndecl = build_decl (FUNCTION_DECL, fnname, type);
2744   TREE_PUBLIC (fndecl) = 1;
2745
2746   decl = build_decl (RESULT_DECL, NULL_TREE, void_type_node);
2747   DECL_ARTIFICIAL (decl) = 1;
2748   DECL_IGNORED_P (decl) = 1;
2749   DECL_CONTEXT (decl) = fndecl;
2750   DECL_RESULT (fndecl) = decl;
2751
2752   pushdecl (fndecl);
2753
2754   current_function_decl = fndecl;
2755
2756   rest_of_decl_compilation (fndecl, 1, 0);
2757
2758   make_decl_rtl (fndecl);
2759
2760   init_function_start (fndecl);
2761
2762   pushlevel (0);
2763
2764   for (; gfc_static_ctors; gfc_static_ctors = TREE_CHAIN (gfc_static_ctors))
2765     {
2766       tmp =
2767         build_function_call_expr (TREE_VALUE (gfc_static_ctors), NULL_TREE);
2768       DECL_SAVED_TREE (fndecl) = build_stmt (EXPR_STMT, tmp);
2769     }
2770
2771   poplevel (1, 0, 1);
2772
2773   BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
2774
2775   free_after_parsing (cfun);
2776   free_after_compilation (cfun);
2777
2778   tree_rest_of_compilation (fndecl);
2779
2780   current_function_decl = NULL_TREE;
2781 #endif
2782 }
2783
2784 /* Translates a BLOCK DATA program unit. This means emitting the
2785    commons contained therein plus their initializations. We also emit
2786    a globally visible symbol to make sure that each BLOCK DATA program
2787    unit remains unique.  */
2788
2789 void
2790 gfc_generate_block_data (gfc_namespace * ns)
2791 {
2792   tree decl;
2793   tree id;
2794
2795   /* Tell the backend the source location of the block data.  */
2796   if (ns->proc_name)
2797     gfc_set_backend_locus (&ns->proc_name->declared_at);
2798   else
2799     gfc_set_backend_locus (&gfc_current_locus);
2800
2801   /* Process the DATA statements.  */
2802   gfc_trans_common (ns);
2803
2804   /* Create a global symbol with the mane of the block data.  This is to
2805      generate linker errors if the same name is used twice.  It is never
2806      really used.  */
2807   if (ns->proc_name)
2808     id = gfc_sym_mangled_function_id (ns->proc_name);
2809   else
2810     id = get_identifier ("__BLOCK_DATA__");
2811
2812   decl = build_decl (VAR_DECL, id, gfc_array_index_type);
2813   TREE_PUBLIC (decl) = 1;
2814   TREE_STATIC (decl) = 1;
2815
2816   pushdecl (decl);
2817   rest_of_decl_compilation (decl, 1, 0);
2818 }
2819
2820
2821 #include "gt-fortran-trans-decl.h"