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