gcc/fortran/trans-decl.c

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