gcc/fortran/trans-decl.c

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