gcc/fortran/trans-decl.c

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