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