gcc/fortran/trans-decl.c

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