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_function_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 /* 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   init_function_start (fndecl);
1302
1303   /* Even though we're inside a function body, we still don't want to
1304      call expand_expr to calculate the size of a variable-sized array.
1305      We haven't necessarily assigned RTL to all variables yet, so it's
1306      not safe to try to expand expressions involving them.  */
1307   cfun->x_dont_save_pending_sizes_p = 1;
1308
1309   /* function.c requires a push at the start of the function.  */
1310   pushlevel (0);
1311 }
1312
1313 /* Create thunks for alternate entry points.  */
1314
1315 static void
1316 build_entry_thunks (gfc_namespace * ns)
1317 {
1318   gfc_formal_arglist *formal;
1319   gfc_formal_arglist *thunk_formal;
1320   gfc_entry_list *el;
1321   gfc_symbol *thunk_sym;
1322   stmtblock_t body;
1323   tree thunk_fndecl;
1324   tree args;
1325   tree string_args;
1326   tree tmp;
1327   locus old_loc;
1328
1329   /* This should always be a toplevel function.  */
1330   gcc_assert (current_function_decl == NULL_TREE);
1331
1332   gfc_get_backend_locus (&old_loc);
1333   for (el = ns->entries; el; el = el->next)
1334     {
1335       thunk_sym = el->sym;
1336
1337       build_function_decl (thunk_sym);
1338       create_function_arglist (thunk_sym);
1339
1340       trans_function_start (thunk_sym);
1341
1342       thunk_fndecl = thunk_sym->backend_decl;
1343
1344       gfc_start_block (&body);
1345
1346       /* Pass extra parameter identifying this entry point.  */
1347       tmp = build_int_cst (gfc_array_index_type, el->id);
1348       args = tree_cons (NULL_TREE, tmp, NULL_TREE);
1349       string_args = NULL_TREE;
1350
1351       /* TODO: Pass return by reference parameters.  */
1352       if (ns->proc_name->attr.function)
1353         gfc_todo_error ("Functons with multiple entry points");
1354
1355       for (formal = ns->proc_name->formal; formal; formal = formal->next)
1356         {
1357           /* We don't have a clever way of identifying arguments, so resort to
1358              a brute-force search.  */
1359           for (thunk_formal = thunk_sym->formal;
1360                thunk_formal;
1361                thunk_formal = thunk_formal->next)
1362             {
1363               if (thunk_formal->sym == formal->sym)
1364                 break;
1365             }
1366
1367           if (thunk_formal)
1368             {
1369               /* Pass the argument.  */
1370               args = tree_cons (NULL_TREE, thunk_formal->sym->backend_decl,
1371                                 args);
1372               if (formal->sym->ts.type == BT_CHARACTER)
1373                 {
1374                   tmp = thunk_formal->sym->ts.cl->backend_decl;
1375                   string_args = tree_cons (NULL_TREE, tmp, string_args);
1376                 }
1377             }
1378           else
1379             {
1380               /* Pass NULL for a missing argument.  */
1381               args = tree_cons (NULL_TREE, null_pointer_node, args);
1382               if (formal->sym->ts.type == BT_CHARACTER)
1383                 {
1384                   tmp = convert (gfc_charlen_type_node, integer_zero_node);
1385                   string_args = tree_cons (NULL_TREE, tmp, string_args);
1386                 }
1387             }
1388         }
1389
1390       /* Call the master function.  */
1391       args = nreverse (args);
1392       args = chainon (args, nreverse (string_args));
1393       tmp = ns->proc_name->backend_decl;
1394       tmp = gfc_build_function_call (tmp, args);
1395       /* TODO: function return value.  */
1396       gfc_add_expr_to_block (&body, tmp);
1397
1398       /* Finish off this function and send it for code generation.  */
1399       DECL_SAVED_TREE (thunk_fndecl) = gfc_finish_block (&body);
1400       poplevel (1, 0, 1);
1401       BLOCK_SUPERCONTEXT (DECL_INITIAL (thunk_fndecl)) = thunk_fndecl;
1402
1403       /* Output the GENERIC tree.  */
1404       dump_function (TDI_original, thunk_fndecl);
1405
1406       /* Store the end of the function, so that we get good line number
1407          info for the epilogue.  */
1408       cfun->function_end_locus = input_location;
1409
1410       /* We're leaving the context of this function, so zap cfun.
1411          It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
1412          tree_rest_of_compilation.  */
1413       cfun = NULL;
1414
1415       current_function_decl = NULL_TREE;
1416
1417       gfc_gimplify_function (thunk_fndecl);
1418       cgraph_finalize_function (thunk_fndecl, false);
1419
1420       /* We share the symbols in the formal argument list with other entry
1421          points and the master function.  Clear them so that they are
1422          recreated for each function.  */
1423       for (formal = thunk_sym->formal; formal; formal = formal->next)
1424         {
1425           formal->sym->backend_decl = NULL_TREE;
1426           if (formal->sym->ts.type == BT_CHARACTER)
1427             formal->sym->ts.cl->backend_decl = NULL_TREE;
1428         }
1429     }
1430
1431   gfc_set_backend_locus (&old_loc);
1432 }
1433
1434
1435 /* Create a decl for a function, and create any thunks for alternate entry
1436    points.  */
1437
1438 void
1439 gfc_create_function_decl (gfc_namespace * ns)
1440 {
1441   /* Create a declaration for the master function.  */
1442   build_function_decl (ns->proc_name);
1443
1444   /* Compile the entry thunks.  */
1445   if (ns->entries)
1446     build_entry_thunks (ns);
1447
1448   /* Now create the read argument list.  */
1449   create_function_arglist (ns->proc_name);
1450 }
1451
1452 /* Return the decl used to hold the function return value.  */
1453
1454 tree
1455 gfc_get_fake_result_decl (gfc_symbol * sym)
1456 {
1457   tree decl;
1458   tree length;
1459
1460   char name[GFC_MAX_SYMBOL_LEN + 10];
1461
1462   if (current_fake_result_decl != NULL_TREE)
1463     return current_fake_result_decl;
1464
1465   /* Only when gfc_get_fake_result_decl is called by gfc_trans_return,
1466      sym is NULL.  */
1467   if (!sym)
1468     return NULL_TREE;
1469
1470   if (sym->ts.type == BT_CHARACTER
1471       && !sym->ts.cl->backend_decl)
1472     {
1473       length = gfc_create_string_length (sym);
1474       gfc_finish_var_decl (length, sym);
1475     }
1476
1477   if (gfc_return_by_reference (sym))
1478     {
1479       decl = DECL_ARGUMENTS (sym->backend_decl);
1480
1481       TREE_USED (decl) = 1;
1482       if (sym->as)
1483         decl = gfc_build_dummy_array_decl (sym, decl);
1484     }
1485   else
1486     {
1487       sprintf (name, "__result_%.20s",
1488                IDENTIFIER_POINTER (DECL_NAME (current_function_decl)));
1489
1490       decl = build_decl (VAR_DECL, get_identifier (name),
1491                          TREE_TYPE (TREE_TYPE (current_function_decl)));
1492
1493       DECL_ARTIFICIAL (decl) = 1;
1494       DECL_EXTERNAL (decl) = 0;
1495       TREE_PUBLIC (decl) = 0;
1496       TREE_USED (decl) = 1;
1497
1498       layout_decl (decl, 0);
1499
1500       gfc_add_decl_to_function (decl);
1501     }
1502
1503   current_fake_result_decl = decl;
1504
1505   return decl;
1506 }
1507
1508
1509 /* Builds a function decl.  The remaining parameters are the types of the
1510    function arguments.  Negative nargs indicates a varargs function.  */
1511
1512 tree
1513 gfc_build_library_function_decl (tree name, tree rettype, int nargs, ...)
1514 {
1515   tree arglist;
1516   tree argtype;
1517   tree fntype;
1518   tree fndecl;
1519   va_list p;
1520   int n;
1521
1522   /* Library functions must be declared with global scope.  */
1523   gcc_assert (current_function_decl == NULL_TREE);
1524
1525   va_start (p, nargs);
1526
1527
1528   /* Create a list of the argument types.  */
1529   for (arglist = NULL_TREE, n = abs (nargs); n > 0; n--)
1530     {
1531       argtype = va_arg (p, tree);
1532       arglist = gfc_chainon_list (arglist, argtype);
1533     }
1534
1535   if (nargs >= 0)
1536     {
1537       /* Terminate the list.  */
1538       arglist = gfc_chainon_list (arglist, void_type_node);
1539     }
1540
1541   /* Build the function type and decl.  */
1542   fntype = build_function_type (rettype, arglist);
1543   fndecl = build_decl (FUNCTION_DECL, name, fntype);
1544
1545   /* Mark this decl as external.  */
1546   DECL_EXTERNAL (fndecl) = 1;
1547   TREE_PUBLIC (fndecl) = 1;
1548
1549   va_end (p);
1550
1551   pushdecl (fndecl);
1552
1553   rest_of_decl_compilation (fndecl, 1, 0);
1554
1555   return fndecl;
1556 }
1557
1558 static void
1559 gfc_build_intrinsic_function_decls (void)
1560 {
1561   tree gfc_int4_type_node = gfc_get_int_type (4);
1562   tree gfc_int8_type_node = gfc_get_int_type (8);
1563   tree gfc_logical4_type_node = gfc_get_logical_type (4);
1564   tree gfc_real4_type_node = gfc_get_real_type (4);
1565   tree gfc_real8_type_node = gfc_get_real_type (8);
1566   tree gfc_complex4_type_node = gfc_get_complex_type (4);
1567   tree gfc_complex8_type_node = gfc_get_complex_type (8);
1568
1569   /* String functions.  */
1570   gfor_fndecl_copy_string =
1571     gfc_build_library_function_decl (get_identifier (PREFIX("copy_string")),
1572                                      void_type_node,
1573                                      4,
1574                                      gfc_charlen_type_node, pchar_type_node,
1575                                      gfc_charlen_type_node, pchar_type_node);
1576
1577   gfor_fndecl_compare_string =
1578     gfc_build_library_function_decl (get_identifier (PREFIX("compare_string")),
1579                                      gfc_int4_type_node,
1580                                      4,
1581                                      gfc_charlen_type_node, pchar_type_node,
1582                                      gfc_charlen_type_node, pchar_type_node);
1583
1584   gfor_fndecl_concat_string =
1585     gfc_build_library_function_decl (get_identifier (PREFIX("concat_string")),
1586                                      void_type_node,
1587                                      6,
1588                                      gfc_charlen_type_node, pchar_type_node,
1589                                      gfc_charlen_type_node, pchar_type_node,
1590                                      gfc_charlen_type_node, pchar_type_node);
1591
1592   gfor_fndecl_string_len_trim =
1593     gfc_build_library_function_decl (get_identifier (PREFIX("string_len_trim")),
1594                                      gfc_int4_type_node,
1595                                      2, gfc_charlen_type_node,
1596                                      pchar_type_node);
1597
1598   gfor_fndecl_string_index =
1599     gfc_build_library_function_decl (get_identifier (PREFIX("string_index")),
1600                                      gfc_int4_type_node,
1601                                      5, gfc_charlen_type_node, pchar_type_node,
1602                                      gfc_charlen_type_node, pchar_type_node,
1603                                      gfc_logical4_type_node);
1604
1605   gfor_fndecl_string_scan =
1606     gfc_build_library_function_decl (get_identifier (PREFIX("string_scan")),
1607                                      gfc_int4_type_node,
1608                                      5, gfc_charlen_type_node, pchar_type_node,
1609                                      gfc_charlen_type_node, pchar_type_node,
1610                                      gfc_logical4_type_node);
1611
1612   gfor_fndecl_string_verify =
1613     gfc_build_library_function_decl (get_identifier (PREFIX("string_verify")),
1614                                      gfc_int4_type_node,
1615                                      5, gfc_charlen_type_node, pchar_type_node,
1616                                      gfc_charlen_type_node, pchar_type_node,
1617                                      gfc_logical4_type_node);
1618
1619   gfor_fndecl_string_trim =
1620     gfc_build_library_function_decl (get_identifier (PREFIX("string_trim")),
1621                                      void_type_node,
1622                                      4,
1623                                      build_pointer_type (gfc_charlen_type_node),
1624                                      ppvoid_type_node,
1625                                      gfc_charlen_type_node,
1626                                      pchar_type_node);
1627
1628   gfor_fndecl_string_repeat =
1629     gfc_build_library_function_decl (get_identifier (PREFIX("string_repeat")),
1630                                      void_type_node,
1631                                      4,
1632                                      pchar_type_node,
1633                                      gfc_charlen_type_node,
1634                                      pchar_type_node,
1635                                      gfc_int4_type_node);
1636
1637   gfor_fndecl_adjustl =
1638     gfc_build_library_function_decl (get_identifier (PREFIX("adjustl")),
1639                                      void_type_node,
1640                                      3,
1641                                      pchar_type_node,
1642                                      gfc_charlen_type_node, pchar_type_node);
1643
1644   gfor_fndecl_adjustr =
1645     gfc_build_library_function_decl (get_identifier (PREFIX("adjustr")),
1646                                      void_type_node,
1647                                      3,
1648                                      pchar_type_node,
1649                                      gfc_charlen_type_node, pchar_type_node);
1650
1651   gfor_fndecl_si_kind =
1652     gfc_build_library_function_decl (get_identifier ("selected_int_kind"),
1653                                      gfc_int4_type_node,
1654                                      1,
1655                                      pvoid_type_node);
1656
1657   gfor_fndecl_sr_kind =
1658     gfc_build_library_function_decl (get_identifier ("selected_real_kind"),
1659                                      gfc_int4_type_node,
1660                                      2, pvoid_type_node,
1661                                      pvoid_type_node);
1662
1663   /* Power functions.  */
1664   {
1665     tree type;
1666     tree itype;
1667     int kind;
1668     int ikind;
1669     static int kinds[2] = {4, 8};
1670     char name[PREFIX_LEN + 10]; /* _gfortran_pow_?n_?n */
1671
1672     for (ikind=0; ikind < 2; ikind++)
1673       {
1674         itype = gfc_get_int_type (kinds[ikind]);
1675         for (kind = 0; kind < 2; kind ++)
1676           {
1677             type = gfc_get_int_type (kinds[kind]);
1678             sprintf(name, PREFIX("pow_i%d_i%d"), kinds[kind], kinds[ikind]);
1679             gfor_fndecl_math_powi[kind][ikind].integer =
1680               gfc_build_library_function_decl (get_identifier (name),
1681                   type, 2, type, itype);
1682
1683             type = gfc_get_real_type (kinds[kind]);
1684             sprintf(name, PREFIX("pow_r%d_i%d"), kinds[kind], kinds[ikind]);
1685             gfor_fndecl_math_powi[kind][ikind].real =
1686               gfc_build_library_function_decl (get_identifier (name),
1687                   type, 2, type, itype);
1688
1689             type = gfc_get_complex_type (kinds[kind]);
1690             sprintf(name, PREFIX("pow_c%d_i%d"), kinds[kind], kinds[ikind]);
1691             gfor_fndecl_math_powi[kind][ikind].cmplx =
1692               gfc_build_library_function_decl (get_identifier (name),
1693                   type, 2, type, itype);
1694           }
1695       }
1696   }
1697
1698   gfor_fndecl_math_cpowf =
1699     gfc_build_library_function_decl (get_identifier ("cpowf"),
1700                                      gfc_complex4_type_node,
1701                                      1, gfc_complex4_type_node);
1702   gfor_fndecl_math_cpow =
1703     gfc_build_library_function_decl (get_identifier ("cpow"),
1704                                      gfc_complex8_type_node,
1705                                      1, gfc_complex8_type_node);
1706   gfor_fndecl_math_ishftc4 =
1707     gfc_build_library_function_decl (get_identifier (PREFIX("ishftc4")),
1708                                      gfc_int4_type_node,
1709                                      3, gfc_int4_type_node,
1710                                      gfc_int4_type_node, gfc_int4_type_node);
1711   gfor_fndecl_math_ishftc8 =
1712     gfc_build_library_function_decl (get_identifier (PREFIX("ishftc8")),
1713                                      gfc_int8_type_node,
1714                                      3, gfc_int8_type_node,
1715                                      gfc_int8_type_node, gfc_int8_type_node);
1716   gfor_fndecl_math_exponent4 =
1717     gfc_build_library_function_decl (get_identifier (PREFIX("exponent_r4")),
1718                                      gfc_int4_type_node,
1719                                      1, gfc_real4_type_node);
1720   gfor_fndecl_math_exponent8 =
1721     gfc_build_library_function_decl (get_identifier (PREFIX("exponent_r8")),
1722                                      gfc_int4_type_node,
1723                                      1, gfc_real8_type_node);
1724
1725   /* Other functions.  */
1726   gfor_fndecl_size0 =
1727     gfc_build_library_function_decl (get_identifier (PREFIX("size0")),
1728                                      gfc_array_index_type,
1729                                      1, pvoid_type_node);
1730   gfor_fndecl_size1 =
1731     gfc_build_library_function_decl (get_identifier (PREFIX("size1")),
1732                                      gfc_array_index_type,
1733                                      2, pvoid_type_node,
1734                                      gfc_array_index_type);
1735
1736   gfor_fndecl_iargc =
1737     gfc_build_library_function_decl (get_identifier (PREFIX ("iargc")),
1738                                      gfc_int4_type_node,
1739                                      0);
1740 }
1741
1742
1743 /* Make prototypes for runtime library functions.  */
1744
1745 void
1746 gfc_build_builtin_function_decls (void)
1747 {
1748   tree gfc_int4_type_node = gfc_get_int_type (4);
1749   tree gfc_int8_type_node = gfc_get_int_type (8);
1750   tree gfc_logical4_type_node = gfc_get_logical_type (4);
1751
1752   gfor_fndecl_internal_malloc =
1753     gfc_build_library_function_decl (get_identifier (PREFIX("internal_malloc")),
1754                                      pvoid_type_node, 1, gfc_int4_type_node);
1755
1756   gfor_fndecl_internal_malloc64 =
1757     gfc_build_library_function_decl (get_identifier
1758                                      (PREFIX("internal_malloc64")),
1759                                      pvoid_type_node, 1, gfc_int8_type_node);
1760
1761   gfor_fndecl_internal_free =
1762     gfc_build_library_function_decl (get_identifier (PREFIX("internal_free")),
1763                                      void_type_node, 1, pvoid_type_node);
1764
1765   gfor_fndecl_allocate =
1766     gfc_build_library_function_decl (get_identifier (PREFIX("allocate")),
1767                                      void_type_node, 2, ppvoid_type_node,
1768                                      gfc_int4_type_node);
1769
1770   gfor_fndecl_allocate64 =
1771     gfc_build_library_function_decl (get_identifier (PREFIX("allocate64")),
1772                                      void_type_node, 2, ppvoid_type_node,
1773                                      gfc_int8_type_node);
1774
1775   gfor_fndecl_deallocate =
1776     gfc_build_library_function_decl (get_identifier (PREFIX("deallocate")),
1777                                      void_type_node, 1, ppvoid_type_node);
1778
1779   gfor_fndecl_stop_numeric =
1780     gfc_build_library_function_decl (get_identifier (PREFIX("stop_numeric")),
1781                                      void_type_node, 1, gfc_int4_type_node);
1782
1783   gfor_fndecl_stop_string =
1784     gfc_build_library_function_decl (get_identifier (PREFIX("stop_string")),
1785                                      void_type_node, 2, pchar_type_node,
1786                                      gfc_int4_type_node);
1787
1788   gfor_fndecl_pause_numeric =
1789     gfc_build_library_function_decl (get_identifier (PREFIX("pause_numeric")),
1790                                      void_type_node, 1, gfc_int4_type_node);
1791
1792   gfor_fndecl_pause_string =
1793     gfc_build_library_function_decl (get_identifier (PREFIX("pause_string")),
1794                                      void_type_node, 2, pchar_type_node,
1795                                      gfc_int4_type_node);
1796
1797   gfor_fndecl_select_string =
1798     gfc_build_library_function_decl (get_identifier (PREFIX("select_string")),
1799                                      pvoid_type_node, 0);
1800
1801   gfor_fndecl_runtime_error =
1802     gfc_build_library_function_decl (get_identifier (PREFIX("runtime_error")),
1803                                      void_type_node,
1804                                      3,
1805                                      pchar_type_node, pchar_type_node,
1806                                      gfc_int4_type_node);
1807
1808   gfor_fndecl_in_pack = gfc_build_library_function_decl (
1809         get_identifier (PREFIX("internal_pack")),
1810         pvoid_type_node, 1, pvoid_type_node);
1811
1812   gfor_fndecl_in_unpack = gfc_build_library_function_decl (
1813         get_identifier (PREFIX("internal_unpack")),
1814         pvoid_type_node, 1, pvoid_type_node);
1815
1816   gfor_fndecl_associated =
1817     gfc_build_library_function_decl (
1818                                      get_identifier (PREFIX("associated")),
1819                                      gfc_logical4_type_node,
1820                                      2,
1821                                      ppvoid_type_node,
1822                                      ppvoid_type_node);
1823
1824   gfc_build_intrinsic_function_decls ();
1825   gfc_build_intrinsic_lib_fndecls ();
1826   gfc_build_io_library_fndecls ();
1827 }
1828
1829
1830 /* Evaluate the length of dummy character variables.  */
1831
1832 static tree
1833 gfc_trans_dummy_character (gfc_charlen * cl, tree fnbody)
1834 {
1835   stmtblock_t body;
1836
1837   gfc_finish_decl (cl->backend_decl, NULL_TREE);
1838
1839   gfc_start_block (&body);
1840
1841   /* Evaluate the string length expression.  */
1842   gfc_trans_init_string_length (cl, &body);
1843
1844   gfc_add_expr_to_block (&body, fnbody);
1845   return gfc_finish_block (&body);
1846 }
1847
1848
1849 /* Allocate and cleanup an automatic character variable.  */
1850
1851 static tree
1852 gfc_trans_auto_character_variable (gfc_symbol * sym, tree fnbody)
1853 {
1854   stmtblock_t body;
1855   tree decl;
1856   tree tmp;
1857
1858   gcc_assert (sym->backend_decl);
1859   gcc_assert (sym->ts.cl && sym->ts.cl->length);
1860
1861   gfc_start_block (&body);
1862
1863   /* Evaluate the string length expression.  */
1864   gfc_trans_init_string_length (sym->ts.cl, &body);
1865
1866   decl = sym->backend_decl;
1867
1868   /* Emit a DECL_EXPR for this variable, which will cause the
1869      gimplifier to allocate storage, and all that good stuff.  */
1870   tmp = build1 (DECL_EXPR, TREE_TYPE (decl), decl);
1871   gfc_add_expr_to_block (&body, tmp);
1872
1873   gfc_add_expr_to_block (&body, fnbody);
1874   return gfc_finish_block (&body);
1875 }
1876
1877
1878 /* Generate function entry and exit code, and add it to the function body.
1879    This includes:
1880     Allocation and initialization of array variables.
1881     Allocation of character string variables.
1882     Initialization and possibly repacking of dummy arrays.  */
1883
1884 static tree
1885 gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
1886 {
1887   locus loc;
1888   gfc_symbol *sym;
1889
1890   /* Deal with implicit return variables.  Explicit return variables will
1891      already have been added.  */
1892   if (gfc_return_by_reference (proc_sym) && proc_sym->result == proc_sym)
1893     {
1894       if (!current_fake_result_decl)
1895         {
1896           warning ("Function does not return a value");
1897           return fnbody;
1898         }
1899
1900       if (proc_sym->as)
1901         {
1902           fnbody = gfc_trans_dummy_array_bias (proc_sym,
1903                                                current_fake_result_decl,
1904                                                fnbody);
1905         }
1906       else if (proc_sym->ts.type == BT_CHARACTER)
1907         {
1908           if (TREE_CODE (proc_sym->ts.cl->backend_decl) == VAR_DECL)
1909             fnbody = gfc_trans_dummy_character (proc_sym->ts.cl, fnbody);
1910         }
1911       else
1912         gfc_todo_error ("Deferred non-array return by reference");
1913     }
1914
1915   for (sym = proc_sym->tlink; sym != proc_sym; sym = sym->tlink)
1916     {
1917       if (sym->attr.dimension)
1918         {
1919           switch (sym->as->type)
1920             {
1921             case AS_EXPLICIT:
1922               if (sym->attr.dummy || sym->attr.result)
1923                 fnbody =
1924                   gfc_trans_dummy_array_bias (sym, sym->backend_decl, fnbody);
1925               else if (sym->attr.pointer || sym->attr.allocatable)
1926                 {
1927                   if (TREE_STATIC (sym->backend_decl))
1928                     gfc_trans_static_array_pointer (sym);
1929                   else
1930                     fnbody = gfc_trans_deferred_array (sym, fnbody);
1931                 }
1932               else
1933                 {
1934                   gfc_get_backend_locus (&loc);
1935                   gfc_set_backend_locus (&sym->declared_at);
1936                   fnbody = gfc_trans_auto_array_allocation (sym->backend_decl,
1937                       sym, fnbody);
1938                   gfc_set_backend_locus (&loc);
1939                 }
1940               break;
1941
1942             case AS_ASSUMED_SIZE:
1943               /* Must be a dummy parameter.  */
1944               gcc_assert (sym->attr.dummy);
1945
1946               /* We should always pass assumed size arrays the g77 way.  */
1947               fnbody = gfc_trans_g77_array (sym, fnbody);
1948               break;
1949
1950             case AS_ASSUMED_SHAPE:
1951               /* Must be a dummy parameter.  */
1952               gcc_assert (sym->attr.dummy);
1953
1954               fnbody = gfc_trans_dummy_array_bias (sym, sym->backend_decl,
1955                                                    fnbody);
1956               break;
1957
1958             case AS_DEFERRED:
1959               fnbody = gfc_trans_deferred_array (sym, fnbody);
1960               break;
1961
1962             default:
1963               gcc_unreachable ();
1964             }
1965         }
1966       else if (sym->ts.type == BT_CHARACTER)
1967         {
1968           gfc_get_backend_locus (&loc);
1969           gfc_set_backend_locus (&sym->declared_at);
1970           if (sym->attr.dummy || sym->attr.result)
1971             fnbody = gfc_trans_dummy_character (sym->ts.cl, fnbody);
1972           else
1973             fnbody = gfc_trans_auto_character_variable (sym, fnbody);
1974           gfc_set_backend_locus (&loc);
1975         }
1976       else
1977         gcc_unreachable ();
1978     }
1979
1980   return fnbody;
1981 }
1982
1983
1984 /* Output an initialized decl for a module variable.  */
1985
1986 static void
1987 gfc_create_module_variable (gfc_symbol * sym)
1988 {
1989   tree decl;
1990
1991   /* Only output symbols from this module.  */
1992   if (sym->ns != module_namespace)
1993     {
1994       /* I don't think this should ever happen.  */
1995       internal_error ("module symbol %s in wrong namespace", sym->name);
1996     }
1997
1998   /* Only output variables and array valued parametes.  */
1999   if (sym->attr.flavor != FL_VARIABLE
2000       && (sym->attr.flavor != FL_PARAMETER || sym->attr.dimension == 0))
2001     return;
2002
2003   /* Don't generate variables from other modules. Variables from
2004      COMMONs will already have been generated.  */
2005   if (sym->attr.use_assoc || sym->attr.in_common)
2006     return;
2007
2008   if (sym->backend_decl)
2009     internal_error ("backend decl for module variable %s already exists",
2010                     sym->name);
2011
2012   /* We always want module variables to be created.  */
2013   sym->attr.referenced = 1;
2014   /* Create the decl.  */
2015   decl = gfc_get_symbol_decl (sym);
2016
2017   /* Create the variable.  */
2018   pushdecl (decl);
2019   rest_of_decl_compilation (decl, 1, 0);
2020
2021   /* Also add length of strings.  */
2022   if (sym->ts.type == BT_CHARACTER)
2023     {
2024       tree length;
2025
2026       length = sym->ts.cl->backend_decl;
2027       if (!INTEGER_CST_P (length))
2028         {
2029           pushdecl (length);
2030           rest_of_decl_compilation (length, 1, 0);
2031         }
2032     }
2033 }
2034
2035
2036 /* Generate all the required code for module variables.  */
2037
2038 void
2039 gfc_generate_module_vars (gfc_namespace * ns)
2040 {
2041   module_namespace = ns;
2042
2043   /* Check if the frontend left the namespace in a reasonable state.  */
2044   gcc_assert (ns->proc_name && !ns->proc_name->tlink);
2045
2046   /* Generate COMMON blocks.  */
2047   gfc_trans_common (ns);
2048
2049   /* Create decls for all the module variables.  */
2050   gfc_traverse_ns (ns, gfc_create_module_variable);
2051 }
2052
2053 static void
2054 gfc_generate_contained_functions (gfc_namespace * parent)
2055 {
2056   gfc_namespace *ns;
2057
2058   /* We create all the prototypes before generating any code.  */
2059   for (ns = parent->contained; ns; ns = ns->sibling)
2060     {
2061       /* Skip namespaces from used modules.  */
2062       if (ns->parent != parent)
2063         continue;
2064
2065       gfc_create_function_decl (ns);
2066     }
2067
2068   for (ns = parent->contained; ns; ns = ns->sibling)
2069     {
2070       /* Skip namespaces from used modules.  */
2071       if (ns->parent != parent)
2072         continue;
2073
2074       gfc_generate_function_code (ns);
2075     }
2076 }
2077
2078
2079 /* Generate decls for all local variables.  We do this to ensure correct
2080    handling of expressions which only appear in the specification of
2081    other functions.  */
2082
2083 static void
2084 generate_local_decl (gfc_symbol * sym)
2085 {
2086   if (sym->attr.flavor == FL_VARIABLE)
2087     {
2088       if (sym->attr.referenced)
2089         gfc_get_symbol_decl (sym);
2090       else if (sym->attr.dummy && warn_unused_parameter)
2091             warning ("unused parameter `%s'", sym->name);
2092       /* Warn for unused variables, but not if they're inside a common
2093          block or are use-associated.  */
2094       else if (warn_unused_variable
2095                && !(sym->attr.in_common || sym->attr.use_assoc))
2096         warning ("unused variable `%s'", sym->name);
2097     }
2098 }
2099
2100 static void
2101 generate_local_vars (gfc_namespace * ns)
2102 {
2103   gfc_traverse_ns (ns, generate_local_decl);
2104 }
2105
2106
2107 /* Generate a switch statement to jump to the correct entry point.  Also
2108    creates the label decls for the entry points.  */
2109
2110 static tree
2111 gfc_trans_entry_master_switch (gfc_entry_list * el)
2112 {
2113   stmtblock_t block;
2114   tree label;
2115   tree tmp;
2116   tree val;
2117
2118   gfc_init_block (&block);
2119   for (; el; el = el->next)
2120     {
2121       /* Add the case label.  */
2122       label = build_decl (LABEL_DECL, NULL_TREE, NULL_TREE);
2123       DECL_CONTEXT (label) = current_function_decl;
2124       val = build_int_cst (gfc_array_index_type, el->id);
2125       tmp = build3_v (CASE_LABEL_EXPR, val, NULL_TREE, label);
2126       gfc_add_expr_to_block (&block, tmp);
2127
2128       /* And jump to the actual entry point.  */
2129       label = gfc_build_label_decl (NULL_TREE);
2130       TREE_USED (label) = 1;
2131       DECL_CONTEXT (label) = current_function_decl;
2132       tmp = build1_v (GOTO_EXPR, label);
2133       gfc_add_expr_to_block (&block, tmp);
2134
2135       /* Save the label decl.  */
2136       el->label = label;
2137     }
2138   tmp = gfc_finish_block (&block);
2139   /* The first argument selects the entry point.  */
2140   val = DECL_ARGUMENTS (current_function_decl);
2141   tmp = build3_v (SWITCH_EXPR, val, tmp, NULL_TREE);
2142   return tmp;
2143 }
2144
2145
2146 /* Generate code for a function.  */
2147
2148 void
2149 gfc_generate_function_code (gfc_namespace * ns)
2150 {
2151   tree fndecl;
2152   tree old_context;
2153   tree decl;
2154   tree tmp;
2155   stmtblock_t block;
2156   stmtblock_t body;
2157   tree result;
2158   gfc_symbol *sym;
2159
2160   sym = ns->proc_name;
2161
2162   /* Check that the frontend isn't still using this.  */
2163   gcc_assert (sym->tlink == NULL);
2164   sym->tlink = sym;
2165
2166   /* Create the declaration for functions with global scope.  */
2167   if (!sym->backend_decl)
2168     gfc_create_function_decl (ns);
2169
2170   fndecl = sym->backend_decl;
2171   old_context = current_function_decl;
2172
2173   if (old_context)
2174     {
2175       push_function_context ();
2176       saved_parent_function_decls = saved_function_decls;
2177       saved_function_decls = NULL_TREE;
2178     }
2179
2180   trans_function_start (sym);
2181
2182   /* Will be created as needed.  */
2183   current_fake_result_decl = NULL_TREE;
2184
2185   gfc_start_block (&block);
2186
2187   gfc_generate_contained_functions (ns);
2188
2189   /* Translate COMMON blocks.  */
2190   gfc_trans_common (ns);
2191
2192   generate_local_vars (ns);
2193
2194   current_function_return_label = NULL;
2195
2196   /* Now generate the code for the body of this function.  */
2197   gfc_init_block (&body);
2198
2199   if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node
2200       && sym->attr.subroutine)
2201     {
2202       tree alternate_return;
2203       alternate_return = gfc_get_fake_result_decl (sym);
2204       gfc_add_modify_expr (&body, alternate_return, integer_zero_node);
2205     }
2206
2207   if (ns->entries)
2208     {
2209       /* Jump to the correct entry point.  */
2210       tmp = gfc_trans_entry_master_switch (ns->entries);
2211       gfc_add_expr_to_block (&body, tmp);
2212     }
2213
2214   tmp = gfc_trans_code (ns->code);
2215   gfc_add_expr_to_block (&body, tmp);
2216
2217   /* Add a return label if needed.  */
2218   if (current_function_return_label)
2219     {
2220       tmp = build1_v (LABEL_EXPR, current_function_return_label);
2221       gfc_add_expr_to_block (&body, tmp);
2222     }
2223
2224   tmp = gfc_finish_block (&body);
2225   /* Add code to create and cleanup arrays.  */
2226   tmp = gfc_trans_deferred_vars (sym, tmp);
2227   gfc_add_expr_to_block (&block, tmp);
2228
2229   if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node)
2230     {
2231       if (sym->attr.subroutine || sym == sym->result)
2232         {
2233           result = current_fake_result_decl;
2234           current_fake_result_decl = NULL_TREE;
2235         }
2236       else
2237         result = sym->result->backend_decl;
2238
2239       if (result == NULL_TREE)
2240         warning ("Function return value not set");
2241       else
2242         {
2243           /* Set the return value to the dummy result variable.  */
2244           tmp = build2 (MODIFY_EXPR, TREE_TYPE (result),
2245                         DECL_RESULT (fndecl), result);
2246           tmp = build1_v (RETURN_EXPR, tmp);
2247           gfc_add_expr_to_block (&block, tmp);
2248         }
2249     }
2250
2251   /* Add all the decls we created during processing.  */
2252   decl = saved_function_decls;
2253   while (decl)
2254     {
2255       tree next;
2256
2257       next = TREE_CHAIN (decl);
2258       TREE_CHAIN (decl) = NULL_TREE;
2259       pushdecl (decl);
2260       decl = next;
2261     }
2262   saved_function_decls = NULL_TREE;
2263
2264   DECL_SAVED_TREE (fndecl) = gfc_finish_block (&block);
2265
2266   /* Finish off this function and send it for code generation.  */
2267   poplevel (1, 0, 1);
2268   BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
2269
2270   /* Output the GENERIC tree.  */
2271   dump_function (TDI_original, fndecl);
2272
2273   /* Store the end of the function, so that we get good line number
2274      info for the epilogue.  */
2275   cfun->function_end_locus = input_location;
2276
2277   /* We're leaving the context of this function, so zap cfun.
2278      It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
2279      tree_rest_of_compilation.  */
2280   cfun = NULL;
2281
2282   if (old_context)
2283     {
2284       pop_function_context ();
2285       saved_function_decls = saved_parent_function_decls;
2286     }
2287   current_function_decl = old_context;
2288
2289   if (decl_function_context (fndecl))
2290     /* Register this function with cgraph just far enough to get it
2291        added to our parent's nested function list.  */
2292     (void) cgraph_node (fndecl);
2293   else
2294     {
2295       gfc_gimplify_function (fndecl);
2296       cgraph_finalize_function (fndecl, false);
2297     }
2298 }
2299
2300 void
2301 gfc_generate_constructors (void)
2302 {
2303   gcc_assert (gfc_static_ctors == NULL_TREE);
2304 #if 0
2305   tree fnname;
2306   tree type;
2307   tree fndecl;
2308   tree decl;
2309   tree tmp;
2310
2311   if (gfc_static_ctors == NULL_TREE)
2312     return;
2313
2314   fnname = get_file_function_name ('I');
2315   type = build_function_type (void_type_node,
2316                               gfc_chainon_list (NULL_TREE, void_type_node));
2317
2318   fndecl = build_decl (FUNCTION_DECL, fnname, type);
2319   TREE_PUBLIC (fndecl) = 1;
2320
2321   decl = build_decl (RESULT_DECL, NULL_TREE, void_type_node);
2322   DECL_ARTIFICIAL (decl) = 1;
2323   DECL_IGNORED_P (decl) = 1;
2324   DECL_CONTEXT (decl) = fndecl;
2325   DECL_RESULT (fndecl) = decl;
2326
2327   pushdecl (fndecl);
2328
2329   current_function_decl = fndecl;
2330
2331   rest_of_decl_compilation (fndecl, 1, 0);
2332
2333   make_decl_rtl (fndecl);
2334
2335   init_function_start (fndecl);
2336
2337   pushlevel (0);
2338
2339   for (; gfc_static_ctors; gfc_static_ctors = TREE_CHAIN (gfc_static_ctors))
2340     {
2341       tmp =
2342         gfc_build_function_call (TREE_VALUE (gfc_static_ctors), NULL_TREE);
2343       DECL_SAVED_TREE (fndecl) = build_stmt (EXPR_STMT, tmp);
2344     }
2345
2346   poplevel (1, 0, 1);
2347
2348   BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
2349
2350   free_after_parsing (cfun);
2351   free_after_compilation (cfun);
2352
2353   tree_rest_of_compilation (fndecl);
2354
2355   current_function_decl = NULL_TREE;
2356 #endif
2357 }
2358
2359 /* Translates a BLOCK DATA program unit. This means emitting the
2360    commons contained therein plus their initializations. We also emit
2361    a globally visible symbol to make sure that each BLOCK DATA program
2362    unit remains unique.  */
2363
2364 void
2365 gfc_generate_block_data (gfc_namespace * ns)
2366 {
2367   tree decl;
2368   tree id;
2369
2370   /* Tell the backend the source location of the block data.  */
2371   if (ns->proc_name)
2372     gfc_set_backend_locus (&ns->proc_name->declared_at);
2373   else
2374     gfc_set_backend_locus (&gfc_current_locus);
2375
2376   /* Process the DATA statements.  */
2377   gfc_trans_common (ns);
2378
2379   /* Create a global symbol with the mane of the block data.  This is to
2380      generate linker errors if the same name is used twice.  It is never
2381      really used.  */
2382   if (ns->proc_name)
2383     id = gfc_sym_mangled_function_id (ns->proc_name);
2384   else
2385     id = get_identifier ("__BLOCK_DATA__");
2386
2387   decl = build_decl (VAR_DECL, id, gfc_array_index_type);
2388   TREE_PUBLIC (decl) = 1;
2389   TREE_STATIC (decl) = 1;
2390
2391   pushdecl (decl);
2392   rest_of_decl_compilation (decl, 1, 0);
2393 }
2394
2395 #include "gt-fortran-trans-decl.h"