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