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           if (isym->formal->next->next == NULL)
1079             isym->resolve.f2 (&e, &argexpr, NULL);
1080           else
1081             {
1082               /* All specific intrinsics take less than 4 arguments.  */
1083               gcc_assert (isym->formal->next->next->next == NULL);
1084               isym->resolve.f3 (&e, &argexpr, NULL, NULL);
1085             }
1086         }
1087
1088       if (gfc_option.flag_f2c
1089           && ((e.ts.type == BT_REAL && e.ts.kind == gfc_default_real_kind)
1090               || e.ts.type == BT_COMPLEX))
1091         {
1092           /* Specific which needs a different implementation if f2c
1093              calling conventions are used.  */
1094           sprintf (s, "f2c_specific%s", e.value.function.name);
1095         }
1096       else
1097         sprintf (s, "specific%s", e.value.function.name);
1098
1099       name = get_identifier (s);
1100       mangled_name = name;
1101     }
1102   else
1103     {
1104       name = gfc_sym_identifier (sym);
1105       mangled_name = gfc_sym_mangled_function_id (sym);
1106     }
1107
1108   type = gfc_get_function_type (sym);
1109   fndecl = build_decl (FUNCTION_DECL, name, type);
1110
1111   SET_DECL_ASSEMBLER_NAME (fndecl, mangled_name);
1112   /* If the return type is a pointer, avoid alias issues by setting
1113      DECL_IS_MALLOC to nonzero. This means that the function should be
1114      treated as if it were a malloc, meaning it returns a pointer that
1115      is not an alias.  */
1116   if (POINTER_TYPE_P (type))
1117     DECL_IS_MALLOC (fndecl) = 1;
1118
1119   /* Set the context of this decl.  */
1120   if (0 && sym->ns && sym->ns->proc_name)
1121     {
1122       /* TODO: Add external decls to the appropriate scope.  */
1123       DECL_CONTEXT (fndecl) = sym->ns->proc_name->backend_decl;
1124     }
1125   else
1126     {
1127       /* Global declaration, e.g. intrinsic subroutine.  */
1128       DECL_CONTEXT (fndecl) = NULL_TREE;
1129     }
1130
1131   DECL_EXTERNAL (fndecl) = 1;
1132
1133   /* This specifies if a function is globally addressable, i.e. it is
1134      the opposite of declaring static in C.  */
1135   TREE_PUBLIC (fndecl) = 1;
1136
1137   /* Set attributes for PURE functions. A call to PURE function in the
1138      Fortran 95 sense is both pure and without side effects in the C
1139      sense.  */
1140   if (sym->attr.pure || sym->attr.elemental)
1141     {
1142       if (sym->attr.function && !gfc_return_by_reference (sym))
1143         DECL_IS_PURE (fndecl) = 1;
1144       /* TODO: check if pure SUBROUTINEs don't have INTENT(OUT)
1145          parameters and don't use alternate returns (is this
1146          allowed?). In that case, calls to them are meaningless, and
1147          can be optimized away. See also in build_function_decl().  */
1148       TREE_SIDE_EFFECTS (fndecl) = 0;
1149     }
1150
1151   /* Mark non-returning functions.  */
1152   if (sym->attr.noreturn)
1153       TREE_THIS_VOLATILE(fndecl) = 1;
1154
1155   sym->backend_decl = fndecl;
1156
1157   if (DECL_CONTEXT (fndecl) == NULL_TREE)
1158     pushdecl_top_level (fndecl);
1159
1160   return fndecl;
1161 }
1162
1163
1164 /* Create a declaration for a procedure.  For external functions (in the C
1165    sense) use gfc_get_extern_function_decl.  HAS_ENTRIES is true if this is
1166    a master function with alternate entry points.  */
1167
1168 static void
1169 build_function_decl (gfc_symbol * sym)
1170 {
1171   tree fndecl, type;
1172   symbol_attribute attr;
1173   tree result_decl;
1174   gfc_formal_arglist *f;
1175
1176   gcc_assert (!sym->backend_decl);
1177   gcc_assert (!sym->attr.external);
1178
1179   /* Set the line and filename.  sym->declared_at seems to point to the
1180      last statement for subroutines, but it'll do for now.  */
1181   gfc_set_backend_locus (&sym->declared_at);
1182
1183   /* Allow only one nesting level.  Allow public declarations.  */
1184   gcc_assert (current_function_decl == NULL_TREE
1185           || DECL_CONTEXT (current_function_decl) == NULL_TREE);
1186
1187   type = gfc_get_function_type (sym);
1188   fndecl = build_decl (FUNCTION_DECL, gfc_sym_identifier (sym), type);
1189
1190   /* Perform name mangling if this is a top level or module procedure.  */
1191   if (current_function_decl == NULL_TREE)
1192     SET_DECL_ASSEMBLER_NAME (fndecl, gfc_sym_mangled_function_id (sym));
1193
1194   /* Figure out the return type of the declared function, and build a
1195      RESULT_DECL for it.  If this is a subroutine with alternate
1196      returns, build a RESULT_DECL for it.  */
1197   attr = sym->attr;
1198
1199   result_decl = NULL_TREE;
1200   /* TODO: Shouldn't this just be TREE_TYPE (TREE_TYPE (fndecl)).  */
1201   if (attr.function)
1202     {
1203       if (gfc_return_by_reference (sym))
1204         type = void_type_node;
1205       else
1206         {
1207           if (sym->result != sym)
1208             result_decl = gfc_sym_identifier (sym->result);
1209
1210           type = TREE_TYPE (TREE_TYPE (fndecl));
1211         }
1212     }
1213   else
1214     {
1215       /* Look for alternate return placeholders.  */
1216       int has_alternate_returns = 0;
1217       for (f = sym->formal; f; f = f->next)
1218         {
1219           if (f->sym == NULL)
1220             {
1221               has_alternate_returns = 1;
1222               break;
1223             }
1224         }
1225
1226       if (has_alternate_returns)
1227         type = integer_type_node;
1228       else
1229         type = void_type_node;
1230     }
1231
1232   result_decl = build_decl (RESULT_DECL, result_decl, type);
1233   DECL_ARTIFICIAL (result_decl) = 1;
1234   DECL_IGNORED_P (result_decl) = 1;
1235   DECL_CONTEXT (result_decl) = fndecl;
1236   DECL_RESULT (fndecl) = result_decl;
1237
1238   /* Don't call layout_decl for a RESULT_DECL.
1239      layout_decl (result_decl, 0);  */
1240
1241   /* If the return type is a pointer, avoid alias issues by setting
1242      DECL_IS_MALLOC to nonzero. This means that the function should be
1243      treated as if it were a malloc, meaning it returns a pointer that
1244      is not an alias.  */
1245   if (POINTER_TYPE_P (type))
1246     DECL_IS_MALLOC (fndecl) = 1;
1247
1248   /* Set up all attributes for the function.  */
1249   DECL_CONTEXT (fndecl) = current_function_decl;
1250   DECL_EXTERNAL (fndecl) = 0;
1251
1252   /* This specifies if a function is globally visible, i.e. it is
1253      the opposite of declaring static in C.  */
1254   if (DECL_CONTEXT (fndecl) == NULL_TREE
1255       && !sym->attr.entry_master)
1256     TREE_PUBLIC (fndecl) = 1;
1257
1258   /* TREE_STATIC means the function body is defined here.  */
1259   TREE_STATIC (fndecl) = 1;
1260
1261   /* Set attributes for PURE functions. A call to a PURE function in the
1262      Fortran 95 sense is both pure and without side effects in the C
1263      sense.  */
1264   if (attr.pure || attr.elemental)
1265     {
1266       /* TODO: check if a pure SUBROUTINE has no INTENT(OUT) arguments
1267          including a alternate return. In that case it can also be
1268          marked as PURE. See also in gfc_get_extern_function_decl().  */
1269       if (attr.function && !gfc_return_by_reference (sym))
1270         DECL_IS_PURE (fndecl) = 1;
1271       TREE_SIDE_EFFECTS (fndecl) = 0;
1272     }
1273
1274   /* Layout the function declaration and put it in the binding level
1275      of the current function.  */
1276   pushdecl (fndecl);
1277
1278   sym->backend_decl = fndecl;
1279 }
1280
1281
1282 /* Create the DECL_ARGUMENTS for a procedure.  */
1283
1284 static void
1285 create_function_arglist (gfc_symbol * sym)
1286 {
1287   tree fndecl;
1288   gfc_formal_arglist *f;
1289   tree typelist, hidden_typelist;
1290   tree arglist, hidden_arglist;
1291   tree type;
1292   tree parm;
1293
1294   fndecl = sym->backend_decl;
1295
1296   /* Build formal argument list. Make sure that their TREE_CONTEXT is
1297      the new FUNCTION_DECL node.  */
1298   arglist = NULL_TREE;
1299   hidden_arglist = NULL_TREE;
1300   typelist = TYPE_ARG_TYPES (TREE_TYPE (fndecl));
1301
1302   if (sym->attr.entry_master)
1303     {
1304       type = TREE_VALUE (typelist);
1305       parm = build_decl (PARM_DECL, get_identifier ("__entry"), type);
1306
1307       DECL_CONTEXT (parm) = fndecl;
1308       DECL_ARG_TYPE (parm) = type;
1309       TREE_READONLY (parm) = 1;
1310       gfc_finish_decl (parm, NULL_TREE);
1311       DECL_ARTIFICIAL (parm) = 1;
1312
1313       arglist = chainon (arglist, parm);
1314       typelist = TREE_CHAIN (typelist);
1315     }
1316
1317   if (gfc_return_by_reference (sym))
1318     {
1319       tree type = TREE_VALUE (typelist), length = NULL;
1320
1321       if (sym->ts.type == BT_CHARACTER)
1322         {
1323           /* Length of character result.  */
1324           tree len_type = TREE_VALUE (TREE_CHAIN (typelist));
1325           gcc_assert (len_type == gfc_charlen_type_node);
1326
1327           length = build_decl (PARM_DECL,
1328                                get_identifier (".__result"),
1329                                len_type);
1330           if (!sym->ts.cl->length)
1331             {
1332               sym->ts.cl->backend_decl = length;
1333               TREE_USED (length) = 1;
1334             }
1335           gcc_assert (TREE_CODE (length) == PARM_DECL);
1336           DECL_CONTEXT (length) = fndecl;
1337           DECL_ARG_TYPE (length) = len_type;
1338           TREE_READONLY (length) = 1;
1339           DECL_ARTIFICIAL (length) = 1;
1340           gfc_finish_decl (length, NULL_TREE);
1341           if (sym->ts.cl->backend_decl == NULL
1342               || sym->ts.cl->backend_decl == length)
1343             {
1344               gfc_symbol *arg;
1345               tree backend_decl;
1346
1347               if (sym->ts.cl->backend_decl == NULL)
1348                 {
1349                   tree len = build_decl (VAR_DECL,
1350                                          get_identifier ("..__result"),
1351                                          gfc_charlen_type_node);
1352                   DECL_ARTIFICIAL (len) = 1;
1353                   TREE_USED (len) = 1;
1354                   sym->ts.cl->backend_decl = len;
1355                 }
1356
1357               /* Make sure PARM_DECL type doesn't point to incomplete type.  */
1358               arg = sym->result ? sym->result : sym;
1359               backend_decl = arg->backend_decl;
1360               /* Temporary clear it, so that gfc_sym_type creates complete
1361                  type.  */
1362               arg->backend_decl = NULL;
1363               type = gfc_sym_type (arg);
1364               arg->backend_decl = backend_decl;
1365               type = build_reference_type (type);
1366             }
1367         }
1368
1369       parm = build_decl (PARM_DECL, get_identifier ("__result"), type);
1370
1371       DECL_CONTEXT (parm) = fndecl;
1372       DECL_ARG_TYPE (parm) = TREE_VALUE (typelist);
1373       TREE_READONLY (parm) = 1;
1374       DECL_ARTIFICIAL (parm) = 1;
1375       gfc_finish_decl (parm, NULL_TREE);
1376
1377       arglist = chainon (arglist, parm);
1378       typelist = TREE_CHAIN (typelist);
1379
1380       if (sym->ts.type == BT_CHARACTER)
1381         {
1382           gfc_allocate_lang_decl (parm);
1383           arglist = chainon (arglist, length);
1384           typelist = TREE_CHAIN (typelist);
1385         }
1386     }
1387
1388   hidden_typelist = typelist;
1389   for (f = sym->formal; f; f = f->next)
1390     if (f->sym != NULL) /* Ignore alternate returns.  */
1391       hidden_typelist = TREE_CHAIN (hidden_typelist);
1392
1393   for (f = sym->formal; f; f = f->next)
1394     {
1395       char name[GFC_MAX_SYMBOL_LEN + 2];
1396
1397       /* Ignore alternate returns.  */
1398       if (f->sym == NULL)
1399         continue;
1400
1401       type = TREE_VALUE (typelist);
1402
1403       if (f->sym->ts.type == BT_CHARACTER)
1404         {
1405           tree len_type = TREE_VALUE (hidden_typelist);
1406           tree length = NULL_TREE;
1407           gcc_assert (len_type == gfc_charlen_type_node);
1408
1409           strcpy (&name[1], f->sym->name);
1410           name[0] = '_';
1411           length = build_decl (PARM_DECL, get_identifier (name), len_type);
1412
1413           hidden_arglist = chainon (hidden_arglist, length);
1414           DECL_CONTEXT (length) = fndecl;
1415           DECL_ARTIFICIAL (length) = 1;
1416           DECL_ARG_TYPE (length) = len_type;
1417           TREE_READONLY (length) = 1;
1418           gfc_finish_decl (length, NULL_TREE);
1419
1420           /* TODO: Check string lengths when -fbounds-check.  */
1421
1422           /* Use the passed value for assumed length variables.  */
1423           if (!f->sym->ts.cl->length)
1424             {
1425               TREE_USED (length) = 1;
1426               if (!f->sym->ts.cl->backend_decl)
1427                 f->sym->ts.cl->backend_decl = length;
1428               else
1429                 {
1430                   /* there is already another variable using this
1431                      gfc_charlen node, build a new one for this variable
1432                      and chain it into the list of gfc_charlens.
1433                      This happens for e.g. in the case
1434                      CHARACTER(*)::c1,c2
1435                      since CHARACTER declarations on the same line share
1436                      the same gfc_charlen node.  */
1437                   gfc_charlen *cl;
1438
1439                   cl = gfc_get_charlen ();
1440                   cl->backend_decl = length;
1441                   cl->next = f->sym->ts.cl->next;
1442                   f->sym->ts.cl->next = cl;
1443                   f->sym->ts.cl = cl;
1444                 }
1445             }
1446
1447           hidden_typelist = TREE_CHAIN (hidden_typelist);
1448
1449           if (f->sym->ts.cl->backend_decl == NULL
1450               || f->sym->ts.cl->backend_decl == length)
1451             {
1452               if (f->sym->ts.cl->backend_decl == NULL)
1453                 gfc_create_string_length (f->sym);
1454
1455               /* Make sure PARM_DECL type doesn't point to incomplete type.  */
1456               if (f->sym->attr.flavor == FL_PROCEDURE)
1457                 type = build_pointer_type (gfc_get_function_type (f->sym));
1458               else
1459                 type = gfc_sym_type (f->sym);
1460             }
1461         }
1462
1463       /* For non-constant length array arguments, make sure they use
1464          a different type node from TYPE_ARG_TYPES type.  */
1465       if (f->sym->attr.dimension
1466           && type == TREE_VALUE (typelist)
1467           && TREE_CODE (type) == POINTER_TYPE
1468           && GFC_ARRAY_TYPE_P (type)
1469           && f->sym->as->type != AS_ASSUMED_SIZE
1470           && ! COMPLETE_TYPE_P (TREE_TYPE (type)))
1471         {
1472           if (f->sym->attr.flavor == FL_PROCEDURE)
1473             type = build_pointer_type (gfc_get_function_type (f->sym));
1474           else
1475             type = gfc_sym_type (f->sym);
1476         }
1477
1478       /* Build a the argument declaration.  */
1479       parm = build_decl (PARM_DECL, gfc_sym_identifier (f->sym), type);
1480
1481       /* Fill in arg stuff.  */
1482       DECL_CONTEXT (parm) = fndecl;
1483       DECL_ARG_TYPE (parm) = TREE_VALUE (typelist);
1484       /* All implementation args are read-only.  */
1485       TREE_READONLY (parm) = 1;
1486
1487       gfc_finish_decl (parm, NULL_TREE);
1488
1489       f->sym->backend_decl = parm;
1490
1491       arglist = chainon (arglist, parm);
1492       typelist = TREE_CHAIN (typelist);
1493     }
1494
1495   /* Add the hidden string length parameters.  */
1496   arglist = chainon (arglist, hidden_arglist);
1497
1498   gcc_assert (TREE_VALUE (hidden_typelist) == void_type_node);
1499   DECL_ARGUMENTS (fndecl) = arglist;
1500 }
1501
1502 /* Convert FNDECL's code to GIMPLE and handle any nested functions.  */
1503
1504 static void
1505 gfc_gimplify_function (tree fndecl)
1506 {
1507   struct cgraph_node *cgn;
1508
1509   gimplify_function_tree (fndecl);
1510   dump_function (TDI_generic, fndecl);
1511
1512   /* Generate errors for structured block violations.  */
1513   /* ??? Could be done as part of resolve_labels.  */
1514   if (flag_openmp)
1515     diagnose_omp_structured_block_errors (fndecl);
1516
1517   /* Convert all nested functions to GIMPLE now.  We do things in this order
1518      so that items like VLA sizes are expanded properly in the context of the
1519      correct function.  */
1520   cgn = cgraph_node (fndecl);
1521   for (cgn = cgn->nested; cgn; cgn = cgn->next_nested)
1522     gfc_gimplify_function (cgn->decl);
1523 }
1524
1525
1526 /* Do the setup necessary before generating the body of a function.  */
1527
1528 static void
1529 trans_function_start (gfc_symbol * sym)
1530 {
1531   tree fndecl;
1532
1533   fndecl = sym->backend_decl;
1534
1535   /* Let GCC know the current scope is this function.  */
1536   current_function_decl = fndecl;
1537
1538   /* Let the world know what we're about to do.  */
1539   announce_function (fndecl);
1540
1541   if (DECL_CONTEXT (fndecl) == NULL_TREE)
1542     {
1543       /* Create RTL for function declaration.  */
1544       rest_of_decl_compilation (fndecl, 1, 0);
1545     }
1546
1547   /* Create RTL for function definition.  */
1548   make_decl_rtl (fndecl);
1549
1550   init_function_start (fndecl);
1551
1552   /* Even though we're inside a function body, we still don't want to
1553      call expand_expr to calculate the size of a variable-sized array.
1554      We haven't necessarily assigned RTL to all variables yet, so it's
1555      not safe to try to expand expressions involving them.  */
1556   cfun->x_dont_save_pending_sizes_p = 1;
1557
1558   /* function.c requires a push at the start of the function.  */
1559   pushlevel (0);
1560 }
1561
1562 /* Create thunks for alternate entry points.  */
1563
1564 static void
1565 build_entry_thunks (gfc_namespace * ns)
1566 {
1567   gfc_formal_arglist *formal;
1568   gfc_formal_arglist *thunk_formal;
1569   gfc_entry_list *el;
1570   gfc_symbol *thunk_sym;
1571   stmtblock_t body;
1572   tree thunk_fndecl;
1573   tree args;
1574   tree string_args;
1575   tree tmp;
1576   locus old_loc;
1577
1578   /* This should always be a toplevel function.  */
1579   gcc_assert (current_function_decl == NULL_TREE);
1580
1581   gfc_get_backend_locus (&old_loc);
1582   for (el = ns->entries; el; el = el->next)
1583     {
1584       thunk_sym = el->sym;
1585
1586       build_function_decl (thunk_sym);
1587       create_function_arglist (thunk_sym);
1588
1589       trans_function_start (thunk_sym);
1590
1591       thunk_fndecl = thunk_sym->backend_decl;
1592
1593       gfc_start_block (&body);
1594
1595       /* Pass extra parameter identifying this entry point.  */
1596       tmp = build_int_cst (gfc_array_index_type, el->id);
1597       args = tree_cons (NULL_TREE, tmp, NULL_TREE);
1598       string_args = NULL_TREE;
1599
1600       if (thunk_sym->attr.function)
1601         {
1602           if (gfc_return_by_reference (ns->proc_name))
1603             {
1604               tree ref = DECL_ARGUMENTS (current_function_decl);
1605               args = tree_cons (NULL_TREE, ref, args);
1606               if (ns->proc_name->ts.type == BT_CHARACTER)
1607                 args = tree_cons (NULL_TREE, TREE_CHAIN (ref),
1608                                   args);
1609             }
1610         }
1611
1612       for (formal = ns->proc_name->formal; formal; formal = formal->next)
1613         {
1614           /* Ignore alternate returns.  */
1615           if (formal->sym == NULL)
1616             continue;
1617
1618           /* We don't have a clever way of identifying arguments, so resort to
1619              a brute-force search.  */
1620           for (thunk_formal = thunk_sym->formal;
1621                thunk_formal;
1622                thunk_formal = thunk_formal->next)
1623             {
1624               if (thunk_formal->sym == formal->sym)
1625                 break;
1626             }
1627
1628           if (thunk_formal)
1629             {
1630               /* Pass the argument.  */
1631               DECL_ARTIFICIAL (thunk_formal->sym->backend_decl) = 1;
1632               args = tree_cons (NULL_TREE, thunk_formal->sym->backend_decl,
1633                                 args);
1634               if (formal->sym->ts.type == BT_CHARACTER)
1635                 {
1636                   tmp = thunk_formal->sym->ts.cl->backend_decl;
1637                   string_args = tree_cons (NULL_TREE, tmp, string_args);
1638                 }
1639             }
1640           else
1641             {
1642               /* Pass NULL for a missing argument.  */
1643               args = tree_cons (NULL_TREE, null_pointer_node, args);
1644               if (formal->sym->ts.type == BT_CHARACTER)
1645                 {
1646                   tmp = build_int_cst (gfc_charlen_type_node, 0);
1647                   string_args = tree_cons (NULL_TREE, tmp, string_args);
1648                 }
1649             }
1650         }
1651
1652       /* Call the master function.  */
1653       args = nreverse (args);
1654       args = chainon (args, nreverse (string_args));
1655       tmp = ns->proc_name->backend_decl;
1656       tmp = build_function_call_expr (tmp, args);
1657       if (ns->proc_name->attr.mixed_entry_master)
1658         {
1659           tree union_decl, field;
1660           tree master_type = TREE_TYPE (ns->proc_name->backend_decl);
1661
1662           union_decl = build_decl (VAR_DECL, get_identifier ("__result"),
1663                                    TREE_TYPE (master_type));
1664           DECL_ARTIFICIAL (union_decl) = 1;
1665           DECL_EXTERNAL (union_decl) = 0;
1666           TREE_PUBLIC (union_decl) = 0;
1667           TREE_USED (union_decl) = 1;
1668           layout_decl (union_decl, 0);
1669           pushdecl (union_decl);
1670
1671           DECL_CONTEXT (union_decl) = current_function_decl;
1672           tmp = build2 (MODIFY_EXPR,
1673                         TREE_TYPE (union_decl),
1674                         union_decl, tmp);
1675           gfc_add_expr_to_block (&body, tmp);
1676
1677           for (field = TYPE_FIELDS (TREE_TYPE (union_decl));
1678                field; field = TREE_CHAIN (field))
1679             if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
1680                 thunk_sym->result->name) == 0)
1681               break;
1682           gcc_assert (field != NULL_TREE);
1683           tmp = build3 (COMPONENT_REF, TREE_TYPE (field), union_decl, field,
1684                         NULL_TREE);
1685           tmp = build2 (MODIFY_EXPR,
1686                         TREE_TYPE (DECL_RESULT (current_function_decl)),
1687                         DECL_RESULT (current_function_decl), tmp);
1688           tmp = build1_v (RETURN_EXPR, tmp);
1689         }
1690       else if (TREE_TYPE (DECL_RESULT (current_function_decl))
1691                != void_type_node)
1692         {
1693           tmp = build2 (MODIFY_EXPR,
1694                         TREE_TYPE (DECL_RESULT (current_function_decl)),
1695                         DECL_RESULT (current_function_decl), tmp);
1696           tmp = build1_v (RETURN_EXPR, tmp);
1697         }
1698       gfc_add_expr_to_block (&body, tmp);
1699
1700       /* Finish off this function and send it for code generation.  */
1701       DECL_SAVED_TREE (thunk_fndecl) = gfc_finish_block (&body);
1702       poplevel (1, 0, 1);
1703       BLOCK_SUPERCONTEXT (DECL_INITIAL (thunk_fndecl)) = thunk_fndecl;
1704
1705       /* Output the GENERIC tree.  */
1706       dump_function (TDI_original, thunk_fndecl);
1707
1708       /* Store the end of the function, so that we get good line number
1709          info for the epilogue.  */
1710       cfun->function_end_locus = input_location;
1711
1712       /* We're leaving the context of this function, so zap cfun.
1713          It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
1714          tree_rest_of_compilation.  */
1715       cfun = NULL;
1716
1717       current_function_decl = NULL_TREE;
1718
1719       gfc_gimplify_function (thunk_fndecl);
1720       cgraph_finalize_function (thunk_fndecl, false);
1721
1722       /* We share the symbols in the formal argument list with other entry
1723          points and the master function.  Clear them so that they are
1724          recreated for each function.  */
1725       for (formal = thunk_sym->formal; formal; formal = formal->next)
1726         if (formal->sym != NULL)  /* Ignore alternate returns.  */
1727           {
1728             formal->sym->backend_decl = NULL_TREE;
1729             if (formal->sym->ts.type == BT_CHARACTER)
1730               formal->sym->ts.cl->backend_decl = NULL_TREE;
1731           }
1732
1733       if (thunk_sym->attr.function)
1734         {
1735           if (thunk_sym->ts.type == BT_CHARACTER)
1736             thunk_sym->ts.cl->backend_decl = NULL_TREE;
1737           if (thunk_sym->result->ts.type == BT_CHARACTER)
1738             thunk_sym->result->ts.cl->backend_decl = NULL_TREE;
1739         }
1740     }
1741
1742   gfc_set_backend_locus (&old_loc);
1743 }
1744
1745
1746 /* Create a decl for a function, and create any thunks for alternate entry
1747    points.  */
1748
1749 void
1750 gfc_create_function_decl (gfc_namespace * ns)
1751 {
1752   /* Create a declaration for the master function.  */
1753   build_function_decl (ns->proc_name);
1754
1755   /* Compile the entry thunks.  */
1756   if (ns->entries)
1757     build_entry_thunks (ns);
1758
1759   /* Now create the read argument list.  */
1760   create_function_arglist (ns->proc_name);
1761 }
1762
1763 /* Return the decl used to hold the function return value.  If
1764    parent_flag is set, the context is the parent_scope*/
1765
1766 tree
1767 gfc_get_fake_result_decl (gfc_symbol * sym, int parent_flag)
1768 {
1769   tree decl;
1770   tree length;
1771   tree this_fake_result_decl;
1772   tree this_function_decl;
1773
1774   char name[GFC_MAX_SYMBOL_LEN + 10];
1775
1776   if (parent_flag)
1777     {
1778       this_fake_result_decl = parent_fake_result_decl;
1779       this_function_decl = DECL_CONTEXT (current_function_decl);
1780     }
1781   else
1782     {
1783       this_fake_result_decl = current_fake_result_decl;
1784       this_function_decl = current_function_decl;
1785     }
1786
1787   if (sym
1788       && sym->ns->proc_name->backend_decl == this_function_decl
1789       && sym->ns->proc_name->attr.entry_master
1790       && sym != sym->ns->proc_name)
1791     {
1792       tree t = NULL, var;
1793       if (this_fake_result_decl != NULL)
1794         for (t = TREE_CHAIN (this_fake_result_decl); t; t = TREE_CHAIN (t))
1795           if (strcmp (IDENTIFIER_POINTER (TREE_PURPOSE (t)), sym->name) == 0)
1796             break;
1797       if (t)
1798         return TREE_VALUE (t);
1799       decl = gfc_get_fake_result_decl (sym->ns->proc_name, parent_flag);
1800
1801       if (parent_flag)
1802         this_fake_result_decl = parent_fake_result_decl;
1803       else
1804         this_fake_result_decl = current_fake_result_decl;
1805
1806       if (decl && sym->ns->proc_name->attr.mixed_entry_master)
1807         {
1808           tree field;
1809
1810           for (field = TYPE_FIELDS (TREE_TYPE (decl));
1811                field; field = TREE_CHAIN (field))
1812             if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
1813                 sym->name) == 0)
1814               break;
1815
1816           gcc_assert (field != NULL_TREE);
1817           decl = build3 (COMPONENT_REF, TREE_TYPE (field), decl, field,
1818                          NULL_TREE);
1819         }
1820
1821       var = create_tmp_var_raw (TREE_TYPE (decl), sym->name);
1822       if (parent_flag)
1823         gfc_add_decl_to_parent_function (var);
1824       else
1825         gfc_add_decl_to_function (var);
1826
1827       SET_DECL_VALUE_EXPR (var, decl);
1828       DECL_HAS_VALUE_EXPR_P (var) = 1;
1829       GFC_DECL_RESULT (var) = 1;
1830
1831       TREE_CHAIN (this_fake_result_decl)
1832           = tree_cons (get_identifier (sym->name), var,
1833                        TREE_CHAIN (this_fake_result_decl));
1834       return var;
1835     }
1836
1837   if (this_fake_result_decl != NULL_TREE)
1838     return TREE_VALUE (this_fake_result_decl);
1839
1840   /* Only when gfc_get_fake_result_decl is called by gfc_trans_return,
1841      sym is NULL.  */
1842   if (!sym)
1843     return NULL_TREE;
1844
1845   if (sym->ts.type == BT_CHARACTER)
1846     {
1847       if (sym->ts.cl->backend_decl == NULL_TREE)
1848         length = gfc_create_string_length (sym);
1849       else
1850         length = sym->ts.cl->backend_decl;
1851       if (TREE_CODE (length) == VAR_DECL
1852           && DECL_CONTEXT (length) == NULL_TREE)
1853         gfc_add_decl_to_function (length);
1854     }
1855
1856   if (gfc_return_by_reference (sym))
1857     {
1858       decl = DECL_ARGUMENTS (this_function_decl);
1859
1860       if (sym->ns->proc_name->backend_decl == this_function_decl
1861           && sym->ns->proc_name->attr.entry_master)
1862         decl = TREE_CHAIN (decl);
1863
1864       TREE_USED (decl) = 1;
1865       if (sym->as)
1866         decl = gfc_build_dummy_array_decl (sym, decl);
1867     }
1868   else
1869     {
1870       sprintf (name, "__result_%.20s",
1871                IDENTIFIER_POINTER (DECL_NAME (this_function_decl)));
1872
1873       decl = build_decl (VAR_DECL, get_identifier (name),
1874                          TREE_TYPE (TREE_TYPE (this_function_decl)));
1875
1876       DECL_ARTIFICIAL (decl) = 1;
1877       DECL_EXTERNAL (decl) = 0;
1878       TREE_PUBLIC (decl) = 0;
1879       TREE_USED (decl) = 1;
1880       GFC_DECL_RESULT (decl) = 1;
1881       TREE_ADDRESSABLE (decl) = 1;
1882
1883       layout_decl (decl, 0);
1884
1885       if (parent_flag)
1886         gfc_add_decl_to_parent_function (decl);
1887       else
1888         gfc_add_decl_to_function (decl);
1889     }
1890
1891   if (parent_flag)
1892     parent_fake_result_decl = build_tree_list (NULL, decl);
1893   else
1894     current_fake_result_decl = build_tree_list (NULL, decl);
1895
1896   return decl;
1897 }
1898
1899
1900 /* Builds a function decl.  The remaining parameters are the types of the
1901    function arguments.  Negative nargs indicates a varargs function.  */
1902
1903 tree
1904 gfc_build_library_function_decl (tree name, tree rettype, int nargs, ...)
1905 {
1906   tree arglist;
1907   tree argtype;
1908   tree fntype;
1909   tree fndecl;
1910   va_list p;
1911   int n;
1912
1913   /* Library functions must be declared with global scope.  */
1914   gcc_assert (current_function_decl == NULL_TREE);
1915
1916   va_start (p, nargs);
1917
1918
1919   /* Create a list of the argument types.  */
1920   for (arglist = NULL_TREE, n = abs (nargs); n > 0; n--)
1921     {
1922       argtype = va_arg (p, tree);
1923       arglist = gfc_chainon_list (arglist, argtype);
1924     }
1925
1926   if (nargs >= 0)
1927     {
1928       /* Terminate the list.  */
1929       arglist = gfc_chainon_list (arglist, void_type_node);
1930     }
1931
1932   /* Build the function type and decl.  */
1933   fntype = build_function_type (rettype, arglist);
1934   fndecl = build_decl (FUNCTION_DECL, name, fntype);
1935
1936   /* Mark this decl as external.  */
1937   DECL_EXTERNAL (fndecl) = 1;
1938   TREE_PUBLIC (fndecl) = 1;
1939
1940   va_end (p);
1941
1942   pushdecl (fndecl);
1943
1944   rest_of_decl_compilation (fndecl, 1, 0);
1945
1946   return fndecl;
1947 }
1948
1949 static void
1950 gfc_build_intrinsic_function_decls (void)
1951 {
1952   tree gfc_int4_type_node = gfc_get_int_type (4);
1953   tree gfc_int8_type_node = gfc_get_int_type (8);
1954   tree gfc_int16_type_node = gfc_get_int_type (16);
1955   tree gfc_logical4_type_node = gfc_get_logical_type (4);
1956   tree gfc_real4_type_node = gfc_get_real_type (4);
1957   tree gfc_real8_type_node = gfc_get_real_type (8);
1958   tree gfc_real10_type_node = gfc_get_real_type (10);
1959   tree gfc_real16_type_node = gfc_get_real_type (16);
1960   tree gfc_complex4_type_node = gfc_get_complex_type (4);
1961   tree gfc_complex8_type_node = gfc_get_complex_type (8);
1962   tree gfc_complex10_type_node = gfc_get_complex_type (10);
1963   tree gfc_complex16_type_node = gfc_get_complex_type (16);
1964   tree gfc_c_int_type_node = gfc_get_int_type (gfc_c_int_kind);
1965
1966   /* String functions.  */
1967   gfor_fndecl_compare_string =
1968     gfc_build_library_function_decl (get_identifier (PREFIX("compare_string")),
1969                                      gfc_int4_type_node,
1970                                      4,
1971                                      gfc_charlen_type_node, pchar_type_node,
1972                                      gfc_charlen_type_node, pchar_type_node);
1973
1974   gfor_fndecl_concat_string =
1975     gfc_build_library_function_decl (get_identifier (PREFIX("concat_string")),
1976                                      void_type_node,
1977                                      6,
1978                                      gfc_charlen_type_node, pchar_type_node,
1979                                      gfc_charlen_type_node, pchar_type_node,
1980                                      gfc_charlen_type_node, pchar_type_node);
1981
1982   gfor_fndecl_string_len_trim =
1983     gfc_build_library_function_decl (get_identifier (PREFIX("string_len_trim")),
1984                                      gfc_int4_type_node,
1985                                      2, gfc_charlen_type_node,
1986                                      pchar_type_node);
1987
1988   gfor_fndecl_string_index =
1989     gfc_build_library_function_decl (get_identifier (PREFIX("string_index")),
1990                                      gfc_int4_type_node,
1991                                      5, gfc_charlen_type_node, pchar_type_node,
1992                                      gfc_charlen_type_node, pchar_type_node,
1993                                      gfc_logical4_type_node);
1994
1995   gfor_fndecl_string_scan =
1996     gfc_build_library_function_decl (get_identifier (PREFIX("string_scan")),
1997                                      gfc_int4_type_node,
1998                                      5, gfc_charlen_type_node, pchar_type_node,
1999                                      gfc_charlen_type_node, pchar_type_node,
2000                                      gfc_logical4_type_node);
2001
2002   gfor_fndecl_string_verify =
2003     gfc_build_library_function_decl (get_identifier (PREFIX("string_verify")),
2004                                      gfc_int4_type_node,
2005                                      5, gfc_charlen_type_node, pchar_type_node,
2006                                      gfc_charlen_type_node, pchar_type_node,
2007                                      gfc_logical4_type_node);
2008
2009   gfor_fndecl_string_trim =
2010     gfc_build_library_function_decl (get_identifier (PREFIX("string_trim")),
2011                                      void_type_node,
2012                                      4,
2013                                      build_pointer_type (gfc_charlen_type_node),
2014                                      ppvoid_type_node,
2015                                      gfc_charlen_type_node,
2016                                      pchar_type_node);
2017
2018   gfor_fndecl_string_repeat =
2019     gfc_build_library_function_decl (get_identifier (PREFIX("string_repeat")),
2020                                      void_type_node,
2021                                      4,
2022                                      pchar_type_node,
2023                                      gfc_charlen_type_node,
2024                                      pchar_type_node,
2025                                      gfc_int4_type_node);
2026
2027   gfor_fndecl_ttynam =
2028     gfc_build_library_function_decl (get_identifier (PREFIX("ttynam")),
2029                                      void_type_node,
2030                                      3,
2031                                      pchar_type_node,
2032                                      gfc_charlen_type_node,
2033                                      gfc_c_int_type_node);
2034
2035   gfor_fndecl_fdate =
2036     gfc_build_library_function_decl (get_identifier (PREFIX("fdate")),
2037                                      void_type_node,
2038                                      2,
2039                                      pchar_type_node,
2040                                      gfc_charlen_type_node);
2041
2042   gfor_fndecl_ctime =
2043     gfc_build_library_function_decl (get_identifier (PREFIX("ctime")),
2044                                      void_type_node,
2045                                      3,
2046                                      pchar_type_node,
2047                                      gfc_charlen_type_node,
2048                                      gfc_int8_type_node);
2049
2050   gfor_fndecl_adjustl =
2051     gfc_build_library_function_decl (get_identifier (PREFIX("adjustl")),
2052                                      void_type_node,
2053                                      3,
2054                                      pchar_type_node,
2055                                      gfc_charlen_type_node, pchar_type_node);
2056
2057   gfor_fndecl_adjustr =
2058     gfc_build_library_function_decl (get_identifier (PREFIX("adjustr")),
2059                                      void_type_node,
2060                                      3,
2061                                      pchar_type_node,
2062                                      gfc_charlen_type_node, pchar_type_node);
2063
2064   gfor_fndecl_si_kind =
2065     gfc_build_library_function_decl (get_identifier ("selected_int_kind"),
2066                                      gfc_int4_type_node,
2067                                      1,
2068                                      pvoid_type_node);
2069
2070   gfor_fndecl_sr_kind =
2071     gfc_build_library_function_decl (get_identifier ("selected_real_kind"),
2072                                      gfc_int4_type_node,
2073                                      2, pvoid_type_node,
2074                                      pvoid_type_node);
2075
2076   /* Power functions.  */
2077   {
2078     tree ctype, rtype, itype, jtype;
2079     int rkind, ikind, jkind;
2080 #define NIKINDS 3
2081 #define NRKINDS 4
2082     static int ikinds[NIKINDS] = {4, 8, 16};
2083     static int rkinds[NRKINDS] = {4, 8, 10, 16};
2084     char name[PREFIX_LEN + 12]; /* _gfortran_pow_?n_?n */
2085
2086     for (ikind=0; ikind < NIKINDS; ikind++)
2087       {
2088         itype = gfc_get_int_type (ikinds[ikind]);
2089
2090         for (jkind=0; jkind < NIKINDS; jkind++)
2091           {
2092             jtype = gfc_get_int_type (ikinds[jkind]);
2093             if (itype && jtype)
2094               {
2095                 sprintf(name, PREFIX("pow_i%d_i%d"), ikinds[ikind],
2096                         ikinds[jkind]);
2097                 gfor_fndecl_math_powi[jkind][ikind].integer =
2098                   gfc_build_library_function_decl (get_identifier (name),
2099                     jtype, 2, jtype, itype);
2100               }
2101           }
2102
2103         for (rkind = 0; rkind < NRKINDS; rkind ++)
2104           {
2105             rtype = gfc_get_real_type (rkinds[rkind]);
2106             if (rtype && itype)
2107               {
2108                 sprintf(name, PREFIX("pow_r%d_i%d"), rkinds[rkind],
2109                         ikinds[ikind]);
2110                 gfor_fndecl_math_powi[rkind][ikind].real =
2111                   gfc_build_library_function_decl (get_identifier (name),
2112                     rtype, 2, rtype, itype);
2113               }
2114
2115             ctype = gfc_get_complex_type (rkinds[rkind]);
2116             if (ctype && itype)
2117               {
2118                 sprintf(name, PREFIX("pow_c%d_i%d"), rkinds[rkind],
2119                         ikinds[ikind]);
2120                 gfor_fndecl_math_powi[rkind][ikind].cmplx =
2121                   gfc_build_library_function_decl (get_identifier (name),
2122                     ctype, 2,ctype, itype);
2123               }
2124           }
2125       }
2126 #undef NIKINDS
2127 #undef NRKINDS
2128   }
2129
2130   gfor_fndecl_math_cpowf =
2131     gfc_build_library_function_decl (get_identifier ("cpowf"),
2132                                      gfc_complex4_type_node,
2133                                      1, gfc_complex4_type_node);
2134   gfor_fndecl_math_cpow =
2135     gfc_build_library_function_decl (get_identifier ("cpow"),
2136                                      gfc_complex8_type_node,
2137                                      1, gfc_complex8_type_node);
2138   if (gfc_complex10_type_node)
2139     gfor_fndecl_math_cpowl10 =
2140       gfc_build_library_function_decl (get_identifier ("cpowl"),
2141                                        gfc_complex10_type_node, 1,
2142                                        gfc_complex10_type_node);
2143   if (gfc_complex16_type_node)
2144     gfor_fndecl_math_cpowl16 =
2145       gfc_build_library_function_decl (get_identifier ("cpowl"),
2146                                        gfc_complex16_type_node, 1,
2147                                        gfc_complex16_type_node);
2148
2149   gfor_fndecl_math_ishftc4 =
2150     gfc_build_library_function_decl (get_identifier (PREFIX("ishftc4")),
2151                                      gfc_int4_type_node,
2152                                      3, gfc_int4_type_node,
2153                                      gfc_int4_type_node, gfc_int4_type_node);
2154   gfor_fndecl_math_ishftc8 =
2155     gfc_build_library_function_decl (get_identifier (PREFIX("ishftc8")),
2156                                      gfc_int8_type_node,
2157                                      3, gfc_int8_type_node,
2158                                      gfc_int4_type_node, gfc_int4_type_node);
2159   if (gfc_int16_type_node)
2160     gfor_fndecl_math_ishftc16 =
2161       gfc_build_library_function_decl (get_identifier (PREFIX("ishftc16")),
2162                                        gfc_int16_type_node, 3,
2163                                        gfc_int16_type_node,
2164                                        gfc_int4_type_node,
2165                                        gfc_int4_type_node);
2166
2167   gfor_fndecl_math_exponent4 =
2168     gfc_build_library_function_decl (get_identifier (PREFIX("exponent_r4")),
2169                                      gfc_int4_type_node,
2170                                      1, gfc_real4_type_node);
2171   gfor_fndecl_math_exponent8 =
2172     gfc_build_library_function_decl (get_identifier (PREFIX("exponent_r8")),
2173                                      gfc_int4_type_node,
2174                                      1, gfc_real8_type_node);
2175   if (gfc_real10_type_node)
2176     gfor_fndecl_math_exponent10 =
2177       gfc_build_library_function_decl (get_identifier (PREFIX("exponent_r10")),
2178                                        gfc_int4_type_node, 1,
2179                                        gfc_real10_type_node);
2180   if (gfc_real16_type_node)
2181     gfor_fndecl_math_exponent16 =
2182       gfc_build_library_function_decl (get_identifier (PREFIX("exponent_r16")),
2183                                        gfc_int4_type_node, 1,
2184                                        gfc_real16_type_node);
2185
2186   /* Other functions.  */
2187   gfor_fndecl_size0 =
2188     gfc_build_library_function_decl (get_identifier (PREFIX("size0")),
2189                                      gfc_array_index_type,
2190                                      1, pvoid_type_node);
2191   gfor_fndecl_size1 =
2192     gfc_build_library_function_decl (get_identifier (PREFIX("size1")),
2193                                      gfc_array_index_type,
2194                                      2, pvoid_type_node,
2195                                      gfc_array_index_type);
2196
2197   gfor_fndecl_iargc =
2198     gfc_build_library_function_decl (get_identifier (PREFIX ("iargc")),
2199                                      gfc_int4_type_node,
2200                                      0);
2201 }
2202
2203
2204 /* Make prototypes for runtime library functions.  */
2205
2206 void
2207 gfc_build_builtin_function_decls (void)
2208 {
2209   tree gfc_c_int_type_node = gfc_get_int_type (gfc_c_int_kind);
2210   tree gfc_int4_type_node = gfc_get_int_type (4);
2211   tree gfc_int8_type_node = gfc_get_int_type (8);
2212   tree gfc_logical4_type_node = gfc_get_logical_type (4);
2213   tree gfc_pint4_type_node = build_pointer_type (gfc_int4_type_node);
2214
2215   /* Treat these two internal malloc wrappers as malloc.  */
2216   gfor_fndecl_internal_malloc =
2217     gfc_build_library_function_decl (get_identifier (PREFIX("internal_malloc")),
2218                                      pvoid_type_node, 1, gfc_int4_type_node);
2219   DECL_IS_MALLOC (gfor_fndecl_internal_malloc) = 1;
2220
2221   gfor_fndecl_internal_malloc64 =
2222     gfc_build_library_function_decl (get_identifier
2223                                      (PREFIX("internal_malloc64")),
2224                                      pvoid_type_node, 1, gfc_int8_type_node);
2225   DECL_IS_MALLOC (gfor_fndecl_internal_malloc64) = 1;
2226
2227   gfor_fndecl_internal_realloc =
2228     gfc_build_library_function_decl (get_identifier
2229                                      (PREFIX("internal_realloc")),
2230                                      pvoid_type_node, 2, pvoid_type_node,
2231                                      gfc_int4_type_node);
2232
2233   gfor_fndecl_internal_realloc64 =
2234     gfc_build_library_function_decl (get_identifier
2235                                      (PREFIX("internal_realloc64")),
2236                                      pvoid_type_node, 2, pvoid_type_node,
2237                                      gfc_int8_type_node);
2238
2239   gfor_fndecl_internal_free =
2240     gfc_build_library_function_decl (get_identifier (PREFIX("internal_free")),
2241                                      void_type_node, 1, pvoid_type_node);
2242
2243   gfor_fndecl_allocate =
2244     gfc_build_library_function_decl (get_identifier (PREFIX("allocate")),
2245                                      void_type_node, 2, ppvoid_type_node,
2246                                      gfc_int4_type_node);
2247
2248   gfor_fndecl_allocate64 =
2249     gfc_build_library_function_decl (get_identifier (PREFIX("allocate64")),
2250                                      void_type_node, 2, ppvoid_type_node,
2251                                      gfc_int8_type_node);
2252
2253   gfor_fndecl_allocate_array =
2254     gfc_build_library_function_decl (get_identifier (PREFIX("allocate_array")),
2255                                      void_type_node, 2, ppvoid_type_node,
2256                                      gfc_int4_type_node);
2257
2258   gfor_fndecl_allocate64_array =
2259     gfc_build_library_function_decl (get_identifier (PREFIX("allocate64_array")),
2260                                      void_type_node, 2, ppvoid_type_node,
2261                                      gfc_int8_type_node);
2262
2263   gfor_fndecl_deallocate =
2264     gfc_build_library_function_decl (get_identifier (PREFIX("deallocate")),
2265                                      void_type_node, 2, ppvoid_type_node,
2266                                      gfc_pint4_type_node);
2267
2268   gfor_fndecl_stop_numeric =
2269     gfc_build_library_function_decl (get_identifier (PREFIX("stop_numeric")),
2270                                      void_type_node, 1, gfc_int4_type_node);
2271
2272   /* Stop doesn't return.  */
2273   TREE_THIS_VOLATILE (gfor_fndecl_stop_numeric) = 1;
2274
2275   gfor_fndecl_stop_string =
2276     gfc_build_library_function_decl (get_identifier (PREFIX("stop_string")),
2277                                      void_type_node, 2, pchar_type_node,
2278                                      gfc_int4_type_node);
2279   /* Stop doesn't return.  */
2280   TREE_THIS_VOLATILE (gfor_fndecl_stop_string) = 1;
2281
2282   gfor_fndecl_pause_numeric =
2283     gfc_build_library_function_decl (get_identifier (PREFIX("pause_numeric")),
2284                                      void_type_node, 1, gfc_int4_type_node);
2285
2286   gfor_fndecl_pause_string =
2287     gfc_build_library_function_decl (get_identifier (PREFIX("pause_string")),
2288                                      void_type_node, 2, pchar_type_node,
2289                                      gfc_int4_type_node);
2290
2291   gfor_fndecl_select_string =
2292     gfc_build_library_function_decl (get_identifier (PREFIX("select_string")),
2293                                      pvoid_type_node, 0);
2294
2295   gfor_fndecl_runtime_error =
2296     gfc_build_library_function_decl (get_identifier (PREFIX("runtime_error")),
2297                                      void_type_node, 1, pchar_type_node);
2298   /* The runtime_error function does not return.  */
2299   TREE_THIS_VOLATILE (gfor_fndecl_runtime_error) = 1;
2300
2301   gfor_fndecl_set_fpe =
2302     gfc_build_library_function_decl (get_identifier (PREFIX("set_fpe")),
2303                                     void_type_node, 1, gfc_c_int_type_node);
2304
2305   gfor_fndecl_set_std =
2306     gfc_build_library_function_decl (get_identifier (PREFIX("set_std")),
2307                                     void_type_node,
2308                                     3,
2309                                     gfc_int4_type_node,
2310                                     gfc_int4_type_node,
2311                                     gfc_int4_type_node);
2312
2313   gfor_fndecl_set_convert =
2314     gfc_build_library_function_decl (get_identifier (PREFIX("set_convert")),
2315                                      void_type_node, 1, gfc_c_int_type_node);
2316
2317   gfor_fndecl_set_record_marker =
2318     gfc_build_library_function_decl (get_identifier (PREFIX("set_record_marker")),
2319                                      void_type_node, 1, gfc_c_int_type_node);
2320
2321   gfor_fndecl_in_pack = gfc_build_library_function_decl (
2322         get_identifier (PREFIX("internal_pack")),
2323         pvoid_type_node, 1, pvoid_type_node);
2324
2325   gfor_fndecl_in_unpack = gfc_build_library_function_decl (
2326         get_identifier (PREFIX("internal_unpack")),
2327         pvoid_type_node, 1, pvoid_type_node);
2328
2329   gfor_fndecl_associated =
2330     gfc_build_library_function_decl (
2331                                      get_identifier (PREFIX("associated")),
2332                                      gfc_logical4_type_node,
2333                                      2,
2334                                      ppvoid_type_node,
2335                                      ppvoid_type_node);
2336
2337   gfc_build_intrinsic_function_decls ();
2338   gfc_build_intrinsic_lib_fndecls ();
2339   gfc_build_io_library_fndecls ();
2340 }
2341
2342
2343 /* Evaluate the length of dummy character variables.  */
2344
2345 static tree
2346 gfc_trans_dummy_character (gfc_symbol *sym, gfc_charlen *cl, tree fnbody)
2347 {
2348   stmtblock_t body;
2349
2350   gfc_finish_decl (cl->backend_decl, NULL_TREE);
2351
2352   gfc_start_block (&body);
2353
2354   /* Evaluate the string length expression.  */
2355   gfc_trans_init_string_length (cl, &body);
2356
2357   gfc_trans_vla_type_sizes (sym, &body);
2358
2359   gfc_add_expr_to_block (&body, fnbody);
2360   return gfc_finish_block (&body);
2361 }
2362
2363
2364 /* Allocate and cleanup an automatic character variable.  */
2365
2366 static tree
2367 gfc_trans_auto_character_variable (gfc_symbol * sym, tree fnbody)
2368 {
2369   stmtblock_t body;
2370   tree decl;
2371   tree tmp;
2372
2373   gcc_assert (sym->backend_decl);
2374   gcc_assert (sym->ts.cl && sym->ts.cl->length);
2375
2376   gfc_start_block (&body);
2377
2378   /* Evaluate the string length expression.  */
2379   gfc_trans_init_string_length (sym->ts.cl, &body);
2380
2381   gfc_trans_vla_type_sizes (sym, &body);
2382
2383   decl = sym->backend_decl;
2384
2385   /* Emit a DECL_EXPR for this variable, which will cause the
2386      gimplifier to allocate storage, and all that good stuff.  */
2387   tmp = build1 (DECL_EXPR, TREE_TYPE (decl), decl);
2388   gfc_add_expr_to_block (&body, tmp);
2389
2390   gfc_add_expr_to_block (&body, fnbody);
2391   return gfc_finish_block (&body);
2392 }
2393
2394 /* Set the initial value of ASSIGN statement auxiliary variable explicitly.  */
2395
2396 static tree
2397 gfc_trans_assign_aux_var (gfc_symbol * sym, tree fnbody)
2398 {
2399   stmtblock_t body;
2400
2401   gcc_assert (sym->backend_decl);
2402   gfc_start_block (&body);
2403
2404   /* Set the initial value to length. See the comments in
2405      function gfc_add_assign_aux_vars in this file.  */
2406   gfc_add_modify_expr (&body, GFC_DECL_STRING_LEN (sym->backend_decl),
2407                        build_int_cst (NULL_TREE, -2));
2408
2409   gfc_add_expr_to_block (&body, fnbody);
2410   return gfc_finish_block (&body);
2411 }
2412
2413 static void
2414 gfc_trans_vla_one_sizepos (tree *tp, stmtblock_t *body)
2415 {
2416   tree t = *tp, var, val;
2417
2418   if (t == NULL || t == error_mark_node)
2419     return;
2420   if (TREE_CONSTANT (t) || DECL_P (t))
2421     return;
2422
2423   if (TREE_CODE (t) == SAVE_EXPR)
2424     {
2425       if (SAVE_EXPR_RESOLVED_P (t))
2426         {
2427           *tp = TREE_OPERAND (t, 0);
2428           return;
2429         }
2430       val = TREE_OPERAND (t, 0);
2431     }
2432   else
2433     val = t;
2434
2435   var = gfc_create_var_np (TREE_TYPE (t), NULL);
2436   gfc_add_decl_to_function (var);
2437   gfc_add_modify_expr (body, var, val);
2438   if (TREE_CODE (t) == SAVE_EXPR)
2439     TREE_OPERAND (t, 0) = var;
2440   *tp = var;
2441 }
2442
2443 static void
2444 gfc_trans_vla_type_sizes_1 (tree type, stmtblock_t *body)
2445 {
2446   tree t;
2447
2448   if (type == NULL || type == error_mark_node)
2449     return;
2450
2451   type = TYPE_MAIN_VARIANT (type);
2452
2453   if (TREE_CODE (type) == INTEGER_TYPE)
2454     {
2455       gfc_trans_vla_one_sizepos (&TYPE_MIN_VALUE (type), body);
2456       gfc_trans_vla_one_sizepos (&TYPE_MAX_VALUE (type), body);
2457
2458       for (t = TYPE_NEXT_VARIANT (type); t; t = TYPE_NEXT_VARIANT (t))
2459         {
2460           TYPE_MIN_VALUE (t) = TYPE_MIN_VALUE (type);
2461           TYPE_MAX_VALUE (t) = TYPE_MAX_VALUE (type);
2462         }
2463     }
2464   else if (TREE_CODE (type) == ARRAY_TYPE)
2465     {
2466       gfc_trans_vla_type_sizes_1 (TREE_TYPE (type), body);
2467       gfc_trans_vla_type_sizes_1 (TYPE_DOMAIN (type), body);
2468       gfc_trans_vla_one_sizepos (&TYPE_SIZE (type), body);
2469       gfc_trans_vla_one_sizepos (&TYPE_SIZE_UNIT (type), body);
2470
2471       for (t = TYPE_NEXT_VARIANT (type); t; t = TYPE_NEXT_VARIANT (t))
2472         {
2473           TYPE_SIZE (t) = TYPE_SIZE (type);
2474           TYPE_SIZE_UNIT (t) = TYPE_SIZE_UNIT (type);
2475         }
2476     }
2477 }
2478
2479 /* Make sure all type sizes and array domains are either constant,
2480    or variable or parameter decls.  This is a simplified variant
2481    of gimplify_type_sizes, but we can't use it here, as none of the
2482    variables in the expressions have been gimplified yet.
2483    As type sizes and domains for various variable length arrays
2484    contain VAR_DECLs that are only initialized at gfc_trans_deferred_vars
2485    time, without this routine gimplify_type_sizes in the middle-end
2486    could result in the type sizes being gimplified earlier than where
2487    those variables are initialized.  */
2488
2489 void
2490 gfc_trans_vla_type_sizes (gfc_symbol *sym, stmtblock_t *body)
2491 {
2492   tree type = TREE_TYPE (sym->backend_decl);
2493
2494   if (TREE_CODE (type) == FUNCTION_TYPE
2495       && (sym->attr.function || sym->attr.result || sym->attr.entry))
2496     {
2497       if (! current_fake_result_decl)
2498         return;
2499
2500       type = TREE_TYPE (TREE_VALUE (current_fake_result_decl));
2501     }
2502
2503   while (POINTER_TYPE_P (type))
2504     type = TREE_TYPE (type);
2505
2506   if (GFC_DESCRIPTOR_TYPE_P (type))
2507     {
2508       tree etype = GFC_TYPE_ARRAY_DATAPTR_TYPE (type);
2509
2510       while (POINTER_TYPE_P (etype))
2511         etype = TREE_TYPE (etype);
2512
2513       gfc_trans_vla_type_sizes_1 (etype, body);
2514     }
2515
2516   gfc_trans_vla_type_sizes_1 (type, body);
2517 }
2518
2519
2520 /* Generate function entry and exit code, and add it to the function body.
2521    This includes:
2522     Allocation and initialization of array variables.
2523     Allocation of character string variables.
2524     Initialization and possibly repacking of dummy arrays.
2525     Initialization of ASSIGN statement auxiliary variable.  */
2526
2527 static tree
2528 gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
2529 {
2530   locus loc;
2531   gfc_symbol *sym;
2532   gfc_formal_arglist *f;
2533   stmtblock_t body;
2534
2535   /* Deal with implicit return variables.  Explicit return variables will
2536      already have been added.  */
2537   if (gfc_return_by_reference (proc_sym) && proc_sym->result == proc_sym)
2538     {
2539       if (!current_fake_result_decl)
2540         {
2541           gfc_entry_list *el = NULL;
2542           if (proc_sym->attr.entry_master)
2543             {
2544               for (el = proc_sym->ns->entries; el; el = el->next)
2545                 if (el->sym != el->sym->result)
2546                   break;
2547             }
2548           if (el == NULL)
2549             warning (0, "Function does not return a value");
2550         }
2551       else if (proc_sym->as)
2552         {
2553           tree result = TREE_VALUE (current_fake_result_decl);
2554           fnbody = gfc_trans_dummy_array_bias (proc_sym, result, fnbody);
2555
2556           /* An automatic character length, pointer array result.  */
2557           if (proc_sym->ts.type == BT_CHARACTER
2558                 && TREE_CODE (proc_sym->ts.cl->backend_decl) == VAR_DECL)
2559             fnbody = gfc_trans_dummy_character (proc_sym, proc_sym->ts.cl,
2560                                                 fnbody);
2561         }
2562       else if (proc_sym->ts.type == BT_CHARACTER)
2563         {
2564           if (TREE_CODE (proc_sym->ts.cl->backend_decl) == VAR_DECL)
2565             fnbody = gfc_trans_dummy_character (proc_sym, proc_sym->ts.cl,
2566                                                 fnbody);
2567         }
2568       else
2569         gcc_assert (gfc_option.flag_f2c
2570                     && proc_sym->ts.type == BT_COMPLEX);
2571     }
2572
2573   for (sym = proc_sym->tlink; sym != proc_sym; sym = sym->tlink)
2574     {
2575       if (sym->attr.dimension)
2576         {
2577           switch (sym->as->type)
2578             {
2579             case AS_EXPLICIT:
2580               if (sym->attr.dummy || sym->attr.result)
2581                 fnbody =
2582                   gfc_trans_dummy_array_bias (sym, sym->backend_decl, fnbody);
2583               else if (sym->attr.pointer || sym->attr.allocatable)
2584                 {
2585                   if (TREE_STATIC (sym->backend_decl))
2586                     gfc_trans_static_array_pointer (sym);
2587                   else
2588                     fnbody = gfc_trans_deferred_array (sym, fnbody);
2589                 }
2590               else
2591                 {
2592                   gfc_get_backend_locus (&loc);
2593                   gfc_set_backend_locus (&sym->declared_at);
2594                   fnbody = gfc_trans_auto_array_allocation (sym->backend_decl,
2595                       sym, fnbody);
2596                   gfc_set_backend_locus (&loc);
2597                 }
2598               break;
2599
2600             case AS_ASSUMED_SIZE:
2601               /* Must be a dummy parameter.  */
2602               gcc_assert (sym->attr.dummy);
2603
2604               /* We should always pass assumed size arrays the g77 way.  */
2605               fnbody = gfc_trans_g77_array (sym, fnbody);
2606               break;
2607
2608             case AS_ASSUMED_SHAPE:
2609               /* Must be a dummy parameter.  */
2610               gcc_assert (sym->attr.dummy);
2611
2612               fnbody = gfc_trans_dummy_array_bias (sym, sym->backend_decl,
2613                                                    fnbody);
2614               break;
2615
2616             case AS_DEFERRED:
2617               fnbody = gfc_trans_deferred_array (sym, fnbody);
2618               break;
2619
2620             default:
2621               gcc_unreachable ();
2622             }
2623         }
2624       else if (sym->ts.type == BT_CHARACTER)
2625         {
2626           gfc_get_backend_locus (&loc);
2627           gfc_set_backend_locus (&sym->declared_at);
2628           if (sym->attr.dummy || sym->attr.result)
2629             fnbody = gfc_trans_dummy_character (sym, sym->ts.cl, fnbody);
2630           else
2631             fnbody = gfc_trans_auto_character_variable (sym, fnbody);
2632           gfc_set_backend_locus (&loc);
2633         }
2634       else if (sym->attr.assign)
2635         {
2636           gfc_get_backend_locus (&loc);
2637           gfc_set_backend_locus (&sym->declared_at);
2638           fnbody = gfc_trans_assign_aux_var (sym, fnbody);
2639           gfc_set_backend_locus (&loc);
2640         }
2641       else
2642         gcc_unreachable ();
2643     }
2644
2645   gfc_init_block (&body);
2646
2647   for (f = proc_sym->formal; f; f = f->next)
2648     if (f->sym && f->sym->tlink == NULL && f->sym->ts.type == BT_CHARACTER)
2649       {
2650         gcc_assert (f->sym->ts.cl->backend_decl != NULL);
2651         if (TREE_CODE (f->sym->ts.cl->backend_decl) == PARM_DECL)
2652           gfc_trans_vla_type_sizes (f->sym, &body);
2653       }
2654
2655   if (gfc_return_by_reference (proc_sym) && proc_sym->ts.type == BT_CHARACTER
2656       && current_fake_result_decl != NULL)
2657     {
2658       gcc_assert (proc_sym->ts.cl->backend_decl != NULL);
2659       if (TREE_CODE (proc_sym->ts.cl->backend_decl) == PARM_DECL)
2660         gfc_trans_vla_type_sizes (proc_sym, &body);
2661     }
2662
2663   gfc_add_expr_to_block (&body, fnbody);
2664   return gfc_finish_block (&body);
2665 }
2666
2667
2668 /* Output an initialized decl for a module variable.  */
2669
2670 static void
2671 gfc_create_module_variable (gfc_symbol * sym)
2672 {
2673   tree decl;
2674
2675   /* Module functions with alternate entries are dealt with later and
2676      would get caught by the next condition.  */
2677   if (sym->attr.entry)
2678     return;
2679
2680   /* Only output symbols from this module.  */
2681   if (sym->ns != module_namespace)
2682     {
2683       /* I don't think this should ever happen.  */
2684       internal_error ("module symbol %s in wrong namespace", sym->name);
2685     }
2686
2687   /* Only output variables and array valued parameters.  */
2688   if (sym->attr.flavor != FL_VARIABLE
2689       && (sym->attr.flavor != FL_PARAMETER || sym->attr.dimension == 0))
2690     return;
2691
2692   /* Don't generate variables from other modules. Variables from
2693      COMMONs will already have been generated.  */
2694   if (sym->attr.use_assoc || sym->attr.in_common)
2695     return;
2696
2697   /* Equivalenced variables arrive here after creation.  */
2698   if (sym->backend_decl
2699         && (sym->equiv_built || sym->attr.in_equivalence))
2700       return;
2701
2702   if (sym->backend_decl)
2703     internal_error ("backend decl for module variable %s already exists",
2704                     sym->name);
2705
2706   /* We always want module variables to be created.  */
2707   sym->attr.referenced = 1;
2708   /* Create the decl.  */
2709   decl = gfc_get_symbol_decl (sym);
2710
2711   /* Create the variable.  */
2712   pushdecl (decl);
2713   rest_of_decl_compilation (decl, 1, 0);
2714
2715   /* Also add length of strings.  */
2716   if (sym->ts.type == BT_CHARACTER)
2717     {
2718       tree length;
2719
2720       length = sym->ts.cl->backend_decl;
2721       if (!INTEGER_CST_P (length))
2722         {
2723           pushdecl (length);
2724           rest_of_decl_compilation (length, 1, 0);
2725         }
2726     }
2727 }
2728
2729
2730 /* Generate all the required code for module variables.  */
2731
2732 void
2733 gfc_generate_module_vars (gfc_namespace * ns)
2734 {
2735   module_namespace = ns;
2736
2737   /* Check if the frontend left the namespace in a reasonable state.  */
2738   gcc_assert (ns->proc_name && !ns->proc_name->tlink);
2739
2740   /* Generate COMMON blocks.  */
2741   gfc_trans_common (ns);
2742
2743   /* Create decls for all the module variables.  */
2744   gfc_traverse_ns (ns, gfc_create_module_variable);
2745 }
2746
2747 static void
2748 gfc_generate_contained_functions (gfc_namespace * parent)
2749 {
2750   gfc_namespace *ns;
2751
2752   /* We create all the prototypes before generating any code.  */
2753   for (ns = parent->contained; ns; ns = ns->sibling)
2754     {
2755       /* Skip namespaces from used modules.  */
2756       if (ns->parent != parent)
2757         continue;
2758
2759       gfc_create_function_decl (ns);
2760     }
2761
2762   for (ns = parent->contained; ns; ns = ns->sibling)
2763     {
2764       /* Skip namespaces from used modules.  */
2765       if (ns->parent != parent)
2766         continue;
2767
2768       gfc_generate_function_code (ns);
2769     }
2770 }
2771
2772
2773 /* Drill down through expressions for the array specification bounds and
2774    character length calling generate_local_decl for all those variables
2775    that have not already been declared.  */
2776
2777 static void
2778 generate_local_decl (gfc_symbol *);
2779
2780 static void
2781 generate_expr_decls (gfc_symbol *sym, gfc_expr *e)
2782 {
2783   gfc_actual_arglist *arg;
2784   gfc_ref *ref;
2785   int i;
2786
2787   if (e == NULL)
2788     return;
2789
2790   switch (e->expr_type)
2791     {
2792     case EXPR_FUNCTION:
2793       for (arg = e->value.function.actual; arg; arg = arg->next)
2794         generate_expr_decls (sym, arg->expr);
2795       break;
2796
2797     /* If the variable is not the same as the dependent, 'sym', and
2798        it is not marked as being declared and it is in the same
2799        namespace as 'sym', add it to the local declarations.  */
2800     case EXPR_VARIABLE:
2801       if (sym == e->symtree->n.sym
2802             || e->symtree->n.sym->mark
2803             || e->symtree->n.sym->ns != sym->ns)
2804         return;
2805
2806       generate_local_decl (e->symtree->n.sym);
2807       break;
2808
2809     case EXPR_OP:
2810       generate_expr_decls (sym, e->value.op.op1);
2811       generate_expr_decls (sym, e->value.op.op2);
2812       break;
2813
2814     default:
2815       break;
2816     }
2817
2818   if (e->ref)
2819     {
2820       for (ref = e->ref; ref; ref = ref->next)
2821         {
2822           switch (ref->type)
2823             {
2824             case REF_ARRAY:
2825               for (i = 0; i < ref->u.ar.dimen; i++)
2826                 {
2827                   generate_expr_decls (sym, ref->u.ar.start[i]);
2828                   generate_expr_decls (sym, ref->u.ar.end[i]);
2829                   generate_expr_decls (sym, ref->u.ar.stride[i]);
2830                 }
2831               break;
2832
2833             case REF_SUBSTRING:
2834               generate_expr_decls (sym, ref->u.ss.start);
2835               generate_expr_decls (sym, ref->u.ss.end);
2836               break;
2837
2838             case REF_COMPONENT:
2839               if (ref->u.c.component->ts.type == BT_CHARACTER
2840                     && ref->u.c.component->ts.cl->length->expr_type
2841                                                 != EXPR_CONSTANT)
2842                 generate_expr_decls (sym, ref->u.c.component->ts.cl->length);
2843
2844               if (ref->u.c.component->as)
2845                 for (i = 0; i < ref->u.c.component->as->rank; i++)
2846                   {
2847                     generate_expr_decls (sym, ref->u.c.component->as->lower[i]);
2848                     generate_expr_decls (sym, ref->u.c.component->as->upper[i]);
2849                   }
2850               break;
2851             }
2852         }
2853     }
2854 }
2855
2856
2857 /* Check for dependencies in the character length and array spec. */
2858
2859 static void
2860 generate_dependency_declarations (gfc_symbol *sym)
2861 {
2862   int i;
2863
2864   if (sym->ts.type == BT_CHARACTER
2865         && sym->ts.cl->length->expr_type != EXPR_CONSTANT)
2866     generate_expr_decls (sym, sym->ts.cl->length);
2867
2868   if (sym->as && sym->as->rank)
2869     {
2870       for (i = 0; i < sym->as->rank; i++)
2871         {
2872           generate_expr_decls (sym, sym->as->lower[i]);
2873           generate_expr_decls (sym, sym->as->upper[i]);
2874         }
2875     }
2876 }
2877
2878
2879 /* Generate decls for all local variables.  We do this to ensure correct
2880    handling of expressions which only appear in the specification of
2881    other functions.  */
2882
2883 static void
2884 generate_local_decl (gfc_symbol * sym)
2885 {
2886   if (sym->attr.flavor == FL_VARIABLE)
2887     {
2888       /* Check for dependencies in the array specification and string
2889         length, adding the necessary declarations to the function.  We
2890         mark the symbol now, as well as in traverse_ns, to prevent
2891         getting stuck in a circular dependency.  */
2892       sym->mark = 1;
2893       if (!sym->attr.dummy && !sym->ns->proc_name->attr.entry_master)
2894         generate_dependency_declarations (sym);
2895
2896       if (sym->attr.referenced)
2897         gfc_get_symbol_decl (sym);
2898       else if (sym->attr.dummy && warn_unused_parameter)
2899         gfc_warning ("Unused parameter %s declared at %L", sym->name,
2900                      &sym->declared_at);
2901       /* Warn for unused variables, but not if they're inside a common
2902          block or are use-associated.  */
2903       else if (warn_unused_variable
2904                && !(sym->attr.in_common || sym->attr.use_assoc))
2905         gfc_warning ("Unused variable %s declared at %L", sym->name,
2906                      &sym->declared_at);
2907       /* For variable length CHARACTER parameters, the PARM_DECL already
2908          references the length variable, so force gfc_get_symbol_decl
2909          even when not referenced.  If optimize > 0, it will be optimized
2910          away anyway.  But do this only after emitting -Wunused-parameter
2911          warning if requested.  */
2912       if (sym->attr.dummy && ! sym->attr.referenced
2913           && sym->ts.type == BT_CHARACTER
2914           && sym->ts.cl->backend_decl != NULL
2915           && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
2916         {
2917           sym->attr.referenced = 1;
2918           gfc_get_symbol_decl (sym);
2919         }
2920     }
2921 }
2922
2923 static void
2924 generate_local_vars (gfc_namespace * ns)
2925 {
2926   gfc_traverse_ns (ns, generate_local_decl);
2927 }
2928
2929
2930 /* Generate a switch statement to jump to the correct entry point.  Also
2931    creates the label decls for the entry points.  */
2932
2933 static tree
2934 gfc_trans_entry_master_switch (gfc_entry_list * el)
2935 {
2936   stmtblock_t block;
2937   tree label;
2938   tree tmp;
2939   tree val;
2940
2941   gfc_init_block (&block);
2942   for (; el; el = el->next)
2943     {
2944       /* Add the case label.  */
2945       label = gfc_build_label_decl (NULL_TREE);
2946       val = build_int_cst (gfc_array_index_type, el->id);
2947       tmp = build3_v (CASE_LABEL_EXPR, val, NULL_TREE, label);
2948       gfc_add_expr_to_block (&block, tmp);
2949
2950       /* And jump to the actual entry point.  */
2951       label = gfc_build_label_decl (NULL_TREE);
2952       tmp = build1_v (GOTO_EXPR, label);
2953       gfc_add_expr_to_block (&block, tmp);
2954
2955       /* Save the label decl.  */
2956       el->label = label;
2957     }
2958   tmp = gfc_finish_block (&block);
2959   /* The first argument selects the entry point.  */
2960   val = DECL_ARGUMENTS (current_function_decl);
2961   tmp = build3_v (SWITCH_EXPR, val, tmp, NULL_TREE);
2962   return tmp;
2963 }
2964
2965
2966 /* Generate code for a function.  */
2967
2968 void
2969 gfc_generate_function_code (gfc_namespace * ns)
2970 {
2971   tree fndecl;
2972   tree old_context;
2973   tree decl;
2974   tree tmp;
2975   stmtblock_t block;
2976   stmtblock_t body;
2977   tree result;
2978   gfc_symbol *sym;
2979
2980   sym = ns->proc_name;
2981
2982   /* Check that the frontend isn't still using this.  */
2983   gcc_assert (sym->tlink == NULL);
2984   sym->tlink = sym;
2985
2986   /* Create the declaration for functions with global scope.  */
2987   if (!sym->backend_decl)
2988     gfc_create_function_decl (ns);
2989
2990   fndecl = sym->backend_decl;
2991   old_context = current_function_decl;
2992
2993   if (old_context)
2994     {
2995       push_function_context ();
2996       saved_parent_function_decls = saved_function_decls;
2997       saved_function_decls = NULL_TREE;
2998     }
2999
3000   trans_function_start (sym);
3001
3002   gfc_start_block (&block);
3003
3004   if (ns->entries && ns->proc_name->ts.type == BT_CHARACTER)
3005     {
3006       /* Copy length backend_decls to all entry point result
3007          symbols.  */
3008       gfc_entry_list *el;
3009       tree backend_decl;
3010
3011       gfc_conv_const_charlen (ns->proc_name->ts.cl);
3012       backend_decl = ns->proc_name->result->ts.cl->backend_decl;
3013       for (el = ns->entries; el; el = el->next)
3014         el->sym->result->ts.cl->backend_decl = backend_decl;
3015     }
3016
3017   /* Translate COMMON blocks.  */
3018   gfc_trans_common (ns);
3019
3020   /* Null the parent fake result declaration if this namespace is
3021      a module function or an external procedures.  */
3022   if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
3023         || ns->parent == NULL)
3024     parent_fake_result_decl = NULL_TREE;
3025
3026   gfc_generate_contained_functions (ns);
3027
3028   generate_local_vars (ns);
3029
3030   /* Keep the parent fake result declaration in module functions
3031      or external procedures.  */
3032   if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
3033         || ns->parent == NULL)
3034     current_fake_result_decl = parent_fake_result_decl;
3035   else
3036     current_fake_result_decl = NULL_TREE;
3037
3038   current_function_return_label = NULL;
3039
3040   /* Now generate the code for the body of this function.  */
3041   gfc_init_block (&body);
3042
3043   /* If this is the main program, add a call to set_std to set up the
3044      runtime library Fortran language standard parameters.  */
3045
3046   if (sym->attr.is_main_program)
3047     {
3048       tree arglist, gfc_int4_type_node;
3049
3050       gfc_int4_type_node = gfc_get_int_type (4);
3051       arglist = gfc_chainon_list (NULL_TREE,
3052                                   build_int_cst (gfc_int4_type_node,
3053                                                  gfc_option.warn_std));
3054       arglist = gfc_chainon_list (arglist,
3055                                   build_int_cst (gfc_int4_type_node,
3056                                                  gfc_option.allow_std));
3057       arglist = gfc_chainon_list (arglist,
3058                                   build_int_cst (gfc_int4_type_node,
3059                                                  pedantic));
3060       tmp = build_function_call_expr (gfor_fndecl_set_std, arglist);
3061       gfc_add_expr_to_block (&body, tmp);
3062     }
3063
3064   /* If this is the main program and a -ffpe-trap option was provided,
3065      add a call to set_fpe so that the library will raise a FPE when
3066      needed.  */
3067   if (sym->attr.is_main_program && gfc_option.fpe != 0)
3068     {
3069       tree arglist, gfc_c_int_type_node;
3070
3071       gfc_c_int_type_node = gfc_get_int_type (gfc_c_int_kind);
3072       arglist = gfc_chainon_list (NULL_TREE,
3073                                   build_int_cst (gfc_c_int_type_node,
3074                                                  gfc_option.fpe));
3075       tmp = build_function_call_expr (gfor_fndecl_set_fpe, arglist);
3076       gfc_add_expr_to_block (&body, tmp);
3077     }
3078
3079   /* If this is the main program and an -fconvert option was provided,
3080      add a call to set_convert.  */
3081
3082   if (sym->attr.is_main_program && gfc_option.convert != CONVERT_NATIVE)
3083     {
3084       tree arglist, gfc_c_int_type_node;
3085
3086       gfc_c_int_type_node = gfc_get_int_type (gfc_c_int_kind);
3087       arglist = gfc_chainon_list (NULL_TREE,
3088                                   build_int_cst (gfc_c_int_type_node,
3089                                                  gfc_option.convert));
3090       tmp = build_function_call_expr (gfor_fndecl_set_convert, arglist);
3091       gfc_add_expr_to_block (&body, tmp);
3092     }
3093
3094   /* If this is the main program and an -frecord-marker option was provided,
3095      add a call to set_record_marker.  */
3096
3097   if (sym->attr.is_main_program && gfc_option.record_marker != 0)
3098     {
3099       tree arglist, gfc_c_int_type_node;
3100
3101       gfc_c_int_type_node = gfc_get_int_type (gfc_c_int_kind);
3102       arglist = gfc_chainon_list (NULL_TREE,
3103                                   build_int_cst (gfc_c_int_type_node,
3104                                                  gfc_option.record_marker));
3105       tmp = build_function_call_expr (gfor_fndecl_set_record_marker, arglist);
3106       gfc_add_expr_to_block (&body, tmp);
3107
3108     }
3109
3110   if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node
3111       && sym->attr.subroutine)
3112     {
3113       tree alternate_return;
3114       alternate_return = gfc_get_fake_result_decl (sym, 0);
3115       gfc_add_modify_expr (&body, alternate_return, integer_zero_node);
3116     }
3117
3118   if (ns->entries)
3119     {
3120       /* Jump to the correct entry point.  */
3121       tmp = gfc_trans_entry_master_switch (ns->entries);
3122       gfc_add_expr_to_block (&body, tmp);
3123     }
3124
3125   tmp = gfc_trans_code (ns->code);
3126   gfc_add_expr_to_block (&body, tmp);
3127
3128   /* Add a return label if needed.  */
3129   if (current_function_return_label)
3130     {
3131       tmp = build1_v (LABEL_EXPR, current_function_return_label);
3132       gfc_add_expr_to_block (&body, tmp);
3133     }
3134
3135   tmp = gfc_finish_block (&body);
3136   /* Add code to create and cleanup arrays.  */
3137   tmp = gfc_trans_deferred_vars (sym, tmp);
3138   gfc_add_expr_to_block (&block, tmp);
3139
3140   if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node)
3141     {
3142       if (sym->attr.subroutine || sym == sym->result)
3143         {
3144           if (current_fake_result_decl != NULL)
3145             result = TREE_VALUE (current_fake_result_decl);
3146           else
3147             result = NULL_TREE;
3148           current_fake_result_decl = NULL_TREE;
3149         }
3150       else
3151         result = sym->result->backend_decl;
3152
3153       if (result == NULL_TREE)
3154         warning (0, "Function return value not set");
3155       else
3156         {
3157           /* Set the return value to the dummy result variable.  */
3158           tmp = build2 (MODIFY_EXPR, TREE_TYPE (result),
3159                         DECL_RESULT (fndecl), result);
3160           tmp = build1_v (RETURN_EXPR, tmp);
3161           gfc_add_expr_to_block (&block, tmp);
3162         }
3163     }
3164
3165   /* Add all the decls we created during processing.  */
3166   decl = saved_function_decls;
3167   while (decl)
3168     {
3169       tree next;
3170
3171       next = TREE_CHAIN (decl);
3172       TREE_CHAIN (decl) = NULL_TREE;
3173       pushdecl (decl);
3174       decl = next;
3175     }
3176   saved_function_decls = NULL_TREE;
3177
3178   DECL_SAVED_TREE (fndecl) = gfc_finish_block (&block);
3179
3180   /* Finish off this function and send it for code generation.  */
3181   poplevel (1, 0, 1);
3182   BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
3183
3184   /* Output the GENERIC tree.  */
3185   dump_function (TDI_original, fndecl);
3186
3187   /* Store the end of the function, so that we get good line number
3188      info for the epilogue.  */
3189   cfun->function_end_locus = input_location;
3190
3191   /* We're leaving the context of this function, so zap cfun.
3192      It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
3193      tree_rest_of_compilation.  */
3194   cfun = NULL;
3195
3196   if (old_context)
3197     {
3198       pop_function_context ();
3199       saved_function_decls = saved_parent_function_decls;
3200     }
3201   current_function_decl = old_context;
3202
3203   if (decl_function_context (fndecl))
3204     /* Register this function with cgraph just far enough to get it
3205        added to our parent's nested function list.  */
3206     (void) cgraph_node (fndecl);
3207   else
3208     {
3209       gfc_gimplify_function (fndecl);
3210       cgraph_finalize_function (fndecl, false);
3211     }
3212 }
3213
3214 void
3215 gfc_generate_constructors (void)
3216 {
3217   gcc_assert (gfc_static_ctors == NULL_TREE);
3218 #if 0
3219   tree fnname;
3220   tree type;
3221   tree fndecl;
3222   tree decl;
3223   tree tmp;
3224
3225   if (gfc_static_ctors == NULL_TREE)
3226     return;
3227
3228   fnname = get_file_function_name ('I');
3229   type = build_function_type (void_type_node,
3230                               gfc_chainon_list (NULL_TREE, void_type_node));
3231
3232   fndecl = build_decl (FUNCTION_DECL, fnname, type);
3233   TREE_PUBLIC (fndecl) = 1;
3234
3235   decl = build_decl (RESULT_DECL, NULL_TREE, void_type_node);
3236   DECL_ARTIFICIAL (decl) = 1;
3237   DECL_IGNORED_P (decl) = 1;
3238   DECL_CONTEXT (decl) = fndecl;
3239   DECL_RESULT (fndecl) = decl;
3240
3241   pushdecl (fndecl);
3242
3243   current_function_decl = fndecl;
3244
3245   rest_of_decl_compilation (fndecl, 1, 0);
3246
3247   make_decl_rtl (fndecl);
3248
3249   init_function_start (fndecl);
3250
3251   pushlevel (0);
3252
3253   for (; gfc_static_ctors; gfc_static_ctors = TREE_CHAIN (gfc_static_ctors))
3254     {
3255       tmp =
3256         build_function_call_expr (TREE_VALUE (gfc_static_ctors), NULL_TREE);
3257       DECL_SAVED_TREE (fndecl) = build_stmt (EXPR_STMT, tmp);
3258     }
3259
3260   poplevel (1, 0, 1);
3261
3262   BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
3263
3264   free_after_parsing (cfun);
3265   free_after_compilation (cfun);
3266
3267   tree_rest_of_compilation (fndecl);
3268
3269   current_function_decl = NULL_TREE;
3270 #endif
3271 }
3272
3273 /* Translates a BLOCK DATA program unit. This means emitting the
3274    commons contained therein plus their initializations. We also emit
3275    a globally visible symbol to make sure that each BLOCK DATA program
3276    unit remains unique.  */
3277
3278 void
3279 gfc_generate_block_data (gfc_namespace * ns)
3280 {
3281   tree decl;
3282   tree id;
3283
3284   /* Tell the backend the source location of the block data.  */
3285   if (ns->proc_name)
3286     gfc_set_backend_locus (&ns->proc_name->declared_at);
3287   else
3288     gfc_set_backend_locus (&gfc_current_locus);
3289
3290   /* Process the DATA statements.  */
3291   gfc_trans_common (ns);
3292
3293   /* Create a global symbol with the mane of the block data.  This is to
3294      generate linker errors if the same name is used twice.  It is never
3295      really used.  */
3296   if (ns->proc_name)
3297     id = gfc_sym_mangled_function_id (ns->proc_name);
3298   else
3299     id = get_identifier ("__BLOCK_DATA__");
3300
3301   decl = build_decl (VAR_DECL, id, gfc_array_index_type);
3302   TREE_PUBLIC (decl) = 1;
3303   TREE_STATIC (decl) = 1;
3304
3305   pushdecl (decl);
3306   rest_of_decl_compilation (decl, 1, 0);
3307 }
3308
3309
3310 #include "gt-fortran-trans-decl.h"