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