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