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