gcc/fortran/trans-decl.c

   1 /* Backend function setup
   2    Copyright (C) 2002, 2003, 2004 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, 59 Temple Place - Suite 330, Boston, MA
  20 02111-1307, 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 "errors.h"
  36 #include "flags.h"
  37 #include "cgraph.h"
  38 #include <assert.h>
  39 #include "gfortran.h"
  40 #include "trans.h"
  41 #include "trans-types.h"
  42 #include "trans-array.h"
  43 #include "trans-const.h"
  44 /* Only for gfc_trans_code.  Shouldn't need to include this.  */
  45 #include "trans-stmt.h"
  46
  47 #define MAX_LABEL_VALUE 99999
  48
  49
  50 /* Holds the result of the function if no result variable specified.  */
  51
  52 static GTY(()) tree current_fake_result_decl;
  53
  54 static GTY(()) tree current_function_return_label;
  55
  56
  57 /* Holds the variable DECLs for the current function.  */
  58
  59 static GTY(()) tree saved_function_decls = NULL_TREE;
  60 static GTY(()) tree saved_parent_function_decls = NULL_TREE;
  61
  62
  63 /* The namespace of the module we're currently generating.  Only used while
  64    outputting decls for module variables.  Do not rely on this being set.  */
  65
  66 static gfc_namespace *module_namespace;
  67
  68
  69 /* List of static constructor functions.  */
  70
  71 tree gfc_static_ctors;
  72
  73
  74 /* Function declarations for builtin library functions.  */
  75
  76 tree gfor_fndecl_internal_malloc;
  77 tree gfor_fndecl_internal_malloc64;
  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_in_pack;
  89 tree gfor_fndecl_in_unpack;
  90 tree gfor_fndecl_associated;
  91
  92
  93 /* Math functions.  Many other math functions are handled in
  94    trans-intrinsic.c.  */
  95
  96 gfc_powdecl_list gfor_fndecl_math_powi[3][2];
  97 tree gfor_fndecl_math_cpowf;
  98 tree gfor_fndecl_math_cpow;
  99 tree gfor_fndecl_math_cabsf;
 100 tree gfor_fndecl_math_cabs;
 101 tree gfor_fndecl_math_sign4;
 102 tree gfor_fndecl_math_sign8;
 103 tree gfor_fndecl_math_ishftc4;
 104 tree gfor_fndecl_math_ishftc8;
 105 tree gfor_fndecl_math_exponent4;
 106 tree gfor_fndecl_math_exponent8;
 107
 108
 109 /* String functions.  */
 110
 111 tree gfor_fndecl_copy_string;
 112 tree gfor_fndecl_compare_string;
 113 tree gfor_fndecl_concat_string;
 114 tree gfor_fndecl_string_len_trim;
 115 tree gfor_fndecl_string_index;
 116 tree gfor_fndecl_string_scan;
 117 tree gfor_fndecl_string_verify;
 118 tree gfor_fndecl_string_trim;
 119 tree gfor_fndecl_string_repeat;
 120 tree gfor_fndecl_adjustl;
 121 tree gfor_fndecl_adjustr;
 122
 123
 124 /* Other misc. runtime library functions.  */
 125
 126 tree gfor_fndecl_size0;
 127 tree gfor_fndecl_size1;
 128 tree gfor_fndecl_iargc;
 129
 130 /* Intrinsic functions implemented in FORTRAN.  */
 131 tree gfor_fndecl_si_kind;
 132 tree gfor_fndecl_sr_kind;
 133
 134
 135 static void
 136 gfc_add_decl_to_parent_function (tree decl)
 137 {
 138   assert (decl);
 139   DECL_CONTEXT (decl) = DECL_CONTEXT (current_function_decl);
 140   DECL_NONLOCAL (decl) = 1;
 141   TREE_CHAIN (decl) = saved_parent_function_decls;
 142   saved_parent_function_decls = decl;
 143 }
 144
 145 void
 146 gfc_add_decl_to_function (tree decl)
 147 {
 148   assert (decl);
 149   TREE_USED (decl) = 1;
 150   DECL_CONTEXT (decl) = current_function_decl;
 151   TREE_CHAIN (decl) = saved_function_decls;
 152   saved_function_decls = decl;
 153 }
 154
 155
 156 /* Build a  backend label declaration.
 157    Set TREE_USED for named lables.  For artificial labels it's up to the
 158    caller to mark the label as used.  */
 159
 160 tree
 161 gfc_build_label_decl (tree label_id)
 162 {
 163   /* 2^32 temporaries should be enough.  */
 164   static unsigned int tmp_num = 1;
 165   tree label_decl;
 166   char *label_name;
 167
 168   if (label_id == NULL_TREE)
 169     {
 170       /* Build an internal label name.  */
 171       ASM_FORMAT_PRIVATE_NAME (label_name, "L", tmp_num++);
 172       label_id = get_identifier (label_name);
 173     }
 174   else
 175     label_name = NULL;
 176
 177   /* Build the LABEL_DECL node. Labels have no type.  */
 178   label_decl = build_decl (LABEL_DECL, label_id, void_type_node);
 179   DECL_CONTEXT (label_decl) = current_function_decl;
 180   DECL_MODE (label_decl) = VOIDmode;
 181
 182   if (label_name)
 183     {
 184       DECL_ARTIFICIAL (label_decl) = 1;
 185     }
 186   else
 187     {
 188       /* We always define the label as used, even if the original source
 189          file never references the label.  We don't want all kinds of
 190          spurious warnings for old-style Fortran code with too many
 191          labels.  */
 192       TREE_USED (label_decl) = 1;
 193     }
 194
 195   return label_decl;
 196 }
 197
 198
 199 /* Returns the return label for the current function.  */
 200
 201 tree
 202 gfc_get_return_label (void)
 203 {
 204   char name[GFC_MAX_SYMBOL_LEN + 10];
 205
 206   if (current_function_return_label)
 207     return current_function_return_label;
 208
 209   sprintf (name, "__return_%s",
 210            IDENTIFIER_POINTER (DECL_NAME (current_function_decl)));
 211
 212   current_function_return_label =
 213     gfc_build_label_decl (get_identifier (name));
 214
 215   DECL_ARTIFICIAL (current_function_return_label) = 1;
 216
 217   return current_function_return_label;
 218 }
 219
 220
 221 /* Return the backend label declaration for a given label structure,
 222    or create it if it doesn't exist yet.  */
 223
 224 tree
 225 gfc_get_label_decl (gfc_st_label * lp)
 226 {
 227
 228   if (lp->backend_decl)
 229     return lp->backend_decl;
 230   else
 231     {
 232       char label_name[GFC_MAX_SYMBOL_LEN + 1];
 233       tree label_decl;
 234
 235       /* Validate the label declaration from the front end.  */
 236       assert (lp != NULL && lp->value <= MAX_LABEL_VALUE);
 237
 238       /* Build a mangled name for the label.  */
 239       sprintf (label_name, "__label_%.6d", lp->value);
 240
 241       /* Build the LABEL_DECL node.  */
 242       label_decl = gfc_build_label_decl (get_identifier (label_name));
 243
 244       /* Tell the debugger where the label came from.  */
 245       if (lp->value <= MAX_LABEL_VALUE) /* An internal label */
 246         {
 247           DECL_SOURCE_LINE (label_decl) = lp->where.lb->linenum;
 248           DECL_SOURCE_FILE (label_decl) = lp->where.lb->file->filename;
 249         }
 250       else
 251         DECL_ARTIFICIAL (label_decl) = 1;
 252
 253       /* Store the label in the label list and return the LABEL_DECL.  */
 254       lp->backend_decl = label_decl;
 255       return label_decl;
 256     }
 257 }
 258
 259
 260 /* Convert a gfc_symbol to an identifier of the same name.  */
 261
 262 static tree
 263 gfc_sym_identifier (gfc_symbol * sym)
 264 {
 265   return (get_identifier (sym->name));
 266 }
 267
 268
 269 /* Construct mangled name from symbol name.  */
 270
 271 static tree
 272 gfc_sym_mangled_identifier (gfc_symbol * sym)
 273 {
 274   char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
 275
 276   if (sym->module[0] == 0)
 277     return gfc_sym_identifier (sym);
 278   else
 279     {
 280       snprintf (name, sizeof name, "__%s__%s", sym->module, sym->name);
 281       return get_identifier (name);
 282     }
 283 }
 284
 285
 286 /* Construct mangled function name from symbol name.  */
 287
 288 static tree
 289 gfc_sym_mangled_function_id (gfc_symbol * sym)
 290 {
 291   int has_underscore;
 292   char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
 293
 294   if (sym->module[0] == 0 || sym->attr.proc == PROC_EXTERNAL
 295       || (sym->module[0] != 0 && sym->attr.if_source == IFSRC_IFBODY))
 296     {
 297       if (strcmp (sym->name, "MAIN__") == 0
 298           || sym->attr.proc == PROC_INTRINSIC)
 299         return get_identifier (sym->name);
 300
 301       if (gfc_option.flag_underscoring)
 302         {
 303           has_underscore = strchr (sym->name, '_') != 0;
 304           if (gfc_option.flag_second_underscore && has_underscore)
 305             snprintf (name, sizeof name, "%s__", sym->name);
 306           else
 307             snprintf (name, sizeof name, "%s_", sym->name);
 308           return get_identifier (name);
 309         }
 310       else
 311         return get_identifier (sym->name);
 312     }
 313   else
 314     {
 315       snprintf (name, sizeof name, "__%s__%s", sym->module, sym->name);
 316       return get_identifier (name);
 317     }
 318 }
 319
 320
 321 /* Finish processing of a declaration and install its initial value.  */
 322
 323 static void
 324 gfc_finish_decl (tree decl, tree init)
 325 {
 326   if (TREE_CODE (decl) == PARM_DECL)
 327     assert (init == NULL_TREE);
 328   /* Remember that PARM_DECL doesn't have a DECL_INITIAL field per se
 329      -- it overlaps DECL_ARG_TYPE.  */
 330   else if (init == NULL_TREE)
 331     assert (DECL_INITIAL (decl) == NULL_TREE);
 332   else
 333     assert (DECL_INITIAL (decl) == error_mark_node);
 334
 335   if (init != NULL_TREE)
 336     {
 337       if (TREE_CODE (decl) != TYPE_DECL)
 338         DECL_INITIAL (decl) = init;
 339       else
 340         {
 341           /* typedef foo = bar; store the type of bar as the type of foo.  */
 342           TREE_TYPE (decl) = TREE_TYPE (init);
 343           DECL_INITIAL (decl) = init = 0;
 344         }
 345     }
 346
 347   if (TREE_CODE (decl) == VAR_DECL)
 348     {
 349       if (DECL_SIZE (decl) == NULL_TREE
 350           && TYPE_SIZE (TREE_TYPE (decl)) != NULL_TREE)
 351         layout_decl (decl, 0);
 352
 353       /* A static variable with an incomplete type is an error if it is
 354          initialized. Also if it is not file scope. Otherwise, let it
 355          through, but if it is not `extern' then it may cause an error
 356          message later.  */
 357       /* An automatic variable with an incomplete type is an error.  */
 358       if (DECL_SIZE (decl) == NULL_TREE
 359           && (TREE_STATIC (decl) ? (DECL_INITIAL (decl) != 0
 360                                     || DECL_CONTEXT (decl) != 0)
 361                                  : !DECL_EXTERNAL (decl)))
 362         {
 363           gfc_fatal_error ("storage size not known");
 364         }
 365
 366       if ((DECL_EXTERNAL (decl) || TREE_STATIC (decl))
 367           && (DECL_SIZE (decl) != 0)
 368           && (TREE_CODE (DECL_SIZE (decl)) != INTEGER_CST))
 369         {
 370           gfc_fatal_error ("storage size not constant");
 371         }
 372     }
 373
 374 }
 375
 376
 377 /* Apply symbol attributes to a variable, and add it to the function scope.  */
 378
 379 static void
 380 gfc_finish_var_decl (tree decl, gfc_symbol * sym)
 381 {
 382   /* TREE_ADDRESSABLE means the address of this variable is acualy needed.
 383      This is the equivalent of the TARGET variables.
 384      We also need to set this if the variable is passed by reference in a
 385      CALL statement.  */
 386   if (sym->attr.target)
 387     TREE_ADDRESSABLE (decl) = 1;
 388   /* If it wasn't used we wouldn't be getting it.  */
 389   TREE_USED (decl) = 1;
 390
 391   /* Chain this decl to the pending declarations.  Don't do pushdecl()
 392      because this would add them to the current scope rather than the
 393      function scope.  */
 394   if (current_function_decl != NULL_TREE)
 395     {
 396       if (sym->ns->proc_name->backend_decl == current_function_decl)
 397         gfc_add_decl_to_function (decl);
 398       else
 399         gfc_add_decl_to_parent_function (decl);
 400     }
 401
 402   /* If a variable is USE associated, it's always external.  */
 403   if (sym->attr.use_assoc)
 404     {
 405       DECL_EXTERNAL (decl) = 1;
 406       TREE_PUBLIC (decl) = 1;
 407     }
 408   else if (sym->module[0] && !sym->attr.result)
 409     {
 410       /* TODO: Don't set sym->module for result variables.  */
 411       assert (current_function_decl == NULL_TREE);
 412       /* This is the declaration of a module variable.  */
 413       TREE_PUBLIC (decl) = 1;
 414       TREE_STATIC (decl) = 1;
 415     }
 416
 417   if ((sym->attr.save || sym->attr.data || sym->value)
 418       && !sym->attr.use_assoc)
 419     TREE_STATIC (decl) = 1;
 420
 421   /* Keep variables larger than max-stack-var-size off stack.  */
 422   if (!sym->ns->proc_name->attr.recursive
 423       && INTEGER_CST_P (DECL_SIZE_UNIT (decl))
 424       && !gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl)))
 425     TREE_STATIC (decl) = 1;
 426 }
 427
 428
 429 /* Allocate the lang-specific part of a decl.  */
 430
 431 void
 432 gfc_allocate_lang_decl (tree decl)
 433 {
 434   DECL_LANG_SPECIFIC (decl) = (struct lang_decl *)
 435     ggc_alloc_cleared (sizeof (struct lang_decl));
 436 }
 437
 438 /* Remember a symbol to generate initialization/cleanup code at function
 439    entry/exit.  */
 440
 441 static void
 442 gfc_defer_symbol_init (gfc_symbol * sym)
 443 {
 444   gfc_symbol *p;
 445   gfc_symbol *last;
 446   gfc_symbol *head;
 447
 448   /* Don't add a symbol twice.  */
 449   if (sym->tlink)
 450     return;
 451
 452   last = head = sym->ns->proc_name;
 453   p = last->tlink;
 454
 455   /* Make sure that setup code for dummy variables which are used in the
 456      setup of other variables is generated first.  */
 457   if (sym->attr.dummy)
 458     {
 459       /* Find the first dummy arg seen after us, or the first non-dummy arg.
 460          This is a circular list, so don't go past the head.  */
 461       while (p != head
 462              && (!p->attr.dummy || p->dummy_order > sym->dummy_order))
 463         {
 464           last = p;
 465           p = p->tlink;
 466         }
 467     }
 468   /* Insert in between last and p.  */
 469   last->tlink = sym;
 470   sym->tlink = p;
 471 }
 472
 473
 474 /* Create an array index type variable with function scope.  */
 475
 476 static tree
 477 create_index_var (const char * pfx, int nest)
 478 {
 479   tree decl;
 480
 481   decl = gfc_create_var_np (gfc_array_index_type, pfx);
 482   if (nest)
 483     gfc_add_decl_to_parent_function (decl);
 484   else
 485     gfc_add_decl_to_function (decl);
 486   return decl;
 487 }
 488
 489
 490 /* Create variables to hold all the non-constant bits of info for a
 491    descriptorless array.  Remember these in the lang-specific part of the
 492    type.  */
 493
 494 static void
 495 gfc_build_qualified_array (tree decl, gfc_symbol * sym)
 496 {
 497   tree type;
 498   int dim;
 499   int nest;
 500
 501   type = TREE_TYPE (decl);
 502
 503   /* We just use the descriptor, if there is one.  */
 504   if (GFC_DESCRIPTOR_TYPE_P (type))
 505     return;
 506
 507   assert (GFC_ARRAY_TYPE_P (type));
 508   nest = (sym->ns->proc_name->backend_decl != current_function_decl)
 509          && !sym->attr.contained;
 510
 511   for (dim = 0; dim < GFC_TYPE_ARRAY_RANK (type); dim++)
 512     {
 513       if (GFC_TYPE_ARRAY_LBOUND (type, dim) == NULL_TREE)
 514         GFC_TYPE_ARRAY_LBOUND (type, dim) = create_index_var ("lbound", nest);
 515       /* Don't try to use the unkown bound for assumed shape arrays.  */
 516       if (GFC_TYPE_ARRAY_UBOUND (type, dim) == NULL_TREE
 517           && (sym->as->type != AS_ASSUMED_SIZE
 518               || dim < GFC_TYPE_ARRAY_RANK (type) - 1))
 519         GFC_TYPE_ARRAY_UBOUND (type, dim) = create_index_var ("ubound", nest);
 520
 521       if (GFC_TYPE_ARRAY_STRIDE (type, dim) == NULL_TREE)
 522         GFC_TYPE_ARRAY_STRIDE (type, dim) = create_index_var ("stride", nest);
 523     }
 524   if (GFC_TYPE_ARRAY_OFFSET (type) == NULL_TREE)
 525     {
 526       GFC_TYPE_ARRAY_OFFSET (type) = gfc_create_var_np (gfc_array_index_type,
 527                                                         "offset");
 528       if (nest)
 529         gfc_add_decl_to_parent_function (GFC_TYPE_ARRAY_OFFSET (type));
 530       else
 531         gfc_add_decl_to_function (GFC_TYPE_ARRAY_OFFSET (type));
 532     }
 533 }
 534
 535
 536 /* For some dummy arguments we don't use the actual argument directly.
 537    Instead we create a local decl and use that.  This allows us to preform
 538    initialization, and construct full type information.  */
 539
 540 static tree
 541 gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy)
 542 {
 543   tree decl;
 544   tree type;
 545   gfc_array_spec *as;
 546   char *name;
 547   int packed;
 548   int n;
 549   bool known_size;
 550
 551   if (sym->attr.pointer || sym->attr.allocatable)
 552     return dummy;
 553
 554   /* Add to list of variables if not a fake result variable.  */
 555   if (sym->attr.result || sym->attr.dummy)
 556     gfc_defer_symbol_init (sym);
 557
 558   type = TREE_TYPE (dummy);
 559   assert (TREE_CODE (dummy) == PARM_DECL
 560           && POINTER_TYPE_P (type));
 561
 562   /* Do we know the element size. */
 563   known_size = sym->ts.type != BT_CHARACTER
 564           || INTEGER_CST_P (sym->ts.cl->backend_decl);
 565
 566   if (known_size && !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type)))
 567     {
 568       /* For descriptorless arrays with known element size the actual
 569          argument is sufficient.  */
 570       assert (GFC_ARRAY_TYPE_P (type));
 571       gfc_build_qualified_array (dummy, sym);
 572       return dummy;
 573     }
 574
 575   type = TREE_TYPE (type);
 576   if (GFC_DESCRIPTOR_TYPE_P (type))
 577     {
 578       /* Create a decriptorless array pointer.  */
 579       as = sym->as;
 580       packed = 0;
 581       if (!gfc_option.flag_repack_arrays)
 582         {
 583           if (as->type == AS_ASSUMED_SIZE)
 584             packed = 2;
 585         }
 586       else
 587         {
 588           if (as->type == AS_EXPLICIT)
 589             {
 590               packed = 2;
 591               for (n = 0; n < as->rank; n++)
 592                 {
 593                   if (!(as->upper[n]
 594                         && as->lower[n]
 595                         && as->upper[n]->expr_type == EXPR_CONSTANT
 596                         && as->lower[n]->expr_type == EXPR_CONSTANT))
 597                     packed = 1;
 598                 }
 599             }
 600           else
 601             packed = 1;
 602         }
 603
 604       type = gfc_typenode_for_spec (&sym->ts);
 605       type = gfc_get_nodesc_array_type (type, sym->as, packed);
 606     }
 607   else
 608     {
 609       /* We now have an expression for the element size, so create a fully
 610          qualified type.  Reset sym->backend decl or this will just return the
 611          old type.  */
 612       sym->backend_decl = NULL_TREE;
 613       type = gfc_sym_type (sym);
 614       packed = 2;
 615     }
 616
 617   ASM_FORMAT_PRIVATE_NAME (name, IDENTIFIER_POINTER (DECL_NAME (dummy)), 0);
 618   decl = build_decl (VAR_DECL, get_identifier (name), type);
 619
 620   DECL_ARTIFICIAL (decl) = 1;
 621   TREE_PUBLIC (decl) = 0;
 622   TREE_STATIC (decl) = 0;
 623   DECL_EXTERNAL (decl) = 0;
 624
 625   /* We should never get deferred shape arrays here.  We used to because of
 626      frontend bugs.  */
 627   assert (sym->as->type != AS_DEFERRED);
 628
 629   switch (packed)
 630     {
 631     case 1:
 632       GFC_DECL_PARTIAL_PACKED_ARRAY (decl) = 1;
 633       break;
 634
 635     case 2:
 636       GFC_DECL_PACKED_ARRAY (decl) = 1;
 637       break;
 638     }
 639
 640   gfc_build_qualified_array (decl, sym);
 641
 642   if (DECL_LANG_SPECIFIC (dummy))
 643     DECL_LANG_SPECIFIC (decl) = DECL_LANG_SPECIFIC (dummy);
 644   else
 645     gfc_allocate_lang_decl (decl);
 646
 647   GFC_DECL_SAVED_DESCRIPTOR (decl) = dummy;
 648
 649   if (sym->ns->proc_name->backend_decl == current_function_decl
 650       || sym->attr.contained)
 651     gfc_add_decl_to_function (decl);
 652   else
 653     gfc_add_decl_to_parent_function (decl);
 654
 655   return decl;
 656 }
 657
 658
 659 /* Return a constant or a variable to use as a string length.  Does not
 660    add the decl to the current scope.  */
 661
 662 static tree
 663 gfc_create_string_length (gfc_symbol * sym)
 664 {
 665   tree length;
 666
 667   assert (sym->ts.cl);
 668   gfc_conv_const_charlen (sym->ts.cl);
 669
 670   if (sym->ts.cl->backend_decl == NULL_TREE)
 671     {
 672       char name[GFC_MAX_MANGLED_SYMBOL_LEN + 2];
 673
 674       /* Also prefix the mangled name.  */
 675       strcpy (&name[1], sym->name);
 676       name[0] = '.';
 677       length = build_decl (VAR_DECL, get_identifier (name),
 678                            gfc_strlen_type_node);
 679       DECL_ARTIFICIAL (length) = 1;
 680       TREE_USED (length) = 1;
 681       gfc_defer_symbol_init (sym);
 682       sym->ts.cl->backend_decl = length;
 683     }
 684
 685   return sym->ts.cl->backend_decl;
 686 }
 687
 688
 689 /* Return the decl for a gfc_symbol, create it if it doesn't already
 690    exist.  */
 691
 692 tree
 693 gfc_get_symbol_decl (gfc_symbol * sym)
 694 {
 695   tree decl;
 696   tree length = NULL_TREE;
 697   int byref;
 698
 699   assert (sym->attr.referenced);
 700
 701   if (sym->ns && sym->ns->proc_name->attr.function)
 702     byref = gfc_return_by_reference (sym->ns->proc_name);
 703   else
 704     byref = 0;
 705
 706   if ((sym->attr.dummy && ! sym->attr.function) || (sym->attr.result && byref))
 707     {
 708       /* Return via extra parameter.  */
 709       if (sym->attr.result && byref
 710           && !sym->backend_decl)
 711         {
 712           sym->backend_decl =
 713             DECL_ARGUMENTS (sym->ns->proc_name->backend_decl);
 714         }
 715
 716       /* Dummy variables should already have been created.  */
 717       assert (sym->backend_decl);
 718
 719       /* Create a character length variable.  */
 720       if (sym->ts.type == BT_CHARACTER)
 721         {
 722           if (sym->ts.cl->backend_decl == NULL_TREE)
 723             {
 724               length = gfc_create_string_length (sym);
 725               if (TREE_CODE (length) != INTEGER_CST)
 726                 {
 727                   gfc_finish_var_decl (length, sym);
 728                   gfc_defer_symbol_init (sym);
 729                 }
 730             }
 731         }
 732
 733       /* Use a copy of the descriptor for dummy arrays.  */
 734       if (sym->attr.dimension && !TREE_USED (sym->backend_decl))
 735         {
 736           sym->backend_decl =
 737             gfc_build_dummy_array_decl (sym, sym->backend_decl);
 738         }
 739
 740       TREE_USED (sym->backend_decl) = 1;
 741       return sym->backend_decl;
 742     }
 743
 744   if (sym->backend_decl)
 745     return sym->backend_decl;
 746
 747   if (sym->attr.entry)
 748     gfc_todo_error ("alternate entry");
 749
 750   /* Catch function declarations.  Only used for actual parameters.  */
 751   if (sym->attr.flavor == FL_PROCEDURE)
 752     {
 753       decl = gfc_get_extern_function_decl (sym);
 754       return decl;
 755     }
 756
 757   if (sym->attr.intrinsic)
 758     internal_error ("intrinsic variable which isn't a procedure");
 759
 760   /* Create string length decl first so that they can be used in the
 761      type declaration.  */
 762   if (sym->ts.type == BT_CHARACTER)
 763     length = gfc_create_string_length (sym);
 764
 765   /* Create the decl for the variable.  */
 766   decl = build_decl (VAR_DECL, gfc_sym_identifier (sym), gfc_sym_type (sym));
 767
 768   /* Symbols from modules have its assembler name should be mangled.
 769      This is done here rather than in gfc_finish_var_decl because it
 770      is different for string length variables.  */
 771   if (sym->module[0])
 772     SET_DECL_ASSEMBLER_NAME (decl, gfc_sym_mangled_identifier (sym));
 773
 774   if (sym->attr.dimension)
 775     {
 776       /* Create variables to hold the non-constant bits of array info.  */
 777       gfc_build_qualified_array (decl, sym);
 778
 779       /* Remember this variable for allocation/cleanup.  */
 780       gfc_defer_symbol_init (sym);
 781
 782       if ((sym->attr.allocatable || !sym->attr.dummy) && !sym->attr.pointer)
 783         GFC_DECL_PACKED_ARRAY (decl) = 1;
 784     }
 785
 786   gfc_finish_var_decl (decl, sym);
 787
 788   if (sym->attr.assign)
 789     {
 790       gfc_allocate_lang_decl (decl);
 791       GFC_DECL_ASSIGN (decl) = 1;
 792       length = gfc_create_var (gfc_strlen_type_node, sym->name);
 793       GFC_DECL_STRING_LEN (decl) = length;
 794       GFC_DECL_ASSIGN_ADDR (decl) = gfc_create_var (pvoid_type_node, sym->name);
 795       /* TODO: Need to check we don't change TREE_STATIC (decl) later.  */
 796       TREE_STATIC (length) = TREE_STATIC (decl);
 797       /*  STRING_LENGTH is also used as flag. Less than -1 means that
 798           ASSIGN_ADDR can not be used. Equal -1 means that ASSIGN_ADDR is the
 799           target label's address. Other value is the length of format string
 800           and ASSIGN_ADDR is the address of format string.  */
 801       DECL_INITIAL (length) = build_int_2 (-2, -1);
 802     }
 803
 804   if (sym->ts.type == BT_CHARACTER)
 805     {
 806       /* Character variables need special handling.  */
 807       gfc_allocate_lang_decl (decl);
 808
 809       if (TREE_CODE (length) != INTEGER_CST)
 810         {
 811           char name[GFC_MAX_MANGLED_SYMBOL_LEN + 2];
 812
 813           if (sym->module[0])
 814             {
 815               /* Also prefix the mangled name for symbols from modules.  */
 816               strcpy (&name[1], sym->name);
 817               name[0] = '.';
 818               strcpy (&name[1],
 819                       IDENTIFIER_POINTER (DECL_ASSEMBLER_NAME (length)));
 820               SET_DECL_ASSEMBLER_NAME (decl, get_identifier (name));
 821             }
 822           gfc_finish_var_decl (length, sym);
 823           assert (!sym->value);
 824         }
 825     }
 826   sym->backend_decl = decl;
 827
 828   if (TREE_STATIC (decl) && !sym->attr.use_assoc)
 829     {
 830       /* Add static initializer.  */
 831       DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
 832           TREE_TYPE (decl), sym->attr.dimension,
 833           sym->attr.pointer || sym->attr.allocatable);
 834     }
 835
 836   return decl;
 837 }
 838
 839
 840 /* Substitute a temporary variable in place of the real one.  */
 841
 842 void
 843 gfc_shadow_sym (gfc_symbol * sym, tree decl, gfc_saved_var * save)
 844 {
 845   save->attr = sym->attr;
 846   save->decl = sym->backend_decl;
 847
 848   gfc_clear_attr (&sym->attr);
 849   sym->attr.referenced = 1;
 850   sym->attr.flavor = FL_VARIABLE;
 851
 852   sym->backend_decl = decl;
 853 }
 854
 855
 856 /* Restore the original variable.  */
 857
 858 void
 859 gfc_restore_sym (gfc_symbol * sym, gfc_saved_var * save)
 860 {
 861   sym->attr = save->attr;
 862   sym->backend_decl = save->decl;
 863 }
 864
 865
 866 /* Get a basic decl for an external function.  */
 867
 868 tree
 869 gfc_get_extern_function_decl (gfc_symbol * sym)
 870 {
 871   tree type;
 872   tree fndecl;
 873   gfc_expr e;
 874   gfc_intrinsic_sym *isym;
 875   gfc_expr argexpr;
 876   char s[GFC_MAX_SYMBOL_LEN];
 877   tree name;
 878   tree mangled_name;
 879
 880   if (sym->backend_decl)
 881     return sym->backend_decl;
 882
 883   if (sym->attr.intrinsic)
 884     {
 885       /* Call the resolution function to get the actual name.  This is
 886          a nasty hack which relies on the resolution functions only looking
 887          at the first argument.  We pass NULL for the second argument
 888          otherwise things like AINT get confused.  */
 889       isym = gfc_find_function (sym->name);
 890       assert (isym->resolve.f0 != NULL);
 891
 892       memset (&e, 0, sizeof (e));
 893       e.expr_type = EXPR_FUNCTION;
 894
 895       memset (&argexpr, 0, sizeof (argexpr));
 896       assert (isym->formal);
 897       argexpr.ts = isym->formal->ts;
 898
 899       if (isym->formal->next == NULL)
 900         isym->resolve.f1 (&e, &argexpr);
 901       else
 902         {
 903           /* All specific intrinsics take one or two arguments.  */
 904           assert (isym->formal->next->next == NULL);
 905           isym->resolve.f2 (&e, &argexpr, NULL);
 906         }
 907       sprintf (s, "specific%s", e.value.function.name);
 908       name = get_identifier (s);
 909       mangled_name = name;
 910     }
 911   else
 912     {
 913       name = gfc_sym_identifier (sym);
 914       mangled_name = gfc_sym_mangled_function_id (sym);
 915     }
 916
 917   type = gfc_get_function_type (sym);
 918   fndecl = build_decl (FUNCTION_DECL, name, type);
 919
 920   SET_DECL_ASSEMBLER_NAME (fndecl, mangled_name);
 921   /* If the return type is a pointer, avoid alias issues by setting
 922      DECL_IS_MALLOC to nonzero. This means that the function should be
 923      treated as if it were a malloc, meaning it returns a pointer that
 924      is not an alias.  */
 925   if (POINTER_TYPE_P (type))
 926     DECL_IS_MALLOC (fndecl) = 1;
 927
 928   /* Set the context of this decl.  */
 929   if (0 && sym->ns && sym->ns->proc_name)
 930     {
 931       /* TODO: Add external decls to the appropriate scope.  */
 932       DECL_CONTEXT (fndecl) = sym->ns->proc_name->backend_decl;
 933     }
 934   else
 935     {
 936       /* Global declaration, eg. intrinsic subroutine.  */
 937       DECL_CONTEXT (fndecl) = NULL_TREE;
 938     }
 939
 940   DECL_EXTERNAL (fndecl) = 1;
 941
 942   /* This specifies if a function is globaly addressable, ie. it is
 943      the opposite of declaring static in C.  */
 944   TREE_PUBLIC (fndecl) = 1;
 945
 946   /* Set attributes for PURE functions. A call to PURE function in the
 947      Fortran 95 sense is both pure and without side effects in the C
 948      sense.  */
 949   if (sym->attr.pure || sym->attr.elemental)
 950     {
 951       if (sym->attr.function)
 952         DECL_IS_PURE (fndecl) = 1;
 953       /* TODO: check if pure SUBROUTINEs don't have INTENT(OUT)
 954          parameters and don't use alternate returns (is this
 955          allowed?). In that case, calls to them are meaningless, and
 956          can be optimized away. See also in gfc_build_function_decl().  */
 957       TREE_SIDE_EFFECTS (fndecl) = 0;
 958     }
 959
 960   sym->backend_decl = fndecl;
 961
 962   if (DECL_CONTEXT (fndecl) == NULL_TREE)
 963     pushdecl_top_level (fndecl);
 964
 965   return fndecl;
 966 }
 967
 968
 969 /* Create a declaration for a procedure.  For external functions (in the C
 970    sense) use gfc_get_extern_function_decl.  */
 971
 972 void
 973 gfc_build_function_decl (gfc_symbol * sym)
 974 {
 975   tree fndecl, type, result_decl, typelist, arglist;
 976   tree length;
 977   symbol_attribute attr;
 978   gfc_formal_arglist *f;
 979
 980   assert (!sym->backend_decl);
 981   assert (!sym->attr.external);
 982
 983   /* Allow only one nesting level.  Allow public declarations.  */
 984   assert (current_function_decl == NULL_TREE
 985           || DECL_CONTEXT (current_function_decl) == NULL_TREE);
 986
 987   type = gfc_get_function_type (sym);
 988   fndecl = build_decl (FUNCTION_DECL, gfc_sym_identifier (sym), type);
 989
 990   /* Perform name mangling if this is a top level or module procedure.  */
 991   if (current_function_decl == NULL_TREE)
 992     SET_DECL_ASSEMBLER_NAME (fndecl, gfc_sym_mangled_function_id (sym));
 993
 994   /* Figure out the return type of the declared function, and build a
 995      RESULT_DECL for it.  If this is subroutine with alternate
 996      returns, build a RESULT_DECL for it.  */
 997   attr = sym->attr;
 998
 999   result_decl = NULL_TREE;
1000   /* TODO: Shouldn't this just be TREE_TYPE (TREE_TYPE (fndecl)).  */
1001   if (attr.function)
1002     {
1003       if (gfc_return_by_reference (sym))
1004         type = void_type_node;
1005       else
1006         {
1007           if (sym->result != sym)
1008             result_decl = gfc_sym_identifier (sym->result);
1009
1010           type = TREE_TYPE (TREE_TYPE (fndecl));
1011         }
1012     }
1013   else
1014     {
1015       /* Look for alternate return placeholders.  */
1016       int has_alternate_returns = 0;
1017       for (f = sym->formal; f; f = f->next)
1018         {
1019           if (f->sym == NULL)
1020             {
1021               has_alternate_returns = 1;
1022               break;
1023             }
1024         }
1025
1026       if (has_alternate_returns)
1027         type = integer_type_node;
1028       else
1029         type = void_type_node;
1030     }
1031
1032   result_decl = build_decl (RESULT_DECL, result_decl, type);
1033   DECL_ARTIFICIAL (result_decl) = 1;
1034   DECL_IGNORED_P (result_decl) = 1;
1035   DECL_CONTEXT (result_decl) = fndecl;
1036   DECL_RESULT (fndecl) = result_decl;
1037
1038   /* Don't call layout_decl for a RESULT_DECL.
1039      layout_decl (result_decl, 0); */
1040
1041   /* If the return type is a pointer, avoid alias issues by setting
1042      DECL_IS_MALLOC to nonzero. This means that the function should be
1043      treated as if it were a malloc, meaning it returns a pointer that
1044      is not an alias.  */
1045   if (POINTER_TYPE_P (type))
1046     DECL_IS_MALLOC (fndecl) = 1;
1047
1048   /* Set up all attributes for the function.  */
1049   DECL_CONTEXT (fndecl) = current_function_decl;
1050   DECL_EXTERNAL (fndecl) = 0;
1051
1052   /* This specifies if a function is globaly addressable, ie. it is
1053      the opposite of declaring static in C.  */
1054   if (DECL_CONTEXT (fndecl) == NULL_TREE || attr.external)
1055     TREE_PUBLIC (fndecl) = 1;
1056
1057   /* TREE_STATIC means the function body is defined here.  */
1058   if (!attr.external)
1059     TREE_STATIC (fndecl) = 1;
1060
1061   /* Set attributes for PURE functions. A call to PURE function in the
1062      Fortran 95 sense is both pure and without side effects in the C
1063      sense.  */
1064   if (attr.pure || attr.elemental)
1065     {
1066       /* TODO: check if a pure SUBROUTINE has no INTENT(OUT) arguments
1067          including a alternate return. In that case it can also be
1068          marked as PURE. See also in gfc_get_extern_fucntion_decl().  */
1069       if (attr.function)
1070         DECL_IS_PURE (fndecl) = 1;
1071       TREE_SIDE_EFFECTS (fndecl) = 0;
1072     }
1073
1074   /* Layout the function declaration and put it in the binding level
1075      of the current function.  */
1076   if (!attr.external)
1077     {
1078       tree parm;
1079
1080       pushdecl (fndecl);
1081       /* Build formal argument list. Make sure that their TREE_CONTEXT is
1082          the new FUNCTION_DECL node.  */
1083       current_function_decl = fndecl;
1084       arglist = NULL_TREE;
1085       typelist = TYPE_ARG_TYPES (TREE_TYPE (fndecl));
1086       if (gfc_return_by_reference (sym))
1087         {
1088           type = TREE_VALUE (typelist);
1089           parm = build_decl (PARM_DECL, get_identifier ("__result"), type);
1090
1091           DECL_CONTEXT (parm) = fndecl;
1092           DECL_ARG_TYPE (parm) = type;
1093           TREE_READONLY (parm) = 1;
1094           gfc_finish_decl (parm, NULL_TREE);
1095
1096           arglist = chainon (arglist, parm);
1097           typelist = TREE_CHAIN (typelist);
1098
1099           if (sym->ts.type == BT_CHARACTER)
1100             {
1101               gfc_allocate_lang_decl (parm);
1102
1103               /* Length of character result.  */
1104               type = TREE_VALUE (typelist);
1105               assert (type == gfc_strlen_type_node);
1106
1107               length = build_decl (PARM_DECL,
1108                                    get_identifier (".__result"),
1109                                    type);
1110               if (!sym->ts.cl->length)
1111                 {
1112                   sym->ts.cl->backend_decl = length;
1113                   TREE_USED (length) = 1;
1114                 }
1115               assert (TREE_CODE (length) == PARM_DECL);
1116               arglist = chainon (arglist, length);
1117               typelist = TREE_CHAIN (typelist);
1118               DECL_CONTEXT (length) = fndecl;
1119               DECL_ARG_TYPE (length) = type;
1120               TREE_READONLY (length) = 1;
1121               gfc_finish_decl (length, NULL_TREE);
1122             }
1123         }
1124
1125       for (f = sym->formal; f; f = f->next)
1126         {
1127           if (f->sym != NULL)   /* ignore alternate returns. */
1128             {
1129               length = NULL_TREE;
1130
1131               type = TREE_VALUE (typelist);
1132
1133               /* Build a the argument declaration.  */
1134               parm = build_decl (PARM_DECL,
1135                                  gfc_sym_identifier (f->sym), type);
1136
1137               /* Fill in arg stuff.  */
1138               DECL_CONTEXT (parm) = fndecl;
1139               DECL_ARG_TYPE (parm) = type;
1140               DECL_ARG_TYPE_AS_WRITTEN (parm) = type;
1141               /* All implementation args are read-only.  */
1142               TREE_READONLY (parm) = 1;
1143
1144               gfc_finish_decl (parm, NULL_TREE);
1145
1146               f->sym->backend_decl = parm;
1147
1148               arglist = chainon (arglist, parm);
1149               typelist = TREE_CHAIN (typelist);
1150             }
1151         }
1152
1153       /* Add the hidden string length parameters.  */
1154       parm = arglist;
1155       for (f = sym->formal; f; f = f->next)
1156         {
1157           char name[GFC_MAX_SYMBOL_LEN + 2];
1158           /* Ignore alternate returns.  */
1159           if (f->sym == NULL)
1160             continue;
1161
1162           if (f->sym->ts.type != BT_CHARACTER)
1163             continue;
1164
1165           parm = f->sym->backend_decl;
1166           type = TREE_VALUE (typelist);
1167           assert (type == gfc_strlen_type_node);
1168
1169           strcpy (&name[1], f->sym->name);
1170           name[0] = '_';
1171           length = build_decl (PARM_DECL, get_identifier (name), type);
1172
1173           arglist = chainon (arglist, length);
1174           DECL_CONTEXT (length) = fndecl;
1175           DECL_ARG_TYPE (length) = type;
1176           TREE_READONLY (length) = 1;
1177           gfc_finish_decl (length, NULL_TREE);
1178
1179           /* TODO: Check string lengths when -fbounds-check.  */
1180
1181           /* Use the passed value for assumed length variables.  */
1182           if (!f->sym->ts.cl->length)
1183             {
1184               TREE_USED (length) = 1;
1185               if (!f->sym->ts.cl->backend_decl)
1186                 f->sym->ts.cl->backend_decl = length;
1187               else
1188                 {
1189                   /* there is already another variable using this
1190                      gfc_charlen node, build a new one for this variable
1191                      and chain it into the list of gfc_charlens.
1192                      This happens for e.g. in the case
1193                      CHARACTER(*)::c1,c2
1194                      since CHARACTER declarations on the same line share
1195                      the same gfc_charlen node.  */
1196                   gfc_charlen *cl;
1197
1198                   cl = gfc_get_charlen ();
1199                   cl->backend_decl = length;
1200                   cl->next = f->sym->ts.cl->next;
1201                   f->sym->ts.cl->next = cl;
1202                   f->sym->ts.cl = cl;
1203                 }
1204             }
1205
1206           parm = TREE_CHAIN (parm);
1207           typelist = TREE_CHAIN (typelist);
1208         }
1209
1210       assert (TREE_VALUE (typelist) == void_type_node);
1211       DECL_ARGUMENTS (fndecl) = arglist;
1212
1213       /* Restore the old context.  */
1214       current_function_decl = DECL_CONTEXT (fndecl);
1215     }
1216   sym->backend_decl = fndecl;
1217 }
1218
1219
1220 /* Return the decl used to hold the function return value.  */
1221
1222 tree
1223 gfc_get_fake_result_decl (gfc_symbol * sym)
1224 {
1225   tree decl;
1226   tree length;
1227
1228   char name[GFC_MAX_SYMBOL_LEN + 10];
1229
1230   if (current_fake_result_decl != NULL_TREE)
1231     return current_fake_result_decl;
1232
1233   /* Only when gfc_get_fake_result_decl is called by gfc_trans_return,
1234      sym is NULL.  */
1235   if (!sym)
1236     return NULL_TREE;
1237
1238   if (sym->ts.type == BT_CHARACTER
1239       && !sym->ts.cl->backend_decl)
1240     {
1241       length = gfc_create_string_length (sym);
1242       gfc_finish_var_decl (length, sym);
1243     }
1244
1245   if (gfc_return_by_reference (sym))
1246     {
1247       decl = DECL_ARGUMENTS (sym->backend_decl);
1248
1249       TREE_USED (decl) = 1;
1250       if (sym->as)
1251         decl = gfc_build_dummy_array_decl (sym, decl);
1252     }
1253   else
1254     {
1255       sprintf (name, "__result_%.20s",
1256                IDENTIFIER_POINTER (DECL_NAME (current_function_decl)));
1257
1258       decl = build_decl (VAR_DECL, get_identifier (name),
1259                          TREE_TYPE (TREE_TYPE (current_function_decl)));
1260
1261       DECL_ARTIFICIAL (decl) = 1;
1262       DECL_EXTERNAL (decl) = 0;
1263       TREE_PUBLIC (decl) = 0;
1264       TREE_USED (decl) = 1;
1265
1266       layout_decl (decl, 0);
1267
1268       gfc_add_decl_to_function (decl);
1269     }
1270
1271   current_fake_result_decl = decl;
1272
1273   return decl;
1274 }
1275
1276
1277 /* Builds a function decl.  The remaining parameters are the types of the
1278    function arguments.  Negative nargs indicates a varargs function.  */
1279
1280 tree
1281 gfc_build_library_function_decl (tree name, tree rettype, int nargs, ...)
1282 {
1283   tree arglist;
1284   tree argtype;
1285   tree fntype;
1286   tree fndecl;
1287   va_list p;
1288   int n;
1289
1290   /* Library functions must be declared with global scope.  */
1291   assert (current_function_decl == NULL_TREE);
1292
1293   va_start (p, nargs);
1294
1295
1296   /* Create a list of the argument types.  */
1297   for (arglist = NULL_TREE, n = abs (nargs); n > 0; n--)
1298     {
1299       argtype = va_arg (p, tree);
1300       arglist = gfc_chainon_list (arglist, argtype);
1301     }
1302
1303   if (nargs >= 0)
1304     {
1305       /* Terminate the list.  */
1306       arglist = gfc_chainon_list (arglist, void_type_node);
1307     }
1308
1309   /* Build the function type and decl.  */
1310   fntype = build_function_type (rettype, arglist);
1311   fndecl = build_decl (FUNCTION_DECL, name, fntype);
1312
1313   /* Mark this decl as external.  */
1314   DECL_EXTERNAL (fndecl) = 1;
1315   TREE_PUBLIC (fndecl) = 1;
1316
1317   va_end (p);
1318
1319   pushdecl (fndecl);
1320
1321   rest_of_decl_compilation (fndecl, 1, 0);
1322
1323   return fndecl;
1324 }
1325
1326 static void
1327 gfc_build_intrinsic_function_decls (void)
1328 {
1329   /* String functions.  */
1330   gfor_fndecl_copy_string =
1331     gfc_build_library_function_decl (get_identifier (PREFIX("copy_string")),
1332                                      void_type_node,
1333                                      4,
1334                                      gfc_strlen_type_node, pchar_type_node,
1335                                      gfc_strlen_type_node, pchar_type_node);
1336
1337   gfor_fndecl_compare_string =
1338     gfc_build_library_function_decl (get_identifier (PREFIX("compare_string")),
1339                                      gfc_int4_type_node,
1340                                      4,
1341                                      gfc_strlen_type_node, pchar_type_node,
1342                                      gfc_strlen_type_node, pchar_type_node);
1343
1344   gfor_fndecl_concat_string =
1345     gfc_build_library_function_decl (get_identifier (PREFIX("concat_string")),
1346                                      void_type_node,
1347                                      6,
1348                                      gfc_strlen_type_node, pchar_type_node,
1349                                      gfc_strlen_type_node, pchar_type_node,
1350                                      gfc_strlen_type_node, pchar_type_node);
1351
1352   gfor_fndecl_string_len_trim =
1353     gfc_build_library_function_decl (get_identifier (PREFIX("string_len_trim")),
1354                                      gfc_int4_type_node,
1355                                      2, gfc_strlen_type_node,
1356                                      pchar_type_node);
1357
1358   gfor_fndecl_string_index =
1359     gfc_build_library_function_decl (get_identifier (PREFIX("string_index")),
1360                                      gfc_int4_type_node,
1361                                      5, gfc_strlen_type_node, pchar_type_node,
1362                                      gfc_strlen_type_node, pchar_type_node,
1363                                      gfc_logical4_type_node);
1364
1365   gfor_fndecl_string_scan =
1366     gfc_build_library_function_decl (get_identifier (PREFIX("string_scan")),
1367                                      gfc_int4_type_node,
1368                                      5, gfc_strlen_type_node, pchar_type_node,
1369                                      gfc_strlen_type_node, pchar_type_node,
1370                                      gfc_logical4_type_node);
1371
1372   gfor_fndecl_string_verify =
1373     gfc_build_library_function_decl (get_identifier (PREFIX("string_verify")),
1374                                      gfc_int4_type_node,
1375                                      5, gfc_strlen_type_node, pchar_type_node,
1376                                      gfc_strlen_type_node, pchar_type_node,
1377                                      gfc_logical4_type_node);
1378
1379   gfor_fndecl_string_trim =
1380     gfc_build_library_function_decl (get_identifier (PREFIX("string_trim")),
1381                                      void_type_node,
1382                                      4,
1383                                      build_pointer_type (gfc_strlen_type_node),
1384                                      ppvoid_type_node,
1385                                      gfc_strlen_type_node,
1386                                      pchar_type_node);
1387
1388   gfor_fndecl_string_repeat =
1389     gfc_build_library_function_decl (get_identifier (PREFIX("string_repeat")),
1390                                      void_type_node,
1391                                      4,
1392                                      pchar_type_node,
1393                                      gfc_strlen_type_node,
1394                                      pchar_type_node,
1395                                      gfc_int4_type_node);
1396
1397   gfor_fndecl_adjustl =
1398     gfc_build_library_function_decl (get_identifier (PREFIX("adjustl")),
1399                                      void_type_node,
1400                                      3,
1401                                      pchar_type_node,
1402                                      gfc_strlen_type_node, pchar_type_node);
1403
1404   gfor_fndecl_adjustr =
1405     gfc_build_library_function_decl (get_identifier (PREFIX("adjustr")),
1406                                      void_type_node,
1407                                      3,
1408                                      pchar_type_node,
1409                                      gfc_strlen_type_node, pchar_type_node);
1410
1411   gfor_fndecl_si_kind =
1412     gfc_build_library_function_decl (get_identifier ("selected_int_kind"),
1413                                      gfc_int4_type_node,
1414                                      1,
1415                                      pvoid_type_node);
1416
1417   gfor_fndecl_sr_kind =
1418     gfc_build_library_function_decl (get_identifier ("selected_real_kind"),
1419                                      gfc_int4_type_node,
1420                                      2, pvoid_type_node,
1421                                      pvoid_type_node);
1422
1423
1424   /* Power functions.  */
1425   {
1426     tree type;
1427     tree itype;
1428     int kind;
1429     int ikind;
1430     static int kinds[2] = {4, 8};
1431     char name[PREFIX_LEN + 10]; /* _gfortran_pow_?n_?n */
1432
1433     for (ikind=0; ikind < 2; ikind++)
1434       {
1435         itype = gfc_get_int_type (kinds[ikind]);
1436         for (kind = 0; kind < 2; kind ++)
1437           {
1438             type = gfc_get_int_type (kinds[kind]);
1439             sprintf(name, PREFIX("pow_i%d_i%d"), kinds[kind], kinds[ikind]);
1440             gfor_fndecl_math_powi[kind][ikind].integer =
1441               gfc_build_library_function_decl (get_identifier (name),
1442                   type, 2, type, itype);
1443
1444             type = gfc_get_real_type (kinds[kind]);
1445             sprintf(name, PREFIX("pow_r%d_i%d"), kinds[kind], kinds[ikind]);
1446             gfor_fndecl_math_powi[kind][ikind].real =
1447               gfc_build_library_function_decl (get_identifier (name),
1448                   type, 2, type, itype);
1449
1450             type = gfc_get_complex_type (kinds[kind]);
1451             sprintf(name, PREFIX("pow_c%d_i%d"), kinds[kind], kinds[ikind]);
1452             gfor_fndecl_math_powi[kind][ikind].cmplx =
1453               gfc_build_library_function_decl (get_identifier (name),
1454                   type, 2, type, itype);
1455           }
1456       }
1457   }
1458
1459   gfor_fndecl_math_cpowf =
1460     gfc_build_library_function_decl (get_identifier ("cpowf"),
1461                                      gfc_complex4_type_node,
1462                                      1, gfc_complex4_type_node);
1463   gfor_fndecl_math_cpow =
1464     gfc_build_library_function_decl (get_identifier ("cpow"),
1465                                      gfc_complex8_type_node,
1466                                      1, gfc_complex8_type_node);
1467   gfor_fndecl_math_cabsf =
1468     gfc_build_library_function_decl (get_identifier ("cabsf"),
1469                                      gfc_real4_type_node,
1470                                      1, gfc_complex4_type_node);
1471   gfor_fndecl_math_cabs =
1472     gfc_build_library_function_decl (get_identifier ("cabs"),
1473                                      gfc_real8_type_node,
1474                                      1, gfc_complex8_type_node);
1475   gfor_fndecl_math_sign4 =
1476     gfc_build_library_function_decl (get_identifier ("copysignf"),
1477                                      gfc_real4_type_node,
1478                                      1, gfc_real4_type_node);
1479   gfor_fndecl_math_sign8 =
1480     gfc_build_library_function_decl (get_identifier ("copysign"),
1481                                      gfc_real8_type_node,
1482                                      1, gfc_real8_type_node);
1483   gfor_fndecl_math_ishftc4 =
1484     gfc_build_library_function_decl (get_identifier (PREFIX("ishftc4")),
1485                                      gfc_int4_type_node,
1486                                      3, gfc_int4_type_node,
1487                                      gfc_int4_type_node, gfc_int4_type_node);
1488   gfor_fndecl_math_ishftc8 =
1489     gfc_build_library_function_decl (get_identifier (PREFIX("ishftc8")),
1490                                      gfc_int8_type_node,
1491                                      3, gfc_int8_type_node,
1492                                      gfc_int8_type_node, gfc_int8_type_node);
1493   gfor_fndecl_math_exponent4 =
1494     gfc_build_library_function_decl (get_identifier (PREFIX("exponent_r4")),
1495                                      gfc_int4_type_node,
1496                                      1, gfc_real4_type_node);
1497   gfor_fndecl_math_exponent8 =
1498     gfc_build_library_function_decl (get_identifier (PREFIX("exponent_r8")),
1499                                      gfc_int4_type_node,
1500                                      1, gfc_real8_type_node);
1501
1502   /* Other functions.  */
1503   gfor_fndecl_size0 =
1504     gfc_build_library_function_decl (get_identifier (PREFIX("size0")),
1505                                      gfc_array_index_type,
1506                                      1, pvoid_type_node);
1507   gfor_fndecl_size1 =
1508     gfc_build_library_function_decl (get_identifier (PREFIX("size1")),
1509                                      gfc_array_index_type,
1510                                      2, pvoid_type_node,
1511                                      gfc_array_index_type);
1512
1513   gfor_fndecl_iargc =
1514     gfc_build_library_function_decl (get_identifier (PREFIX ("iargc")),
1515                                      gfc_int4_type_node,
1516                                      0);
1517 }
1518
1519
1520 /* Make prototypes for runtime library functions.  */
1521
1522 void
1523 gfc_build_builtin_function_decls (void)
1524 {
1525   gfor_fndecl_internal_malloc =
1526     gfc_build_library_function_decl (get_identifier (PREFIX("internal_malloc")),
1527                                      pvoid_type_node, 1, gfc_int4_type_node);
1528
1529   gfor_fndecl_internal_malloc64 =
1530     gfc_build_library_function_decl (get_identifier
1531                                      (PREFIX("internal_malloc64")),
1532                                      pvoid_type_node, 1, gfc_int8_type_node);
1533
1534   gfor_fndecl_internal_free =
1535     gfc_build_library_function_decl (get_identifier (PREFIX("internal_free")),
1536                                      void_type_node, 1, pvoid_type_node);
1537
1538   gfor_fndecl_allocate =
1539     gfc_build_library_function_decl (get_identifier (PREFIX("allocate")),
1540                                      void_type_node, 2, ppvoid_type_node,
1541                                      gfc_int4_type_node);
1542
1543   gfor_fndecl_allocate64 =
1544     gfc_build_library_function_decl (get_identifier (PREFIX("allocate64")),
1545                                      void_type_node, 2, ppvoid_type_node,
1546                                      gfc_int8_type_node);
1547
1548   gfor_fndecl_deallocate =
1549     gfc_build_library_function_decl (get_identifier (PREFIX("deallocate")),
1550                                      void_type_node, 1, ppvoid_type_node);
1551
1552   gfor_fndecl_stop_numeric =
1553     gfc_build_library_function_decl (get_identifier (PREFIX("stop_numeric")),
1554                                      void_type_node, 1, gfc_int4_type_node);
1555
1556   gfor_fndecl_stop_string =
1557     gfc_build_library_function_decl (get_identifier (PREFIX("stop_string")),
1558                                      void_type_node, 2, pchar_type_node,
1559                                      gfc_int4_type_node);
1560
1561   gfor_fndecl_pause_numeric =
1562     gfc_build_library_function_decl (get_identifier (PREFIX("pause_numeric")),
1563                                      void_type_node, 1, gfc_int4_type_node);
1564
1565   gfor_fndecl_pause_string =
1566     gfc_build_library_function_decl (get_identifier (PREFIX("pause_string")),
1567                                      void_type_node, 2, pchar_type_node,
1568                                      gfc_int4_type_node);
1569
1570   gfor_fndecl_select_string =
1571     gfc_build_library_function_decl (get_identifier (PREFIX("select_string")),
1572                                      pvoid_type_node, 0);
1573
1574   gfor_fndecl_runtime_error =
1575     gfc_build_library_function_decl (get_identifier (PREFIX("runtime_error")),
1576                                      void_type_node,
1577                                      3,
1578                                      pchar_type_node, pchar_type_node,
1579                                      gfc_int4_type_node);
1580
1581   gfor_fndecl_in_pack = gfc_build_library_function_decl (
1582         get_identifier (PREFIX("internal_pack")),
1583         pvoid_type_node, 1, pvoid_type_node);
1584
1585   gfor_fndecl_in_unpack = gfc_build_library_function_decl (
1586         get_identifier (PREFIX("internal_unpack")),
1587         pvoid_type_node, 1, pvoid_type_node);
1588
1589   gfor_fndecl_associated =
1590     gfc_build_library_function_decl (
1591                                      get_identifier (PREFIX("associated")),
1592                                      gfc_logical4_type_node,
1593                                      2,
1594                                      ppvoid_type_node,
1595                                      ppvoid_type_node);
1596
1597   gfc_build_intrinsic_function_decls ();
1598   gfc_build_intrinsic_lib_fndecls ();
1599   gfc_build_io_library_fndecls ();
1600 }
1601
1602
1603 /* Exaluate the length of dummy character variables.  */
1604
1605 static tree
1606 gfc_trans_dummy_character (gfc_charlen * cl, tree fnbody)
1607 {
1608   stmtblock_t body;
1609
1610   gfc_finish_decl (cl->backend_decl, NULL_TREE);
1611
1612   gfc_start_block (&body);
1613
1614   /* Evaluate the string length expression.  */
1615   gfc_trans_init_string_length (cl, &body);
1616
1617   gfc_add_expr_to_block (&body, fnbody);
1618   return gfc_finish_block (&body);
1619 }
1620
1621
1622 /* Allocate and cleanup an automatic character variable.  */
1623
1624 static tree
1625 gfc_trans_auto_character_variable (gfc_symbol * sym, tree fnbody)
1626 {
1627   stmtblock_t body;
1628   tree decl;
1629   tree tmp;
1630
1631   assert (sym->backend_decl);
1632   assert (sym->ts.cl && sym->ts.cl->length);
1633
1634   gfc_start_block (&body);
1635
1636   /* Evaluate the string length expression.  */
1637   gfc_trans_init_string_length (sym->ts.cl, &body);
1638
1639   decl = sym->backend_decl;
1640
1641   /* Emit a DECL_EXPR for this variable, which will cause the
1642      gimplifier to allocate stoage, and all that good stuff.  */
1643   tmp = build (DECL_EXPR, TREE_TYPE (decl), decl);
1644   gfc_add_expr_to_block (&body, tmp);
1645
1646   gfc_add_expr_to_block (&body, fnbody);
1647   return gfc_finish_block (&body);
1648 }
1649
1650
1651 /* Generate function entry and exit code, and add it to the function body.
1652    This includes:
1653     Allocation and initialisation of array variables.
1654     Allocation of character string variables.
1655     Initialization and possibly repacking of dummy arrays.  */
1656
1657 static tree
1658 gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
1659 {
1660   locus loc;
1661   gfc_symbol *sym;
1662
1663   /* Deal with implicit return variables.  Explicit return variables will
1664      already have been added.  */
1665   if (gfc_return_by_reference (proc_sym) && proc_sym->result == proc_sym)
1666     {
1667       if (!current_fake_result_decl)
1668         {
1669           warning ("Function does not return a value");
1670           return fnbody;
1671         }
1672
1673       if (proc_sym->as)
1674         {
1675           fnbody = gfc_trans_dummy_array_bias (proc_sym,
1676                                                current_fake_result_decl,
1677                                                fnbody);
1678         }
1679       else if (proc_sym->ts.type == BT_CHARACTER)
1680         {
1681           if (TREE_CODE (proc_sym->ts.cl->backend_decl) == VAR_DECL)
1682             fnbody = gfc_trans_dummy_character (proc_sym->ts.cl, fnbody);
1683         }
1684       else
1685         gfc_todo_error ("Deferred non-array return by reference");
1686     }
1687
1688   for (sym = proc_sym->tlink; sym != proc_sym; sym = sym->tlink)
1689     {
1690       if (sym->attr.dimension)
1691         {
1692           switch (sym->as->type)
1693             {
1694             case AS_EXPLICIT:
1695               if (sym->attr.dummy || sym->attr.result)
1696                 fnbody =
1697                   gfc_trans_dummy_array_bias (sym, sym->backend_decl, fnbody);
1698               else if (sym->attr.pointer || sym->attr.allocatable)
1699                 {
1700                   if (TREE_STATIC (sym->backend_decl))
1701                     gfc_trans_static_array_pointer (sym);
1702                   else
1703                     fnbody = gfc_trans_deferred_array (sym, fnbody);
1704                 }
1705               else
1706                 {
1707                   gfc_get_backend_locus (&loc);
1708                   gfc_set_backend_locus (&sym->declared_at);
1709                   fnbody = gfc_trans_auto_array_allocation (sym->backend_decl,
1710                       sym, fnbody);
1711                   gfc_set_backend_locus (&loc);
1712                 }
1713               break;
1714
1715             case AS_ASSUMED_SIZE:
1716               /* Must be a dummy parameter.  */
1717               assert (sym->attr.dummy);
1718
1719               /* We should always pass assumed size arrays the g77 way.  */
1720               fnbody = gfc_trans_g77_array (sym, fnbody);
1721               break;
1722
1723             case AS_ASSUMED_SHAPE:
1724               /* Must be a dummy parameter.  */
1725               assert (sym->attr.dummy);
1726
1727               fnbody = gfc_trans_dummy_array_bias (sym, sym->backend_decl,
1728                                                    fnbody);
1729               break;
1730
1731             case AS_DEFERRED:
1732               fnbody = gfc_trans_deferred_array (sym, fnbody);
1733               break;
1734
1735             default:
1736               abort ();
1737             }
1738         }
1739       else if (sym->ts.type == BT_CHARACTER)
1740         {
1741           gfc_get_backend_locus (&loc);
1742           gfc_set_backend_locus (&sym->declared_at);
1743           if (sym->attr.dummy || sym->attr.result)
1744             fnbody = gfc_trans_dummy_character (sym->ts.cl, fnbody);
1745           else
1746             fnbody = gfc_trans_auto_character_variable (sym, fnbody);
1747           gfc_set_backend_locus (&loc);
1748         }
1749       else
1750         abort ();
1751     }
1752
1753   return fnbody;
1754 }
1755
1756
1757 /* Output an initialized decl for a module variable.  */
1758
1759 static void
1760 gfc_create_module_variable (gfc_symbol * sym)
1761 {
1762   tree decl;
1763
1764   /* Only output symbols from this module.  */
1765   if (sym->ns != module_namespace)
1766     {
1767       /* I don't think this should ever happen.  */
1768       internal_error ("module symbol %s in wrong namespace", sym->name);
1769     }
1770
1771   /* Only output variables and array valued parametes.  */
1772   if (sym->attr.flavor != FL_VARIABLE
1773       && (sym->attr.flavor != FL_PARAMETER || sym->attr.dimension == 0))
1774     return;
1775
1776   /* Don't generate variables from other modules. Variables from
1777      COMMONs will already have been generated.  */
1778   if (sym->attr.use_assoc || sym->attr.in_common)
1779     return;
1780
1781   if (sym->backend_decl)
1782     internal_error ("backend decl for module variable %s already exists",
1783                     sym->name);
1784
1785   /* We always want module variables to be created.  */
1786   sym->attr.referenced = 1;
1787   /* Create the decl.  */
1788   decl = gfc_get_symbol_decl (sym);
1789
1790   /* Create the variable.  */
1791   pushdecl (decl);
1792   rest_of_decl_compilation (decl, 1, 0);
1793
1794   /* Also add length of strings.  */
1795   if (sym->ts.type == BT_CHARACTER)
1796     {
1797       tree length;
1798
1799       length = sym->ts.cl->backend_decl;
1800       if (!INTEGER_CST_P (length))
1801         {
1802           pushdecl (length);
1803           rest_of_decl_compilation (length, 1, 0);
1804         }
1805     }
1806 }
1807
1808
1809 /* Generate all the required code for module variables.  */
1810
1811 void
1812 gfc_generate_module_vars (gfc_namespace * ns)
1813 {
1814   module_namespace = ns;
1815
1816   /* Check if the frontend left the namespace in a reasonable state.  */
1817   assert (ns->proc_name && !ns->proc_name->tlink);
1818
1819   /* Generate COMMON blocks.  */
1820   gfc_trans_common (ns);
1821
1822   /* Create decls for all the module variables.  */
1823   gfc_traverse_ns (ns, gfc_create_module_variable);
1824 }
1825
1826 static void
1827 gfc_generate_contained_functions (gfc_namespace * parent)
1828 {
1829   gfc_namespace *ns;
1830
1831   /* We create all the prototypes before generating any code.  */
1832   for (ns = parent->contained; ns; ns = ns->sibling)
1833     {
1834       /* Skip namespaces from used modules.  */
1835       if (ns->parent != parent)
1836         continue;
1837
1838       gfc_build_function_decl (ns->proc_name);
1839     }
1840
1841   for (ns = parent->contained; ns; ns = ns->sibling)
1842     {
1843       /* Skip namespaces from used modules.  */
1844       if (ns->parent != parent)
1845         continue;
1846
1847       gfc_generate_function_code (ns);
1848     }
1849 }
1850
1851
1852 /* Generate decls for all local variables.  We do this to ensure correct
1853    handling of expressions which only appear in the specification of
1854    other functions.  */
1855
1856 static void
1857 generate_local_decl (gfc_symbol * sym)
1858 {
1859   if (sym->attr.flavor == FL_VARIABLE)
1860     {
1861       if (sym->attr.referenced)
1862         gfc_get_symbol_decl (sym);
1863       else if (sym->attr.dummy)
1864         {
1865           if (warn_unused_parameter)
1866             warning ("unused parameter `%s'", sym->name);
1867         }
1868       /* warn for unused variables, but not if they're inside a common
1869          block or are use_associated.  */
1870       else if (warn_unused_variable
1871                && !(sym->attr.in_common || sym->attr.use_assoc))
1872         warning ("unused variable `%s'", sym->name);
1873     }
1874 }
1875
1876 static void
1877 generate_local_vars (gfc_namespace * ns)
1878 {
1879   gfc_traverse_ns (ns, generate_local_decl);
1880 }
1881
1882
1883 /* Finalize DECL and all nested functions with cgraph.  */
1884
1885 static void
1886 gfc_finalize (tree decl)
1887 {
1888   struct cgraph_node *cgn;
1889
1890   cgn = cgraph_node (decl);
1891   for (cgn = cgn->nested; cgn ; cgn = cgn->next_nested)
1892     gfc_finalize (cgn->decl);
1893
1894   cgraph_finalize_function (decl, false);
1895 }
1896
1897 /* Convert FNDECL's code to GIMPLE and handle any nested functions.  */
1898
1899 static void
1900 gfc_gimplify_function (tree fndecl)
1901 {
1902   struct cgraph_node *cgn;
1903
1904   gimplify_function_tree (fndecl);
1905   dump_function (TDI_generic, fndecl);
1906
1907   /* Convert all nested functions to GIMPLE now.  We do things in this order
1908      so that items like VLA sizes are expanded properly in the context of the
1909      correct function.  */
1910   cgn = cgraph_node (fndecl);
1911   for (cgn = cgn->nested; cgn; cgn = cgn->next_nested)
1912     gfc_gimplify_function (cgn->decl);
1913 }
1914
1915 /* Generate code for a function.  */
1916
1917 void
1918 gfc_generate_function_code (gfc_namespace * ns)
1919 {
1920   tree fndecl;
1921   tree old_context;
1922   tree decl;
1923   tree tmp;
1924   stmtblock_t block;
1925   stmtblock_t body;
1926   tree result;
1927   gfc_symbol *sym;
1928
1929   sym = ns->proc_name;
1930   /* Check that the frontend isn't still using this.  */
1931   assert (sym->tlink == NULL);
1932
1933   sym->tlink = sym;
1934
1935   /* Create the declaration for functions with global scope.  */
1936   if (!sym->backend_decl)
1937     gfc_build_function_decl (ns->proc_name);
1938
1939   fndecl = sym->backend_decl;
1940   old_context = current_function_decl;
1941
1942   if (old_context)
1943     {
1944       push_function_context ();
1945       saved_parent_function_decls = saved_function_decls;
1946       saved_function_decls = NULL_TREE;
1947     }
1948
1949   /* let GCC know the current scope is this function */
1950   current_function_decl = fndecl;
1951
1952   /* print function name on the console at compile time
1953      (unless this feature was switched of by command line option "-quiet" */
1954   announce_function (fndecl);
1955
1956   if (DECL_CONTEXT (fndecl) == NULL_TREE)
1957     {
1958       /* create RTL for function declaration */
1959       rest_of_decl_compilation (fndecl, 1, 0);
1960     }
1961
1962   /* create RTL for function definition */
1963   make_decl_rtl (fndecl);
1964
1965   /* Set the line and filename.  sym->decalred_at seems to point to the last
1966      statement for subroutines, but it'll do for now.  */
1967   gfc_set_backend_locus (&sym->declared_at);
1968
1969   /* line and file should not be 0 */
1970   init_function_start (fndecl);
1971
1972   /* Even though we're inside a function body, we still don't want to
1973      call expand_expr to calculate the size of a variable-sized array.
1974      We haven't necessarily assigned RTL to all variables yet, so it's
1975      not safe to try to expand expressions involving them.  */
1976   cfun->x_dont_save_pending_sizes_p = 1;
1977
1978   /* Will be created as needed.  */
1979   current_fake_result_decl = NULL_TREE;
1980
1981   /* function.c requires a push at the start of the function */
1982   pushlevel (0);
1983
1984   gfc_start_block (&block);
1985
1986   gfc_generate_contained_functions (ns);
1987
1988   /* Translate COMMON blocks.  */
1989   gfc_trans_common (ns);
1990
1991   generate_local_vars (ns);
1992
1993   current_function_return_label = NULL;
1994
1995   /* Now generate the code for the body of this function.  */
1996   gfc_init_block (&body);
1997
1998   if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node
1999       && sym->attr.subroutine)
2000     {
2001       tree alternate_return;
2002       alternate_return = gfc_get_fake_result_decl (sym);
2003       gfc_add_modify_expr (&body, alternate_return, integer_zero_node);
2004     }
2005
2006   tmp = gfc_trans_code (ns->code);
2007   gfc_add_expr_to_block (&body, tmp);
2008
2009   /* Add a return label if needed.  */
2010   if (current_function_return_label)
2011     {
2012       tmp = build1_v (LABEL_EXPR, current_function_return_label);
2013       gfc_add_expr_to_block (&body, tmp);
2014     }
2015
2016   tmp = gfc_finish_block (&body);
2017   /* Add code to create and cleanup arrays.  */
2018   tmp = gfc_trans_deferred_vars (sym, tmp);
2019   gfc_add_expr_to_block (&block, tmp);
2020
2021   if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node)
2022     {
2023       if (sym->attr.subroutine ||sym == sym->result)
2024         {
2025           result = current_fake_result_decl;
2026           current_fake_result_decl = NULL_TREE;
2027         }
2028       else
2029         result = sym->result->backend_decl;
2030
2031       if (result == NULL_TREE)
2032         warning ("Function return value not set");
2033       else
2034         {
2035           /* Set the return value to the the dummy result variable.  */
2036           tmp = build (MODIFY_EXPR, TREE_TYPE (result),
2037                        DECL_RESULT (fndecl), result);
2038           tmp = build_v (RETURN_EXPR, tmp);
2039           gfc_add_expr_to_block (&block, tmp);
2040         }
2041     }
2042
2043   /* Add all the decls we created during processing.  */
2044   decl = saved_function_decls;
2045   while (decl)
2046     {
2047       tree next;
2048
2049       next = TREE_CHAIN (decl);
2050       TREE_CHAIN (decl) = NULL_TREE;
2051       pushdecl (decl);
2052       decl = next;
2053     }
2054   saved_function_decls = NULL_TREE;
2055
2056   DECL_SAVED_TREE (fndecl) = gfc_finish_block (&block);
2057
2058   /* Finish off this function and send it for code generation.  */
2059   poplevel (1, 0, 1);
2060   BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
2061
2062   /* Output the GENERIC tree.  */
2063   dump_function (TDI_original, fndecl);
2064
2065   /* Store the end of the function, so that we get good line number
2066      info for the epilogue.  */
2067   cfun->function_end_locus = input_location;
2068
2069   /* We're leaving the context of this function, so zap cfun.
2070      It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
2071      tree_rest_of_compilation.  */
2072   cfun = NULL;
2073
2074   if (old_context)
2075     {
2076       pop_function_context ();
2077       saved_function_decls = saved_parent_function_decls;
2078     }
2079   current_function_decl = old_context;
2080
2081   if (decl_function_context (fndecl))
2082     /* Register this function with cgraph just far enough to get it
2083        added to our parent's nested function list.  */
2084     (void) cgraph_node (fndecl);
2085   else
2086     {
2087       gfc_gimplify_function (fndecl);
2088       lower_nested_functions (fndecl);
2089       gfc_finalize (fndecl);
2090     }
2091 }
2092
2093 void
2094 gfc_generate_constructors (void)
2095 {
2096   if (gfc_static_ctors != NULL_TREE)
2097     abort ();
2098 #if 0
2099   tree fnname;
2100   tree type;
2101   tree fndecl;
2102   tree decl;
2103   tree tmp;
2104
2105   if (gfc_static_ctors == NULL_TREE)
2106     return;
2107
2108   fnname = get_file_function_name ('I');
2109   type = build_function_type (void_type_node,
2110                               gfc_chainon_list (NULL_TREE, void_type_node));
2111
2112   fndecl = build_decl (FUNCTION_DECL, fnname, type);
2113   TREE_PUBLIC (fndecl) = 1;
2114
2115   decl = build_decl (RESULT_DECL, NULL_TREE, void_type_node);
2116   DECL_ARTIFICIAL (decl) = 1;
2117   DECL_IGNORED_P (decl) = 1;
2118   DECL_CONTEXT (decl) = fndecl;
2119   DECL_RESULT (fndecl) = decl;
2120
2121   pushdecl (fndecl);
2122
2123   current_function_decl = fndecl;
2124
2125   rest_of_decl_compilation (fndecl, 1, 0);
2126
2127   make_decl_rtl (fndecl);
2128
2129   init_function_start (fndecl, input_filename, input_line);
2130
2131   pushlevel (0);
2132
2133   for (; gfc_static_ctors; gfc_static_ctors = TREE_CHAIN (gfc_static_ctors))
2134     {
2135       tmp =
2136         gfc_build_function_call (TREE_VALUE (gfc_static_ctors), NULL_TREE);
2137       DECL_SAVED_TREE (fndecl) = build_stmt (EXPR_STMT, tmp);
2138     }
2139
2140   poplevel (1, 0, 1);
2141
2142   BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
2143
2144   free_after_parsing (cfun);
2145   free_after_compilation (cfun);
2146
2147   tree_rest_of_compilation (fndecl, 0);
2148
2149   current_function_decl = NULL_TREE;
2150 #endif
2151 }
2152
2153 #include "gt-fortran-trans-decl.h"