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