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 + 13]; /* "f2c_specific" and '\0'.  */
 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
 941       if (gfc_option.flag_f2c
 942           && ((e.ts.type == BT_REAL && e.ts.kind == gfc_default_real_kind)
 943               || e.ts.type == BT_COMPLEX))
 944         {
 945           /* Specific which needs a different implementation if f2c
 946              calling conventions are used.  */
 947           sprintf (s, "f2c_specific%s", e.value.function.name);
 948         }
 949       else
 950         sprintf (s, "specific%s", e.value.function.name);
 951
 952       name = get_identifier (s);
 953       mangled_name = name;
 954     }
 955   else
 956     {
 957       name = gfc_sym_identifier (sym);
 958       mangled_name = gfc_sym_mangled_function_id (sym);
 959     }
 960
 961   type = gfc_get_function_type (sym);
 962   fndecl = build_decl (FUNCTION_DECL, name, type);
 963
 964   SET_DECL_ASSEMBLER_NAME (fndecl, mangled_name);
 965   /* If the return type is a pointer, avoid alias issues by setting
 966      DECL_IS_MALLOC to nonzero. This means that the function should be
 967      treated as if it were a malloc, meaning it returns a pointer that
 968      is not an alias.  */
 969   if (POINTER_TYPE_P (type))
 970     DECL_IS_MALLOC (fndecl) = 1;
 971
 972   /* Set the context of this decl.  */
 973   if (0 && sym->ns && sym->ns->proc_name)
 974     {
 975       /* TODO: Add external decls to the appropriate scope.  */
 976       DECL_CONTEXT (fndecl) = sym->ns->proc_name->backend_decl;
 977     }
 978   else
 979     {
 980       /* Global declaration, e.g. intrinsic subroutine.  */
 981       DECL_CONTEXT (fndecl) = NULL_TREE;
 982     }
 983
 984   DECL_EXTERNAL (fndecl) = 1;
 985
 986   /* This specifies if a function is globally addressable, i.e. it is
 987      the opposite of declaring static in C.  */
 988   TREE_PUBLIC (fndecl) = 1;
 989
 990   /* Set attributes for PURE functions. A call to PURE function in the
 991      Fortran 95 sense is both pure and without side effects in the C
 992      sense.  */
 993   if (sym->attr.pure || sym->attr.elemental)
 994     {
 995       if (sym->attr.function)
 996         DECL_IS_PURE (fndecl) = 1;
 997       /* TODO: check if pure SUBROUTINEs don't have INTENT(OUT)
 998          parameters and don't use alternate returns (is this
 999          allowed?). In that case, calls to them are meaningless, and
1000          can be optimized away. See also in build_function_decl().  */
1001       TREE_SIDE_EFFECTS (fndecl) = 0;
1002     }
1003
1004   sym->backend_decl = fndecl;
1005
1006   if (DECL_CONTEXT (fndecl) == NULL_TREE)
1007     pushdecl_top_level (fndecl);
1008
1009   return fndecl;
1010 }
1011
1012
1013 /* Create a declaration for a procedure.  For external functions (in the C
1014    sense) use gfc_get_extern_function_decl.  HAS_ENTRIES is true if this is
1015    a master function with alternate entry points.  */
1016
1017 static void
1018 build_function_decl (gfc_symbol * sym)
1019 {
1020   tree fndecl, type;
1021   symbol_attribute attr;
1022   tree result_decl;
1023   gfc_formal_arglist *f;
1024
1025   gcc_assert (!sym->backend_decl);
1026   gcc_assert (!sym->attr.external);
1027
1028   /* Set the line and filename.  sym->declared_at seems to point to the
1029      last statement for subroutines, but it'll do for now.  */
1030   gfc_set_backend_locus (&sym->declared_at);
1031
1032   /* Allow only one nesting level.  Allow public declarations.  */
1033   gcc_assert (current_function_decl == NULL_TREE
1034           || DECL_CONTEXT (current_function_decl) == NULL_TREE);
1035
1036   type = gfc_get_function_type (sym);
1037   fndecl = build_decl (FUNCTION_DECL, gfc_sym_identifier (sym), type);
1038
1039   /* Perform name mangling if this is a top level or module procedure.  */
1040   if (current_function_decl == NULL_TREE)
1041     SET_DECL_ASSEMBLER_NAME (fndecl, gfc_sym_mangled_function_id (sym));
1042
1043   /* Figure out the return type of the declared function, and build a
1044      RESULT_DECL for it.  If this is a subroutine with alternate
1045      returns, build a RESULT_DECL for it.  */
1046   attr = sym->attr;
1047
1048   result_decl = NULL_TREE;
1049   /* TODO: Shouldn't this just be TREE_TYPE (TREE_TYPE (fndecl)).  */
1050   if (attr.function)
1051     {
1052       if (gfc_return_by_reference (sym))
1053         type = void_type_node;
1054       else
1055         {
1056           if (sym->result != sym)
1057             result_decl = gfc_sym_identifier (sym->result);
1058
1059           type = TREE_TYPE (TREE_TYPE (fndecl));
1060         }
1061     }
1062   else
1063     {
1064       /* Look for alternate return placeholders.  */
1065       int has_alternate_returns = 0;
1066       for (f = sym->formal; f; f = f->next)
1067         {
1068           if (f->sym == NULL)
1069             {
1070               has_alternate_returns = 1;
1071               break;
1072             }
1073         }
1074
1075       if (has_alternate_returns)
1076         type = integer_type_node;
1077       else
1078         type = void_type_node;
1079     }
1080
1081   result_decl = build_decl (RESULT_DECL, result_decl, type);
1082   DECL_ARTIFICIAL (result_decl) = 1;
1083   DECL_IGNORED_P (result_decl) = 1;
1084   DECL_CONTEXT (result_decl) = fndecl;
1085   DECL_RESULT (fndecl) = result_decl;
1086
1087   /* Don't call layout_decl for a RESULT_DECL.
1088      layout_decl (result_decl, 0);  */
1089
1090   /* If the return type is a pointer, avoid alias issues by setting
1091      DECL_IS_MALLOC to nonzero. This means that the function should be
1092      treated as if it were a malloc, meaning it returns a pointer that
1093      is not an alias.  */
1094   if (POINTER_TYPE_P (type))
1095     DECL_IS_MALLOC (fndecl) = 1;
1096
1097   /* Set up all attributes for the function.  */
1098   DECL_CONTEXT (fndecl) = current_function_decl;
1099   DECL_EXTERNAL (fndecl) = 0;
1100
1101   /* This specifies if a function is globally visible, i.e. it is
1102      the opposite of declaring static in C.  */
1103   if (DECL_CONTEXT (fndecl) == NULL_TREE
1104       && !sym->attr.entry_master)
1105     TREE_PUBLIC (fndecl) = 1;
1106
1107   /* TREE_STATIC means the function body is defined here.  */
1108   TREE_STATIC (fndecl) = 1;
1109
1110   /* Set attributes for PURE functions. A call to a PURE function in the
1111      Fortran 95 sense is both pure and without side effects in the C
1112      sense.  */
1113   if (attr.pure || attr.elemental)
1114     {
1115       /* TODO: check if a pure SUBROUTINE has no INTENT(OUT) arguments
1116          including a alternate return. In that case it can also be
1117          marked as PURE. See also in gfc_get_extern_function_decl().  */
1118       if (attr.function)
1119         DECL_IS_PURE (fndecl) = 1;
1120       TREE_SIDE_EFFECTS (fndecl) = 0;
1121     }
1122
1123   /* Layout the function declaration and put it in the binding level
1124      of the current function.  */
1125   pushdecl (fndecl);
1126
1127   sym->backend_decl = fndecl;
1128 }
1129
1130
1131 /* Create the DECL_ARGUMENTS for a procedure.  */
1132
1133 static void
1134 create_function_arglist (gfc_symbol * sym)
1135 {
1136   tree fndecl;
1137   gfc_formal_arglist *f;
1138   tree typelist;
1139   tree arglist;
1140   tree length;
1141   tree type;
1142   tree parm;
1143
1144   fndecl = sym->backend_decl;
1145
1146   /* Build formal argument list. Make sure that their TREE_CONTEXT is
1147      the new FUNCTION_DECL node.  */
1148   arglist = NULL_TREE;
1149   typelist = TYPE_ARG_TYPES (TREE_TYPE (fndecl));
1150
1151   if (sym->attr.entry_master)
1152     {
1153       type = TREE_VALUE (typelist);
1154       parm = build_decl (PARM_DECL, get_identifier ("__entry"), type);
1155
1156       DECL_CONTEXT (parm) = fndecl;
1157       DECL_ARG_TYPE (parm) = type;
1158       TREE_READONLY (parm) = 1;
1159       gfc_finish_decl (parm, NULL_TREE);
1160
1161       arglist = chainon (arglist, parm);
1162       typelist = TREE_CHAIN (typelist);
1163     }
1164
1165   if (gfc_return_by_reference (sym))
1166     {
1167       type = TREE_VALUE (typelist);
1168       parm = build_decl (PARM_DECL, get_identifier ("__result"), type);
1169
1170       DECL_CONTEXT (parm) = fndecl;
1171       DECL_ARG_TYPE (parm) = type;
1172       TREE_READONLY (parm) = 1;
1173       DECL_ARTIFICIAL (parm) = 1;
1174       gfc_finish_decl (parm, NULL_TREE);
1175
1176       arglist = chainon (arglist, parm);
1177       typelist = TREE_CHAIN (typelist);
1178
1179       if (sym->ts.type == BT_CHARACTER)
1180         {
1181           gfc_allocate_lang_decl (parm);
1182
1183           /* Length of character result.  */
1184           type = TREE_VALUE (typelist);
1185           gcc_assert (type == gfc_charlen_type_node);
1186
1187           length = build_decl (PARM_DECL,
1188                                get_identifier (".__result"),
1189                                type);
1190           if (!sym->ts.cl->length)
1191             {
1192               sym->ts.cl->backend_decl = length;
1193               TREE_USED (length) = 1;
1194             }
1195           gcc_assert (TREE_CODE (length) == PARM_DECL);
1196           arglist = chainon (arglist, length);
1197           typelist = TREE_CHAIN (typelist);
1198           DECL_CONTEXT (length) = fndecl;
1199           DECL_ARG_TYPE (length) = type;
1200           TREE_READONLY (length) = 1;
1201           DECL_ARTIFICIAL (length) = 1;
1202           gfc_finish_decl (length, NULL_TREE);
1203         }
1204     }
1205
1206   for (f = sym->formal; f; f = f->next)
1207     {
1208       if (f->sym != NULL)       /* ignore alternate returns.  */
1209         {
1210           length = NULL_TREE;
1211
1212           type = TREE_VALUE (typelist);
1213
1214           /* Build a the argument declaration.  */
1215           parm = build_decl (PARM_DECL,
1216                              gfc_sym_identifier (f->sym), type);
1217
1218           /* Fill in arg stuff.  */
1219           DECL_CONTEXT (parm) = fndecl;
1220           DECL_ARG_TYPE (parm) = type;
1221           DECL_ARG_TYPE_AS_WRITTEN (parm) = type;
1222           /* All implementation args are read-only.  */
1223           TREE_READONLY (parm) = 1;
1224
1225           gfc_finish_decl (parm, NULL_TREE);
1226
1227           f->sym->backend_decl = parm;
1228
1229           arglist = chainon (arglist, parm);
1230           typelist = TREE_CHAIN (typelist);
1231         }
1232     }
1233
1234   /* Add the hidden string length parameters.  */
1235   parm = arglist;
1236   for (f = sym->formal; f; f = f->next)
1237     {
1238       char name[GFC_MAX_SYMBOL_LEN + 2];
1239       /* Ignore alternate returns.  */
1240       if (f->sym == NULL)
1241         continue;
1242
1243       if (f->sym->ts.type != BT_CHARACTER)
1244         continue;
1245
1246       parm = f->sym->backend_decl;
1247       type = TREE_VALUE (typelist);
1248       gcc_assert (type == gfc_charlen_type_node);
1249
1250       strcpy (&name[1], f->sym->name);
1251       name[0] = '_';
1252       length = build_decl (PARM_DECL, get_identifier (name), type);
1253
1254       arglist = chainon (arglist, length);
1255       DECL_CONTEXT (length) = fndecl;
1256       DECL_ARTIFICIAL (length) = 1;
1257       DECL_ARG_TYPE (length) = type;
1258       TREE_READONLY (length) = 1;
1259       gfc_finish_decl (length, NULL_TREE);
1260
1261       /* TODO: Check string lengths when -fbounds-check.  */
1262
1263       /* Use the passed value for assumed length variables.  */
1264       if (!f->sym->ts.cl->length)
1265         {
1266           TREE_USED (length) = 1;
1267           if (!f->sym->ts.cl->backend_decl)
1268             f->sym->ts.cl->backend_decl = length;
1269           else
1270             {
1271               /* there is already another variable using this
1272                  gfc_charlen node, build a new one for this variable
1273                  and chain it into the list of gfc_charlens.
1274                  This happens for e.g. in the case
1275                  CHARACTER(*)::c1,c2
1276                  since CHARACTER declarations on the same line share
1277                  the same gfc_charlen node.  */
1278               gfc_charlen *cl;
1279
1280               cl = gfc_get_charlen ();
1281               cl->backend_decl = length;
1282               cl->next = f->sym->ts.cl->next;
1283               f->sym->ts.cl->next = cl;
1284               f->sym->ts.cl = cl;
1285             }
1286         }
1287
1288       parm = TREE_CHAIN (parm);
1289       typelist = TREE_CHAIN (typelist);
1290     }
1291
1292   gcc_assert (TREE_VALUE (typelist) == void_type_node);
1293   DECL_ARGUMENTS (fndecl) = arglist;
1294 }
1295
1296 /* Convert FNDECL's code to GIMPLE and handle any nested functions.  */
1297
1298 static void
1299 gfc_gimplify_function (tree fndecl)
1300 {
1301   struct cgraph_node *cgn;
1302
1303   gimplify_function_tree (fndecl);
1304   dump_function (TDI_generic, fndecl);
1305
1306   /* Convert all nested functions to GIMPLE now.  We do things in this order
1307      so that items like VLA sizes are expanded properly in the context of the
1308      correct function.  */
1309   cgn = cgraph_node (fndecl);
1310   for (cgn = cgn->nested; cgn; cgn = cgn->next_nested)
1311     gfc_gimplify_function (cgn->decl);
1312 }
1313
1314
1315 /* Do the setup necessary before generating the body of a function.  */
1316
1317 static void
1318 trans_function_start (gfc_symbol * sym)
1319 {
1320   tree fndecl;
1321
1322   fndecl = sym->backend_decl;
1323
1324   /* Let GCC know the current scope is this function.  */
1325   current_function_decl = fndecl;
1326
1327   /* Let the world know what we're about to do.  */
1328   announce_function (fndecl);
1329
1330   if (DECL_CONTEXT (fndecl) == NULL_TREE)
1331     {
1332       /* Create RTL for function declaration.  */
1333       rest_of_decl_compilation (fndecl, 1, 0);
1334     }
1335
1336   /* Create RTL for function definition.  */
1337   make_decl_rtl (fndecl);
1338
1339   init_function_start (fndecl);
1340
1341   /* Even though we're inside a function body, we still don't want to
1342      call expand_expr to calculate the size of a variable-sized array.
1343      We haven't necessarily assigned RTL to all variables yet, so it's
1344      not safe to try to expand expressions involving them.  */
1345   cfun->x_dont_save_pending_sizes_p = 1;
1346
1347   /* function.c requires a push at the start of the function.  */
1348   pushlevel (0);
1349 }
1350
1351 /* Create thunks for alternate entry points.  */
1352
1353 static void
1354 build_entry_thunks (gfc_namespace * ns)
1355 {
1356   gfc_formal_arglist *formal;
1357   gfc_formal_arglist *thunk_formal;
1358   gfc_entry_list *el;
1359   gfc_symbol *thunk_sym;
1360   stmtblock_t body;
1361   tree thunk_fndecl;
1362   tree args;
1363   tree string_args;
1364   tree tmp;
1365   locus old_loc;
1366
1367   /* This should always be a toplevel function.  */
1368   gcc_assert (current_function_decl == NULL_TREE);
1369
1370   gfc_get_backend_locus (&old_loc);
1371   for (el = ns->entries; el; el = el->next)
1372     {
1373       thunk_sym = el->sym;
1374
1375       build_function_decl (thunk_sym);
1376       create_function_arglist (thunk_sym);
1377
1378       trans_function_start (thunk_sym);
1379
1380       thunk_fndecl = thunk_sym->backend_decl;
1381
1382       gfc_start_block (&body);
1383
1384       /* Pass extra parameter identifying this entry point.  */
1385       tmp = build_int_cst (gfc_array_index_type, el->id);
1386       args = tree_cons (NULL_TREE, tmp, NULL_TREE);
1387       string_args = NULL_TREE;
1388
1389       if (thunk_sym->attr.function)
1390         {
1391           if (gfc_return_by_reference (ns->proc_name))
1392             {
1393               tree ref = DECL_ARGUMENTS (current_function_decl);
1394               args = tree_cons (NULL_TREE, ref, args);
1395               if (ns->proc_name->ts.type == BT_CHARACTER)
1396                 args = tree_cons (NULL_TREE, TREE_CHAIN (ref),
1397                                   args);
1398             }
1399         }
1400
1401       for (formal = ns->proc_name->formal; formal; formal = formal->next)
1402         {
1403           /* Ignore alternate returns.  */
1404           if (formal->sym == NULL)
1405             continue;
1406
1407           /* We don't have a clever way of identifying arguments, so resort to
1408              a brute-force search.  */
1409           for (thunk_formal = thunk_sym->formal;
1410                thunk_formal;
1411                thunk_formal = thunk_formal->next)
1412             {
1413               if (thunk_formal->sym == formal->sym)
1414                 break;
1415             }
1416
1417           if (thunk_formal)
1418             {
1419               /* Pass the argument.  */
1420               args = tree_cons (NULL_TREE, thunk_formal->sym->backend_decl,
1421                                 args);
1422               if (formal->sym->ts.type == BT_CHARACTER)
1423                 {
1424                   tmp = thunk_formal->sym->ts.cl->backend_decl;
1425                   string_args = tree_cons (NULL_TREE, tmp, string_args);
1426                 }
1427             }
1428           else
1429             {
1430               /* Pass NULL for a missing argument.  */
1431               args = tree_cons (NULL_TREE, null_pointer_node, args);
1432               if (formal->sym->ts.type == BT_CHARACTER)
1433                 {
1434                   tmp = convert (gfc_charlen_type_node, integer_zero_node);
1435                   string_args = tree_cons (NULL_TREE, tmp, string_args);
1436                 }
1437             }
1438         }
1439
1440       /* Call the master function.  */
1441       args = nreverse (args);
1442       args = chainon (args, nreverse (string_args));
1443       tmp = ns->proc_name->backend_decl;
1444       tmp = gfc_build_function_call (tmp, args);
1445       if (ns->proc_name->attr.mixed_entry_master)
1446         {
1447           tree union_decl, field;
1448           tree master_type = TREE_TYPE (ns->proc_name->backend_decl);
1449
1450           union_decl = build_decl (VAR_DECL, get_identifier ("__result"),
1451                                    TREE_TYPE (master_type));
1452           DECL_ARTIFICIAL (union_decl) = 1;
1453           DECL_EXTERNAL (union_decl) = 0;
1454           TREE_PUBLIC (union_decl) = 0;
1455           TREE_USED (union_decl) = 1;
1456           layout_decl (union_decl, 0);
1457           pushdecl (union_decl);
1458
1459           DECL_CONTEXT (union_decl) = current_function_decl;
1460           tmp = build2 (MODIFY_EXPR,
1461                         TREE_TYPE (union_decl),
1462                         union_decl, tmp);
1463           gfc_add_expr_to_block (&body, tmp);
1464
1465           for (field = TYPE_FIELDS (TREE_TYPE (union_decl));
1466                field; field = TREE_CHAIN (field))
1467             if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
1468                 thunk_sym->result->name) == 0)
1469               break;
1470           gcc_assert (field != NULL_TREE);
1471           tmp = build3 (COMPONENT_REF, TREE_TYPE (field), union_decl, field,
1472                         NULL_TREE);
1473           tmp = build2 (MODIFY_EXPR,
1474                         TREE_TYPE (DECL_RESULT (current_function_decl)),
1475                         DECL_RESULT (current_function_decl), tmp);
1476           tmp = build1_v (RETURN_EXPR, tmp);
1477         }
1478       else if (TREE_TYPE (DECL_RESULT (current_function_decl))
1479                != void_type_node)
1480         {
1481           tmp = build2 (MODIFY_EXPR,
1482                         TREE_TYPE (DECL_RESULT (current_function_decl)),
1483                         DECL_RESULT (current_function_decl), tmp);
1484           tmp = build1_v (RETURN_EXPR, tmp);
1485         }
1486       gfc_add_expr_to_block (&body, tmp);
1487
1488       /* Finish off this function and send it for code generation.  */
1489       DECL_SAVED_TREE (thunk_fndecl) = gfc_finish_block (&body);
1490       poplevel (1, 0, 1);
1491       BLOCK_SUPERCONTEXT (DECL_INITIAL (thunk_fndecl)) = thunk_fndecl;
1492
1493       /* Output the GENERIC tree.  */
1494       dump_function (TDI_original, thunk_fndecl);
1495
1496       /* Store the end of the function, so that we get good line number
1497          info for the epilogue.  */
1498       cfun->function_end_locus = input_location;
1499
1500       /* We're leaving the context of this function, so zap cfun.
1501          It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
1502          tree_rest_of_compilation.  */
1503       cfun = NULL;
1504
1505       current_function_decl = NULL_TREE;
1506
1507       gfc_gimplify_function (thunk_fndecl);
1508       cgraph_finalize_function (thunk_fndecl, false);
1509
1510       /* We share the symbols in the formal argument list with other entry
1511          points and the master function.  Clear them so that they are
1512          recreated for each function.  */
1513       for (formal = thunk_sym->formal; formal; formal = formal->next)
1514         if (formal->sym != NULL)  /* Ignore alternate returns.  */
1515           {
1516             formal->sym->backend_decl = NULL_TREE;
1517             if (formal->sym->ts.type == BT_CHARACTER)
1518               formal->sym->ts.cl->backend_decl = NULL_TREE;
1519           }
1520
1521       if (thunk_sym->attr.function)
1522         {
1523           if (thunk_sym->ts.type == BT_CHARACTER)
1524             thunk_sym->ts.cl->backend_decl = NULL_TREE;
1525           if (thunk_sym->result->ts.type == BT_CHARACTER)
1526             thunk_sym->result->ts.cl->backend_decl = NULL_TREE;
1527         }
1528     }
1529
1530   gfc_set_backend_locus (&old_loc);
1531 }
1532
1533
1534 /* Create a decl for a function, and create any thunks for alternate entry
1535    points.  */
1536
1537 void
1538 gfc_create_function_decl (gfc_namespace * ns)
1539 {
1540   /* Create a declaration for the master function.  */
1541   build_function_decl (ns->proc_name);
1542
1543   /* Compile the entry thunks.  */
1544   if (ns->entries)
1545     build_entry_thunks (ns);
1546
1547   /* Now create the read argument list.  */
1548   create_function_arglist (ns->proc_name);
1549 }
1550
1551 /* Return the decl used to hold the function return value.  */
1552
1553 tree
1554 gfc_get_fake_result_decl (gfc_symbol * sym)
1555 {
1556   tree decl;
1557   tree length;
1558
1559   char name[GFC_MAX_SYMBOL_LEN + 10];
1560
1561   if (sym
1562       && sym->ns->proc_name->backend_decl == current_function_decl
1563       && sym->ns->proc_name->attr.mixed_entry_master
1564       && sym != sym->ns->proc_name)
1565     {
1566       decl = gfc_get_fake_result_decl (sym->ns->proc_name);
1567       if (decl)
1568         {
1569           tree field;
1570
1571           for (field = TYPE_FIELDS (TREE_TYPE (decl));
1572                field; field = TREE_CHAIN (field))
1573             if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
1574                 sym->name) == 0)
1575               break;
1576
1577           gcc_assert (field != NULL_TREE);
1578           decl = build3 (COMPONENT_REF, TREE_TYPE (field), decl, field,
1579                          NULL_TREE);
1580         }
1581       return decl;
1582     }
1583
1584   if (current_fake_result_decl != NULL_TREE)
1585     return current_fake_result_decl;
1586
1587   /* Only when gfc_get_fake_result_decl is called by gfc_trans_return,
1588      sym is NULL.  */
1589   if (!sym)
1590     return NULL_TREE;
1591
1592   if (sym->ts.type == BT_CHARACTER
1593       && !sym->ts.cl->backend_decl)
1594     {
1595       length = gfc_create_string_length (sym);
1596       gfc_finish_var_decl (length, sym);
1597     }
1598
1599   if (gfc_return_by_reference (sym))
1600     {
1601       decl = DECL_ARGUMENTS (current_function_decl);
1602
1603       if (sym->ns->proc_name->backend_decl == current_function_decl
1604           && sym->ns->proc_name->attr.entry_master)
1605         decl = TREE_CHAIN (decl);
1606
1607       TREE_USED (decl) = 1;
1608       if (sym->as)
1609         decl = gfc_build_dummy_array_decl (sym, decl);
1610     }
1611   else
1612     {
1613       sprintf (name, "__result_%.20s",
1614                IDENTIFIER_POINTER (DECL_NAME (current_function_decl)));
1615
1616       decl = build_decl (VAR_DECL, get_identifier (name),
1617                          TREE_TYPE (TREE_TYPE (current_function_decl)));
1618
1619       DECL_ARTIFICIAL (decl) = 1;
1620       DECL_EXTERNAL (decl) = 0;
1621       TREE_PUBLIC (decl) = 0;
1622       TREE_USED (decl) = 1;
1623
1624       layout_decl (decl, 0);
1625
1626       gfc_add_decl_to_function (decl);
1627     }
1628
1629   current_fake_result_decl = decl;
1630
1631   return decl;
1632 }
1633
1634
1635 /* Builds a function decl.  The remaining parameters are the types of the
1636    function arguments.  Negative nargs indicates a varargs function.  */
1637
1638 tree
1639 gfc_build_library_function_decl (tree name, tree rettype, int nargs, ...)
1640 {
1641   tree arglist;
1642   tree argtype;
1643   tree fntype;
1644   tree fndecl;
1645   va_list p;
1646   int n;
1647
1648   /* Library functions must be declared with global scope.  */
1649   gcc_assert (current_function_decl == NULL_TREE);
1650
1651   va_start (p, nargs);
1652
1653
1654   /* Create a list of the argument types.  */
1655   for (arglist = NULL_TREE, n = abs (nargs); n > 0; n--)
1656     {
1657       argtype = va_arg (p, tree);
1658       arglist = gfc_chainon_list (arglist, argtype);
1659     }
1660
1661   if (nargs >= 0)
1662     {
1663       /* Terminate the list.  */
1664       arglist = gfc_chainon_list (arglist, void_type_node);
1665     }
1666
1667   /* Build the function type and decl.  */
1668   fntype = build_function_type (rettype, arglist);
1669   fndecl = build_decl (FUNCTION_DECL, name, fntype);
1670
1671   /* Mark this decl as external.  */
1672   DECL_EXTERNAL (fndecl) = 1;
1673   TREE_PUBLIC (fndecl) = 1;
1674
1675   va_end (p);
1676
1677   pushdecl (fndecl);
1678
1679   rest_of_decl_compilation (fndecl, 1, 0);
1680
1681   return fndecl;
1682 }
1683
1684 static void
1685 gfc_build_intrinsic_function_decls (void)
1686 {
1687   tree gfc_int4_type_node = gfc_get_int_type (4);
1688   tree gfc_int8_type_node = gfc_get_int_type (8);
1689   tree gfc_logical4_type_node = gfc_get_logical_type (4);
1690   tree gfc_real4_type_node = gfc_get_real_type (4);
1691   tree gfc_real8_type_node = gfc_get_real_type (8);
1692   tree gfc_complex4_type_node = gfc_get_complex_type (4);
1693   tree gfc_complex8_type_node = gfc_get_complex_type (8);
1694
1695   /* String functions.  */
1696   gfor_fndecl_copy_string =
1697     gfc_build_library_function_decl (get_identifier (PREFIX("copy_string")),
1698                                      void_type_node,
1699                                      4,
1700                                      gfc_charlen_type_node, pchar_type_node,
1701                                      gfc_charlen_type_node, pchar_type_node);
1702
1703   gfor_fndecl_compare_string =
1704     gfc_build_library_function_decl (get_identifier (PREFIX("compare_string")),
1705                                      gfc_int4_type_node,
1706                                      4,
1707                                      gfc_charlen_type_node, pchar_type_node,
1708                                      gfc_charlen_type_node, pchar_type_node);
1709
1710   gfor_fndecl_concat_string =
1711     gfc_build_library_function_decl (get_identifier (PREFIX("concat_string")),
1712                                      void_type_node,
1713                                      6,
1714                                      gfc_charlen_type_node, pchar_type_node,
1715                                      gfc_charlen_type_node, pchar_type_node,
1716                                      gfc_charlen_type_node, pchar_type_node);
1717
1718   gfor_fndecl_string_len_trim =
1719     gfc_build_library_function_decl (get_identifier (PREFIX("string_len_trim")),
1720                                      gfc_int4_type_node,
1721                                      2, gfc_charlen_type_node,
1722                                      pchar_type_node);
1723
1724   gfor_fndecl_string_index =
1725     gfc_build_library_function_decl (get_identifier (PREFIX("string_index")),
1726                                      gfc_int4_type_node,
1727                                      5, gfc_charlen_type_node, pchar_type_node,
1728                                      gfc_charlen_type_node, pchar_type_node,
1729                                      gfc_logical4_type_node);
1730
1731   gfor_fndecl_string_scan =
1732     gfc_build_library_function_decl (get_identifier (PREFIX("string_scan")),
1733                                      gfc_int4_type_node,
1734                                      5, gfc_charlen_type_node, pchar_type_node,
1735                                      gfc_charlen_type_node, pchar_type_node,
1736                                      gfc_logical4_type_node);
1737
1738   gfor_fndecl_string_verify =
1739     gfc_build_library_function_decl (get_identifier (PREFIX("string_verify")),
1740                                      gfc_int4_type_node,
1741                                      5, gfc_charlen_type_node, pchar_type_node,
1742                                      gfc_charlen_type_node, pchar_type_node,
1743                                      gfc_logical4_type_node);
1744
1745   gfor_fndecl_string_trim =
1746     gfc_build_library_function_decl (get_identifier (PREFIX("string_trim")),
1747                                      void_type_node,
1748                                      4,
1749                                      build_pointer_type (gfc_charlen_type_node),
1750                                      ppvoid_type_node,
1751                                      gfc_charlen_type_node,
1752                                      pchar_type_node);
1753
1754   gfor_fndecl_string_repeat =
1755     gfc_build_library_function_decl (get_identifier (PREFIX("string_repeat")),
1756                                      void_type_node,
1757                                      4,
1758                                      pchar_type_node,
1759                                      gfc_charlen_type_node,
1760                                      pchar_type_node,
1761                                      gfc_int4_type_node);
1762
1763   gfor_fndecl_adjustl =
1764     gfc_build_library_function_decl (get_identifier (PREFIX("adjustl")),
1765                                      void_type_node,
1766                                      3,
1767                                      pchar_type_node,
1768                                      gfc_charlen_type_node, pchar_type_node);
1769
1770   gfor_fndecl_adjustr =
1771     gfc_build_library_function_decl (get_identifier (PREFIX("adjustr")),
1772                                      void_type_node,
1773                                      3,
1774                                      pchar_type_node,
1775                                      gfc_charlen_type_node, pchar_type_node);
1776
1777   gfor_fndecl_si_kind =
1778     gfc_build_library_function_decl (get_identifier ("selected_int_kind"),
1779                                      gfc_int4_type_node,
1780                                      1,
1781                                      pvoid_type_node);
1782
1783   gfor_fndecl_sr_kind =
1784     gfc_build_library_function_decl (get_identifier ("selected_real_kind"),
1785                                      gfc_int4_type_node,
1786                                      2, pvoid_type_node,
1787                                      pvoid_type_node);
1788
1789   /* Power functions.  */
1790   {
1791     tree type;
1792     tree itype;
1793     int kind;
1794     int ikind;
1795     static int kinds[2] = {4, 8};
1796     char name[PREFIX_LEN + 10]; /* _gfortran_pow_?n_?n */
1797
1798     for (ikind=0; ikind < 2; ikind++)
1799       {
1800         itype = gfc_get_int_type (kinds[ikind]);
1801         for (kind = 0; kind < 2; kind ++)
1802           {
1803             type = gfc_get_int_type (kinds[kind]);
1804             sprintf(name, PREFIX("pow_i%d_i%d"), kinds[kind], kinds[ikind]);
1805             gfor_fndecl_math_powi[kind][ikind].integer =
1806               gfc_build_library_function_decl (get_identifier (name),
1807                   type, 2, type, itype);
1808
1809             type = gfc_get_real_type (kinds[kind]);
1810             sprintf(name, PREFIX("pow_r%d_i%d"), kinds[kind], kinds[ikind]);
1811             gfor_fndecl_math_powi[kind][ikind].real =
1812               gfc_build_library_function_decl (get_identifier (name),
1813                   type, 2, type, itype);
1814
1815             type = gfc_get_complex_type (kinds[kind]);
1816             sprintf(name, PREFIX("pow_c%d_i%d"), kinds[kind], kinds[ikind]);
1817             gfor_fndecl_math_powi[kind][ikind].cmplx =
1818               gfc_build_library_function_decl (get_identifier (name),
1819                   type, 2, type, itype);
1820           }
1821       }
1822   }
1823
1824   gfor_fndecl_math_cpowf =
1825     gfc_build_library_function_decl (get_identifier ("cpowf"),
1826                                      gfc_complex4_type_node,
1827                                      1, gfc_complex4_type_node);
1828   gfor_fndecl_math_cpow =
1829     gfc_build_library_function_decl (get_identifier ("cpow"),
1830                                      gfc_complex8_type_node,
1831                                      1, gfc_complex8_type_node);
1832   gfor_fndecl_math_ishftc4 =
1833     gfc_build_library_function_decl (get_identifier (PREFIX("ishftc4")),
1834                                      gfc_int4_type_node,
1835                                      3, gfc_int4_type_node,
1836                                      gfc_int4_type_node, gfc_int4_type_node);
1837   gfor_fndecl_math_ishftc8 =
1838     gfc_build_library_function_decl (get_identifier (PREFIX("ishftc8")),
1839                                      gfc_int8_type_node,
1840                                      3, gfc_int8_type_node,
1841                                      gfc_int8_type_node, gfc_int8_type_node);
1842   gfor_fndecl_math_exponent4 =
1843     gfc_build_library_function_decl (get_identifier (PREFIX("exponent_r4")),
1844                                      gfc_int4_type_node,
1845                                      1, gfc_real4_type_node);
1846   gfor_fndecl_math_exponent8 =
1847     gfc_build_library_function_decl (get_identifier (PREFIX("exponent_r8")),
1848                                      gfc_int4_type_node,
1849                                      1, gfc_real8_type_node);
1850
1851   /* Other functions.  */
1852   gfor_fndecl_size0 =
1853     gfc_build_library_function_decl (get_identifier (PREFIX("size0")),
1854                                      gfc_array_index_type,
1855                                      1, pvoid_type_node);
1856   gfor_fndecl_size1 =
1857     gfc_build_library_function_decl (get_identifier (PREFIX("size1")),
1858                                      gfc_array_index_type,
1859                                      2, pvoid_type_node,
1860                                      gfc_array_index_type);
1861
1862   gfor_fndecl_iargc =
1863     gfc_build_library_function_decl (get_identifier (PREFIX ("iargc")),
1864                                      gfc_int4_type_node,
1865                                      0);
1866 }
1867
1868
1869 /* Make prototypes for runtime library functions.  */
1870
1871 void
1872 gfc_build_builtin_function_decls (void)
1873 {
1874   tree gfc_int4_type_node = gfc_get_int_type (4);
1875   tree gfc_int8_type_node = gfc_get_int_type (8);
1876   tree gfc_logical4_type_node = gfc_get_logical_type (4);
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, 1, ppvoid_type_node);
1904
1905   gfor_fndecl_stop_numeric =
1906     gfc_build_library_function_decl (get_identifier (PREFIX("stop_numeric")),
1907                                      void_type_node, 1, gfc_int4_type_node);
1908
1909   gfor_fndecl_stop_string =
1910     gfc_build_library_function_decl (get_identifier (PREFIX("stop_string")),
1911                                      void_type_node, 2, pchar_type_node,
1912                                      gfc_int4_type_node);
1913
1914   gfor_fndecl_pause_numeric =
1915     gfc_build_library_function_decl (get_identifier (PREFIX("pause_numeric")),
1916                                      void_type_node, 1, gfc_int4_type_node);
1917
1918   gfor_fndecl_pause_string =
1919     gfc_build_library_function_decl (get_identifier (PREFIX("pause_string")),
1920                                      void_type_node, 2, pchar_type_node,
1921                                      gfc_int4_type_node);
1922
1923   gfor_fndecl_select_string =
1924     gfc_build_library_function_decl (get_identifier (PREFIX("select_string")),
1925                                      pvoid_type_node, 0);
1926
1927   gfor_fndecl_runtime_error =
1928     gfc_build_library_function_decl (get_identifier (PREFIX("runtime_error")),
1929                                      void_type_node,
1930                                      3,
1931                                      pchar_type_node, pchar_type_node,
1932                                      gfc_int4_type_node);
1933
1934   gfor_fndecl_in_pack = gfc_build_library_function_decl (
1935         get_identifier (PREFIX("internal_pack")),
1936         pvoid_type_node, 1, pvoid_type_node);
1937
1938   gfor_fndecl_in_unpack = gfc_build_library_function_decl (
1939         get_identifier (PREFIX("internal_unpack")),
1940         pvoid_type_node, 1, pvoid_type_node);
1941
1942   gfor_fndecl_associated =
1943     gfc_build_library_function_decl (
1944                                      get_identifier (PREFIX("associated")),
1945                                      gfc_logical4_type_node,
1946                                      2,
1947                                      ppvoid_type_node,
1948                                      ppvoid_type_node);
1949
1950   gfc_build_intrinsic_function_decls ();
1951   gfc_build_intrinsic_lib_fndecls ();
1952   gfc_build_io_library_fndecls ();
1953 }
1954
1955
1956 /* Evaluate the length of dummy character variables.  */
1957
1958 static tree
1959 gfc_trans_dummy_character (gfc_charlen * cl, tree fnbody)
1960 {
1961   stmtblock_t body;
1962
1963   gfc_finish_decl (cl->backend_decl, NULL_TREE);
1964
1965   gfc_start_block (&body);
1966
1967   /* Evaluate the string length expression.  */
1968   gfc_trans_init_string_length (cl, &body);
1969
1970   gfc_add_expr_to_block (&body, fnbody);
1971   return gfc_finish_block (&body);
1972 }
1973
1974
1975 /* Allocate and cleanup an automatic character variable.  */
1976
1977 static tree
1978 gfc_trans_auto_character_variable (gfc_symbol * sym, tree fnbody)
1979 {
1980   stmtblock_t body;
1981   tree decl;
1982   tree tmp;
1983
1984   gcc_assert (sym->backend_decl);
1985   gcc_assert (sym->ts.cl && sym->ts.cl->length);
1986
1987   gfc_start_block (&body);
1988
1989   /* Evaluate the string length expression.  */
1990   gfc_trans_init_string_length (sym->ts.cl, &body);
1991
1992   decl = sym->backend_decl;
1993
1994   /* Emit a DECL_EXPR for this variable, which will cause the
1995      gimplifier to allocate storage, and all that good stuff.  */
1996   tmp = build1 (DECL_EXPR, TREE_TYPE (decl), decl);
1997   gfc_add_expr_to_block (&body, tmp);
1998
1999   gfc_add_expr_to_block (&body, fnbody);
2000   return gfc_finish_block (&body);
2001 }
2002
2003
2004 /* Generate function entry and exit code, and add it to the function body.
2005    This includes:
2006     Allocation and initialization of array variables.
2007     Allocation of character string variables.
2008     Initialization and possibly repacking of dummy arrays.  */
2009
2010 static tree
2011 gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
2012 {
2013   locus loc;
2014   gfc_symbol *sym;
2015
2016   /* Deal with implicit return variables.  Explicit return variables will
2017      already have been added.  */
2018   if (gfc_return_by_reference (proc_sym) && proc_sym->result == proc_sym)
2019     {
2020       if (!current_fake_result_decl)
2021         {
2022           gfc_entry_list *el = NULL;
2023           if (proc_sym->attr.entry_master)
2024             {
2025               for (el = proc_sym->ns->entries; el; el = el->next)
2026                 if (el->sym != el->sym->result)
2027                   break;
2028             }
2029           if (el == NULL)
2030             warning (0, "Function does not return a value");
2031         }
2032       else if (proc_sym->as)
2033         {
2034           fnbody = gfc_trans_dummy_array_bias (proc_sym,
2035                                                current_fake_result_decl,
2036                                                fnbody);
2037         }
2038       else if (proc_sym->ts.type == BT_CHARACTER)
2039         {
2040           if (TREE_CODE (proc_sym->ts.cl->backend_decl) == VAR_DECL)
2041             fnbody = gfc_trans_dummy_character (proc_sym->ts.cl, fnbody);
2042         }
2043       else
2044         gcc_assert (gfc_option.flag_f2c
2045                     && proc_sym->ts.type == BT_COMPLEX);
2046     }
2047
2048   for (sym = proc_sym->tlink; sym != proc_sym; sym = sym->tlink)
2049     {
2050       if (sym->attr.dimension)
2051         {
2052           switch (sym->as->type)
2053             {
2054             case AS_EXPLICIT:
2055               if (sym->attr.dummy || sym->attr.result)
2056                 fnbody =
2057                   gfc_trans_dummy_array_bias (sym, sym->backend_decl, fnbody);
2058               else if (sym->attr.pointer || sym->attr.allocatable)
2059                 {
2060                   if (TREE_STATIC (sym->backend_decl))
2061                     gfc_trans_static_array_pointer (sym);
2062                   else
2063                     fnbody = gfc_trans_deferred_array (sym, fnbody);
2064                 }
2065               else
2066                 {
2067                   gfc_get_backend_locus (&loc);
2068                   gfc_set_backend_locus (&sym->declared_at);
2069                   fnbody = gfc_trans_auto_array_allocation (sym->backend_decl,
2070                       sym, fnbody);
2071                   gfc_set_backend_locus (&loc);
2072                 }
2073               break;
2074
2075             case AS_ASSUMED_SIZE:
2076               /* Must be a dummy parameter.  */
2077               gcc_assert (sym->attr.dummy);
2078
2079               /* We should always pass assumed size arrays the g77 way.  */
2080               fnbody = gfc_trans_g77_array (sym, fnbody);
2081               break;
2082
2083             case AS_ASSUMED_SHAPE:
2084               /* Must be a dummy parameter.  */
2085               gcc_assert (sym->attr.dummy);
2086
2087               fnbody = gfc_trans_dummy_array_bias (sym, sym->backend_decl,
2088                                                    fnbody);
2089               break;
2090
2091             case AS_DEFERRED:
2092               fnbody = gfc_trans_deferred_array (sym, fnbody);
2093               break;
2094
2095             default:
2096               gcc_unreachable ();
2097             }
2098         }
2099       else if (sym->ts.type == BT_CHARACTER)
2100         {
2101           gfc_get_backend_locus (&loc);
2102           gfc_set_backend_locus (&sym->declared_at);
2103           if (sym->attr.dummy || sym->attr.result)
2104             fnbody = gfc_trans_dummy_character (sym->ts.cl, fnbody);
2105           else
2106             fnbody = gfc_trans_auto_character_variable (sym, fnbody);
2107           gfc_set_backend_locus (&loc);
2108         }
2109       else
2110         gcc_unreachable ();
2111     }
2112
2113   return fnbody;
2114 }
2115
2116
2117 /* Output an initialized decl for a module variable.  */
2118
2119 static void
2120 gfc_create_module_variable (gfc_symbol * sym)
2121 {
2122   tree decl;
2123
2124   /* Only output symbols from this module.  */
2125   if (sym->ns != module_namespace)
2126     {
2127       /* I don't think this should ever happen.  */
2128       internal_error ("module symbol %s in wrong namespace", sym->name);
2129     }
2130
2131   /* Only output variables and array valued parameters.  */
2132   if (sym->attr.flavor != FL_VARIABLE
2133       && (sym->attr.flavor != FL_PARAMETER || sym->attr.dimension == 0))
2134     return;
2135
2136   /* Don't generate variables from other modules. Variables from
2137      COMMONs will already have been generated.  */
2138   if (sym->attr.use_assoc || sym->attr.in_common)
2139     return;
2140
2141   if (sym->backend_decl)
2142     internal_error ("backend decl for module variable %s already exists",
2143                     sym->name);
2144
2145   /* We always want module variables to be created.  */
2146   sym->attr.referenced = 1;
2147   /* Create the decl.  */
2148   decl = gfc_get_symbol_decl (sym);
2149
2150   /* Create the variable.  */
2151   pushdecl (decl);
2152   rest_of_decl_compilation (decl, 1, 0);
2153
2154   /* Also add length of strings.  */
2155   if (sym->ts.type == BT_CHARACTER)
2156     {
2157       tree length;
2158
2159       length = sym->ts.cl->backend_decl;
2160       if (!INTEGER_CST_P (length))
2161         {
2162           pushdecl (length);
2163           rest_of_decl_compilation (length, 1, 0);
2164         }
2165     }
2166 }
2167
2168
2169 /* Generate all the required code for module variables.  */
2170
2171 void
2172 gfc_generate_module_vars (gfc_namespace * ns)
2173 {
2174   module_namespace = ns;
2175
2176   /* Check if the frontend left the namespace in a reasonable state.  */
2177   gcc_assert (ns->proc_name && !ns->proc_name->tlink);
2178
2179   /* Generate COMMON blocks.  */
2180   gfc_trans_common (ns);
2181
2182   /* Create decls for all the module variables.  */
2183   gfc_traverse_ns (ns, gfc_create_module_variable);
2184 }
2185
2186 static void
2187 gfc_generate_contained_functions (gfc_namespace * parent)
2188 {
2189   gfc_namespace *ns;
2190
2191   /* We create all the prototypes before generating any code.  */
2192   for (ns = parent->contained; ns; ns = ns->sibling)
2193     {
2194       /* Skip namespaces from used modules.  */
2195       if (ns->parent != parent)
2196         continue;
2197
2198       gfc_create_function_decl (ns);
2199     }
2200
2201   for (ns = parent->contained; ns; ns = ns->sibling)
2202     {
2203       /* Skip namespaces from used modules.  */
2204       if (ns->parent != parent)
2205         continue;
2206
2207       gfc_generate_function_code (ns);
2208     }
2209 }
2210
2211
2212 /* Generate decls for all local variables.  We do this to ensure correct
2213    handling of expressions which only appear in the specification of
2214    other functions.  */
2215
2216 static void
2217 generate_local_decl (gfc_symbol * sym)
2218 {
2219   if (sym->attr.flavor == FL_VARIABLE)
2220     {
2221       if (sym->attr.referenced)
2222         gfc_get_symbol_decl (sym);
2223       else if (sym->attr.dummy && warn_unused_parameter)
2224             warning (0, "unused parameter %qs", sym->name);
2225       /* Warn for unused variables, but not if they're inside a common
2226          block or are use-associated.  */
2227       else if (warn_unused_variable
2228                && !(sym->attr.in_common || sym->attr.use_assoc))
2229         warning (0, "unused variable %qs", sym->name);
2230     }
2231 }
2232
2233 static void
2234 generate_local_vars (gfc_namespace * ns)
2235 {
2236   gfc_traverse_ns (ns, generate_local_decl);
2237 }
2238
2239
2240 /* Generate a switch statement to jump to the correct entry point.  Also
2241    creates the label decls for the entry points.  */
2242
2243 static tree
2244 gfc_trans_entry_master_switch (gfc_entry_list * el)
2245 {
2246   stmtblock_t block;
2247   tree label;
2248   tree tmp;
2249   tree val;
2250
2251   gfc_init_block (&block);
2252   for (; el; el = el->next)
2253     {
2254       /* Add the case label.  */
2255       label = gfc_build_label_decl (NULL_TREE);
2256       val = build_int_cst (gfc_array_index_type, el->id);
2257       tmp = build3_v (CASE_LABEL_EXPR, val, NULL_TREE, label);
2258       gfc_add_expr_to_block (&block, tmp);
2259
2260       /* And jump to the actual entry point.  */
2261       label = gfc_build_label_decl (NULL_TREE);
2262       tmp = build1_v (GOTO_EXPR, label);
2263       gfc_add_expr_to_block (&block, tmp);
2264
2265       /* Save the label decl.  */
2266       el->label = label;
2267     }
2268   tmp = gfc_finish_block (&block);
2269   /* The first argument selects the entry point.  */
2270   val = DECL_ARGUMENTS (current_function_decl);
2271   tmp = build3_v (SWITCH_EXPR, val, tmp, NULL_TREE);
2272   return tmp;
2273 }
2274
2275
2276 /* Generate code for a function.  */
2277
2278 void
2279 gfc_generate_function_code (gfc_namespace * ns)
2280 {
2281   tree fndecl;
2282   tree old_context;
2283   tree decl;
2284   tree tmp;
2285   stmtblock_t block;
2286   stmtblock_t body;
2287   tree result;
2288   gfc_symbol *sym;
2289
2290   sym = ns->proc_name;
2291
2292   /* Check that the frontend isn't still using this.  */
2293   gcc_assert (sym->tlink == NULL);
2294   sym->tlink = sym;
2295
2296   /* Create the declaration for functions with global scope.  */
2297   if (!sym->backend_decl)
2298     gfc_create_function_decl (ns);
2299
2300   fndecl = sym->backend_decl;
2301   old_context = current_function_decl;
2302
2303   if (old_context)
2304     {
2305       push_function_context ();
2306       saved_parent_function_decls = saved_function_decls;
2307       saved_function_decls = NULL_TREE;
2308     }
2309
2310   trans_function_start (sym);
2311
2312   /* Will be created as needed.  */
2313   current_fake_result_decl = NULL_TREE;
2314
2315   gfc_start_block (&block);
2316
2317   gfc_generate_contained_functions (ns);
2318
2319   if (ns->entries && ns->proc_name->ts.type == BT_CHARACTER)
2320     {
2321       /* Copy length backend_decls to all entry point result
2322          symbols.  */
2323       gfc_entry_list *el;
2324       tree backend_decl;
2325
2326       gfc_conv_const_charlen (ns->proc_name->ts.cl);
2327       backend_decl = ns->proc_name->result->ts.cl->backend_decl;
2328       for (el = ns->entries; el; el = el->next)
2329         el->sym->result->ts.cl->backend_decl = backend_decl;
2330     }
2331
2332   /* Translate COMMON blocks.  */
2333   gfc_trans_common (ns);
2334
2335   generate_local_vars (ns);
2336
2337   current_function_return_label = NULL;
2338
2339   /* Now generate the code for the body of this function.  */
2340   gfc_init_block (&body);
2341
2342   if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node
2343       && sym->attr.subroutine)
2344     {
2345       tree alternate_return;
2346       alternate_return = gfc_get_fake_result_decl (sym);
2347       gfc_add_modify_expr (&body, alternate_return, integer_zero_node);
2348     }
2349
2350   if (ns->entries)
2351     {
2352       /* Jump to the correct entry point.  */
2353       tmp = gfc_trans_entry_master_switch (ns->entries);
2354       gfc_add_expr_to_block (&body, tmp);
2355     }
2356
2357   tmp = gfc_trans_code (ns->code);
2358   gfc_add_expr_to_block (&body, tmp);
2359
2360   /* Add a return label if needed.  */
2361   if (current_function_return_label)
2362     {
2363       tmp = build1_v (LABEL_EXPR, current_function_return_label);
2364       gfc_add_expr_to_block (&body, tmp);
2365     }
2366
2367   tmp = gfc_finish_block (&body);
2368   /* Add code to create and cleanup arrays.  */
2369   tmp = gfc_trans_deferred_vars (sym, tmp);
2370   gfc_add_expr_to_block (&block, tmp);
2371
2372   if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node)
2373     {
2374       if (sym->attr.subroutine || sym == sym->result)
2375         {
2376           result = current_fake_result_decl;
2377           current_fake_result_decl = NULL_TREE;
2378         }
2379       else
2380         result = sym->result->backend_decl;
2381
2382       if (result == NULL_TREE)
2383         warning (0, "Function return value not set");
2384       else
2385         {
2386           /* Set the return value to the dummy result variable.  */
2387           tmp = build2 (MODIFY_EXPR, TREE_TYPE (result),
2388                         DECL_RESULT (fndecl), result);
2389           tmp = build1_v (RETURN_EXPR, tmp);
2390           gfc_add_expr_to_block (&block, tmp);
2391         }
2392     }
2393
2394   /* Add all the decls we created during processing.  */
2395   decl = saved_function_decls;
2396   while (decl)
2397     {
2398       tree next;
2399
2400       next = TREE_CHAIN (decl);
2401       TREE_CHAIN (decl) = NULL_TREE;
2402       pushdecl (decl);
2403       decl = next;
2404     }
2405   saved_function_decls = NULL_TREE;
2406
2407   DECL_SAVED_TREE (fndecl) = gfc_finish_block (&block);
2408
2409   /* Finish off this function and send it for code generation.  */
2410   poplevel (1, 0, 1);
2411   BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
2412
2413   /* Output the GENERIC tree.  */
2414   dump_function (TDI_original, fndecl);
2415
2416   /* Store the end of the function, so that we get good line number
2417      info for the epilogue.  */
2418   cfun->function_end_locus = input_location;
2419
2420   /* We're leaving the context of this function, so zap cfun.
2421      It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
2422      tree_rest_of_compilation.  */
2423   cfun = NULL;
2424
2425   if (old_context)
2426     {
2427       pop_function_context ();
2428       saved_function_decls = saved_parent_function_decls;
2429     }
2430   current_function_decl = old_context;
2431
2432   if (decl_function_context (fndecl))
2433     /* Register this function with cgraph just far enough to get it
2434        added to our parent's nested function list.  */
2435     (void) cgraph_node (fndecl);
2436   else
2437     {
2438       gfc_gimplify_function (fndecl);
2439       cgraph_finalize_function (fndecl, false);
2440     }
2441 }
2442
2443 void
2444 gfc_generate_constructors (void)
2445 {
2446   gcc_assert (gfc_static_ctors == NULL_TREE);
2447 #if 0
2448   tree fnname;
2449   tree type;
2450   tree fndecl;
2451   tree decl;
2452   tree tmp;
2453
2454   if (gfc_static_ctors == NULL_TREE)
2455     return;
2456
2457   fnname = get_file_function_name ('I');
2458   type = build_function_type (void_type_node,
2459                               gfc_chainon_list (NULL_TREE, void_type_node));
2460
2461   fndecl = build_decl (FUNCTION_DECL, fnname, type);
2462   TREE_PUBLIC (fndecl) = 1;
2463
2464   decl = build_decl (RESULT_DECL, NULL_TREE, void_type_node);
2465   DECL_ARTIFICIAL (decl) = 1;
2466   DECL_IGNORED_P (decl) = 1;
2467   DECL_CONTEXT (decl) = fndecl;
2468   DECL_RESULT (fndecl) = decl;
2469
2470   pushdecl (fndecl);
2471
2472   current_function_decl = fndecl;
2473
2474   rest_of_decl_compilation (fndecl, 1, 0);
2475
2476   make_decl_rtl (fndecl);
2477
2478   init_function_start (fndecl);
2479
2480   pushlevel (0);
2481
2482   for (; gfc_static_ctors; gfc_static_ctors = TREE_CHAIN (gfc_static_ctors))
2483     {
2484       tmp =
2485         gfc_build_function_call (TREE_VALUE (gfc_static_ctors), NULL_TREE);
2486       DECL_SAVED_TREE (fndecl) = build_stmt (EXPR_STMT, tmp);
2487     }
2488
2489   poplevel (1, 0, 1);
2490
2491   BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
2492
2493   free_after_parsing (cfun);
2494   free_after_compilation (cfun);
2495
2496   tree_rest_of_compilation (fndecl);
2497
2498   current_function_decl = NULL_TREE;
2499 #endif
2500 }
2501
2502 /* Translates a BLOCK DATA program unit. This means emitting the
2503    commons contained therein plus their initializations. We also emit
2504    a globally visible symbol to make sure that each BLOCK DATA program
2505    unit remains unique.  */
2506
2507 void
2508 gfc_generate_block_data (gfc_namespace * ns)
2509 {
2510   tree decl;
2511   tree id;
2512
2513   /* Tell the backend the source location of the block data.  */
2514   if (ns->proc_name)
2515     gfc_set_backend_locus (&ns->proc_name->declared_at);
2516   else
2517     gfc_set_backend_locus (&gfc_current_locus);
2518
2519   /* Process the DATA statements.  */
2520   gfc_trans_common (ns);
2521
2522   /* Create a global symbol with the mane of the block data.  This is to
2523      generate linker errors if the same name is used twice.  It is never
2524      really used.  */
2525   if (ns->proc_name)
2526     id = gfc_sym_mangled_function_id (ns->proc_name);
2527   else
2528     id = get_identifier ("__BLOCK_DATA__");
2529
2530   decl = build_decl (VAR_DECL, id, gfc_array_index_type);
2531   TREE_PUBLIC (decl) = 1;
2532   TREE_STATIC (decl) = 1;
2533
2534   pushdecl (decl);
2535   rest_of_decl_compilation (decl, 1, 0);
2536 }
2537
2538 #include "gt-fortran-trans-decl.h"