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