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