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