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