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