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